#define JBACTIVE(O) (SCM_CAR (O) & (1L << 16L))
#define ACTIVATEJB(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
#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (O) )
scm_print_state *pstate;
{
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_gen_putc ('>', port);
return 1 ;
0
};
-static SCM make_jmpbuf SCM_P ((void));
+static SCM make_jmpbuf SCM_P ((int lazyp));
static SCM
-make_jmpbuf ()
+make_jmpbuf (int lazyp)
{
SCM answer;
SCM_NEWCELL (answer);
char *mem = scm_must_malloc (sizeof (scm_cell), "jb");
SCM_SETCDR (answer, (SCM) mem);
#endif
- SCM_CAR(answer) = scm_tc16_jmpbuffer;
- SETJBJMPBUF(answer, (jmp_buf *)0);
- DEACTIVATEJB(answer);
+ SCM_CAR (answer) = scm_tc16_jmpbuffer | (lazyp ? JBLAZY : 0);
+ SETJBJMPBUF (answer, (jmp_buf *) 0);
+ DEACTIVATEJB (answer);
}
SCM_REALLOW_INTS;
return answer;
SCM retval;
};
-SCM_PROC(s_catch, "catch", 3, 0, 0, scm_catch);
SCM
-scm_catch (tag, thunk, handler)
+scm_catch_apply (tag, proc, a1, args, handler, lazyp)
SCM tag;
- SCM thunk;
+ SCM proc;
+ SCM a1;
+ SCM args;
SCM handler;
+ int lazyp;
{
struct jmp_buf_and_retval jbr;
SCM jmpbuf;
SCM answer;
- SCM_ASSERT ((tag == SCM_BOOL_F) || (SCM_NIMP(tag) && SCM_SYMBOLP(tag)) || (tag == SCM_BOOL_T),
- tag, SCM_ARG1, s_catch);
- jmpbuf = make_jmpbuf ();
+ jmpbuf = make_jmpbuf (lazyp);
answer = SCM_EOL;
scm_dynwinds = scm_acons (tag, jmpbuf, scm_dynwinds);
SETJBJMPBUF(jmpbuf, &jbr.buf);
#ifdef DEBUG_EXTENSIONS
- SCM_SETJBDFRAME(jmpbuf, last_debug_info_frame);
+ SCM_SETJBDFRAME(jmpbuf, scm_last_debug_frame);
#endif
if (setjmp (jbr.buf))
{
else
{
ACTIVATEJB (jmpbuf);
- answer = scm_apply (thunk,
- ((tag == SCM_BOOL_F) ? scm_cons (jmpbuf, SCM_EOL) : SCM_EOL),
- SCM_EOL);
+ if (tag == SCM_BOOL_F)
+ answer = scm_apply (proc,
+ 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;
DEACTIVATEJB (jmpbuf);
scm_dynwinds = SCM_CDR (scm_dynwinds);
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.
1) If the user wants something different, they can use (catch #t
scm_exitval = scm_cons (key, args);
scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds));
#ifdef DEBUG_EXTENSIONS
- last_debug_info_frame = SCM_DFRAME (scm_rootcont);
+ scm_last_debug_frame = SCM_DFRAME (scm_rootcont);
#endif
longjmp (SCM_JMPBUF (scm_rootcont), 1);
}
}
scm_dowinds (wind_goal, scm_ilength (scm_dynwinds) - scm_ilength (wind_goal));
#ifdef DEBUG_EXTENSIONS
- last_debug_info_frame = SCM_JBDFRAME (jmpbuf);
+ scm_last_debug_frame = SCM_JBDFRAME (jmpbuf);
#endif
longjmp (*JBJMPBUF (jmpbuf), 1);
}