Control-Flow Stack Extensions

2011-08-19

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 the Standard are few with the result only simple control structures can be realized. To alleviate this shortcoming the following extensions are presented.

Control-Flow Stack Extensions

CS-DROP ( C: x -- )

Remove the top item from the control-flow stack.

CS-PUSH ( C: xu..x1 x0 -- x0 xu..x1 )

Rotate items on the control-flow stack such that the top item becomes the bottom. An ambiguous condition exists if the control-flow stack is empty before CS-PUSH is executed.

CS-POP ( C: xu xu-1..x0 -- xu-1..x0 xu )

Rotate items on the control-flow stack such that the bottom item becomes the top. An ambiguous condition exists if the control-flow stack is empty before CS-POP is executed.

CS-MARK ( C: -- x )

Place a marker on the control-flow stack. A marker occupies the same width as an orig|dest but is distinguishable using CS-TEST.

CS-TEST ( C: x -- x ) ( S: -- flag )

Return a true flag if x is an orig|dest, or false if a marker. x is not altered or removed.

If the control-flow stack is implemented using the data stack, flag shall be the topmost item on the data stack.

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

  \ Build Standard CASE

  : CASE  cs-mark ; immediate

  : ENDOF  postpone else ; immediate

  : OF  postpone over  postpone =  postpone if
    postpone drop ; immediate

  : END-CASE
    postpone thens ; immediate

  : ENDCASE
    postpone drop  postpone end-case ; 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

  \ Case demo
  hex
  : test ( n )  space
    case
      cond
            0  20 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
        ." Not a character "
    endcase ;
  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 Standard 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 ;

Top    Home    Forth

Page updated: 19 Aug 2011