Path: utzoo!utgpu!news-server.csri.toronto.edu!rutgers!rochester!pt.cs.cmu.edu!dsl.pitt.edu!pitt!willett!ForthNet
From: ForthNet@willett.pgh.pa.us (ForthNet articles from GEnie)
Newsgroups: comp.lang.forth
Subject: PUZZLES AND PROBLEMS
Message-ID: <1511.UUL1.3#5129@willett.pgh.pa.us>
Date: 13 Aug 90 03:45:16 GMT
Organization: String, Scotch tape, and Paperclips.  (in Pgh, PA)
Lines: 95

Category 3,  Topic 35
Message 131       Sun Aug 12, 1990
W.BADEN1 [Wil]               at 09:39 PDT
 
 \ Examples of readable Forth by Mitch Bradley as edited by Wil Baden.

 \ CATCH/THROW Error Handling Wordset.

 \ This implementation uses the non-standard words SP@ , SP! , RP@ , and
 \ RP! .  These words, or their equivalents, are present in most systems.

 \ Thanks to Don Colburn and Dean Sanderson for implementation suggestions.

 VARIABLE Handler  \ Most recent error handler (should be a USER variable).

 : CATCH  ( cfa -- error#, or 0 )
                   ( cfa )  \ Return address is already on the stack.
    SP@ >R         ( cfa )  \ Save data stack pointer.
    Exception @ >R ( cfa )  \ Previous handler.
    RP@ Handler !  ( cfa )  \ Set current handler to this one.
    EXECUTE        (  )     \ Execute the word passed in on the stack.
    R> Handler !   (  )     \ Restore previous handler.
    R> DROP        (  )     \ Discard saved stack pointer.
    0              ( 0 )    \ Signify normal completion.
 ;

 : THROW  ( ??? error# -- ??? error# ) \ Returns in saved context.
    ?DUP IF          ( err# )
       Handler @ RP! ( err# )      \ Return to saved return stack context.
       R> Handler !  ( err# )      \ Restore previous handler.

       \ Remember error# on return stack before changing data stack pointer.

       R> SWAP >R    ( saved-sp )  \ err# is on return stack.
       SP! (  ) R>   ( err# )      \ Change stack pointer.

       \ This return will return to the caller of catch, because the return
       \ stack has been restored to the state that existed when CATCH began
       \ execution.
    THEN             ( err# )
 ;

 Another readable code submission:

 \ LEFT-PARSE-STRING  ( adr len char -- adra lena  adrb lenb )
 \ Splits a string into two halves around a delimiter character.
 \ If the delimiter character is present in the string, adra lena is the
 \ substring after the first occurrence of the character, adrb lenb
 \ is the substring before it.
 \ Both substrings exclude the character itself.
 \
 \ If the character is not present in the string, the original string
 \ adr len is returned, and the flag on top of the stack is false.

 \ Removes max(n,len) characters from the beginning of the string "adr len".
 : /string  ( adr len n -- adr+len adr-len )
    OVER MIN    >R ( adr len) SWAP ( len adr ) R@ +    SWAP ( adr len ) R> -
 ;
 ( Another definition.)
 : /string  ( adr len n -- adr+len adr-len )
    OVER MIN    2>R ( adr ) R@ +    2R> ( adr len n ) -
 ;

 : +string  ( adr len -- adr len+1 ) 1+  ;
 : -string  ( adr len -- adr+1 len-1 ) >R ( adr ) 1+    R> ( adr len ) 1- ;

 \ adra,lena is the string after the delimiter.
 \ adrb,lenb is the string before the delimiter.
 \ lena = 0 if there was no delimiter.

 : left-parse-string  ( adr len char -- adra lena  adrb lenb  )
    >R ( adr len ) OVER 0 ( adra lena adrb lenb ) 2SWAP ( adrb lenb adra lena
)

    \ Throughout the loop, we maintain both substrings.  Each time through,
    \ we add a character to the first string and remove it from the second.
    \ The loop terminates when either the second string is empty or the
    \ desired character is found.

    BEGIN    DUP WHILE                  ( adr0 len0  adr1 len1 )
       OVER C@ R@ = IF                  \ Found it; exchange strings.
          R> DROP   -string    2SWAP    ( adra lena  adrb lenb )
          EXIT
       THEN                             ( adr0 len0  adr1 len1 )
       2>R ( adr0 len0 ) +string    2R> ( adr0 len0  adr1 len1 )
       -string                          ( adr0 len0  adr1 len1 )
    REPEAT                              ( adr0 len0  adr1 len1 )

    \ Character not found.  len1 is 0.
    2SWAP                               ( adra lena  adrb lenb )
    R> DROP
 ;
-----
This message came from GEnie via willett through a semi-automated process.
Report problems to: uunet!willett!dwp or dwp@willett.pgh.pa.us