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