\\ EH:Exception handling      clv 04jul89
                                         
                                         
Es wird eine Methode der Fehlerbehandlung
vorgestellt, die                         
- abort" und error" umleitet             
- schachtelbar und von der Ebene des     
  installierenden Wortes abh„nt          
- ihre Daten auf dem Returnstack lagert  
                                         
                                         
                                         
                                         
                                         
                                         
                                         
                                         
                                         
                                         
                                         
                                         
                                         
                                         
                                         
                                        
\ EH:LOADs exception handling clv24feb88 
                                         
User ep           \ error-return-pointer 
User err  err off \ error-message        
                                         
                                         
                                         
  1 3 +thru \ throw EXITS #FAILS RETRY   
    4 +load \ patches (abort" (err" quit 
\ 5 7 +thru \ beispiel                   
                                         
                                         
save quit                                
                                         
                                         
                                         
\\ (c) 1988 volksFORTH83-Autoren         
       in der Forth-Gesellschaft e.V.    
                                         
enwickelt von Claus Vogt, 1988           
unter ultraFORTH83 Vs 3.8 auf CBM +4     
                                         
Thanks to Klaus Schleisiek and TLC-Lisp  
                                         
                                        
\ EH:returnstack  catch-throw clv24feb88 
                                         
: <rstack r> rp@ >r >r ; restrict        
                                         
: ,r      ( u--)                         
  r> r> rot >r >r >r ; restrict          
                                         
: rmove   ( adr u --)                    
  r> r>  rp@ 3 pick - rp!                
  rp@ -rot >r >r swap cmove ; restrict   
                                         
Create: unstack  r> rp! ;                
Create: uncatch  r> r> ep ! rp! ;        
: rstack> r> unstack >r >r ; restrict    
                                         
: catch>  r> r> ep @ >r rp@ ep ! >r      
             uncatch >r >r ; restrict    
                                         
: throw  err @                           
  IF ep @ rp!  r> ep ! ELSE rdrop THEN   
  ; restrict                             
                                         
: ?throw ( flag--)                       
  IF rdrop throw THEN ; restrict         
                                        
\ EH:(exits (fails (#fails    clv24feb88 
                                         
: (exits \ frame to be executed after    
         \ error or exit                 
  r>  err @ IF err dup push off THEN     
  dup 2+  >r  <rstack catch>             
  dup @ + >r ; restrict                  
                                         
: (fails \ frame executes after error    
  r>  <rstack  dup 2+ ,r  catch>         
  dup @ + >r ; restrict                  
                                         
Create: getargs          \ restore:      
 s0 @ r> 2* - sp!        \ stack-pointer 
 sp@ rp@ swap  r@ 1+ 2*  cmove \ values  
 r> 2* rp@ + rp! ;       \ returnstack   
                                         
: (#fails ( u*args u--u*args)            
  >r sp@ r> \ saves also arguments       
  r> <rstack  dup 2+ ,r                  
       -rot under 2* rmove ,r            
       depth ,r  getargs ,r  catch>      
  dup @ + >r ; restrict                  
                                         
                                        
\ EH:FAILS EXITS #FAILS RETRY clv24feb88 
                                         
: EXITS  compile (exits  >mark -1        
         ; immediate restrict            
                                         
: FAILS  compile (fails  >mark -1        
         ; immediate restrict            
                                         
: #FAILS ( n--)                          
         compile (#fails >mark -1        
         ; immediate restrict            
                                         
: RETRY  compile branch over 2- <resolve 
         [compile] THEN                  
         ; immediate restrict            
                                         
\\ use:                                  
                                         
EXITS      ...        throw THEN  ...    
                                         
(#)FAILS   ...   ?throw ... RETRY ...    
                                         
don't use: IF ... ELSE ... RETRY  !!!!   
                                         
                                        
\ EH:(error (abort" quit      clv24feb88 
                                         
' noop errorhandler  !                   
                                         
| : err! ( flag--) rdrop  "lit swap      
  IF dup err ! errorhandler perform drop 
     throw THEN  drop ;  restrict        
                                         
: n(abort" rdrop ( * ) err! ; restrict   
' n(abort"  ' (abort" >body  !           
                                         
: n(err"   rdrop ( * ) err! ; restrict   
' error" >body 2+ @  | Alias (err"       
' n(err"   ' (err"   >body  !            
                                         
: .err  space here .name                 
  err @  count type space ?cr ;          
: nquit    rdrop ( * )  r0 @ rp!         
  FAILS  standardi/o .err                
    blk @ ?dup IF scr !  >in @ r# ! THEN 
    err @ 2- @   ['] (err" -             
    IF clearstack THEN                   
  RETRY  err off  [compile] [  'quit ;   
' nquit  ' quit >body  !                 
                                        
\ EH:sample..                 clv24feb88 
                                         
: devon   ." aktion begonnen "  cr ;     
: devoff  ." aktion beendet "   cr ;     
                                         
                                         
: .ok     ." alles erfolgreich" cr ;     
: .handle ." Ausnahmebehandlung: " ;     
: .stack  ." Stack:" .s cr ;             
                                         
: ?y?  ( --flag)                         
  ." =y "  key capital Ascii Y =         
  dup 0= IF del del ." n " THEN cr ;     
                                         
: ok?  ." Fehler?" ?y? abort" abbruch" ; 
                                         
: retry? ( --flag) ." nochmal?" ?y? ;    
                                         
: action ( n1 n2 n3--nSum)               
  devon                                  
  .stack + +  ok?                        
  devoff ;                               
                                         
                                         
                                        
\ EH:..sample                 clv24feb88 
                                         
: tf    ."  t-1 " devon                  
  FAILS .handle   devoff   throw THEN    
        ."  t-2 " ok?                    
        ."  t-3 " devoff .ok ;           
                                         
: te    ."  t-1 " devon                  
  EXITS .handle   devoff   throw THEN    
        ."  t-2 " ok? .ok ;              
                                         
: t#       1111 2222 3333                
  3 #FAILS  .handle .stack               
            retry? 0= ?throw cr RETRY    
  action .ok .stack drop ;               
                                         
                                         
                                         
: test  0 #FAILS cr cr ." alles" retry?  
                 0= ?throw cr RETRY      
    cr ." mit FAILS:"  cr tf cr          
    cr ." mit EXITS:"  cr te cr          
    cr ." mit #FAILS:" cr t# cr ;        
                                         
                                        
\ EH:ouput of returnstack     clv24feb88 
                                         
\ Fuer Neugierige:                       
                                         
: tab at? &22 umax at ;                  
                                         
: ?.n ( adr string--)                    
  swap >name ?dup                        
  IF swap  count type  tab .name         
     rdrop exit THEN  drop ; restrict    
                                         
: ?.name ( adr--)                        
  dup 2-    " pfa of"  ?.n               
  dup 2- @  " "        ?.n               
  dup 4 - @ " data of" ?.n               
  tab ." ???" ;                          
                                         
: .rs r0 @ rp@  \ gibt rstack aus        
  DO cr I 6 u.r   I @ 6 u.r  space       
     I @ ?.name drop  2 +LOOP            
  cr ep @ 6 u.r ."  ep ! " ;             
                                         
                                         
                                         
                                        
                                         
                                         
                                         
                                         
                                         
                                         
                                         
                                         
                                         
                                         
                                         
                                         
                                         
                                         
                                         
                                         
                                         
                                         
                                         
                                         
                                         
                                         
                                         
                                         
                                        
\\ EH:the concept             clv24feb88 
                                         
This level-(and sytem-!!)-dependant,     
nestable exception-handler               
is able to reconstruct stack-pointer and 
stack-datas.                             
                                         
It uses a structured syntax              
opened by FAILS, #FAILS ( u--), EXITS    
closed by THEN, RETRY                    
                                         
The opening word installs the following  
clause as errorhandler and continues     
execution after the closing words.       
                                         
If ABORT" or ERROR" is invoked during    
this execution the installed errorclause 
is executed. It may RETRY execution or   
THROW away execution to the surrounding  
errorhandler, which may be for example   
the top-level errorhandler installed by  
QUIT.                                    
It remains the possiblitity to install   
a post-mortom-handler on lowest level.   
                                        
\\ EH:returnstack catch-throw clv24feb88 
                                         
r( --f)      begins frame                
                                         
r( f--u f)   adds word to frame          
                                         
                                         
r( f--u*Bytes f)  adds bytes at addr     
                                         
                                         
                                         
removes frame                            
r( f--f unstack-pfa) ends frame          
                                         
                                         
r( f--f errorLink uncatch-pfa)           
                                         
                                         
continues execution at installed error-h 
andling-clause if ERR. Else like EXIT.   
--------------------------------------   
 f     is the rstack-pointer above frame 
 ep    points to a linked list of        
       errorhandling-frames              
 frame means a data-block on retStack   
\\ EH:(exits (fails (#fails   clv24feb88 
                                         
RSTACK after execution of:               
                                         
    (exits        (fails      (#fails    
    -----------   ---------   ---------  
    ...........   .........   .........  
    ...........   .........   .... <--+  
    ...........   .........   arg1    ^  
    ...rstack..   ..rstack.   arg2    ^  
    ...before..   ..before.    ..     ^  
    ...(exits..   ..(fails.   argU    ^  
    ...........   .........   u       ^  
    ...........   .........   sDepth  ^  
    ...........   .... <--+   GETARGS ^  
    handle <--+   handle  ^   handle  ^  
    f  -->-->-+   f  -->--+   f  -->--+  
 +->oldEP         oldEP       oldEP-->   
 ^  UNCATCH       UNCATCH     UNCATCH    
 ^     !             !           !       
 ^     !             !           !       
 ^     V             V           V       
 ^                                       
                                         
EP @                                    
\\ EH:FAILS EXITS #FAILS RETRYclv24feb88 
                                         
Syntax: : name clause1                   
               beg  handle-clause end    
               clause2 ;                 
                                         
beg::= EXITS / FAILS / u #FAILS          
end::= THEN  / RETRY                     
                                         
handle-clause may contain THROW, ?THROW  
or other words. It is invoked, if ABORT" 
or ERROR" is called during execution of  
clause2.                                 
                                         
compiles to:                             
                                         
 (EXITS           +--> (FAILS / (#fails  
  ptr ->-+        ^     ptr ->-+         
  ...    !        ^     ...    !         
 THROW   !        ^    ?THROW  !         
  ... <--+        ^     ...    !         
                  ^    BRANCH  !         
                  +--<- ptr    !         
                        ... <--+         
                                        
\\ EH:patches for volksFORTH  clv24feb88 
                                         
ERRORHANDLER called on low level. May    
 used to output post-mortem-information  
                                         
(ABORT" and (ERR" must be patched.       
 Stores following string, performs       
 ERRORHANDLER and THROWs to outer level  
 error-clauses.                          
                                         
QUIT must be patched.                    
 Installs top-level errorhandler-clause, 
 which executes the same as the old      
 (ERROR-handler, which can be omitted.   
 It also demonstrates the (perhaps only) 
 use of .. FAILS ... RETRY ...           
                                         
                                         
( * ) RDROPs with this mark are          
      necessary when patching words      
                                         
                                         
                                         
                                         
                                        
\\ EH:sample..                clv24feb88 
                                         
DEVON is an example for an action,       
 which must be closed by another: DEVOFF 
 Used to demonstrate EXITS and FAILS     
                                         
.OK .HANDLE .STACK prints silly texts    
                                         
                                         
                                         
?Y? prompts for Yes/No and displays      
 the answer                              
                                         
                                         
OK? is an example for any action, that   
 may cause an error. It asks the User    
 to produce an error or not.             
                                         
ACTION is an example for any action      
 which consumes some arguments and       
 may cause an error.                     
 Used to demonstrate #FAILS              
                                         
                                         
                                        
\\ EH:..sample                clv24feb88 
                                         
TF demonstrates how to use               
     FAILS ... THEN                      
 to close an action if an error occures  
                                         
                                         
TE demonstrates how to use               
   EXITS ... THEN   for the same purpose 
                                         
                                         
T# demonstrates how to use               
   u #FAILS ... ?throw ... THEN          
 to save stack-pointer and arguments, so 
 that the error-causing action may be    
 RETRYd after the handling clause        
 decided not to THROW up execution.      
                                         
TEST puts TF, TE, T# in one word         
                                         
                                         
                                         
                                         
                                         
                                        
\\ EH:ouput of returnstack    clv24feb88 
                                         
                                         
                                         
                                         
                                         
?.N tries to output the name             
    corresponding to adr witch comment   
    string and leaves if possible        
                                         
                                         
?.NAME detects names of                  
    PFAs ( ie created bye CREATE:)       
    normal colon-definitions             
    words like BRANCH and (DO with data  
    and nothing else                     
                                         
.RS outputs adresses, contents           
    and perhaps right names on retStack  
    and the contents of EP which points  
    to a linked list of errorframes      
    placed on returnstack.               
                                         
                                         
                                        
























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































