This is G o o g l e's cache of http://home.earthlink.net/~neilbawd/goto.html.
G o o g l e's cache is the snapshot that we took of the page as we crawled the web.
The page may have changed since that time. Click here for the current page without highlighting.
To link to or bookmark this page, use the following url: http://www.google.com/search?q=cache:qGClcMAywJ0C:home.earthlink.net/~neilbawd/goto.html+&hl=en&ie=UTF-8

Google is not affiliated with the authors of this page nor responsible for its content.
GOTO in Forth

GOTO in Forth

Get TEXT

Wil Baden 2000-06-10 2001-10-01

[IFGOTO and use of VOCABULARY removed 2001-07-12.]

LABEL <name> GOTO <name>

Forth control flow is complete. Everything that gotos and labels 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 GOTOs 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 THENs 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



    THIRD   3DUP   3DROP   NOT   SIGN-BIT




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= ;

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 GOTOs.


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




Go back to home page.