[gforth] / gforth / except.fs  

gforth: gforth/except.fs

1 : anton 1.1 \ catch, throw, etc.
2 :    
3 : anton 1.20 \ Copyright (C) 1999,2000,2003,2006,2007 Free Software Foundation, Inc.
4 : anton 1.1
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 : anton 1.21 \ as published by the Free Software Foundation, either version 3
10 : anton 1.1 \ 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 : anton 1.21 \ along with this program. If not, see http://www.gnu.org/licenses/.
19 : anton 1.1
20 :     \ !! use a separate exception stack? anton
21 :    
22 :     \ has? backtrace [IF]
23 :     Defer store-backtrace
24 :     ' noop IS store-backtrace
25 :     \ [THEN]
26 :    
27 : anton 1.9 \ 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 :    
70 : pazsan 1.12 Variable first-throw
71 : anton 1.13 : 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 ;
77 : pazsan 1.12
78 : anton 1.22 : (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 :    
97 : anton 1.5 : (try) ( ahandler -- )
98 : pazsan 1.12 first-throw on
99 : anton 1.1 r>
100 : anton 1.5 swap >r \ recovery address
101 : anton 1.1 sp@ >r
102 :     fp@ >r
103 :     lp@ >r
104 :     handler @ >r
105 :     rp@ handler !
106 : anton 1.5 >r ;
107 : anton 1.1
108 : anton 1.22 \ : 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 :    
113 : anton 1.18 : try ( compilation -- orig ; run-time -- R:sys1 ) \ gforth
114 :     \G Start an exception-catching region.
115 : anton 1.8 POSTPONE ahead here >r >mark 1 cs-roll POSTPONE then
116 : anton 1.22 POSTPONE (try0) r> POSTPONE literal POSTPONE (try1) POSTPONE (try2)
117 :     ; immediate compile-only
118 :    
119 : anton 1.1
120 : anton 1.17 : (endtry) ( -- )
121 : anton 1.1 \ 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 :    
130 : anton 1.17 : handler-intro, ( -- )
131 : anton 1.9 docol: here 0 , 0 , code-address! \ start a colon def
132 :     postpone rdrop \ drop the return address
133 : anton 1.17 ;
134 :    
135 :     : iferror ( compilation orig1 -- orig2 ; run-time -- ) \ gforth
136 : anton 1.18 \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}.
139 : anton 1.17 \ !! check using a special tag
140 :     POSTPONE else handler-intro,
141 :     ; immediate compile-only
142 :    
143 :     : restore ( compilation orig1 -- ; run-time -- ) \ gforth
144 : anton 1.18 \G Starts restoring code, that is executed if there is an
145 :     \G exception, and if there is no exception.
146 : anton 1.17 POSTPONE iferror POSTPONE then
147 : anton 1.9 ; immediate compile-only
148 : anton 1.1
149 : anton 1.18 : endtry ( compilation -- ; run-time R:sys1 -- ) \ gforth
150 :     \G End an exception-catching region.
151 : anton 1.17 POSTPONE (endtry)
152 : anton 1.18 ; 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)
161 : anton 1.16 ; immediate compile-only
162 : anton 1.1
163 :     :noname ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
164 :     try
165 :     execute 0
166 : anton 1.17 iferror
167 :     nip
168 :     then endtry ;
169 : anton 1.1 is catch
170 :    
171 : anton 1.23 [undefined] (throw1)
172 :     : (throw1) ( ... ball frame -- ... ball )
173 :     dup rp! ( ... ball frame )
174 :     cell+ dup @ lp!
175 :     cell+ dup @ fp!
176 :     cell+ dup @ ( ... ball addr sp ) -rot 2>r sp! drop 2r>
177 :     cell+ @ perform ;
178 :     [endif]
179 :    
180 : anton 1.1 :noname ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
181 :     ?DUP IF
182 :     [ here forthstart 9 cells + ! ]
183 : pazsan 1.12 first-throw @ IF
184 :     store-backtrace error-stack off
185 :     first-throw off
186 :     THEN
187 : anton 1.1 handler @ ?dup-0=-IF
188 : anton 1.6 >stderr cr ." uncaught exception: " .error cr
189 : anton 1.1 2 (bye)
190 : anton 1.6 \ quit
191 : anton 1.1 THEN
192 : anton 1.23 \ cr .s dup 64 dump
193 :     (throw1)
194 : anton 1.1 THEN ;
195 :     is throw
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help