Annotation of gforth/exceptions.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: 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] ]
! 138: handler @ dup 0= IF
! 139: \ [ has? os [IF] ]
! 140: cr ." error " .
! 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>