Annotation of gforth/except.fs, revision 1.22
1.1 anton 1: \ catch, throw, etc.
2:
1.20 anton 3: \ Copyright (C) 1999,2000,2003,2006,2007 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
1.21 anton 9: \ as published by the Free Software Foundation, either version 3
1.1 anton 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
1.21 anton 18: \ along with this program. If not, see http://www.gnu.org/licenses/.
1.1 anton 19:
20: \ !! use a separate exception stack? anton
21:
22: \ has? backtrace [IF]
23: Defer store-backtrace
24: ' noop IS store-backtrace
25: \ [THEN]
26:
1.9 anton 27: \ Ok, here's the story about how we get to the native code for the
28: \ recovery code in case of a THROW, and why there is all this funny
29: \ stuff being compiled by TRY and RECOVER:
30:
31: \ Upon a THROW, we cannot just return through the ordinary return
32: \ address, but have to use a different one, for code after the
33: \ RECOVER. How do we do that, in a way portable between the various
34: \ threaded and native code engines? In particular, how does the
35: \ native code engine learn about the address of the native recovery
36: \ code?
37:
38: \ On the Forth level, we can compile only references to threaded code.
39: \ The only thing that translates a threaded code address to a native
40: \ code address is docol, which is only called with EXECUTE and
41: \ friends. So we start the recovery code with a docol, and invoke it
42: \ with PERFORM; the recovery code then rdrops the superfluously
43: \ generated return address and continues with the proper recovery
44: \ code.
45:
46: \ At compile time, since we cannot compile a forward reference (to the
47: \ recovery code) as a literal (backpatching does not work for
48: \ native-code literals), we produce a data cell (wrapped in AHEAD
49: \ ... THEN) that we can backpatch, and compile the address of that as
50: \ literal.
51:
52: \ Overall, this leads to the following resulting code:
53:
54: \ ahead
55: \ +><recovery address>-+
56: \ | then |
57: \ +-lit |
58: \ (try) |
59: \ ... |
60: \ (recover) |
61: \ ahead |
62: \ docol: <-----------+
63: \ rdrop
64: \ ...
65: \ then
66: \ ...
67:
68: \ !! explain handler on-stack structure
69:
1.12 pazsan 70: Variable first-throw
1.13 anton 71: : nothrow ( -- ) \ gforth
72: \G Use this (or the standard sequence @code{['] false catch drop})
73: \G after a @code{catch} or @code{endtry} that does not rethrow;
74: \G this ensures that the next @code{throw} will record a
75: \G backtrace.
76: first-throw on ;
1.12 pazsan 77:
1.22 ! anton 78: : (try0) ( -- aoldhandler )
! 79: first-throw on
! 80: handler @ ;
! 81:
! 82: [undefined] (try1) [if]
! 83: : (try1) ( aoldhandler arecovery -- anewhandler )
! 84: r>
! 85: swap >r \ recovery address
! 86: sp@ cell+ >r
! 87: fp@ >r
! 88: lp@ >r
! 89: swap >r \ old handler
! 90: rp@ swap \ new handler
! 91: >r ;
! 92: [endif]
! 93:
! 94: : (try2)
! 95: handler ! ;
! 96:
1.5 anton 97: : (try) ( ahandler -- )
1.12 pazsan 98: first-throw on
1.1 anton 99: r>
1.5 anton 100: swap >r \ recovery address
1.1 anton 101: sp@ >r
102: fp@ >r
103: lp@ >r
104: handler @ >r
105: rp@ handler !
1.5 anton 106: >r ;
1.1 anton 107:
1.22 ! anton 108: \ : try ( compilation -- orig ; run-time -- R:sys1 ) \ gforth
! 109: \ \G Start an exception-catching region.
! 110: \ POSTPONE ahead here >r >mark 1 cs-roll POSTPONE then
! 111: \ r> POSTPONE literal POSTPONE (try) ; immediate compile-only
! 112:
1.18 anton 113: : try ( compilation -- orig ; run-time -- R:sys1 ) \ gforth
114: \G Start an exception-catching region.
1.8 anton 115: POSTPONE ahead here >r >mark 1 cs-roll POSTPONE then
1.22 ! anton 116: POSTPONE (try0) r> POSTPONE literal POSTPONE (try1) POSTPONE (try2)
! 117: ; immediate compile-only
! 118:
1.1 anton 119:
1.17 anton 120: : (endtry) ( -- )
1.1 anton 121: \ normal end of try block: restore handler, forget rest
122: r>
123: r> handler !
124: rdrop \ lp
125: rdrop \ fp
126: rdrop \ sp
127: rdrop \ recovery address
128: >r ;
129:
1.17 anton 130: : handler-intro, ( -- )
1.9 anton 131: docol: here 0 , 0 , code-address! \ start a colon def
132: postpone rdrop \ drop the return address
1.17 anton 133: ;
134:
135: : iferror ( compilation orig1 -- orig2 ; run-time -- ) \ gforth
1.18 anton 136: \G Starts the exception handling code (executed if there is an
137: \G exception between @code{try} and @code{endtry}). This part has
138: \G to be finished with @code{then}.
1.17 anton 139: \ !! check using a special tag
140: POSTPONE else handler-intro,
141: ; immediate compile-only
142:
143: : restore ( compilation orig1 -- ; run-time -- ) \ gforth
1.18 anton 144: \G Starts restoring code, that is executed if there is an
145: \G exception, and if there is no exception.
1.17 anton 146: POSTPONE iferror POSTPONE then
1.9 anton 147: ; immediate compile-only
1.1 anton 148:
1.18 anton 149: : endtry ( compilation -- ; run-time R:sys1 -- ) \ gforth
150: \G End an exception-catching region.
1.17 anton 151: POSTPONE (endtry)
1.18 anton 152: ; immediate compile-only
153:
154: : endtry-iferror ( compilation orig1 -- orig2 ; run-time R:sys1 -- ) \ gforth
155: \G End an exception-catching region while starting
156: \G exception-handling code outside that region (executed if there
157: \G is an exception between @code{try} and @code{endtry-iferror}).
158: \G This part has to be finished with @code{then} (or
159: \G @code{else}...@code{then}).
160: POSTPONE (endtry) POSTPONE iferror POSTPONE (endtry)
1.16 anton 161: ; immediate compile-only
1.1 anton 162:
163: :noname ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
164: try
165: execute 0
1.17 anton 166: iferror
167: nip
168: then endtry ;
1.1 anton 169: is catch
170:
171: :noname ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
172: ?DUP IF
173: [ here forthstart 9 cells + ! ]
1.12 pazsan 174: first-throw @ IF
175: store-backtrace error-stack off
176: first-throw off
177: THEN
1.1 anton 178: handler @ ?dup-0=-IF
1.6 anton 179: >stderr cr ." uncaught exception: " .error cr
1.1 anton 180: 2 (bye)
1.6 anton 181: \ quit
1.1 anton 182: THEN
1.19 anton 183: dup rp! ( ... ball frame )
184: cell+ dup @ lp!
185: cell+ dup @ fp!
186: cell+ dup @ ( ... ball addr sp ) -rot 2>r sp! drop 2r>
187: cell+ @ perform
1.1 anton 188: THEN ;
189: is throw
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>