version 1.2, 2000/09/23 15:05:59
|
version 1.24, 2010/09/05 17:58:41
|
Line 1
|
Line 1
|
\ catch, throw, etc. |
\ catch, throw, etc. |
|
|
\ Copyright (C) 1999,2000 Free Software Foundation, Inc. |
\ Copyright (C) 1999,2000,2003,2006,2007 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
\ Gforth is free software; you can redistribute it and/or |
\ Gforth is free software; you can redistribute it and/or |
\ modify it under the terms of the GNU General Public License |
\ modify it under the terms of the GNU General Public License |
\ as published by the Free Software Foundation; either version 2 |
\ as published by the Free Software Foundation, either version 3 |
\ of the License, or (at your option) any later version. |
\ of the License, or (at your option) any later version. |
|
|
\ This program is distributed in the hope that it will be useful, |
\ This program is distributed in the hope that it will be useful, |
Line 15
|
Line 15
|
\ GNU General Public License for more details. |
\ GNU General Public License for more details. |
|
|
\ You should have received a copy of the GNU General Public License |
\ You should have received a copy of the GNU General Public License |
\ along with this program; if not, write to the Free Software |
\ along with this program. If not, see http://www.gnu.org/licenses/. |
\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. |
|
|
|
\ !! use a separate exception stack? anton |
\ !! use a separate exception stack? anton |
|
|
\ user-definable rollback actions |
|
|
|
Defer 'catch |
|
Defer 'throw |
|
|
|
' noop IS 'catch |
|
' noop IS 'throw |
|
|
|
\ has? backtrace [IF] |
\ has? backtrace [IF] |
Defer store-backtrace |
Defer store-backtrace |
' noop IS store-backtrace |
' noop IS store-backtrace |
\ [THEN] |
\ [THEN] |
|
|
: (try) ( -- ) |
\ Ok, here's the story about how we get to the native code for the |
\ inline argument: address of the handler |
\ recovery code in case of a THROW, and why there is all this funny |
|
\ stuff being compiled by TRY and RECOVER: |
|
|
|
\ Upon a THROW, we cannot just return through the ordinary return |
|
\ address, but have to use a different one, for code after the |
|
\ RECOVER. How do we do that, in a way portable between the various |
|
\ threaded and native code engines? In particular, how does the |
|
\ native code engine learn about the address of the native recovery |
|
\ code? |
|
|
|
\ On the Forth level, we can compile only references to threaded code. |
|
\ The only thing that translates a threaded code address to a native |
|
\ code address is docol, which is only called with EXECUTE and |
|
\ friends. So we start the recovery code with a docol, and invoke it |
|
\ with PERFORM; the recovery code then rdrops the superfluously |
|
\ generated return address and continues with the proper recovery |
|
\ code. |
|
|
|
\ At compile time, since we cannot compile a forward reference (to the |
|
\ recovery code) as a literal (backpatching does not work for |
|
\ native-code literals), we produce a data cell (wrapped in AHEAD |
|
\ ... THEN) that we can backpatch, and compile the address of that as |
|
\ literal. |
|
|
|
\ Overall, this leads to the following resulting code: |
|
|
|
\ ahead |
|
\ +><recovery address>-+ |
|
\ | then | |
|
\ +-lit | |
|
\ (try) | |
|
\ ... | |
|
\ (recover) | |
|
\ ahead | |
|
\ docol: <-----------+ |
|
\ rdrop |
|
\ ... |
|
\ then |
|
\ ... |
|
|
|
\ !! explain handler on-stack structure |
|
|
|
Variable first-throw |
|
: nothrow ( -- ) \ gforth |
|
\G Use this (or the standard sequence @code{['] false catch drop}) |
|
\G after a @code{catch} or @code{endtry} that does not rethrow; |
|
\G this ensures that the next @code{throw} will record a |
|
\G backtrace. |
|
first-throw on ; |
|
|
|
: (try0) ( -- aoldhandler ) |
|
first-throw on |
|
handler @ ; |
|
|
|
[undefined] (try1) [if] |
|
: (try1) ( aoldhandler arecovery -- anewhandler ) |
|
r> |
|
swap >r \ recovery address |
|
sp@ cell+ >r |
|
fp@ >r |
|
lp@ >r |
|
swap >r \ old handler |
|
rp@ swap \ new handler |
|
>r ; |
|
[endif] |
|
|
|
: (try2) |
|
handler ! ; |
|
|
|
: (try) ( ahandler -- ) |
|
first-throw on |
r> |
r> |
dup dup @ + >r \ recovery address |
swap >r \ recovery address |
rp@ 'catch >r |
|
sp@ >r |
sp@ >r |
fp@ >r |
fp@ >r |
lp@ >r |
lp@ >r |
handler @ >r |
handler @ >r |
rp@ handler ! |
rp@ handler ! |
backtrace-empty on |
>r ; |
cell+ >r ; |
|
|
|
: try ( compilation -- orig ; run-time -- ) \ gforth |
\ : try ( compilation -- orig ; run-time -- R:sys1 ) \ gforth |
POSTPONE (try) >mark ; immediate compile-only |
\ \G Start an exception-catching region. |
|
\ POSTPONE ahead here >r >mark 1 cs-roll POSTPONE then |
|
\ r> POSTPONE literal POSTPONE (try) ; immediate compile-only |
|
|
|
: try ( compilation -- orig ; run-time -- R:sys1 ) \ gforth |
|
\G Start an exception-catching region. |
|
POSTPONE ahead here >r >mark 1 cs-roll POSTPONE then |
|
POSTPONE (try0) r> POSTPONE literal POSTPONE (try1) POSTPONE (try2) |
|
; immediate compile-only |
|
|
: (recover) ( -- ) |
|
|
: (endtry) ( -- ) |
\ normal end of try block: restore handler, forget rest |
\ normal end of try block: restore handler, forget rest |
r> |
r> |
r> handler ! |
r> handler ! |
rdrop \ lp |
rdrop \ lp |
rdrop \ fp |
rdrop \ fp |
rdrop \ sp |
rdrop \ sp |
r> rp! |
|
rdrop \ recovery address |
rdrop \ recovery address |
>r ; |
>r ; |
|
|
: recover ( compilation orig1 -- orig2 ; run-time -- ) \ gforth |
: handler-intro, ( -- ) |
|
docol: here 0 , 0 , code-address! \ start a colon def |
|
postpone rdrop \ drop the return address |
|
; |
|
|
|
: iferror ( compilation orig1 -- orig2 ; run-time -- ) \ gforth |
|
\G Starts the exception handling code (executed if there is an |
|
\G exception between @code{try} and @code{endtry}). This part has |
|
\G to be finished with @code{then}. |
\ !! check using a special tag |
\ !! check using a special tag |
POSTPONE (recover) |
POSTPONE else handler-intro, |
POSTPONE else ; immediate compile-only |
; immediate compile-only |
|
|
: endtry ( compilation orig -- ; run-time -- ) \ gforth |
: restore ( compilation orig1 -- ; run-time -- ) \ gforth |
POSTPONE then ; immediate compile-only |
\G Starts restoring code, that is executed if there is an |
|
\G exception, and if there is no exception. |
|
POSTPONE iferror POSTPONE then |
|
; immediate compile-only |
|
|
|
: endtry ( compilation -- ; run-time R:sys1 -- ) \ gforth |
|
\G End an exception-catching region. |
|
POSTPONE (endtry) |
|
; immediate compile-only |
|
|
|
: endtry-iferror ( compilation orig1 -- orig2 ; run-time R:sys1 -- ) \ gforth |
|
\G End an exception-catching region while starting |
|
\G exception-handling code outside that region (executed if there |
|
\G is an exception between @code{try} and @code{endtry-iferror}). |
|
\G This part has to be finished with @code{then} (or |
|
\G @code{else}...@code{then}). |
|
POSTPONE (endtry) POSTPONE iferror POSTPONE (endtry) |
|
; immediate compile-only |
|
|
:noname ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception |
:noname ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception |
try |
try |
execute 0 |
execute 0 |
recover |
iferror |
nip |
nip |
endtry ; |
then endtry ; |
is catch |
is catch |
|
|
|
[undefined] (throw1) [if] |
|
: (throw1) ( ... ball frame -- ... ball ) |
|
dup rp! ( ... ball frame ) |
|
cell+ dup @ lp! |
|
cell+ dup @ fp! |
|
cell+ dup @ ( ... ball addr sp ) -rot 2>r sp! drop 2r> |
|
cell+ @ perform ; |
|
[endif] |
|
|
:noname ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception |
:noname ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception |
?DUP IF |
?DUP IF |
[ here forthstart 9 cells + ! ] |
[ here forthstart 9 cells + ! ] |
store-backtrace |
first-throw @ IF |
|
store-backtrace error-stack off |
|
first-throw off |
|
THEN |
handler @ ?dup-0=-IF |
handler @ ?dup-0=-IF |
cr ." uncaught exception: " .error cr |
>stderr cr ." uncaught exception: " .error cr |
2 (bye) |
2 (bye) |
quit |
\ quit |
THEN |
THEN |
rp! |
\ cr .s dup 64 dump |
r> handler ! |
(throw1) |
r> lp! |
|
r> fp! |
|
r> swap >r sp! drop r> |
|
rdrop 'throw |
|
THEN ; |
THEN ; |
is throw |
is throw |
|
|