Return to exceptions.fs CVS log

Up to [gforth] / gforth

Annotation of gforth/exceptions.fs, revision 1.4

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: 
1.4     ! anton      32: : (try) ( -- )
1.1       anton      33:     \ inline argument: address of the handler
                     34:     r>
                     35:     'catch
1.4     ! anton      36:     sp@ >r
        !            37:     fp@ >r
1.1       anton      38:     dup dup @ + >r \ recovery address
                     39:     lp@ >r
                     40:     handler @ >r
                     41:     rp@ handler !
                     42:     backtrace-empty on
                     43:     cell+ >r ;
                     44: 
                     45: : try ( compilation  -- orig ; run-time  -- ) \ gforth
1.4     ! anton      46:     POSTPONE (try) >mark ; immediate compile-only
1.1       anton      47: 
                     48: : (recover) ( -- )
                     49:     \ normal end of try block: restore handler, forget rest
                     50:     r>
                     51:     r> handler !
                     52:     rdrop \ lp
                     53:     rdrop \ recovery address
                     54:     rdrop \ fp
                     55:     rdrop \ sp
                     56:     >r ;
                     57: 
                     58: : (recover2) ( ... x -- ... x )
                     59:     \ restore sp and fp
                     60:     r>
                     61:     r> fp!
                     62:     r> -rot >r >r sp! drop r> ;
                     63: 
                     64: : recover ( compilation  orig -- ; run-time  -- ) \ gforth
                     65:     \ !! check using a special tag
1.4     ! anton      66:     POSTPONE (recover)
1.1       anton      67:     POSTPONE else
                     68:     POSTPONE (recover2) ; immediate compile-only
                     69: 
                     70: : endtry ( compilation  orig -- ; run-time  -- ) \ gforth
                     71:     POSTPONE then ; immediate compile-only
                     72: 
                     73: :noname ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
                     74:     try
                     75:        execute 0
                     76:     recover
                     77:         nip
                     78:     endtry ;
                     79: is catch
                     80: 
                     81: \ :noname ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
                     82: \     'catch
                     83: \     sp@ >r
                     84: \ \ [ has? floating [IF] ]
                     85: \     fp@ >r
                     86: \ \ [ [THEN] ]
                     87: \ \ [ has? glocals [IF] ]
                     88: \     lp@ >r
                     89: \ \ [ [THEN] ]
                     90: \     handler @ >r
                     91: \     rp@ handler !
                     92: \ \ [ has? backtrace [IF] ]
                     93: \     backtrace-empty on
                     94: \ \ [ [THEN] ]
                     95: \     execute
                     96: \     r> handler ! rdrop 
                     97: \ \ [ has? floating [IF] ]
                     98: \     rdrop
                     99: \ \ [ [THEN] ]
                    100: \ \ [ has? glocals [IF] ]
                    101: \     rdrop
                    102: \ \ [ [THEN] ]
                    103: \     0 ;
                    104: \ is catch
                    105: 
                    106: :noname ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
                    107:     ?DUP IF
                    108:        [ here forthstart 9 cells + ! ]
                    109: \      [ has? header [IF] here 9 cells ! [THEN] ] \ entry point for signal handler
                    110: \ [ has? backtrace [IF] ]
                    111:        store-backtrace
                    112: \ [ [THEN] ]
                    113: \ [ has? interpreter [IF] ]
1.2       anton     114:        handler @ ?dup-0=-IF
1.1       anton     115: \ [ has? os [IF] ]
1.3       anton     116:            cr .error cr
1.1       anton     117:            2 (bye)
                    118: \ [ [ELSE] ]
                    119:            quit
                    120: \ [ [THEN] ]
                    121:        THEN
                    122: \ [ [THEN] ]
                    123:        rp!
                    124:        r> handler !
                    125: \ [ has? glocals [IF] ]
                    126:         r> lp!
                    127: \ [ [THEN] ]
                    128:        'throw
                    129:     THEN ;
                    130: is throw
                    131: