apply_from_stack_frame: use correct frame base

Previously, we assumed that all stack frames were lying at the top of
the lisp stack. This is not always true due to e.g.
multiple-value-prog1 pushing onto the lisp stack.

src/c/eval.d

@@ -19,7 +19,7 @@
 cl_object *
 _ecl_va_sp(cl_narg narg)
 {
-  return ecl_process_env()->stack_top - narg;
+  return ecl_process_env()->stack_frame->frame.base + narg;
 }
 
 /* Calling conventions:
@@ -37,6 +37,8 @@ ecl_apply_from_stack_frame(cl_object frame, cl_object x)
   cl_object *sp = frame->frame.base;
   cl_index narg = frame->frame.size;
   cl_object fun = x;
+  cl_object ret;
+  frame->frame.env->stack_frame = frame;
  AGAIN:
   frame->frame.env->function = fun;
   if (ecl_unlikely(fun == OBJNULL || fun == ECL_NIL))
@@ -45,37 +47,47 @@ ecl_apply_from_stack_frame(cl_object frame, cl_object x)
   case t_cfunfixed:
     if (ecl_unlikely(narg != (cl_index)fun->cfun.narg))
       FEwrong_num_arguments(fun);
-    return APPLY_fixed(narg, fun->cfunfixed.entry_fixed, sp);
+    ret = APPLY_fixed(narg, fun->cfunfixed.entry_fixed, sp);
+    break;
   case t_cfun:
-    return APPLY(narg, fun->cfun.entry, sp);
+    ret = APPLY(narg, fun->cfun.entry, sp);
+    break;
   case t_cclosure:
-    return APPLY(narg, fun->cclosure.entry, sp);
+    ret = APPLY(narg, fun->cclosure.entry, sp);
+    break;
   case t_instance:
     switch (fun->instance.isgf) {
     case ECL_STANDARD_DISPATCH:
     case ECL_RESTRICTED_DISPATCH:
-      return _ecl_standard_dispatch(frame, fun);
+      ret = _ecl_standard_dispatch(frame, fun);
+      break;
     case ECL_USER_DISPATCH:
       fun = fun->instance.slots[fun->instance.length - 1];
       goto AGAIN;
     case ECL_READER_DISPATCH:
     case ECL_WRITER_DISPATCH:
-      return APPLY(narg, fun->instance.entry, sp);
+      ret = APPLY(narg, fun->instance.entry, sp);
+      break;
     default:
       FEinvalid_function(fun);
     }
+    break;
   case t_symbol:
     if (ecl_unlikely(fun->symbol.stype & ecl_stp_macro))
       FEundefined_function(x);
     fun = ECL_SYM_FUN(fun);
     goto AGAIN;
   case t_bytecodes:
-    return ecl_interpret(frame, ECL_NIL, fun);
+    ret = ecl_interpret(frame, ECL_NIL, fun);
+    break;
   case t_bclosure:
-    return ecl_interpret(frame, fun->bclosure.lex, fun->bclosure.code);
+    ret = ecl_interpret(frame, fun->bclosure.lex, fun->bclosure.code);
+    break;
   default:
     FEinvalid_function(x);
   }
+  frame->frame.env->stack_frame = NULL; /* for gc's sake */
+  return ret;
 }
 
 cl_objectfn

src/c/interpreter.d

@@ -510,6 +510,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes)
       cl_object frame = (cl_object)&frame_aux;
       frame_aux.size = narg;
       frame_aux.base = the_env->stack_top - narg;
+      the_env->stack_frame = frame;
       SETUP_ENV(the_env);
     AGAIN:
       if (ecl_unlikely(reg0 == OBJNULL || reg0 == ECL_NIL))
@@ -561,11 +562,12 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes)
         FEinvalid_function(reg0);
       }
       ECL_STACK_POP_N_UNSAFE(the_env, narg);
+      the_env->stack_frame = NULL; /* for gc's sake */
       THREAD_NEXT;
     }
 
     /* OP_POP
-       Pops a singe value pushed by a OP_PUSH* operator.
+       Pops a single value pushed by a OP_PUSH* operator.
     */
     CASE(OP_POP); {
       reg0 = ECL_STACK_POP_UNSAFE(the_env);

src/c/unixint.d

@@ -384,6 +384,7 @@ handle_all_queued_interrupt_safe(cl_env_ptr env)
         cl_index nvalues = env->nvalues;
         cl_object values[ECL_MULTIPLE_VALUES_LIMIT];
         memcpy(values, env->values, ECL_MULTIPLE_VALUES_LIMIT*sizeof(cl_object));
+        cl_object stack_frame = env->stack_frame;
         cl_object big_register[3];
         memcpy(big_register, env->big_register, 3*sizeof(cl_object));
         cl_object packages_to_be_created = env->packages_to_be_created;
@@ -409,6 +410,7 @@ handle_all_queued_interrupt_safe(cl_env_ptr env)
         env->packages_to_be_created_p = packages_to_be_created_p;
         env->packages_to_be_created = packages_to_be_created;
         memcpy(env->big_register, big_register, 3*sizeof(cl_object));
+        env->stack_frame = stack_frame;
         memcpy(env->values, values, ECL_MULTIPLE_VALUES_LIMIT*sizeof(cl_object));
         env->nvalues = nvalues;
         env->function = fun;

src/h/external.h

@@ -26,6 +26,9 @@ struct cl_env_struct {
         /* Environment for calling closures, CLOS generic functions, etc */
         cl_object function;
 
+        /* Current stack frame */
+        cl_object stack_frame;
+
         /* The four stacks in ECL. */
 
         /*

src/h/stacks.h

@@ -340,7 +340,7 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(register cl_env_ptr);
 #define ecl_va_start(a,p,n,k) { \
         a[0].narg = (n)-(k); \
         va_start(a[0].args,p); \
-        a[0].sp = ((n) <= ECL_C_ARGUMENTS_LIMIT)? 0 : _ecl_va_sp(a[0].narg); }
+        a[0].sp = ((n) <= ECL_C_ARGUMENTS_LIMIT)? 0 : _ecl_va_sp(k); }
 #define ecl_va_arg(a) \
         (a[0].narg--,(a[0].sp? *(a[0].sp++) : va_arg(a[0].args,cl_object)))
 #define ecl_va_copy(dest,orig) { \