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:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>