Return to except.fs CVS log

Up to [gforth] / gforth

Annotation of gforth/except.fs, revision 1.8

1.1       anton       1: \ catch, throw, etc.
                      2: 
1.7       anton       3: \ Copyright (C) 1999,2000,2003 Free Software Foundation, Inc.
1.1       anton       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
1.3       anton      19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
1.1       anton      20: 
                     21: \ !! use a separate exception stack?           anton
                     22: 
                     23: \ user-definable rollback actions
                     24: 
                     25: Defer 'catch
                     26: Defer 'throw
                     27: 
                     28: ' noop IS 'catch
                     29: ' noop IS 'throw
                     30: 
                     31: \ has? backtrace [IF]
                     32: Defer store-backtrace
                     33: ' noop IS store-backtrace
                     34: \ [THEN]
                     35: 
1.5       anton      36: : (try) ( ahandler -- )
1.1       anton      37:     r>
1.5       anton      38:     swap >r \ recovery address
1.1       anton      39:     rp@ 'catch >r
                     40:     sp@ >r
                     41:     fp@ >r
                     42:     lp@ >r
                     43:     handler @ >r
                     44:     rp@ handler !
                     45:     backtrace-empty on
1.5       anton      46:     >r ;
1.1       anton      47: 
                     48: : try ( compilation  -- orig ; run-time  -- ) \ gforth
1.5       anton      49:     \ !! does not work correctly for gforth-native
1.8     ! anton      50:     POSTPONE ahead here >r >mark 1 cs-roll POSTPONE then
        !            51:     r> POSTPONE literal POSTPONE @ POSTPONE (try) ; immediate compile-only
1.1       anton      52: 
                     53: : (recover) ( -- )
                     54:     \ normal end of try block: restore handler, forget rest
                     55:     r>
                     56:     r> handler !
                     57:     rdrop \ lp
                     58:     rdrop \ fp
                     59:     rdrop \ sp
                     60:     r> rp!
                     61:     rdrop \ recovery address
                     62:     >r ;
                     63: 
                     64: : recover ( compilation  orig1 -- orig2 ; run-time  -- ) \ gforth
                     65:     \ !! check using a special tag
                     66:     POSTPONE (recover)
                     67:     POSTPONE else ; immediate compile-only
                     68: 
                     69: : endtry ( compilation  orig -- ; run-time  -- ) \ gforth
                     70:     POSTPONE then ; immediate compile-only
                     71: 
                     72: :noname ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
                     73:     try
                     74:        execute 0
                     75:     recover
                     76:         nip
                     77:     endtry ;
                     78: is catch
                     79: 
                     80: :noname ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
                     81:     ?DUP IF
                     82:        [ here forthstart 9 cells + ! ]
                     83:        store-backtrace
                     84:        handler @ ?dup-0=-IF
1.6       anton      85:            >stderr cr ." uncaught exception: " .error cr
1.1       anton      86:            2 (bye)
1.6       anton      87: \          quit
1.1       anton      88:        THEN
                     89:        rp!
                     90:        r> handler !
                     91:        r> lp!
                     92:        r> fp!
                     93:        r> swap >r sp! drop r>
                     94:        rdrop 'throw
                     95:     THEN ;
                     96: is throw
                     97: