[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 : anton 1.5 : (try) ( ahandler -- )
80 : anton 1.1 r>
81 : anton 1.5 swap >r \ recovery address
82 : anton 1.1 rp@ 'catch >r
83 :     sp@ >r
84 :     fp@ >r
85 :     lp@ >r
86 :     handler @ >r
87 :     rp@ handler !
88 : anton 1.5 >r ;
89 : anton 1.1
90 :     : try ( compilation -- orig ; run-time -- ) \ gforth
91 : anton 1.5 \ !! does not work correctly for gforth-native
92 : anton 1.8 POSTPONE ahead here >r >mark 1 cs-roll POSTPONE then
93 : anton 1.9 r> POSTPONE literal POSTPONE (try) ; immediate compile-only
94 : anton 1.1
95 :     : (recover) ( -- )
96 :     \ normal end of try block: restore handler, forget rest
97 :     r>
98 :     r> handler !
99 :     rdrop \ lp
100 :     rdrop \ fp
101 :     rdrop \ sp
102 :     r> rp!
103 :     rdrop \ recovery address
104 :     >r ;
105 :    
106 :     : recover ( compilation orig1 -- orig2 ; run-time -- ) \ gforth
107 :     \ !! check using a special tag
108 :     POSTPONE (recover)
109 : anton 1.9 POSTPONE else
110 :     docol: here 0 , 0 , code-address! \ start a colon def
111 :     postpone rdrop \ drop the return address
112 :     ; immediate compile-only
113 : anton 1.1
114 :     : endtry ( compilation orig -- ; run-time -- ) \ gforth
115 :     POSTPONE then ; immediate compile-only
116 :    
117 :     :noname ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
118 :     try
119 :     execute 0
120 :     recover
121 :     nip
122 :     endtry ;
123 :     is catch
124 :    
125 :     :noname ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
126 :     ?DUP IF
127 :     [ here forthstart 9 cells + ! ]
128 : pazsan 1.10 store-backtrace error-stack off
129 : anton 1.1 handler @ ?dup-0=-IF
130 : anton 1.6 >stderr cr ." uncaught exception: " .error cr
131 : anton 1.1 2 (bye)
132 : anton 1.6 \ quit
133 : anton 1.1 THEN
134 :     rp!
135 :     r> handler !
136 :     r> lp!
137 :     r> fp!
138 :     r> swap >r sp! drop r>
139 : anton 1.9 rdrop 'throw r> perform
140 : anton 1.1 THEN ;
141 :     is throw
142 : pazsan 1.10 [IFDEF] throw>error
143 :     :noname ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
144 :     ?DUP IF
145 :     handler @ ?dup-0=-IF
146 :     >stderr cr ." uncaught exception: " .error cr
147 :     2 (bye)
148 :     \ quit
149 :     THEN
150 :     rp!
151 :     r> handler !
152 :     r> lp!
153 :     r> fp!
154 :     r> swap >r sp! drop r>
155 :     rdrop 'throw r> perform
156 :     THEN ;
157 :     is throw>error
158 :     [THEN]
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help