version 1.14, 2006/12/28 20:53:03
|
version 1.20, 2007/12/31 17:34:58
|
Line 1
|
Line 1
|
\ catch, throw, etc. |
\ catch, throw, etc. |
|
|
\ Copyright (C) 1999,2000,2003 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. |
|
|
Line 20
|
Line 20
|
|
|
\ !! 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 |
Line 88 Variable first-throw
|
Line 80 Variable first-throw
|
first-throw on |
first-throw on |
r> |
r> |
swap >r \ recovery address |
swap >r \ recovery address |
rp@ 'catch >r |
|
sp@ >r |
sp@ >r |
fp@ >r |
fp@ >r |
lp@ >r |
lp@ >r |
Line 96 Variable first-throw
|
Line 87 Variable first-throw
|
rp@ handler ! |
rp@ handler ! |
>r ; |
>r ; |
|
|
: try ( compilation -- orig ; run-time -- ) \ gforth |
: try ( compilation -- orig ; run-time -- R:sys1 ) \ gforth |
\ !! does not work correctly for gforth-native |
\G Start an exception-catching region. |
POSTPONE ahead here >r >mark 1 cs-roll POSTPONE then |
POSTPONE ahead here >r >mark 1 cs-roll POSTPONE then |
r> POSTPONE literal POSTPONE (try) ; immediate compile-only |
r> POSTPONE literal POSTPONE (try) ; 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, ( -- ) |
\ !! check using a special tag |
|
POSTPONE (recover) |
|
POSTPONE else |
|
docol: here 0 , 0 , code-address! \ start a colon def |
docol: here 0 , 0 , code-address! \ start a colon def |
postpone rdrop \ drop the return address |
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 |
|
POSTPONE else handler-intro, |
; 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 |
|
|
:noname ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception |
:noname ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception |
Line 143 is catch
|
Line 155 is catch
|
2 (bye) |
2 (bye) |
\ quit |
\ quit |
THEN |
THEN |
rp! |
dup rp! ( ... ball frame ) |
r> handler ! |
cell+ dup @ lp! |
r> lp! |
cell+ dup @ fp! |
r> fp! |
cell+ dup @ ( ... ball addr sp ) -rot 2>r sp! drop 2r> |
r> swap >r sp! drop r> |
cell+ @ perform |
rdrop 'throw r> perform |
|
THEN ; |
THEN ; |
is throw |
is throw |
[IFDEF] rethrow |
|
:noname ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception |
|
?DUP IF |
|
handler @ ?dup-0=-IF |
|
>stderr cr ." uncaught exception: " .error cr |
|
2 (bye) |
|
\ quit |
|
THEN |
|
rp! |
|
r> handler ! |
|
r> lp! |
|
r> fp! |
|
r> swap >r sp! drop r> |
|
rdrop 'throw r> perform |
|
THEN ; |
|
is rethrow |
|
[THEN] |
|