Implementation for the R6RS (rnrs sorting) library.

[bpt/guile.git] / libguile / vm-i-system.c

diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 262bb87..cedd43f 100644 (file)
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -484,12 +484,12 @@ VM_DEFINE_INSTRUCTION (35, br, "br", 3, 0, 0)
 
 VM_DEFINE_INSTRUCTION (36, br_if, "br-if", 3, 0, 0)
 {
-  BR (scm_is_true_and_not_nil (*sp));
+  BR (scm_is_true (*sp));
 }
 
 VM_DEFINE_INSTRUCTION (37, br_if_not, "br-if-not", 3, 0, 0)
 {
-  BR (scm_is_false_or_nil (*sp));
+  BR (scm_is_false (*sp));
 }
 
 VM_DEFINE_INSTRUCTION (38, br_if_eq, "br-if-eq", 3, 0, 0)
@@ -506,12 +506,12 @@ VM_DEFINE_INSTRUCTION (39, br_if_not_eq, "br-if-not-eq", 3, 0, 0)
 
 VM_DEFINE_INSTRUCTION (40, br_if_null, "br-if-null", 3, 0, 0)
 {
-  BR (scm_is_null_or_nil (*sp));
+  BR (scm_is_null (*sp));
 }
 
 VM_DEFINE_INSTRUCTION (41, br_if_not_null, "br-if-not-null", 3, 0, 0)
 {
-  BR (!scm_is_null_or_nil (*sp));
+  BR (!scm_is_null (*sp));
 }
 
 \f
@@ -983,6 +983,7 @@ VM_DEFINE_INSTRUCTION (89, continuation_call, "continuation-call", 0, -1, 0)
   SCM contregs;
   POP (contregs);
 
+  SYNC_ALL ();
   scm_i_check_continuation (contregs);
   vm_return_to_continuation (scm_i_contregs_vm (contregs),
                              scm_i_contregs_vm_cont (contregs),
@@ -995,7 +996,7 @@ VM_DEFINE_INSTRUCTION (89, continuation_call, "continuation-call", 0, -1, 0)
 
 VM_DEFINE_INSTRUCTION (94, partial_cont_call, "partial-cont-call", 0, -1, 0)
 {
-  SCM vmcont, intwinds;
+  SCM vmcont, intwinds, prevwinds;
   POP (intwinds);
   POP (vmcont);
   SYNC_REGISTER ();
@@ -1003,7 +1004,18 @@ VM_DEFINE_INSTRUCTION (94, partial_cont_call, "partial-cont-call", 0, -1, 0)
     { finish_args = vmcont;
       goto vm_error_continuation_not_rewindable;
     }
-  vm_reinstate_partial_continuation (vm, vmcont, intwinds, sp + 1 - fp, fp);
+  prevwinds = scm_i_dynwinds ();
+  vm_reinstate_partial_continuation (vm, vmcont, intwinds, sp + 1 - fp, fp,
+                                     vm_cookie);
+
+  /* Rewind prompt jmpbuffers, if any. */
+  {
+    SCM winds = scm_i_dynwinds ();
+    for (; !scm_is_eq (winds, prevwinds); winds = scm_cdr (winds))
+      if (SCM_PROMPT_P (scm_car (winds)) && SCM_PROMPT_SETJMP (scm_car (winds)))
+        break;
+  }
+    
   CACHE_REGISTER ();
   program = SCM_FRAME_PROGRAM (fp);
   CACHE_PROGRAM ();
@@ -1480,8 +1492,9 @@ VM_DEFINE_INSTRUCTION (83, prompt, "prompt", 4, 2, 0)
 
   SYNC_REGISTER ();
   /* Push the prompt onto the dynamic stack. */
-  prompt = scm_c_make_prompt (k, fp, sp, ip + offset, escape_only_p, vm_cookie);
-  scm_i_set_dynwinds (scm_cons (prompt, scm_i_dynwinds ()));
+  prompt = scm_c_make_prompt (k, fp, sp, ip + offset, escape_only_p, vm_cookie,
+                              scm_i_dynwinds ());
+  scm_i_set_dynwinds (scm_cons (prompt, SCM_PROMPT_DYNWINDS (prompt)));
   if (SCM_PROMPT_SETJMP (prompt))
     {
       /* The prompt exited nonlocally. Cache the regs back from the vp, and go
@@ -1552,6 +1565,7 @@ VM_DEFINE_INSTRUCTION (90, wind_fluids, "wind-fluids", 1, -1, 0)
   if (sp - 2*n < SCM_FRAME_UPPER_ADDRESS (fp))
     goto vm_error_stack_underflow;
 
+  SYNC_REGISTER ();
   wf = scm_i_make_with_fluids (n, sp + 1 - 2*n, sp + 1 - n);
   scm_i_swap_with_fluids (wf, dynstate);
   scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
@@ -1608,6 +1622,26 @@ VM_DEFINE_INSTRUCTION (93, fluid_set, "fluid-set", 0, 2, 0)
   NEXT;
 }
 
+VM_DEFINE_INSTRUCTION (95, assert_nargs_ee_locals, "assert-nargs-ee/locals", 1, 0, 0)
+{
+  scm_t_ptrdiff n;
+  SCM *old_sp;
+
+  /* nargs = n & 0x7, nlocs = nargs + (n >> 3) */
+  n = FETCH ();
+
+  if (SCM_UNLIKELY (sp - (fp - 1) != (n & 0x7)))
+    goto vm_error_wrong_num_args;
+
+  old_sp = sp;
+  sp += (n >> 3);
+  CHECK_OVERFLOW ();
+  while (old_sp < sp)
+    *++old_sp = SCM_UNDEFINED;
+  
+  NEXT;
+}
+
 
 /*
 (defun renumber-ops ()