1
Fork 0
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:
Mikael Djurfeldt 1996-10-05 16:50:52 +00:00
parent 033c7f3d09
commit e68b42c156

View file

@ -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);
} }