merge guile-vm to guile

[bpt/guile.git] / src / vm_system.c

diff --git a/src/vm_system.c b/src/vm_system.c
index 9b45227..f227e79 100644 (file)
--- a/src/vm_system.c
+++ b/src/vm_system.c
@@ -119,7 +119,7 @@ VM_DEFINE_INSTRUCTION (make_eol, "make-eol", 0, 0, 1)
 
 VM_DEFINE_INSTRUCTION (make_int8, "make-int8", 1, 0, 1)
 {
-  PUSH (scm_from_schar ((signed char) FETCH ()));
+  PUSH (SCM_I_MAKINUM ((signed char) FETCH ()));
   NEXT;
 }
 
@@ -139,7 +139,7 @@ VM_DEFINE_INSTRUCTION (make_int16, "make-int16", 2, 0, 1)
 {
   int h = FETCH ();
   int l = FETCH ();
-  PUSH (scm_from_short ((signed short) (h << 8) + l));
+  PUSH (SCM_I_MAKINUM ((signed short) (h << 8) + l));
   NEXT;
 }
 
@@ -149,17 +149,21 @@ VM_DEFINE_INSTRUCTION (make_char8, "make-char8", 1, 0, 1)
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (list, "list", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (list, "list", 2, -1, 1)
 {
-  int n = FETCH ();
-  POP_LIST (n);
+  unsigned h = FETCH ();
+  unsigned l = FETCH ();
+  unsigned len = ((h << 8) + l);
+  POP_LIST (len);
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (vector, "vector", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (vector, "vector", 2, -1, 1)
 {
-  int n = FETCH ();
-  POP_LIST (n);
+  unsigned h = FETCH ();
+  unsigned l = FETCH ();
+  unsigned len = ((h << 8) + l);
+  POP_LIST (len);
   *sp = scm_vector (*sp);
   NEXT;
 }
@@ -197,14 +201,20 @@ VM_DEFINE_INSTRUCTION (list_break, "list-break", 0, 0, 0)
 #define LOCAL_REF(i)           SCM_FRAME_VARIABLE (fp, i)
 #define LOCAL_SET(i,o)         SCM_FRAME_VARIABLE (fp, i) = o
 
-/* #define VARIABLE_REF(v)             SCM_CDR (v) */
-/* #define VARIABLE_SET(v,o)   SCM_SETCDR (v, o) */
+/* For the variable operations, we _must_ obviously avoid function calls to
+   `scm_variable_ref ()', `scm_variable_bound_p ()' and friends which do
+   nothing more than the corresponding macros.  */
+#define VARIABLE_REF(v)                SCM_VARIABLE_REF (v)
+#define VARIABLE_SET(v,o)      SCM_VARIABLE_SET (v, o)
+#define VARIABLE_BOUNDP(v)      (VARIABLE_REF (v) != SCM_UNDEFINED)
 
 /* ref */
 
 VM_DEFINE_INSTRUCTION (object_ref, "object-ref", 1, 0, 1)
 {
-  PUSH (OBJECT_REF (FETCH ()));
+  register unsigned objnum = FETCH ();
+  CHECK_OBJECT (objnum);
+  PUSH (OBJECT_REF (objnum));
   NEXT;
 }
 
@@ -232,7 +242,7 @@ VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0, 0, 1)
 {
   SCM x = *sp;
 
-  if (SCM_FALSEP (scm_variable_bound_p (x)))
+  if (!VARIABLE_BOUNDP (x))
     {
       err_args = SCM_LIST1 (x);
       /* Was: err_args = SCM_LIST1 (SCM_CAR (x)); */
@@ -240,13 +250,37 @@ VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0, 0, 1)
     }
   else
     {
-      SCM o = scm_variable_ref (x);
+      SCM o = VARIABLE_REF (x);
       *sp = o;
     }
 
   NEXT;
 }
 
+VM_DEFINE_INSTRUCTION (late_variable_ref, "late-variable-ref", 1, 0, 1)
+{
+  unsigned objnum = FETCH ();
+  SCM pair_or_var;
+  CHECK_OBJECT (objnum);
+  pair_or_var = OBJECT_REF (objnum);
+
+  if (!SCM_VARIABLEP (pair_or_var)) 
+    {
+      SCM mod = scm_resolve_module (SCM_CAR (pair_or_var));
+      /* module_lookup might longjmp */
+      pair_or_var = scm_module_lookup (mod, SCM_CDR (pair_or_var));
+      OBJECT_SET (objnum, pair_or_var);
+      if (!VARIABLE_BOUNDP (pair_or_var))
+        {
+          err_args = SCM_LIST1 (pair_or_var);
+          goto vm_error_unbound;
+        }
+    }
+
+  PUSH (VARIABLE_REF (pair_or_var));
+  NEXT;
+}
+
 /* set */
 
 VM_DEFINE_INSTRUCTION (local_set, "local-set", 1, 1, 0)
@@ -273,12 +307,32 @@ VM_DEFINE_INSTRUCTION (external_set, "external-set", 1, 1, 0)
 
 VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0, 1, 0)
 {
-  scm_variable_set_x (sp[0], sp[-1]);
+  VARIABLE_SET (sp[0], sp[-1]);
   scm_set_object_property_x (sp[-1], scm_sym_name, SCM_CAR (sp[0]));
   sp -= 2;
   NEXT;
 }
 
+VM_DEFINE_INSTRUCTION (late_variable_set, "late-variable-set", 1, 1, 0)
+{
+  unsigned objnum = FETCH ();
+  SCM pair_or_var;
+  CHECK_OBJECT (objnum);
+  pair_or_var = OBJECT_REF (objnum);
+
+  if (!SCM_VARIABLEP (pair_or_var)) 
+    {
+      SCM mod = scm_resolve_module (SCM_CAR (pair_or_var));
+      /* module_lookup might longjmp */
+      pair_or_var = scm_module_lookup (mod, SCM_CDR (pair_or_var));
+      OBJECT_SET (objnum, pair_or_var);
+    }
+
+  VARIABLE_SET (pair_or_var, *sp);
+  DROP ();
+  NEXT;
+}
+
 \f
 /*
  * branch and jump
@@ -372,8 +426,16 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
    */
   if (!SCM_FALSEP (scm_procedure_p (x)))
     {
+      /* At this point, the stack contains the procedure and each one of its
+        arguments.  */
       SCM args;
+
+#if 1
       POP_LIST (nargs);
+#else
+      /* Experimental:  Build the arglist on the VM stack.  XXX  */
+      POP_LIST_ON_STACK (nargs);
+#endif
       POP (args);
       *sp = scm_apply (x, args, SCM_EOL);
       NEXT;
@@ -403,7 +465,7 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
 
 VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1)
 {
-  SCM x;
+  register SCM x;
   nargs = FETCH ();
   x = sp[-nargs];
 
@@ -421,7 +483,9 @@ VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1)
       sp -= bp->nargs - 1;
       for (i = 0; i < bp->nargs; i++)
        LOCAL_SET (i, sp[i]);
-      sp--;
+
+      /* Drop the first argument and the program itself.  */
+      sp -= 2;
 
       /* Call itself */
       ip = bp->base;