git.gag.com Git - debian/pforth/blob - catch.fth

   1 \ @(#) catch.fth 98/01/26 1.2
   2 \ Catch and Throw support
   3 \
   4 \ Lifted from X3J14 dpANS-6 document.
   5
   6 anew task-catch.fth
   7
   8 variable CATCH-HANDLER
   9 0 catch-handler !
  10
  11 : CATCH  ( xt -- exception# | 0 )
  12         sp@ >r              ( xt ) \ save data stack pointer
  13         catch-handler @ >r  ( xt ) \ save previous handler
  14         rp@ catch-handler ! ( xt ) \ set current handler
  15         execute             ( )    \ execute returns if no throw
  16         r> catch-handler !  ( )    \ restore previous handler
  17         r> drop             ( )    \ discard saved stack pointer
  18         0                   ( )    \ normal completion
  19 ;
  20
  21 : THROW ( ???? exception# -- ???? exception# )
  22         ?dup                      ( exc# ) \ 0 THROW is a no-op
  23         IF
  24                 catch-handler @
  25                 dup 0=
  26                 IF
  27                         ." THROW has noone to catch!" cr
  28                         quit
  29                 THEN
  30                 rp!   ( exc# ) \ restore prev return stack
  31                 r> catch-handler !    ( exc# ) \ restore prev handler
  32                 r> swap >r            ( saved-sp ) \ exc# on return stack
  33                 sp! drop r>           ( exc# ) \ restore stack
  34         THEN
  35         \ return to caller of catch
  36 ;
  37
  38
  39 : (ABORT) ERR_ABORT  throw ;
  40 defer old.abort
  41 what's abort is old.abort
  42 ' (abort) is abort
  43 : restore.abort  what's old.abort is abort ;
  44 if.forgotten restore.abort
  45
  46 hex
  47 : BAD.WORD  -5 throw ;
  48 : NAIVE.WORD ( -- )
  49         7777 8888 23 . cr
  50         bad.word
  51         ." After bad word!" cr
  52 ;
  53
  54 : CATCH.BAD ( -- )
  55         ['] naive.word catch  .
  56 ;
  57
  58 : CATCH.GOOD ( -- )
  59         777 ['] . catch . cr
  60 ;
  61 decimal