[gforth] / gforth / except.fs  

gforth: gforth/except.fs

1 : anton 1.1 \ catch, throw, etc.
2 :    
3 : anton 1.7 \ Copyright (C) 1999,2000,2003 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 :     \ 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 : anton 1.3 \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
20 : anton 1.1
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 : anton 1.9 \ Ok, here's the story about how we get to the native code for the
37 :     \ recovery code in case of a THROW, and why there is all this funny
38 :     \ stuff being compiled by TRY and RECOVER:
39 :    
40 :     \ Upon a THROW, we cannot just return through the ordinary return
41 :     \ address, but have to use a different one, for code after the
42 :     \ RECOVER. How do we do that, in a way portable between the various
43 :     \ threaded and native code engines? In particular, how does the
44 :     \ native code engine learn about the address of the native recovery
45 :     \ code?
46 :    
47 :     \ On the Forth level, we can compile only references to threaded code.
48 :     \ The only thing that translates a threaded code address to a native
49 :     \ code address is docol, which is only called with EXECUTE and
50 :     \ friends. So we start the recovery code with a docol, and invoke it
51 :     \ with PERFORM; the recovery code then rdrops the superfluously
52 :     \ generated return address and continues with the proper recovery
53 :     \ code.
54 :    
55 :     \ At compile time, since we cannot compile a forward reference (to the
56 :     \ recovery code) as a literal (backpatching does not work for
57 :     \ native-code literals), we produce a data cell (wrapped in AHEAD
58 :     \ ... THEN) that we can backpatch, and compile the address of that as
59 :     \ literal.
60 :    
61 :     \ Overall, this leads to the following resulting code:
62 :    
63 :     \ ahead
64 :     \ +><recovery address>-+
65 :     \ | then |
66 :     \ +-lit |
67 :     \ (try) |
68 :     \ ... |
69 :     \ (recover) |
70 :     \ ahead |
71 :     \ docol: <-----------+
72 :     \ rdrop
73 :     \ ...
74 :     \ then
75 :     \ ...
76 :    
77 :     \ !! explain handler on-stack structure
78 :    
79 : pazsan 1.12 Variable first-throw
80 :     : nothrow ( -- ) first-throw on ;
81 :    
82 : anton 1.5 : (try) ( ahandler -- )
83 : pazsan 1.12 first-throw on
84 : anton 1.1 r>
85 : anton 1.5 swap >r \ recovery address
86 : anton 1.1 rp@ 'catch >r
87 :     sp@ >r
88 :     fp@ >r
89 :     lp@ >r
90 :     handler @ >r
91 :     rp@ handler !
92 : anton 1.5 >r ;
93 : anton 1.1
94 :     : try ( compilation -- orig ; run-time -- ) \ gforth
95 : anton 1.5 \ !! does not work correctly for gforth-native
96 : anton 1.8 POSTPONE ahead here >r >mark 1 cs-roll POSTPONE then
97 : anton 1.9 r> POSTPONE literal POSTPONE (try) ; immediate compile-only
98 : anton 1.1
99 :     : (recover) ( -- )
100 :     \ normal end of try block: restore handler, forget rest
101 :     r>
102 :     r> handler !
103 :     rdrop \ lp
104 :     rdrop \ fp
105 :     rdrop \ sp
106 :     r> rp!
107 :     rdrop \ recovery address
108 :     >r ;
109 :    
110 :     : recover ( compilation orig1 -- orig2 ; run-time -- ) \ gforth
111 :     \ !! check using a special tag
112 :     POSTPONE (recover)
113 : anton 1.9 POSTPONE else
114 :     docol: here 0 , 0 , code-address! \ start a colon def
115 :     postpone rdrop \ drop the return address
116 :     ; immediate compile-only
117 : anton 1.1
118 :     : endtry ( compilation orig -- ; run-time -- ) \ gforth
119 :     POSTPONE then ; immediate compile-only
120 :    
121 :     :noname ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
122 :     try
123 :     execute 0
124 :     recover
125 :     nip
126 :     endtry ;
127 :     is catch
128 :    
129 :     :noname ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
130 :     ?DUP IF
131 :     [ here forthstart 9 cells + ! ]
132 : pazsan 1.12 first-throw @ IF
133 :     store-backtrace error-stack off
134 :     first-throw off
135 :     THEN
136 : anton 1.1 handler @ ?dup-0=-IF
137 : anton 1.6 >stderr cr ." uncaught exception: " .error cr
138 : anton 1.1 2 (bye)
139 : anton 1.6 \ quit
140 : anton 1.1 THEN
141 :     rp!
142 :     r> handler !
143 :     r> lp!
144 :     r> fp!
145 :     r> swap >r sp! drop r>
146 : anton 1.9 rdrop 'throw r> perform
147 : anton 1.1 THEN ;
148 :     is throw
149 : pazsan 1.11 [IFDEF] rethrow
150 : pazsan 1.10 :noname ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
151 :     ?DUP IF
152 :     handler @ ?dup-0=-IF
153 :     >stderr cr ." uncaught exception: " .error cr
154 :     2 (bye)
155 :     \ quit
156 :     THEN
157 :     rp!
158 :     r> handler !
159 :     r> lp!
160 :     r> fp!
161 :     r> swap >r sp! drop r>
162 :     rdrop 'throw r> perform
163 :     THEN ;
164 : pazsan 1.11 is rethrow
165 : pazsan 1.10 [THEN]
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help