-/* Copyright (C) 2000 Free Software Foundation, Inc.
+/* Copyright (C) 2001 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
VM_DEFINE_INSTRUCTION (halt, "halt", 0, 0, 0)
{
- SCM ret = *sp;
+ SCM ret;
vp->time += scm_c_get_internal_run_time () - start_time;
HALT_HOOK ();
+ POP (ret);
FREE_FRAME ();
SYNC_ALL ();
return ret;
}
+VM_DEFINE_INSTRUCTION (break, "break", 0, 0, 0)
+{
+ BREAK_HOOK ();
+ NEXT;
+}
+
VM_DEFINE_INSTRUCTION (drop, "drop", 0, 0, 0)
{
DROP ();
NEXT;
}
+VM_DEFINE_INSTRUCTION (mark, "mark", 0, 0, 1)
+{
+ PUSH (SCM_UNDEFINED);
+ NEXT;
+}
+
VM_DEFINE_INSTRUCTION (dup, "dup", 0, 0, 1)
{
- PUSH (*sp);
+ SCM x = *sp;
+ PUSH (x);
NEXT;
}
VM_DEFINE_INSTRUCTION (make_int8, "make-int8", 1, 0, 1)
{
- PUSH (SCM_MAKINUM ((signed char) FETCH ()));
+ PUSH (SCM_I_MAKINUM ((signed char) FETCH ()));
NEXT;
}
VM_DEFINE_INSTRUCTION (make_int8_0, "make-int8:0", 0, 0, 1)
{
- PUSH (SCM_MAKINUM (0));
+ PUSH (SCM_INUM0);
NEXT;
}
VM_DEFINE_INSTRUCTION (make_int8_1, "make-int8:1", 0, 0, 1)
{
- PUSH (SCM_MAKINUM (1));
+ PUSH (SCM_I_MAKINUM (1));
NEXT;
}
{
int h = FETCH ();
int l = FETCH ();
- PUSH (SCM_MAKINUM ((signed short) (h << 8) + l));
+ PUSH (SCM_I_MAKINUM ((signed short) (h << 8) + l));
NEXT;
}
NEXT;
}
+VM_DEFINE_INSTRUCTION (list, "list", 2, -1, 1)
+{
+ unsigned h = FETCH ();
+ unsigned l = FETCH ();
+ unsigned len = ((h << 8) + l);
+ POP_LIST (len);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (vector, "vector", 2, -1, 1)
+{
+ unsigned h = FETCH ();
+ unsigned l = FETCH ();
+ unsigned len = ((h << 8) + l);
+ POP_LIST (len);
+ *sp = scm_vector (*sp);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (list_mark, "list-mark", 0, 0, 0)
+{
+ POP_LIST_MARK ();
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (vector_mark, "vector-mark", 0, 0, 0)
+{
+ POP_LIST_MARK ();
+ *sp = scm_vector (*sp);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (list_break, "list-break", 0, 0, 0)
+{
+ SCM l;
+ POP (l);
+ for (; !SCM_NULLP (l); l = SCM_CDR (l))
+ PUSH (SCM_CAR (l));
+ NEXT;
+}
+
\f
/*
* Variable access
#define OBJECT_REF(i) objects[i]
#define OBJECT_SET(i,o) objects[i] = o
-#define LOCAL_REF(i) SCM_VM_FRAME_VARIABLE (fp, i)
-#define LOCAL_SET(i,o) SCM_VM_FRAME_VARIABLE (fp, i) = o
+#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;
}
unsigned int i;
SCM e = external;
for (i = FETCH (); i; i--)
- e = SCM_CDR (e);
+ {
+ CHECK_EXTERNAL(e);
+ e = SCM_CDR (e);
+ }
+ CHECK_EXTERNAL(e);
PUSH (SCM_CAR (e));
NEXT;
}
VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0, 0, 1)
{
SCM x = *sp;
- SCM o = VARIABLE_REF (x);
- if (SCM_UNBNDP (o))
+
+ if (!VARIABLE_BOUNDP (x))
{
- /* Try autoload here */
- err_args = SCM_LIST1 (SCM_CAR (x));
+ err_args = SCM_LIST1 (x);
+ /* Was: err_args = SCM_LIST1 (SCM_CAR (x)); */
goto vm_error_unbound;
}
- *sp = o;
+ else
+ {
+ 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;
}
unsigned int i;
SCM e = external;
for (i = FETCH (); i; i--)
- e = SCM_CDR (e);
+ {
+ CHECK_EXTERNAL(e);
+ e = SCM_CDR (e);
+ }
+ CHECK_EXTERNAL(e);
SCM_SETCAR (e, *sp);
DROP ();
NEXT;
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
#define BR(p) \
{ \
- signed char offset = FETCH (); \
+ int h = FETCH (); \
+ int l = FETCH (); \
+ signed short offset = (h << 8) + l; \
if (p) \
ip += offset; \
DROP (); \
NEXT; \
}
-VM_DEFINE_INSTRUCTION (br_if, "br-if", 1, 0, 0)
+VM_DEFINE_INSTRUCTION (br, "br", 2, 0, 0)
+{
+ int h = FETCH ();
+ int l = FETCH ();
+ ip += (signed short) (h << 8) + l;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (br_if, "br-if", 2, 0, 0)
{
BR (!SCM_FALSEP (*sp));
}
-VM_DEFINE_INSTRUCTION (br_if_not, "br-if-not", 1, 0, 0)
+VM_DEFINE_INSTRUCTION (br_if_not, "br-if-not", 2, 0, 0)
{
BR (SCM_FALSEP (*sp));
}
-VM_DEFINE_INSTRUCTION (br_if_eq, "br-if-eq", 1, 0, 0)
+VM_DEFINE_INSTRUCTION (br_if_eq, "br-if-eq", 2, 0, 0)
{
BR (SCM_EQ_P (sp[0], sp--[1]));
}
-VM_DEFINE_INSTRUCTION (br_if_not_eq, "br-if-not-eq", 1, 0, 0)
+VM_DEFINE_INSTRUCTION (br_if_not_eq, "br-if-not-eq", 2, 0, 0)
{
BR (!SCM_EQ_P (sp[0], sp--[1]));
}
-VM_DEFINE_INSTRUCTION (br_if_null, "br-if-null", 1, 0, 0)
+VM_DEFINE_INSTRUCTION (br_if_null, "br-if-null", 2, 0, 0)
{
BR (SCM_NULLP (*sp));
}
-VM_DEFINE_INSTRUCTION (br_if_not_null, "br-if-not-null", 1, 0, 0)
+VM_DEFINE_INSTRUCTION (br_if_not_null, "br-if-not-null", 2, 0, 0)
{
BR (!SCM_NULLP (*sp));
}
-VM_DEFINE_INSTRUCTION (jump, "jump", 1, 0, 0)
-{
- ip += (signed char) FETCH ();
- NEXT;
-}
-
\f
/*
* Subprogram call
*/
if (SCM_PROGRAM_P (x))
{
- int i, last;
-
program = x;
vm_call_program:
CACHE_PROGRAM ();
INIT_ARGS ();
NEW_FRAME ();
-
- /* Init local variables */
- last = bp->nargs + bp->nlocs;
- for (i = bp->nargs; i < last; i++)
- LOCAL_SET (i, SCM_UNDEFINED);
-
- /* Create external variables */
- for (i = 0; i < bp->nexts; i++)
- CONS (external, SCM_UNDEFINED, external);
-
ENTER_HOOK ();
APPLY_HOOK ();
NEXT;
*/
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);
- sp[-1] = scm_apply (x, *sp, SCM_EOL);
- sp--;
+#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;
}
/*
EXIT_HOOK ();
reinstate_vm_cont (vp, x);
CACHE_REGISTER ();
- program = SCM_VM_FRAME_PROGRAM (fp);
+ program = SCM_FRAME_PROGRAM (fp);
CACHE_PROGRAM ();
NEXT;
}
+ program = x;
goto vm_error_wrong_type_apply;
}
VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1)
{
- SCM x;
+ register SCM x;
nargs = FETCH ();
x = sp[-nargs];
*/
if (SCM_EQ_P (x, program))
{
- INIT_ARGS ();
+ int i;
/* Move arguments */
- if (bp->nargs)
- {
- int i;
- sp -= bp->nargs - 1;
- for (i = 0; i < bp->nargs; i++)
- LOCAL_SET (i, sp[i]);
- sp -= 2;
- }
+ INIT_ARGS ();
+ sp -= bp->nargs - 1;
+ for (i = 0; i < bp->nargs; i++)
+ LOCAL_SET (i, sp[i]);
+ /* Drop the first argument and the program itself. */
+ sp -= 2;
+
+ /* Call itself */
ip = bp->base;
APPLY_HOOK ();
NEXT;
*/
if (SCM_PROGRAM_P (x))
{
- SCM *limit = sp;
- SCM *base = sp - nargs - 1;
-
- /* Exit the current frame */
EXIT_HOOK ();
FREE_FRAME ();
-
- /* Move arguments */
- while (base < limit)
- *++sp = *++base;
-
- /* Call the program */
program = x;
goto vm_call_program;
}
*/
if (!SCM_FALSEP (scm_procedure_p (x)))
{
+ SCM args;
POP_LIST (nargs);
- sp[-1] = scm_apply (x, *sp, SCM_EOL);
- sp--;
+ POP (args);
+ *sp = scm_apply (x, args, SCM_EOL);
goto vm_return;
}
/*
if (SCM_VM_CONT_P (x))
goto vm_call_cc;
+ program = x;
goto vm_error_wrong_type_apply;
}
VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1)
{
- SCM ret;
vm_return:
- ret = *sp;
EXIT_HOOK ();
RETURN_HOOK ();
FREE_FRAME ();
/* Restore the last program */
- program = SCM_VM_FRAME_PROGRAM (fp);
+ program = SCM_FRAME_PROGRAM (fp);
CACHE_PROGRAM ();
- PUSH (ret);
+ CACHE_EXTERNAL ();
NEXT;
}
HCoop / bpt / guile.git / blobdiff