mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-07-03 08:10:31 +02:00
Code Activity

* throw.c (scm_catch_apply): Finished implementation of

Browse source 
`lazy-catch'.
This commit is contained in:
Mikael Djurfeldt 1996-10-06 22:16:33 +00:00
parent a239e35b1c
commit 11702758ec
1 changed files with 28 additions and 26 deletions
Download patch file Download diff file Expand all files Collapse all files

54
libguile/throw.c
View file

@ -64,8 +64,6 @@ static int scm_tc16_jmpbuffer;
#define JBACTIVE(O) (SCM_CAR (O) & (1L << 16L)) #define JBACTIVE(O) (SCM_CAR (O) & (1L << 16L))
#define ACTIVATEJB(O) (SCM_CAR (O) |= (1L << 16L)) #define ACTIVATEJB(O) (SCM_CAR (O) |= (1L << 16L))
#define DEACTIVATEJB(O) (SCM_CAR (O) &= ~(1L << 16L)) #define DEACTIVATEJB(O) (SCM_CAR (O) &= ~(1L << 16L))
#define JBLAZY (1L << 17L)
#define JBLAZYP(O) (SCM_CAR (O) & JBLAZY)
#ifndef DEBUG_EXTENSIONS #ifndef DEBUG_EXTENSIONS
#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (O) ) #define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (O) )
@ -95,10 +93,7 @@ printjb (exp, port, pstate)
scm_print_state *pstate; scm_print_state *pstate;
{ {
scm_gen_puts (scm_regular_string, "#<jmpbuffer ", port); scm_gen_puts (scm_regular_string, "#<jmpbuffer ", port);
scm_gen_puts (scm_regular_string, JBACTIVE (exp) ? "(active" : "(inactive", port); scm_gen_puts (scm_regular_string, JBACTIVE(exp) ? "(active) " : "(inactive) ", port);
if (JBLAZYP (exp))
scm_gen_puts (scm_regular_string, ", lazy", port);
scm_gen_puts (scm_regular_string, ") ", port);
scm_intprint((SCM) JBJMPBUF(exp), 16, port); scm_intprint((SCM) JBJMPBUF(exp), 16, port);
scm_gen_putc ('>', port); scm_gen_putc ('>', port);
return 1 ; return 1 ;
@ -115,9 +110,9 @@ static scm_smobfuns jbsmob = {
0 0
}; };
static SCM make_jmpbuf SCM_P ((int lazyp)); static SCM make_jmpbuf SCM_P ((void));
static SCM static SCM
make_jmpbuf (int lazyp) make_jmpbuf ()
{ {
SCM answer; SCM answer;
SCM_NEWCELL (answer); SCM_NEWCELL (answer);
@ -127,9 +122,9 @@ make_jmpbuf (int lazyp)
char *mem = scm_must_malloc (sizeof (scm_cell), "jb"); char *mem = scm_must_malloc (sizeof (scm_cell), "jb");
SCM_SETCDR (answer, (SCM) mem); SCM_SETCDR (answer, (SCM) mem);
#endif #endif
SCM_CAR (answer) = scm_tc16_jmpbuffer | (lazyp ? JBLAZY : 0); SCM_CAR(answer) = scm_tc16_jmpbuffer;
SETJBJMPBUF (answer, (jmp_buf *) 0); SETJBJMPBUF(answer, (jmp_buf *)0);
DEACTIVATEJB (answer); DEACTIVATEJB(answer);
} }
SCM_REALLOW_INTS; SCM_REALLOW_INTS;
return answer; return answer;
@ -143,19 +138,18 @@ struct jmp_buf_and_retval /* use only on the stack, in scm_catch */
}; };
SCM SCM
scm_catch_apply (tag, proc, a1, args, handler, lazyp) scm_catch_apply (tag, proc, a1, args, handler)
SCM tag; SCM tag;
SCM proc; SCM proc;
SCM a1; SCM a1;
SCM args; SCM args;
SCM handler; SCM handler;
int lazyp;
{ {
struct jmp_buf_and_retval jbr; struct jmp_buf_and_retval jbr;
SCM jmpbuf; SCM jmpbuf;
SCM answer; SCM answer;
jmpbuf = make_jmpbuf (lazyp); jmpbuf = make_jmpbuf ();
answer = SCM_EOL; answer = SCM_EOL;
scm_dynwinds = scm_acons (tag, jmpbuf, scm_dynwinds); scm_dynwinds = scm_acons (tag, jmpbuf, scm_dynwinds);
SETJBJMPBUF(jmpbuf, &jbr.buf); SETJBJMPBUF(jmpbuf, &jbr.buf);
@ -210,7 +204,7 @@ scm_catch (tag, thunk, handler)
|| (SCM_NIMP(tag) && SCM_SYMBOLP(tag)) || (SCM_NIMP(tag) && SCM_SYMBOLP(tag))
|| (tag == SCM_BOOL_T), || (tag == SCM_BOOL_T),
tag, SCM_ARG1, s_catch); tag, SCM_ARG1, s_catch);
return scm_catch_apply (tag, thunk, SCM_EOL, SCM_EOL, handler, 0); return scm_catch_apply (tag, thunk, SCM_EOL, SCM_EOL, handler);
} }
SCM_PROC(s_lazy_catch, "lazy-catch", 3, 0, 0, scm_lazy_catch); SCM_PROC(s_lazy_catch, "lazy-catch", 3, 0, 0, scm_lazy_catch);
@ -220,11 +214,11 @@ scm_lazy_catch (tag, thunk, handler)
SCM thunk; SCM thunk;
SCM handler; SCM handler;
{ {
SCM_ASSERT ((tag == SCM_BOOL_F) SCM_ASSERT ((SCM_NIMP(tag) && SCM_SYMBOLP(tag))
|| (SCM_NIMP(tag) && SCM_SYMBOLP(tag))
|| (tag == SCM_BOOL_T), || (tag == SCM_BOOL_T),
tag, SCM_ARG1, s_lazy_catch); tag, SCM_ARG1, s_lazy_catch);
return scm_catch_apply (tag, thunk, SCM_EOL, SCM_EOL, handler, 1); scm_dynwinds = scm_acons (tag, handler, scm_dynwinds);
return scm_apply (thunk, SCM_EOL, SCM_EOL);
} }
/* The user has thrown to an uncaught key --- print a message and die. /* The user has thrown to an uncaught key --- print a message and die.
@ -332,13 +326,21 @@ scm_ithrow (key, args, noreturn)
SCM_CDAR (wind_goal) != jmpbuf; SCM_CDAR (wind_goal) != jmpbuf;
wind_goal = SCM_CDR (wind_goal)) wind_goal = SCM_CDR (wind_goal))
; ;
{
struct jmp_buf_and_retval * jbr;
jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf);
jbr->throw_tag = key;
jbr->retval = args;
}
scm_dowinds (wind_goal, scm_ilength (scm_dynwinds) - scm_ilength (wind_goal)); scm_dowinds (wind_goal, scm_ilength (scm_dynwinds) - scm_ilength (wind_goal));
if (!SCM_JMPBUFP (jmpbuf))
{
SCM_REDEFER_INTS;
scm_dynwinds = SCM_CDR (scm_dynwinds);
SCM_REALLOW_INTS;
return scm_apply (jmpbuf, scm_cons (key, args), SCM_EOL);
}
else
{
struct jmp_buf_and_retval * jbr;
jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf);
jbr->throw_tag = key;
jbr->retval = args;
}
#ifdef DEBUG_EXTENSIONS #ifdef DEBUG_EXTENSIONS
scm_last_debug_frame = SCM_JBDFRAME (jmpbuf); scm_last_debug_frame = SCM_JBDFRAME (jmpbuf);
#endif #endif
@ -352,8 +354,8 @@ scm_throw (key, args)
SCM key; SCM key;
SCM args; SCM args;
{ {
scm_ithrow (key, args, 1); /* May return if handled by lazy catch. */
return SCM_BOOL_F; /* never really returns */ return scm_ithrow (key, args, 1);
} }