home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / setjmp.seq < prev    next >
Text File  |  1990-03-27  |  2KB  |  56 lines
  1. \\ SETJMP.SEQ       Add "C"-like setjmp to F-PC          by Tom Zimmer
  2.  
  3.   Add "C"-like error exit to F-PC. If an error occurs that needs to abort
  4. up to a much higher execution level, this file provides a mechanism to
  5. do it without having to include a test at each level above the current
  6. level until the desired level is reached.
  7.  
  8.                                 +0       +2       +4
  9.         jump buffer format:     [rp_ptr] [rp_off] [sp]
  10.  
  11.         ****** this file can be loaded on either F-PC or TCOM ******
  12.  
  13. {
  14.  
  15. DEFINED :: NIP 0= #IF ' : alias :: #ENDIF       \ define if needed
  16.  
  17. :: jumpbuf      ( | <name> -- )         \ allow defining a jump buffer
  18.                 create 0 , 0 , 0 , does> ;
  19.  
  20. : setjmp        ( a1 -- f1 )            \ a place to come back from "longjmp"
  21.                 rp@ over !              \ save current return stack ptr
  22.                 r@  over 2+ !           \ and contents of return stack
  23.                 sp@ 2+ over 4 + !       \ and current data stack ptr
  24.                 drop false ;            \ discard buffer and return false
  25.  
  26. : longjmp       ( a1 -- f1 )            \ jump back to after "setjmp"
  27.                 dup @ 0= abort" No `setjmp' performed!"
  28.                 dup>r 2+ @ r@ @ !       \ fix return stack to follow "setjmp"
  29.                 r@ 4 + @ sp!            \ fix data stack, as at "setjmp"
  30.                 r> @ rp! true ;         \ set return stack to "setjmp"
  31.                                         \ and return true flag
  32.  
  33. \S              **** don't load the rest of this file ****
  34.  
  35. \ ***************************************************************************
  36. \ here is an example of how to use "jumpbuf", "setjmp", and "longjmp".
  37. \ ***************************************************************************
  38.  
  39. jumpbuf jumptest
  40.  
  41. : test4         ( -- )
  42.                 cr ." about to longjump "
  43.                 jumptest longjmp        \ jump to right after "setjmp"
  44.                                         \ with a true flag on stask
  45.                 ." failed" ;            \ shouldn't ever get here
  46. : test3         ( -- ) test4 ;
  47. : test2         ( -- ) test3 ;
  48. : test          ( -- )
  49.                 jumptest setjmp         \ initialize a long jump
  50.                 if      ." true "       \ gets here if there was an error
  51.                         ABORT
  52.                 else    ." false "      \ goes here on first execution
  53.                 then
  54.                 test2 ;
  55. }
  56.