Return to except.fs CVS log

Up to [gforth] / gforth

Annotation of gforth/except.fs, revision 1.1

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: \ !! 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: 
        !            36: : (try) ( -- )
        !            37:     \ inline argument: address of the handler
        !            38:     r>
        !            39:     dup dup @ + >r \ recovery address
        !            40:     rp@ 'catch >r
        !            41:     sp@ >r
        !            42:     fp@ >r
        !            43:     lp@ >r
        !            44:     handler @ >r
        !            45:     rp@ handler !
        !            46:     backtrace-empty on
        !            47:     cell+ >r ;
        !            48: 
        !            49: : try ( compilation  -- orig ; run-time  -- ) \ gforth
        !            50:     POSTPONE (try) >mark ; immediate compile-only
        !            51: 
        !            52: : (recover) ( -- )
        !            53:     \ normal end of try block: restore handler, forget rest
        !            54:     r>
        !            55:     r> handler !
        !            56:     rdrop \ lp
        !            57:     rdrop \ fp
        !            58:     rdrop \ sp
        !            59:     r> rp!
        !            60:     rdrop \ recovery address
        !            61:     >r ;
        !            62: 
        !            63: : recover ( compilation  orig1 -- orig2 ; run-time  -- ) \ gforth
        !            64:     \ !! check using a special tag
        !            65:     POSTPONE (recover)
        !            66:     POSTPONE else ; immediate compile-only
        !            67: 
        !            68: : endtry ( compilation  orig -- ; run-time  -- ) \ gforth
        !            69:     POSTPONE then ; immediate compile-only
        !            70: 
        !            71: :noname ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
        !            72:     try
        !            73:        execute 0
        !            74:     recover
        !            75:         nip
        !            76:     endtry ;
        !            77: is catch
        !            78: 
        !            79: :noname ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
        !            80:     ?DUP IF
        !            81:        [ here forthstart 9 cells + ! ]
        !            82:        store-backtrace
        !            83:        handler @ ?dup-0=-IF
        !            84:            cr ." uncaught exception: " .error cr
        !            85:            2 (bye)
        !            86:            quit
        !            87:        THEN
        !            88:        rp!
        !            89:        r> handler !
        !            90:        r> lp!
        !            91:        r> fp!
        !            92:        r> swap >r sp! drop r>
        !            93:        rdrop 'throw
        !            94:     THEN ;
        !            95: is throw
        !            96: