🚀 go-pugleaf

: LINE-EATER   80 EXPECT  DROP ;

  In the July, 1986 issue of _Dr. Dobb's Journal of Software Tools_ (the annual
FORTH issue), George W. Shaw II proposes some extensions to the standard FORTH
control structures. While I think some of his ideas are good, I feel that they
got rather mangled somewhere along the way. (i.e. Aren't implemented well.)
Herein are some of my suggestions.

  The main idea in George Shaw's article was that of using linked lists instead
of the stack to store information about forward branches.  Since a cell has to
be allocated after BRANCH or ?BRANCH in a definition to store the branch
address, which isn't available until the branch is resolved, it can be put to
use to allow a BEGIN-WHILE loop to have the structure: "BEGIN", any number of
"WHILE"s (including 0), and "REPEAT" or "UNTIL", as in this example:

: FOO   BEGIN aaa WHILE bbb WHILE ccc UNTIL ;

 where the linked list uses a variable as its head pointer, resulting in this
dictionary organization jusrt before "until" resolves the works:

{header stuff}  aaa ?BRANCH ___ bbb ?BRANCH ___ ccc 
                ^           | ^             | ^
STACK ----------+     null <+ +-------------+ +----- LIST-PTR

 and, after UNTIL, we have:

                +--------------------------------------------+
                v                                            |
{header stuff}  aaa ?BRANCH ___ bbb ?BRANCH ___ ccc ?BRANCH ___
                             |               |                  ^
                             +-------------->+------------------+

 which is just as it should be. This can also be used to allow a word such as
THENS, which fixes all the  IF aaa IF bbb IF ccc THEN THEN THEN  stuff that
you often have to wade through. Before the first THEN, things would look like
this:

{header stuff}  ?BRANCH ___ aaa ?BRANCH ___ bbb ?BRANCH ___ ccc
                        | ^             | ^             | ^
                 null <-+ +-------------+ +-------------+ +- IF-PTR

 and THENS could resolve the whole linked list like so:

{header stuff}  ?BRANCH ___ aaa ?BRANCH ___ bbb ?BRANCH ___ ccc
                         |               |               |      ^
                         +-------------->+-------------->+------+

 as it should be.  Just plain THEN would just resolve the last link of the
list.  ELSE would change the list from this:   

{header stuff}  ?BRANCH ___ aaa
                        | ^
                 null <-+ +---- IF-PTR

 to this:

                         +-----------------+
                         |                 v
{header stuff}  ?BRANCH ___ aaa BRANCH ___
                                       | ^
                                null <-+ +--- IF-PTR

 by just patching the last link of the list.

 The other control word which can benifit from this is the F-83 standard
LEAVE, which branches _immediately_ to past the end of the loop.  Since there
is no constant number of LEAVEs in a DO-LOOP, the stack can't be used to store
forward branch addresses for LOOP to patch.  A linked list works admirably int
this application.

 Since DO-LOOPs and BEGINs can be nested, it is necessary to put the head
pointer for the outer loop on the stack while the inner loop uses it for
bookkeeping. Since DO and BEGIN already use the stack to store backwards-branch
information, the addition of an extra value there should not upset anyone
else's compile-time use of the stack.

 One really wonderful (I modestly think) consequence of this system is that IF,
ELSE, and THEN make _no_ use of the stack whatsoever at compile time, thus
allowing words like this: 

: BAR  aaa BEGIN bbb IF ccc REPEAT ddd THEN eee ;

 That is, looping constructs such as BEGIN and REPEAT can be put inside IF
statements.  The most crying need for this is in the use of a LEAVE command.
It's easy to write:

: HUNT
   0 1000 DO aaa  IF  ." Search succeeds for n = " .  LEAVE THEN  bbb LOOP ;

but how do you add a "Search fails" message, to be printed if the loop ends by  reaching 1000 with no result?  The answer is:

: HUNT
   0 1000 DO aaa  IF  ." Success! n = " .  ELSE  bbb LOOP ." Failed"  THEN ;

 which I think is rather more elegant than putting a flag on the stack and
testing it after the LOOP.  The only catch is that a DO-LOOP puts some values
on the return stack, which have to be cleaned up before EXIT sees them and
crashes the system.  An ENDLOOP word can be added somewhere between IF and ELSE
to straighten this out:

: ENDLOOP ( --)   R>            ( save return address to calling word)
                  R> R> 2DROP   ( get rid of index and limit)
                  >R            ( put return address back)
                  ;

 This use of intersecting control structures is quite commonly used in
interpreted BASIC (yes, I admit it, that's where I started), and I don't
see why I should have to give up a useful control structure when using a
better language.

Now, the guts of this article: the code.

Note: If you can think up better names for any of the words I use in this
      code, I'd loove to hear them. I _do_ use a few clumsy multi-word
      names, which isn't great.

      ******* WARNING: This code is UNTESTED. It is in no *******
      ******* way guaranteed to work, and in fact probably ******
      ***** _won't_ work the forst time around. Good  luck! *****

( A few things you might not have - F-83 standard and otherwise)

: 0!        0 SWAP ! ;       ( fairly obvious)
: >MARK     HERE  2 ALLOT ;  ( -- addr) ( see F-83 standard)
: >RESOLVE  HERE SWAP ! ;    ( addr --) ( ditto)
: <MARK     HERE ;           ( -- addr)
: <RESOLVE  , ;              ( addr --)

( The new stuff)

VARIABLE IF-LIST
VARIABLE DO-LIST
VARIABLE BEGIN-LIST

: INIT-LISTS   IF-LIST 0!  DO-LIST 0!  BEGIN-LIST 0! ;

: >LISTMARK ( addr --) ( mark forward branch origin using list "addr")
            HERE SWAP DUP   ( here addr addr) 
            @               ( here addr list-head)
            ,               ( here addr)  ( point this link to last one)
            ! ;             ( ) ( make list-ptr point to this link)

: >LISTRESOLVE ( addr --) ( resolve forward branch)
            DUP @           ( addr list-head)
            DUP @           ( addr list-head new-list-head)
            ROT !           ( list-head) (make list-ptr point to previous link)
            >RESOLVE ;      ( ) ( do standard resolution stuff)

: >RESOLVELIST ( addr --) ( resolve entire list)
            DUP 0! @        ( list-head) ( go down one link and set list-ptr to                                            null)
            BEGIN
              DUP WHILE     ( list-head) ( when the list-head is null, we've                                               reached the end)
              DUP @ SWAP    ( new-list-head list-head)
              >RESOLVE      ( new-list-head) ( resolve this link)
            REPEAT          ( null) 
            DROP ;          ( )

: IF  ( --)
            COMPILE ?BRANCH         ( just like regular IF)
            IF-LIST >LISTMARK ;     ( mark forward branch)
            ; IMMEDIATE

: ELSE  ( --)
            COMPILE BRANCH
            IF-LIST >LISTMARK       ( These two lines are rather tricky)
            IF-LIST @ >LISTRESOLVE  ( Follow the algorithm to prove they work)
            ; IMMEDIATE

: THEN ( --)
            IF-LIST >LISTRESOLVE    ( does this need explaining?)
            ; IMMEDIATE

: THENS ( --)                       ( like THEN THEN THEN...., as often as                                            necessary)
            IF-LIST >RESOLVELIST
            ; IMMEDIATE

: BEGIN ( -- old-list-ptr back-branch-ptr)
            BEGIN-LIST DUP @   ( 'list-ptr contents-of-list-ptr)
            SWAP 0!            ( old-list-ptr)
( The list-ptr now contains null, ready for this nesting level)
            <MARK              ( old-list-ptr back-branch-ptr)
            ; IMMEDIATE

: WHILE  ( --)
            COMPILE ?BRANCH
            BEGIN-LIST >LISTMARK
            ; IMMEDIATE

: REPEAT ( old-list-ptr back-branch-ptr --)
            COMPILE BRANCH
            <RESOLVE                    ( old-list-ptr)
            BEGIN-LIST DUP >RESOLVELIST ( old-list-ptr 'list-ptr)
            !                           ( )
            ; IMMEDIATE

: UNTIL  ( old-list-ptr back-branch-ptr --)
( The stack comments here are the same as those for REPEAT. These comments on     what's going on also apply to REPEAT.)
            COMPILE ?BRANCH
            <RESOLVE            ( fix branch back to BEGIN)
            BEGIN-LIST DUP >RESOLVELIST
( Make all the WHILEs point to just past the UNTIL, keeping a copy of the         address of BEGIN-LIST...)
            !                    ( ...to restore the old list pointer to)
            ; IMMEDIATE

: DO    ( -- old-list-ptr back-branch-ptr)
            DO-LIST DUP @       ( 'list-ptr old-list-ptr) ( save old DO-LIST)
            SWAP 0!             ( old-list-ptr) ( set DO-LIST to null)
            COMPILE (DO)        ( old-list-ptr) ( DO run-time part)
            <MARK               ( old-list-ptr back-branch-ptr)
            ; IMMEDIATE

: LEAVE  ( --)
            COMPILE BRANCH
            DO-LIST >LISTMARK
            ; IMMEDIATE

: LOOP  ( old-list-ptr back-branch-ptr --) ( see BEGIN and UNTIL for comments)
            COMPILE (LOOP)
            <RESOLVE
            DO-LIST DUP >RESOLVELIST
            !
            ; IMMEDIATE

: +LOOP ( old-list-ptr back-branch-ptr --)
            COMPILE (+LOOP)
            <RESOLVE
            DO-LIST DUP >RESOLVELIST
            !
            ; IMMEDIATE

: ENDLOOP ( --) ( clear LOOP's gunk off the return stack)
            R>  R> R> 2DROP  >R ; ( you've seen the comments already!)

EXIT       ( ignore final comments)

Note: I did copy quite a bit of the preceeding code from the DDJ article.
      DDJ has a policy of allowing use of any code published therein for
      non-commercial use. If you intend to sell this code in a product, you
      might want to talk to them (M&T Publishing, Inc., 501 Galveston Dr.,
      Redwood City, CA 94063, U.S.A.) first.  Myself, I've no objections 
      *whatsoever* to *any* use of these ideas - I'd find it highly flattering.
      I'd like it even better if you'd tell me about it, or even give me a copy.
      Since George Shaw is proposing this as a new standard, I don't think he'll
      mind anyone spreading it around. (I'm proposing mine as a *better*
      standard)

  I hope you find this interesting!       - Colin Plumb (ccplumb@watnot.UUCP)

Quote:   : LIFE  BEGIN  5 0 DO WORK LOOP  SLEEP SLEEP REPEAT ;
   ( See? With these new control structures you don't need AGAIN or 0 UNTIL!)