Revised 2014-03-10
Background
The "control-flow stack" in Forth-94 describes the
compile-time behaviour of control structures. Support functions
for the
control-flow stack include AHEAD CS-ROLL
CS-PICK . Using these tools it is possible to create
conditionals and
control structures such as WHILE REPEAT
ELSE CASE in a portable manner.
Despite the potential the control-flow stack offers, the tools
provided by Forth-94 are few with the result only simple
control structures can be realized. To address this shortcoming
the following extensions are presented.
Implementing the extensions requires knowledge of the host system. A sample implementation is provided.
Control-Flow Stack Extensions
Examples
1. BEGINCASE..NEXTCASE
\ BEGINCASE..NEXTCASE
\ MPE CASE extension
: BEGINCASE
postpone case postpone begin cs-push ; immediate
: NEXT-CASE
cs-pop postpone again postpone endcase ; immediate
: NEXTCASE
postpone drop postpone next-case ; immediate
: test
begincase
cr ." Press a key ('2' '4' '9' exits) : " key
[char] 2 of ." ... 2 " endof
[char] 4 of ." ... 4 " endof
[char] 9 of ." ... 9 " endof
dup emit ." try again"
nextcase ;
2. "Miser's CASE"
\ Wil Baden's COND THENS
: COND cs-mark ; immediate
: THENS
begin cs-test while postpone then repeat cs-drop ; immediate
: OF postpone over postpone = postpone if
postpone drop ; immediate
\ Add Pascal-like features
: WHEN
postpone else cs-push postpone thens cs-pop
postpone drop ; immediate
: EQUAL
postpone over postpone - postpone if ; immediate
: (range) \ assumes 2's complement arithmetic
2>r dup 2r> over - -rot - u< ;
: RANGE \ values may be signed or unsigned
postpone (range) postpone if ; immediate
\ Add C Switch flow-through
: CONTINUE
cs-push postpone thens cs-mark cs-pop ; immediate
\ Forth-94 compatibility words
: CASE postpone cond ; immediate
: ENDOF postpone else ; immediate
: ENDCASE
postpone drop postpone thens ; immediate
\ Case demo
hex
: test ( n ) space
cond
cond
0 1F range
7F equal when ." Control char " else
cond
20 2F range
3A 40 range
5B 60 range
7B 7E range when ." Punctuation " else
cond 30 39 range when ." Digit " else
cond 41 5A range when ." Upper case letter " else
cond 61 7A range when ." Lower case letter " else
drop ." Not a character "
thens ;
decimal
cr cr .( [press any key] ) key drop
cr cr .( Miser's CASE demo ...) cr
cr char a .( ) dup emit test
cr char , .( ) dup emit test
cr char 8 .( ) dup emit test
cr char ? .( ) dup emit test
cr char K .( ) dup emit test
cr 0 dup 3 .r test
cr 127 dup 3 .r test
cr 128 dup 3 .r test
3. "Duff's Device"
\ Requires "Miser's CASE"
\ : send >r >r dup c@ r@ c! char+ r> r> ;
: send >r >r dup c@ emit char+ r> r> ;
: duff ( data port count )
dup 7 + 8 /
swap 8 mod
case
0 of
begin [ cs-push ]
send endof
7 of continue send endof
6 of continue send endof
5 of continue send endof
4 of continue send endof
3 of continue send endof
2 of continue send endof
1 of continue send
1- dup 0= [ cs-pop ] until
endof
endcase drop 2drop ;
: filldata ( )
26 0 do i [char] A + pad i chars + c! loop ;
: go ( )
filldata 27 1 do cr pad 0 i dup . duff 3 +loop ;
cr cr .( [press any key] ) key drop
cr cr .( Duff's Device demo ...) cr
go
4. BEGIN..REPEAT with optional WHILE
\ BEGIN..REPEAT with optional WHILE
\ For demonstration purposes only.
: back \ alias for AGAIN or 0 UNTIL
[defined] again [if] postpone again
[else] postpone 0 postpone until [then] ; immediate
\ drop marker
: -mark ( C: mark -- ; orig|dest -- orig|dest )
cs-test 0= if cs-drop then ;
: BEGIN ( C: -- mark dest )
cs-mark postpone begin ; immediate
: WHILE
cs-push -mark cs-pop
postpone while ; immediate
: REPEAT
postpone back
cs-test if postpone then else -mark then ; immediate
: UNTIL
postpone until -mark ; immediate
\ Not needed since BEGIN..REPEAT now replaces AGAIN
\ : AGAIN postpone back ; immediate
\ Compilation tests
\ Forth-94 loops
: t1 begin 0 while repeat ;
: t2 begin 0 while 1 while repeat then ;
: t3 begin 1 until ;
: t4 begin 1 while 1 until then ;
: t5 begin 0 while begin 1 while repeat repeat ;
\ Infinite loop using BEGIN..REPEAT
: ?break key? if key drop quit then ;
: t6 begin ?break repeat ;
: t7 begin ?break t5 repeat ;
\ Control-flow stack extension words. Sample implementation.
\ Assumes control flow is on the data stack and control flow
\ items are one cell wide.
variable cf0
\ initialize control flow stack base
: !cfs ( -- ) sp@ cf0 ! ; !cfs
: #cs ( -- n )
sp@ cf0 @ - negate [ 1 cells ] literal / 1-
0 max ( handle empty stack) ;
: CS-PICK pick ( +bal) ;
: CS-ROLL roll ;
: CS-DROP drop ( -bal) ;
: CS-MARK 0 ( +bal) ;
: CS-TEST dup 0<> ;
: CS-PUSH #cs -roll ;
: CS-POP #cs roll ;
: : ( "name" -- ) ... ( !csp bal off) !cfs ;
: :NONAME ( -- xt ) ... ( xt ) ( !csp bal off) !cfs ;
\ start Forth with control flow base set to a safe value
: COLD ( -- ) ... !cfs ;
2014-03-10 Update example 2. Add sample implementation.
Page updated: 10 Mar 2014