callees now check their args, cons rest list, reserve locals

[bpt/guile.git] / libguile / vm-engine.c

diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 90cf697..f86a498 100644 (file)
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -21,14 +21,14 @@
 #if (VM_ENGINE == SCM_VM_REGULAR_ENGINE)
 #define VM_USE_HOOKS           0       /* Various hooks */
 #define VM_USE_CLOCK           0       /* Bogoclock */
-#define VM_CHECK_EXTERNAL      1       /* Check external link */
 #define VM_CHECK_OBJECT         1       /* Check object table */
+#define VM_CHECK_FREE_VARIABLES 1       /* Check free variable access */
 #define VM_PUSH_DEBUG_FRAMES    0       /* Push frames onto the evaluator debug stack */
 #elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE)
 #define VM_USE_HOOKS           1
 #define VM_USE_CLOCK           1
-#define VM_CHECK_EXTERNAL      1
 #define VM_CHECK_OBJECT         1
+#define VM_CHECK_FREE_VARIABLES 1
 #define VM_PUSH_DEBUG_FRAMES    1
 #else
 #error unknown debug engine VM_ENGINE
@@ -41,16 +41,16 @@ static SCM
 VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
 {
   /* VM registers */
-  register scm_byte_t *ip IP_REG;      /* instruction pointer */
+  register scm_t_uint8 *ip IP_REG;     /* instruction pointer */
   register SCM *sp SP_REG;             /* stack pointer */
   register SCM *fp FP_REG;             /* frame pointer */
 
   /* Cache variables */
   struct scm_objcode *bp = NULL;       /* program base pointer */
-  SCM external = SCM_EOL;              /* external environment */
+  SCM *free_vars = NULL;                /* free variables */
+  size_t free_vars_count = 0;           /* length of FREE_VARS */
   SCM *objects = NULL;                 /* constant objects */
   size_t object_count = 0;              /* length of OBJECTS */
-  SCM *stack_base = vp->stack_base;    /* stack base address */
   SCM *stack_limit = vp->stack_limit;  /* stack limit address */
 
   /* Internal variables */
@@ -106,11 +106,17 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
 
     /* Initial frame */
     CACHE_REGISTER ();
+    PUSH ((SCM)fp); /* dynamic link */
+    PUSH (0); /* mvra */
+    PUSH ((SCM)ip); /* ra */
     CACHE_PROGRAM ();
     PUSH (program);
-    NEW_FRAME ();
-
-    /* Initial arguments */
+    fp = sp + 1;
+    ip = bp->base;
+    /* MV-call frame, function & arguments */
+    PUSH ((SCM)fp); /* dynamic link */
+    PUSH (0); /* mvra */
+    PUSH (0); /* ra */
     PUSH (prog);
     if (SCM_UNLIKELY (sp + nargs >= stack_limit))
       goto vm_error_too_many_args;
@@ -151,12 +157,12 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
     SCM err_msg;
 
   vm_error_bad_instruction:
-    err_msg  = scm_from_locale_string ("VM: Bad instruction: ~A");
+    err_msg  = scm_from_locale_string ("VM: Bad instruction: ~s");
     finish_args = scm_list_1 (scm_from_uchar (ip[-1]));
     goto vm_error;
 
   vm_error_unbound:
-    err_msg  = scm_from_locale_string ("VM: Unbound variable: ~A");
+    err_msg  = scm_from_locale_string ("VM: Unbound variable: ~s");
     goto vm_error;
 
   vm_error_wrong_type_arg:
@@ -177,10 +183,9 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
     goto vm_error;
 
   vm_error_wrong_type_apply:
-    err_msg  = scm_from_locale_string ("VM: Wrong type to apply: ~S "
-                                      "[IP offset: ~a]");
-    finish_args = scm_list_2 (program,
-                             SCM_I_MAKINUM (ip - bp->base));
+    SYNC_ALL ();
+    scm_error (scm_misc_error_key, FUNC_NAME, "Wrong type to apply: ~S",
+               scm_list_1 (program), SCM_BOOL_F);
     goto vm_error;
 
   vm_error_stack_overflow:
@@ -194,7 +199,7 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
     goto vm_error;
 
   vm_error_improper_list:
-    err_msg  = scm_from_locale_string ("VM: Attempt to unroll an improper list: tail is ~A");
+    err_msg  = scm_from_locale_string ("Expected a proper list, but got object with tail ~s");
     goto vm_error;
 
   vm_error_not_a_pair:
@@ -210,15 +215,19 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
     goto vm_error;
 
   vm_error_no_values:
-    err_msg  = scm_from_locale_string ("VM: 0-valued return");
+    err_msg  = scm_from_locale_string ("Zero values returned to single-valued continuation");
     finish_args = SCM_EOL;
     goto vm_error;
 
   vm_error_not_enough_values:
-    err_msg  = scm_from_locale_string ("VM: Not enough values for mv-bind");
+    err_msg  = scm_from_locale_string ("Too few values returned to continuation");
     finish_args = SCM_EOL;
     goto vm_error;
 
+  vm_error_bad_wide_string_length:
+    err_msg  = scm_from_locale_string ("VM: Bad wide string length: ~S");
+    goto vm_error;
+
 #if VM_CHECK_IP
   vm_error_invalid_address:
     err_msg  = scm_from_locale_string ("VM: Invalid program address");
@@ -226,16 +235,16 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
     goto vm_error;
 #endif
 
-#if VM_CHECK_EXTERNAL
-  vm_error_external:
-    err_msg  = scm_from_locale_string ("VM: Invalid external access");
+#if VM_CHECK_OBJECT
+  vm_error_object:
+    err_msg = scm_from_locale_string ("VM: Invalid object table access");
     finish_args = SCM_EOL;
     goto vm_error;
 #endif
 
-#if VM_CHECK_OBJECT
-  vm_error_object:
-    err_msg = scm_from_locale_string ("VM: Invalid object table access");
+#if VM_CHECK_FREE_VARIABLES
+  vm_error_free_variable:
+    err_msg = scm_from_locale_string ("VM: Invalid free variable access");
     finish_args = SCM_EOL;
     goto vm_error;
 #endif
@@ -252,8 +261,8 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
 
 #undef VM_USE_HOOKS
 #undef VM_USE_CLOCK
-#undef VM_CHECK_EXTERNAL
 #undef VM_CHECK_OBJECT
+#undef VM_CHECK_FREE_VARIABLE
 #undef VM_PUSH_DEBUG_FRAMES
 
 /*