mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-12 14:50:19 +02:00
* continuations.c, debug.[ch], eval.c, gscm.c init.c, root.c,
throw.c: Renamed last_debug_info_frame -> scm_last_debug_frame. * throw.c: Renamed scm_catch --> scm_catch_apply and added more arguments. The motivation is that code in root.c needs catch functionality, and we want to avoid code duplication. New functions: scm_catch, scm_lazy_catch. These are wrappers for scm_catch_apply. scm_lazy_catch is intended to introduce catch handlers that run without popping the stack into the dynwind chain.
This commit is contained in:
parent
033c7f3d09
commit
e68b42c156
1 changed files with 55 additions and 18 deletions
|
@ -64,6 +64,8 @@ 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) )
|
||||||
|
@ -93,7 +95,10 @@ 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 ;
|
||||||
|
@ -110,9 +115,9 @@ static scm_smobfuns jbsmob = {
|
||||||
0
|
0
|
||||||
};
|
};
|
||||||
|
|
||||||
static SCM make_jmpbuf SCM_P ((void));
|
static SCM make_jmpbuf SCM_P ((int lazyp));
|
||||||
static SCM
|
static SCM
|
||||||
make_jmpbuf ()
|
make_jmpbuf (int lazyp)
|
||||||
{
|
{
|
||||||
SCM answer;
|
SCM answer;
|
||||||
SCM_NEWCELL (answer);
|
SCM_NEWCELL (answer);
|
||||||
|
@ -122,9 +127,9 @@ make_jmpbuf ()
|
||||||
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;
|
SCM_CAR (answer) = scm_tc16_jmpbuffer | (lazyp ? JBLAZY : 0);
|
||||||
SETJBJMPBUF(answer, (jmp_buf *)0);
|
SETJBJMPBUF (answer, (jmp_buf *) 0);
|
||||||
DEACTIVATEJB(answer);
|
DEACTIVATEJB (answer);
|
||||||
}
|
}
|
||||||
SCM_REALLOW_INTS;
|
SCM_REALLOW_INTS;
|
||||||
return answer;
|
return answer;
|
||||||
|
@ -137,25 +142,25 @@ struct jmp_buf_and_retval /* use only on the stack, in scm_catch */
|
||||||
SCM retval;
|
SCM retval;
|
||||||
};
|
};
|
||||||
|
|
||||||
SCM_PROC(s_catch, "catch", 3, 0, 0, scm_catch);
|
|
||||||
SCM
|
SCM
|
||||||
scm_catch (tag, thunk, handler)
|
scm_catch_apply (tag, proc, a1, args, handler, lazyp)
|
||||||
SCM tag;
|
SCM tag;
|
||||||
SCM thunk;
|
SCM proc;
|
||||||
|
SCM a1;
|
||||||
|
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;
|
||||||
|
|
||||||
SCM_ASSERT ((tag == SCM_BOOL_F) || (SCM_NIMP(tag) && SCM_SYMBOLP(tag)) || (tag == SCM_BOOL_T),
|
jmpbuf = make_jmpbuf (lazyp);
|
||||||
tag, SCM_ARG1, s_catch);
|
|
||||||
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);
|
||||||
#ifdef DEBUG_EXTENSIONS
|
#ifdef DEBUG_EXTENSIONS
|
||||||
SCM_SETJBDFRAME(jmpbuf, last_debug_info_frame);
|
SCM_SETJBDFRAME(jmpbuf, scm_last_debug_frame);
|
||||||
#endif
|
#endif
|
||||||
if (setjmp (jbr.buf))
|
if (setjmp (jbr.buf))
|
||||||
{
|
{
|
||||||
|
@ -178,9 +183,14 @@ scm_catch (tag, thunk, handler)
|
||||||
else
|
else
|
||||||
{
|
{
|
||||||
ACTIVATEJB (jmpbuf);
|
ACTIVATEJB (jmpbuf);
|
||||||
answer = scm_apply (thunk,
|
if (tag == SCM_BOOL_F)
|
||||||
((tag == SCM_BOOL_F) ? scm_cons (jmpbuf, SCM_EOL) : SCM_EOL),
|
answer = scm_apply (proc,
|
||||||
SCM_EOL);
|
SCM_NULLP (a1)
|
||||||
|
? scm_cons (jmpbuf, SCM_EOL)
|
||||||
|
: scm_cons2 (jmpbuf, a1, args),
|
||||||
|
SCM_EOL);
|
||||||
|
else
|
||||||
|
answer = scm_apply (proc, a1, args);
|
||||||
SCM_REDEFER_INTS;
|
SCM_REDEFER_INTS;
|
||||||
DEACTIVATEJB (jmpbuf);
|
DEACTIVATEJB (jmpbuf);
|
||||||
scm_dynwinds = SCM_CDR (scm_dynwinds);
|
scm_dynwinds = SCM_CDR (scm_dynwinds);
|
||||||
|
@ -189,6 +199,33 @@ scm_catch (tag, thunk, handler)
|
||||||
return answer;
|
return answer;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
SCM_PROC(s_catch, "catch", 3, 0, 0, scm_catch);
|
||||||
|
SCM
|
||||||
|
scm_catch (tag, thunk, handler)
|
||||||
|
SCM tag;
|
||||||
|
SCM thunk;
|
||||||
|
SCM handler;
|
||||||
|
{
|
||||||
|
SCM_ASSERT ((tag == SCM_BOOL_F)
|
||||||
|
|| (SCM_NIMP(tag) && SCM_SYMBOLP(tag))
|
||||||
|
|| (tag == SCM_BOOL_T),
|
||||||
|
tag, SCM_ARG1, s_catch);
|
||||||
|
return scm_catch_apply (tag, thunk, SCM_EOL, SCM_EOL, handler, 0);
|
||||||
|
}
|
||||||
|
|
||||||
|
SCM_PROC(s_lazy_catch, "lazy-catch", 3, 0, 0, scm_lazy_catch);
|
||||||
|
SCM
|
||||||
|
scm_lazy_catch (tag, thunk, handler)
|
||||||
|
SCM tag;
|
||||||
|
SCM thunk;
|
||||||
|
SCM handler;
|
||||||
|
{
|
||||||
|
SCM_ASSERT ((tag == SCM_BOOL_F)
|
||||||
|
|| (SCM_NIMP(tag) && SCM_SYMBOLP(tag))
|
||||||
|
|| (tag == SCM_BOOL_T),
|
||||||
|
tag, SCM_ARG1, s_lazy_catch);
|
||||||
|
return scm_catch_apply (tag, thunk, SCM_EOL, SCM_EOL, handler, 1);
|
||||||
|
}
|
||||||
|
|
||||||
/* 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.
|
||||||
1) If the user wants something different, they can use (catch #t
|
1) If the user wants something different, they can use (catch #t
|
||||||
|
@ -285,7 +322,7 @@ scm_ithrow (key, args, noreturn)
|
||||||
scm_exitval = scm_cons (key, args);
|
scm_exitval = scm_cons (key, args);
|
||||||
scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds));
|
scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds));
|
||||||
#ifdef DEBUG_EXTENSIONS
|
#ifdef DEBUG_EXTENSIONS
|
||||||
last_debug_info_frame = SCM_DFRAME (scm_rootcont);
|
scm_last_debug_frame = SCM_DFRAME (scm_rootcont);
|
||||||
#endif
|
#endif
|
||||||
longjmp (SCM_JMPBUF (scm_rootcont), 1);
|
longjmp (SCM_JMPBUF (scm_rootcont), 1);
|
||||||
}
|
}
|
||||||
|
@ -303,7 +340,7 @@ scm_ithrow (key, args, noreturn)
|
||||||
}
|
}
|
||||||
scm_dowinds (wind_goal, scm_ilength (scm_dynwinds) - scm_ilength (wind_goal));
|
scm_dowinds (wind_goal, scm_ilength (scm_dynwinds) - scm_ilength (wind_goal));
|
||||||
#ifdef DEBUG_EXTENSIONS
|
#ifdef DEBUG_EXTENSIONS
|
||||||
last_debug_info_frame = SCM_JBDFRAME (jmpbuf);
|
scm_last_debug_frame = SCM_JBDFRAME (jmpbuf);
|
||||||
#endif
|
#endif
|
||||||
longjmp (*JBJMPBUF (jmpbuf), 1);
|
longjmp (*JBJMPBUF (jmpbuf), 1);
|
||||||
}
|
}
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue