Annotation of gforth/exceptions.fs, revision 1.3

1.1       anton       1: \ catch, throw, etc.
                      2: 
                      3: \ Copyright (C) 1999 Free Software Foundation, Inc.
                      4: 
                      5: \ This file is part of Gforth.
                      6: 
                      7: \ Gforth is free software; you can redistribute it and/or
                      8: \ modify it under the terms of the GNU General Public License
                      9: \ as published by the Free Software Foundation; either version 2
                     10: \ of the License, or (at your option) any later version.
                     11: 
                     12: \ This program is distributed in the hope that it will be useful,
                     13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
                     14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     15: \ GNU General Public License for more details.
                     16: 
                     17: \ You should have received a copy of the GNU General Public License
                     18: \ along with this program; if not, write to the Free Software
                     19: \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
                     20: 
                     21: Defer 'catch
                     22: Defer 'throw
                     23: 
                     24: ' noop IS 'catch
                     25: ' noop IS 'throw
                     26: 
                     27: \ has? backtrace [IF]
                     28: Defer store-backtrace
                     29: ' noop IS store-backtrace
                     30: \ [THEN]
                     31: 
                     32: : (protect) ( -- )
                     33:     \ inline argument: address of the handler
                     34:     r>
                     35:     'catch
                     36:     dup dup @ + >r \ recovery address
                     37:     lp@ >r
                     38:     handler @ >r
                     39:     rp@ handler !
                     40:     backtrace-empty on
                     41:     cell+ >r ;
                     42: 
                     43: : protect ( compilation  -- orig ; run-time  -- ) \ gforth
                     44:     POSTPONE (protect) >mark ; immediate compile-only
                     45: 
                     46: : (endprotect) ( -- )
                     47:     \ end of protect block: restore handler, forget rest
                     48:     r>
                     49:     r> handler !
                     50:     rdrop \ lp
                     51:     rdrop \ recovery address
                     52:     >r ;
                     53: 
                     54: : endprotect ( compilation  orig -- ; run-time  -- x ) \ gforth
                     55:     0 POSTPONE literal
                     56:     POSTPONE (endprotect)
                     57:     POSTPONE then ; immediate compile-only
                     58: 
                     59: : catch-protect ( ... xt -- ... x )
                     60:     protect execute endprotect ;
                     61: 
                     62: : (try) ( -- )
                     63:     \ inline argument: address of the handler
                     64:     r>
                     65:     sp@ >r
                     66:     fp@ >r
                     67:     >r ;
                     68: 
                     69: : try ( compilation  -- orig ; run-time  -- ) \ gforth
                     70:     POSTPONE (try) POSTPONE (protect) >mark ; immediate compile-only
                     71: 
                     72: : (recover) ( -- )
                     73:     \ normal end of try block: restore handler, forget rest
                     74:     r>
                     75:     r> handler !
                     76:     rdrop \ lp
                     77:     rdrop \ recovery address
                     78:     rdrop \ fp
                     79:     rdrop \ sp
                     80:     >r ;
                     81: 
                     82: : (recover2) ( ... x -- ... x )
                     83:     \ restore sp and fp
                     84:     r>
                     85:     r> fp!
                     86:     r> -rot >r >r sp! drop r> ;
                     87: 
                     88: : recover ( compilation  orig -- ; run-time  -- ) \ gforth
                     89:     \ !! check using a special tag
                     90:     POSTPONE (endprotect) POSTPONE rdrop POSTPONE rdrop
                     91:     POSTPONE else
                     92:     POSTPONE (recover2) ; immediate compile-only
                     93: 
                     94: : endtry ( compilation  orig -- ; run-time  -- ) \ gforth
                     95:     POSTPONE then ; immediate compile-only
                     96: 
                     97: :noname ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
                     98:     try
                     99:        execute 0
                    100:     recover
                    101:         nip
                    102:     endtry ;
                    103: is catch
                    104: 
                    105: \ :noname ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
                    106: \     'catch
                    107: \     sp@ >r
                    108: \ \ [ has? floating [IF] ]
                    109: \     fp@ >r
                    110: \ \ [ [THEN] ]
                    111: \ \ [ has? glocals [IF] ]
                    112: \     lp@ >r
                    113: \ \ [ [THEN] ]
                    114: \     handler @ >r
                    115: \     rp@ handler !
                    116: \ \ [ has? backtrace [IF] ]
                    117: \     backtrace-empty on
                    118: \ \ [ [THEN] ]
                    119: \     execute
                    120: \     r> handler ! rdrop 
                    121: \ \ [ has? floating [IF] ]
                    122: \     rdrop
                    123: \ \ [ [THEN] ]
                    124: \ \ [ has? glocals [IF] ]
                    125: \     rdrop
                    126: \ \ [ [THEN] ]
                    127: \     0 ;
                    128: \ is catch
                    129: 
                    130: :noname ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
                    131:     ?DUP IF
                    132:        [ here forthstart 9 cells + ! ]
                    133: \      [ has? header [IF] here 9 cells ! [THEN] ] \ entry point for signal handler
                    134: \ [ has? backtrace [IF] ]
                    135:        store-backtrace
                    136: \ [ [THEN] ]
                    137: \ [ has? interpreter [IF] ]
1.2       anton     138:        handler @ ?dup-0=-IF
1.1       anton     139: \ [ has? os [IF] ]
1.3     ! anton     140:            cr .error cr
1.1       anton     141:            2 (bye)
                    142: \ [ [ELSE] ]
                    143:            quit
                    144: \ [ [THEN] ]
                    145:        THEN
                    146: \ [ [THEN] ]
                    147:        rp!
                    148:        r> handler !
                    149: \ [ has? glocals [IF] ]
                    150:         r> lp!
                    151: \ [ [THEN] ]
                    152:        'throw
                    153:     THEN ;
                    154: is throw
                    155: 

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>