ANEW --GOTO--  DECIMAL                        \  Wil Baden  2000-06-10

\  GOTO in Forth

\          LABEL <name>    GOTO <name>

\  Forth control flow is complete.  Everything that GOTO and
\  LABEL can do, Forth can replicate.  Using `CS-ROLL`, Forth
\  can implement gotos and labels.

\  On occasions when unstructured control flow is desirable,
\  gotos and labels are clearer than explicitly shuffling the
\  control-flow stack with `CS-ROLL`.

\  Donald E. Knuth, "Structured Programming with `goto`
\  Statements" (1974), reprinted in _Literate Programming_
\  (1992), discusses situations where gotos are appropriate.
\  Elsewhere I will convert and compare his examples in
\  structured Forth and Forth with gotos.

\  In the following implementation, labels are case sensitive and
\  must be recognized by the first `2 CELLS` characters.
\  Only one `GOTO` can go to a previous label. This is to keep
\  the programming simple - the `AGAIN` compiled by `GOTO` to an
\  already defined label consumes the label. Previous labels may
\  be defined more than once to handle more than one backward
\  goto. However, many `GOTO`s can be made to each one of future
\  labels.

\  Because control-flow elements are removed when they are
\  resolved, labels may be redefined. Thus all loops may begin
\  and end with the same labels, such as `START` and `END`. Or
\  you may use distinct labels.

\  Programming note.  Many Forth systems use the data stack for
\  control flow.  Therefore the data stack must be cleared before
\  compiling control-flow words.

\  LABEL   ( "name" -- )( C: -- dest  OR  orig_1 ... orig_n -- )
\     A destination.  If _name_ has no gotos to it, `LABEL
\     _name_` becomes a `BEGIN`, otherwise enough `THEN`s are
\     used to resolve the gotos.  As labels are resolved they
\     are removed (from `Label-Table`).

\  GOTO   ( "name" -- )( C: -- orig  OR  dest -- )
\     The origin of an unconditional branch.  If _name_ has
\     no `LABEL`, `GOTO _name_` becomes `FALSE IF` (or `AHEAD`),
\     otherwise the last `LABEL _name_` is resolved with `AGAIN`
\     and removed (from `Label-Table`).

\          Needed from Tool Belt

\  Uses  THIRD   3DUP   3DROP   NOT  from ToolBelt.

TRUE 0<> [IF]  \  Comment out any words that are already defined.
    : THIRD  ( x y z -- x y z x )  2 PICK ;
    : 3dup   ( x y z -- x y z x y z )  THIRD THIRD THIRD ;
    : 3DROP  ( x y z -- )  2DROP DROP ;
    : NOT    ( x -- flag )  0= ;
[THEN]

    TRUE 1 RSHIFT INVERT  CONSTANT  Sign-Bit

\  Label-Table         ( -- addr )
\     Extension of the control-flow stack. The
\     contents are double numbers - label for `GOTO`,
\     "smudged" label for `LABEL`, `0.` for control-flow words.

\  CS-Count            ( -- addr )
\     Counter for the depth of `Label-Table`.

\  Pickup-Label-for-Lookup  ( "label" -- label . )
\     Get next word from source input and store its first two
\     cells in the top of `Label-Table`.

\     Used in `Lookup-Comefrom` and `Lookup-Goto`.

\  Lookup-Label        ( label . index -- label . index' )
\     Look up a label beginning at _index_-1.  If label isn't
\     found, returns -1 as _index'_, otherwise the index where
\     it was found.

\  Lookup-Comefrom     ( "label" -- index )
\     Get next word from source input and look for it as a
\     previous `GOTO`.

\     Used in `LABEL`.

\  Lookup-Goto         ( "label" -- index )
\     Get next word from source input and look for it as a
\     previous `LABEL`.

\     Used in `GOTO`.

\  Resolve-Label       ( index n -- )
\     The equivalent of `n CS-ROLL` for `Label-Table`.

\  Resolve-the-ComeFroms  ( index -- )
\     Do `THEN` for each of the previous `GOTO`s.

\     Used in `LABEL`.

100 CONSTANT Max#Labels  \  Undocumented restriction.
CREATE Label-Table  Max#Labels 2* CELLS ALLOT

VARIABLE CS-Count      \  Counter for unresolved control flow.

: Pickup-Label-for-Lookup    ( "label" -- label . )
    BL WORD COUNT  2 CELLS MIN          ( str len)
    CS-Count @ 2* CELLS Label-Table +   ( str len addr)
    dup >R
        0. R@ 2!  SWAP MOVE
    R> 2@ ( label .) ;

: Lookup-Label    ( label . index -- label . index' )
    BEGIN
        1-  dup 0< NOT WHILE
        3dup 2* CELLS Label-Table + 2@ D=
    UNTIL THEN ;

: Lookup-Comefrom    ( "label" -- index )
    Pickup-Label-for-Lookup      ( label .)
    CS-Count @ Lookup-Label      ( label . index)
    NIP NIP ( index) ;

: Lookup-Goto         ( "label" -- index )
    Pickup-Label-for-Lookup      ( label .)
    Sign-Bit OR
    CS-Count @ Lookup-Label      ( label . index)
    NIP NIP ( index) ;

: Resolve-Label       ( index n -- )
    over - >R                    ( index)
        2* CELLS Label-Table +   ( addr)
        dup 2 CELLS + SWAP       ( addr' addr)
    R> 2* CELLS MOVE ( ) ;

: Resolve-the-Comefroms   ( index -- )
    dup 2* CELLS Label-Table + 2@ ROT  ( label . index)
    BEGIN
        dup 2SWAP 2>R >R       ( index)( R: label . index)
            CS-Count -1 over +! @   ( index cnt)
            2dup 2>R
                SWAP - CS-ROLL postpone THEN
            2R> Resolve-Label  ( )
        R> 2R> ROT             ( label . index)( R: )
        Lookup-Label
    dup 0< UNTIL
    3DROP ( ) ;

: LABEL ( "_label_" -- )( C: -- dest  OR  orig_1 ... orig_n -- )
    Lookup-Comefrom       ( index)
    dup 0< IF DROP        ( )          \  BEGIN
        postpone BEGIN
        CS-Count @ 2* CELLS Label-Table +
            dup >R  @ Sign-Bit OR  R> !
        1 CS-Count +!
    ELSE                  ( index)     \  THEN
        Resolve-the-Comefroms
    THEN ; IMMEDIATE

: GOTO ( "_label_" -- )( C: -- orig  OR  dest -- )
    Lookup-Goto           ( index)
    dup 0< IF DROP        ( )          \  AHEAD
        \ POSTPONE AHEAD
        postpone FALSE  postpone IF
        1 CS-Count +!
    ELSE                  ( index)     \  AGAIN
        CS-Count -1 over +! @  ( index cnt)
        2dup 2>R
            SWAP - CS-ROLL postpone AGAIN
        2R> Resolve-Label  ( )
    THEN ; IMMEDIATE

\                                            2000-05-31 Wil Baden

\      IF  WHILE  ELSE  THEN  BEGIN  AGAIN  UNTIL  REPEAT  :

\  The standard control-flow words must be redefined so they can
\  be mingled with the label words.

\  `IF` and `BEGIN` are extended to put an empty label on top of
\  `Label-Table`.

\  The other control-flow words search `Label-Table` for the empty
\  label of the last control-flow word.

\  `CS-ROLL` brings the control-flow word to the top of the
\  control-flow stack, and the normal control-flow word is
\  compiled. `Label-Table` is updated equivalently.

\  `:` is extended to initialize Label-Table.

\  As defined in standard Forth, DO-loops can not be mingled
\  with control-flow words.  Use `LEAVE` to break out of a
\  DO-loop, or rewrite DO-loops as `BEGIN ... UNTIL`.

\  Mark-Control-Flow      ( -- )
\     Mark control flow for `IF` and `BEGIN` in `Label-Table`.

\  Resolve-Control-Flow   ( -- index )
\     Resolve control flow in `Label-Table`.

: Mark-Control-Flow      ( -- )
    0.  CS-Count @ 2* CELLS Label-Table +  2!
    1 CS-Count +! ;

: Resolve-Control-Flow   ( -- index )
    0.  CS-Count @ Lookup-Label NIP NIP ( index)
    dup 0< ABORT" Missing Control Flow " ;

: IF   ( C: -- orig )
    postpone IF  Mark-Control-Flow ; IMMEDIATE

: WHILE   ( C: dest -- orig dest )
    Resolve-Control-Flow  ( index)
    CS-Count @ SWAP - 1- CS-ROLL  ( )
    postpone IF  1 CS-ROLL            \  Uses new IF.
    ; IMMEDIATE

: ELSE   ( C: orig_1 -- orig_2 )
    Resolve-Control-Flow  ( index)
    CS-Count @ SWAP - 1- CS-ROLL  ( )
    postpone ELSE
    ; IMMEDIATE

: THEN   ( C: orig -- )
    Resolve-Control-Flow ( index)
    CS-Count -1 over +! @   ( index cnt)
    2dup 2>R
        SWAP - CS-ROLL postpone THEN
    2R> Resolve-Label                      ( )
    ; IMMEDIATE

: BEGIN   ( C: -- dest )
    postpone BEGIN  Mark-Control-Flow ; IMMEDIATE

: AGAIN   ( C: dest -- )
    Resolve-Control-Flow ( index)
    CS-Count -1 over +! @   ( index cnt)
    2dup 2>R
        SWAP - CS-ROLL postpone AGAIN
    2R> Resolve-Label                      ( )
    ; IMMEDIATE

: UNTIL   ( C: dest -- )
    Resolve-Control-Flow ( index)
    CS-Count -1 over +! @   ( index cnt)
    2dup 2>R
        SWAP - CS-ROLL postpone UNTIL
    2R> Resolve-Label                      ( )
    ; IMMEDIATE

: REPEAT   ( C: orig dest -- )
    \  Uses new AGAIN and THEN.
    postpone AGAIN  postpone THEN ; IMMEDIATE

: : : 0 CS-Count ! ;

\      * * * * * * *
\      * Examples  *
\      * * * * * * *

MARKER Test-and-Forget

\  Labels only.

: GCD1  ( m n -- gcd )
    LABEL START
        dup 0= IF GOTO END THEN
        TUCK ( n  m n) MOD ( m n)
    GOTO START
    LABEL END  DROP ;

20451 24140 GCD1 CR .  \  17

\  Mingled label and control flow.

: GCD2  ( m n -- gcd )
    BEGIN
        dup 0= IF GOTO END THEN
        TUCK ( n  m n) MOD ( m n)
    AGAIN
    LABEL END  DROP ;

20451 24140 GCD2 CR .  \  17

\  Multiple Labels

: Multi-Go  ( -- )
    4 -2 DO  CR  ." \ "
        I 1 AND IF GOTO NEXT THEN
        ." even "
        I IF GOTO NEXT THEN
        ." zero "
    LABEL NEXT
        I 0< IF GOTO NEXT THEN
        ." non-negative "
    LABEL NEXT
        I .
    LOOP ;

Multi-Go

\ even -2
\ -1
\ even zero non-negative 0
\ non-negative 1
\ even non-negative 2
\ non-negative 3

( END ) Test-and-Forget

\\  End of GOTO in Forth