X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/033c7f3d09e31ddff2f301ff099afa20bc10c67e..e68b42c156f2f1b68580c5d9b318fe2c125a3199:/libguile/throw.c

diff --git a/libguile/throw.c b/libguile/throw.c
index 0345c1d99..87a931b1d 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -64,6 +64,8 @@ static int scm_tc16_jmpbuffer;
 #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) )
@@ -93,7 +95,10 @@ printjb (exp, port, pstate)
      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 ;
@@ -110,9 +115,9 @@ static scm_smobfuns jbsmob = {
   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);
@@ -122,9 +127,9 @@ make_jmpbuf ()
     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;
@@ -137,25 +142,25 @@ struct jmp_buf_and_retval	/* use only on the stack, in scm_catch */
   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))
     {
@@ -178,9 +183,14 @@ scm_catch (tag, thunk, handler)
   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);
@@ -189,6 +199,33 @@ scm_catch (tag, thunk, handler)
   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
@@ -285,7 +322,7 @@ scm_ithrow (key, args, noreturn)
 	      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);
 	    }
@@ -303,7 +340,7 @@ scm_ithrow (key, args, noreturn)
   }
   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);
 }