gforth/except.fs - diff

Return to except.fs CVS log

Up to [gforth] / gforth

Diff for /gforth/except.fs between versions 1.10 and 1.20

version 1.10, 2006/05/26 21:18:45	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 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
Line 87 Defer store-backtrace	Line 87 Defer store-backtrace
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
?DUP IF	?DUP IF
[ here forthstart 9 cells + ! ]	[ here forthstart 9 cells + ! ]
store-backtrace error-stack off	first-throw @ IF
handler @ ?dup-0=-IF	store-backtrace error-stack off
>stderr cr ." uncaught exception: " .error cr	first-throw off
2 (bye)
\ quit
THEN	THEN
rp!
r> handler !
r> lp!
r> fp!
r> swap >r sp! drop r>
rdrop 'throw r> perform
THEN ;
is throw
[IFDEF] throw>error
:noname ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
?DUP IF
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! ( ... 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>error
[THEN]

	is throw

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>

Removed from v.1.10
changed lines
	Added in v.1.20