version 1.9, 2003/11/23 22:52:29
|
version 1.16, 2007/02/18 17:57:12
|
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 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 76 Defer store-backtrace
|
Line 68 Defer store-backtrace
|
|
|
\ !! explain handler on-stack structure |
\ !! 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 ; |
|
|
: (try) ( ahandler -- ) |
: (try) ( ahandler -- ) |
|
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 |
handler @ >r |
handler @ >r |
rp@ handler ! |
rp@ handler ! |
backtrace-empty on |
|
>r ; |
>r ; |
|
|
: try ( compilation -- orig ; run-time -- ) \ gforth |
: try ( compilation -- orig ; run-time -- ) \ gforth |
Line 100 Defer store-backtrace
|
Line 99 Defer store-backtrace
|
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 |
: recover ( compilation orig1 -- orig2 ; run-time -- ) \ gforth |
\ !! check using a special tag |
\ !! check using a special tag |
POSTPONE (recover) |
|
POSTPONE else |
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 |
; immediate compile-only |
; immediate compile-only |
|
|
: endtry ( compilation orig -- ; run-time -- ) \ gforth |
: endtry ( compilation orig -- ; run-time -- ) \ gforth |
POSTPONE then ; immediate compile-only |
POSTPONE then |
|
POSTPONE (recover) |
|
; 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 |
Line 126 is catch
|
Line 125 is catch
|
: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 |
>stderr cr ." uncaught exception: " .error cr |
>stderr cr ." uncaught exception: " .error cr |
2 (bye) |
2 (bye) |
\ quit |
\ quit |
THEN |
THEN |
rp! |
dup rp! |
r> handler ! |
rdrop |
r> lp! |
r> lp! |
r> fp! |
r> fp! |
r> swap >r sp! drop r> |
r> -rot 2>r sp! drop 2r> |
rdrop 'throw r> perform |
r@ swap rp! perform |
THEN ; |
THEN ; |
is throw |
is throw |
|
|