summaryrefslogtreecommitdiff
path: root/libguile/vm-i-system.c
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-11-08 18:28:24 +0100
committerAndy Wingo <wingo@pobox.com>2013-11-08 18:28:24 +0100
commit1c33be992e8120abd20add8021e4d91d226f5b6a (patch)
tree71f78961b6a29aa1e342049419f402af555e6f20 /libguile/vm-i-system.c
parent84680d238299c3b2c8be42b16a8be0ff6e02ba5c (diff)
downloadguile-1c33be992e8120abd20add8021e4d91d226f5b6a.tar.gz
Remove stack programs, objcode, and the old VM.
* libguile/Makefile.am: * libguile/vm-i-loader.c: * libguile/vm-i-scheme.c: * libguile/vm-i-system.c: Remove the old VM files, and the rules to build the .i files. * libguile/vm-engine.c: * libguile/vm.c: Remove the old VM. Woot! * libguile/_scm.h (SCM_OBJCODE_COOKIE, SCM_OBJCODE_ENDIANNESS_OFFSET) (SCM_OBJCODE_WORD_SIZE_OFFSET): Remove. * libguile/evalext.c (scm_self_evaluating_p): Remove objcode and program cases. * libguile/frames.c (scm_frame_num_locals, scm_frame_previous): Remove program cases. * libguile/gc.c (scm_i_tag_name): Remove objcode case. * libguile/goops.c (scm_class_of, create_standard_classes): Remove objcode and program cases. * libguile/instructions.h: * libguile/instructions.c (scm_instruction_list, scm_instruction_p) (scm_instruction_length, scm_instruction_pops, scm_instruction_pushes) (scm_instruction_to_opcode, scm_opcode_to_instruction): Remove old VM code. * libguile/objcodes.h: * libguile/objcodes.c: Remove the objcode data type, and handling for objcode files. * libguile/print.c: Remove objcode and program printers. * libguile/procprop.c: Remove program cases. * libguile/procs.c: * libguile/programs.h: * libguile/programs.c: Remove old program code. * libguile/smob.c: Remove objcodes include. * libguile/snarf.h: Remove static program defines. * libguile/stacks.c: Remove program case. * libguile/tags.h: Remove program and objcode tc7s. * module/ice-9/session.scm (procedure-arguments) * module/language/tree-il/analyze.scm (validate-arity) * module/statprof.scm (get-call-data, procedure=?) * module/system/vm/frame.scm (frame-bindings) (frame-call-representation): Remove old program cases. * module/system/repl/debug.scm (frame->module): Add a FIXME. * module/system/vm/instruction.scm: Remove old exports. * module/system/vm/program.scm: Remove old program code.
Diffstat (limited to 'libguile/vm-i-system.c')
-rw-r--r--libguile/vm-i-system.c1656
1 files changed, 0 insertions, 1656 deletions
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
deleted file mode 100644
index e023d562b..000000000
--- a/libguile/vm-i-system.c
+++ /dev/null
@@ -1,1656 +0,0 @@
-/* Copyright (C) 2001,2008,2009,2010,2011,2012,2013 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public License
- * as published by the Free Software Foundation; either version 3 of
- * the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
- * 02110-1301 USA
- */
-
-
-/* This file is included in vm_engine.c */
-
-
-/*
- * Basic operations
- */
-
-VM_DEFINE_INSTRUCTION (0, nop, "nop", 0, 0, 0)
-{
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
-{
- SCM ret;
-
- nvalues = SCM_I_INUM (*sp--);
- NULLSTACK (1);
-
- if (nvalues == 1)
- POP (ret);
- else
- {
- SYNC_REGISTER ();
- sp -= nvalues;
- CHECK_UNDERFLOW ();
- ret = scm_c_values (sp + 1, nvalues);
- NULLSTACK (nvalues);
- }
-
- {
-#ifdef VM_ENABLE_STACK_NULLING
- SCM *old_sp = sp;
-#endif
-
- /* Restore registers */
- sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
- /* Setting the ip here doesn't actually affect control flow, as the calling
- code will restore its own registers, but it does help when walking the
- stack */
- ip = SCM_FRAME_RETURN_ADDRESS (fp);
- fp = SCM_FRAME_DYNAMIC_LINK (fp);
- NULLSTACK (old_sp - sp);
- }
-
- SYNC_ALL ();
- return ret;
-}
-
-VM_DEFINE_INSTRUCTION (2, drop, "drop", 0, 1, 0)
-{
- DROP ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (3, dup, "dup", 0, 0, 1)
-{
- SCM x = *sp;
- PUSH (x);
- NEXT;
-}
-
-
-/*
- * Object creation
- */
-
-VM_DEFINE_INSTRUCTION (4, void, "void", 0, 0, 1)
-{
- PUSH (SCM_UNSPECIFIED);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (5, make_true, "make-true", 0, 0, 1)
-{
- PUSH (SCM_BOOL_T);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (6, make_false, "make-false", 0, 0, 1)
-{
- PUSH (SCM_BOOL_F);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (7, make_nil, "make-nil", 0, 0, 1)
-{
- PUSH (SCM_ELISP_NIL);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (8, make_eol, "make-eol", 0, 0, 1)
-{
- PUSH (SCM_EOL);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (9, make_int8, "make-int8", 1, 0, 1)
-{
- PUSH (SCM_I_MAKINUM ((signed char) FETCH ()));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (10, make_int8_0, "make-int8:0", 0, 0, 1)
-{
- PUSH (SCM_INUM0);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (11, make_int8_1, "make-int8:1", 0, 0, 1)
-{
- PUSH (SCM_I_MAKINUM (1));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (12, make_int16, "make-int16", 2, 0, 1)
-{
- int h = FETCH ();
- int l = FETCH ();
- PUSH (SCM_I_MAKINUM ((signed short) (h << 8) + l));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (13, make_int64, "make-int64", 8, 0, 1)
-{
- scm_t_uint64 v = 0;
- v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- PUSH (scm_from_int64 ((scm_t_int64) v));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (14, make_uint64, "make-uint64", 8, 0, 1)
-{
- scm_t_uint64 v = 0;
- v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- PUSH (scm_from_uint64 (v));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (15, make_char8, "make-char8", 1, 0, 1)
-{
- scm_t_uint8 v = 0;
- v = FETCH ();
-
- PUSH (SCM_MAKE_CHAR (v));
- /* Don't simplify this to PUSH (SCM_MAKE_CHAR (FETCH ())). The
- contents of SCM_MAKE_CHAR may be evaluated more than once,
- resulting in a double fetch. */
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (16, make_char32, "make-char32", 4, 0, 1)
-{
- scm_t_wchar v = 0;
- v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- PUSH (SCM_MAKE_CHAR (v));
- NEXT;
-}
-
-
-
-VM_DEFINE_INSTRUCTION (17, list, "list", 2, -1, 1)
-{
- unsigned h = FETCH ();
- unsigned l = FETCH ();
- unsigned len = ((h << 8) + l);
- POP_LIST (len);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (18, vector, "vector", 2, -1, 1)
-{
- unsigned h = FETCH ();
- unsigned l = FETCH ();
- unsigned len = ((h << 8) + l);
- SCM vect;
-
- SYNC_REGISTER ();
- sp++; sp -= len;
- CHECK_UNDERFLOW ();
- vect = scm_make_vector (scm_from_uint (len), SCM_BOOL_F);
- memcpy (SCM_I_VECTOR_WELTS(vect), sp, sizeof(SCM) * len);
- NULLSTACK (len);
- *sp = vect;
-
- NEXT;
-}
-
-
-/*
- * Variable access
- */
-
-#define OBJECT_REF(i) objects[i]
-#define OBJECT_SET(i,o) objects[i] = o
-
-#define LOCAL_REF(i) SCM_FRAME_VARIABLE (fp, i)
-#define LOCAL_SET(i,o) SCM_FRAME_VARIABLE (fp, i) = 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) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED))
-
-#define FREE_VARIABLE_REF(i) SCM_PROGRAM_FREE_VARIABLE_REF (program, i)
-
-/* ref */
-
-VM_DEFINE_INSTRUCTION (19, object_ref, "object-ref", 1, 0, 1)
-{
- register unsigned objnum = FETCH ();
- CHECK_OBJECT (objnum);
- PUSH (OBJECT_REF (objnum));
- NEXT;
-}
-
-/* FIXME: necessary? elt 255 of the vector could be a vector... */
-VM_DEFINE_INSTRUCTION (20, long_object_ref, "long-object-ref", 2, 0, 1)
-{
- unsigned int objnum = FETCH ();
- objnum <<= 8;
- objnum += FETCH ();
- CHECK_OBJECT (objnum);
- PUSH (OBJECT_REF (objnum));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (21, local_ref, "local-ref", 1, 0, 1)
-{
- PUSH (LOCAL_REF (FETCH ()));
- ASSERT_BOUND (*sp);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (22, long_local_ref, "long-local-ref", 2, 0, 1)
-{
- unsigned int i = FETCH ();
- i <<= 8;
- i += FETCH ();
- PUSH (LOCAL_REF (i));
- ASSERT_BOUND (*sp);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (23, local_bound, "local-bound?", 1, 0, 1)
-{
- PUSH (scm_from_bool (!scm_is_eq (LOCAL_REF (FETCH ()), SCM_UNDEFINED)));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (24, long_local_bound, "long-local-bound?", 2, 0, 1)
-{
- unsigned int i = FETCH ();
- i <<= 8;
- i += FETCH ();
- PUSH (scm_from_bool (!scm_is_eq (LOCAL_REF (i), SCM_UNDEFINED)));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (25, variable_ref, "variable-ref", 0, 1, 1)
-{
- SCM x = *sp;
-
- /* We don't use ASSERT_VARIABLE or ASSERT_BOUND_VARIABLE here because,
- unlike in top-variable-ref, it really isn't an internal assertion
- that can be optimized out -- the variable could be coming directly
- from the user. */
- VM_ASSERT (SCM_VARIABLEP (x),
- vm_error_not_a_variable ("variable-ref", x));
-
- if (SCM_UNLIKELY (!VARIABLE_BOUNDP (x)))
- {
- SCM var_name;
-
- SYNC_ALL ();
- /* Attempt to provide the variable name in the error message. */
- var_name = scm_module_reverse_lookup (scm_current_module (), x);
- vm_error_unbound (program, scm_is_true (var_name) ? var_name : x);
- }
- else
- {
- SCM o = VARIABLE_REF (x);
- *sp = o;
- }
-
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (26, variable_bound, "variable-bound?", 0, 1, 1)
-{
- SCM x = *sp;
-
- VM_ASSERT (SCM_VARIABLEP (x),
- vm_error_not_a_variable ("variable-bound?", x));
-
- *sp = scm_from_bool (VARIABLE_BOUNDP (x));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (27, toplevel_ref, "toplevel-ref", 1, 0, 1)
-{
- unsigned objnum = FETCH ();
- SCM what, resolved;
- CHECK_OBJECT (objnum);
- what = OBJECT_REF (objnum);
-
- if (!SCM_VARIABLEP (what))
- {
- SYNC_REGISTER ();
- resolved = resolve_variable (what, scm_program_module (program));
- VM_ASSERT (VARIABLE_BOUNDP (resolved), vm_error_unbound (program, what));
- what = resolved;
- OBJECT_SET (objnum, what);
- }
-
- PUSH (VARIABLE_REF (what));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (28, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
-{
- SCM what, resolved;
- unsigned int objnum = FETCH ();
- objnum <<= 8;
- objnum += FETCH ();
- CHECK_OBJECT (objnum);
- what = OBJECT_REF (objnum);
-
- if (!SCM_VARIABLEP (what))
- {
- SYNC_REGISTER ();
- resolved = resolve_variable (what, scm_program_module (program));
- VM_ASSERT (VARIABLE_BOUNDP (resolved),
- vm_error_unbound (program, what));
- what = resolved;
- OBJECT_SET (objnum, what);
- }
-
- PUSH (VARIABLE_REF (what));
- NEXT;
-}
-
-/* set */
-
-VM_DEFINE_INSTRUCTION (29, local_set, "local-set", 1, 1, 0)
-{
- SCM x;
- POP (x);
- LOCAL_SET (FETCH (), x);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (30, long_local_set, "long-local-set", 2, 1, 0)
-{
- SCM x;
- unsigned int i = FETCH ();
- i <<= 8;
- i += FETCH ();
- POP (x);
- LOCAL_SET (i, x);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (31, variable_set, "variable-set", 0, 2, 0)
-{
- VM_ASSERT (SCM_VARIABLEP (sp[0]),
- vm_error_not_a_variable ("variable-set!", sp[0]));
- VARIABLE_SET (sp[0], sp[-1]);
- DROPN (2);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (32, toplevel_set, "toplevel-set", 1, 1, 0)
-{
- unsigned objnum = FETCH ();
- SCM what;
- CHECK_OBJECT (objnum);
- what = OBJECT_REF (objnum);
-
- if (!SCM_VARIABLEP (what))
- {
- SYNC_BEFORE_GC ();
- what = resolve_variable (what, scm_program_module (program));
- OBJECT_SET (objnum, what);
- }
-
- VARIABLE_SET (what, *sp);
- DROP ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (33, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
-{
- SCM what;
- unsigned int objnum = FETCH ();
- objnum <<= 8;
- objnum += FETCH ();
- CHECK_OBJECT (objnum);
- what = OBJECT_REF (objnum);
-
- if (!SCM_VARIABLEP (what))
- {
- SYNC_BEFORE_GC ();
- what = resolve_variable (what, scm_program_module (program));
- OBJECT_SET (objnum, what);
- }
-
- VARIABLE_SET (what, *sp);
- DROP ();
- NEXT;
-}
-
-
-/*
- * branch and jump
- */
-
-/* offset must be at least 24 bits wide, and signed */
-#define FETCH_OFFSET(offset) \
-{ \
- offset = FETCH () << 16; \
- offset += FETCH () << 8; \
- offset += FETCH (); \
- offset -= (offset & (1<<23)) << 1; \
-}
-
-#define BR(p) \
-{ \
- scm_t_int32 offset; \
- FETCH_OFFSET (offset); \
- if (p) \
- ip += offset; \
- if (offset < 0) \
- VM_HANDLE_INTERRUPTS; \
- NEXT; \
-}
-
-VM_DEFINE_INSTRUCTION (34, br, "br", 3, 0, 0)
-{
- scm_t_int32 offset;
- FETCH_OFFSET (offset);
- ip += offset;
- if (offset < 0)
- VM_HANDLE_INTERRUPTS;
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (35, br_if, "br-if", 3, 0, 0)
-{
- SCM x;
- POP (x);
- BR (scm_is_true (x));
-}
-
-VM_DEFINE_INSTRUCTION (36, br_if_not, "br-if-not", 3, 0, 0)
-{
- SCM x;
- POP (x);
- BR (scm_is_false (x));
-}
-
-VM_DEFINE_INSTRUCTION (37, br_if_eq, "br-if-eq", 3, 0, 0)
-{
- SCM x, y;
- POP2 (y, x);
- BR (scm_is_eq (x, y));
-}
-
-VM_DEFINE_INSTRUCTION (38, br_if_not_eq, "br-if-not-eq", 3, 0, 0)
-{
- SCM x, y;
- POP2 (y, x);
- BR (!scm_is_eq (x, y));
-}
-
-VM_DEFINE_INSTRUCTION (39, br_if_null, "br-if-null", 3, 0, 0)
-{
- SCM x;
- POP (x);
- BR (scm_is_null (x));
-}
-
-VM_DEFINE_INSTRUCTION (40, br_if_not_null, "br-if-not-null", 3, 0, 0)
-{
- SCM x;
- POP (x);
- BR (!scm_is_null (x));
-}
-
-VM_DEFINE_INSTRUCTION (41, br_if_nil, "br-if-nil", 3, 0, 0)
-{
- SCM x;
- POP (x);
- BR (scm_is_lisp_false (x));
-}
-
-VM_DEFINE_INSTRUCTION (42, br_if_not_nil, "br-if-not-nil", 3, 0, 0)
-{
- SCM x;
- POP (x);
- BR (!scm_is_lisp_false (x));
-}
-
-#undef BR
-
-
-/*
- * Subprogram call
- */
-
-VM_DEFINE_INSTRUCTION (43, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0)
-{
- scm_t_ptrdiff n;
- scm_t_int32 offset;
- n = FETCH () << 8;
- n += FETCH ();
- FETCH_OFFSET (offset);
- if (sp - (fp - 1) != n)
- ip += offset;
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (44, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0)
-{
- scm_t_ptrdiff n;
- scm_t_int32 offset;
- n = FETCH () << 8;
- n += FETCH ();
- FETCH_OFFSET (offset);
- if (sp - (fp - 1) < n)
- ip += offset;
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (45, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0)
-{
- scm_t_ptrdiff n;
- scm_t_int32 offset;
-
- n = FETCH () << 8;
- n += FETCH ();
- FETCH_OFFSET (offset);
- if (sp - (fp - 1) > n)
- ip += offset;
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (46, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0)
-{
- scm_t_ptrdiff n;
- n = FETCH () << 8;
- n += FETCH ();
- VM_ASSERT (sp - (fp - 1) == n,
- vm_error_wrong_num_args (program));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (47, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0)
-{
- scm_t_ptrdiff n;
- n = FETCH () << 8;
- n += FETCH ();
- VM_ASSERT (sp - (fp - 1) >= n,
- vm_error_wrong_num_args (program));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (48, bind_optionals, "bind-optionals", 2, -1, -1)
-{
- scm_t_ptrdiff n;
- n = FETCH () << 8;
- n += FETCH ();
- while (sp - (fp - 1) < n)
- PUSH (SCM_UNDEFINED);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (49, bind_optionals_shuffle, "bind-optionals/shuffle", 6, -1, -1)
-{
- SCM *walk;
- scm_t_ptrdiff nreq, nreq_and_opt, ntotal;
- nreq = FETCH () << 8;
- nreq += FETCH ();
- nreq_and_opt = FETCH () << 8;
- nreq_and_opt += FETCH ();
- ntotal = FETCH () << 8;
- ntotal += FETCH ();
-
- /* look in optionals for first keyword or last positional */
- /* starting after the last required positional arg */
- walk = fp + nreq;
- while (/* while we have args */
- walk <= sp
- /* and we still have positionals to fill */
- && walk - fp < nreq_and_opt
- /* and we haven't reached a keyword yet */
- && !scm_is_keyword (*walk))
- /* bind this optional arg (by leaving it in place) */
- walk++;
- /* now shuffle up, from walk to ntotal */
- {
- scm_t_ptrdiff nshuf = sp - walk + 1, i;
- sp = (fp - 1) + ntotal + nshuf;
- CHECK_OVERFLOW ();
- for (i = 0; i < nshuf; i++)
- sp[-i] = walk[nshuf-i-1];
- }
- /* and fill optionals & keyword args with SCM_UNDEFINED */
- while (walk <= (fp - 1) + ntotal)
- *walk++ = SCM_UNDEFINED;
-
- NEXT;
-}
-
-/* See also bind-optionals/shuffle-or-br below. */
-
-/* Flags that determine whether other keywords are allowed, and whether a
- rest argument is expected. These values must match those used by the
- glil->assembly compiler. */
-#define F_ALLOW_OTHER_KEYS 1
-#define F_REST 2
-
-VM_DEFINE_INSTRUCTION (50, bind_kwargs, "bind-kwargs", 5, 0, 0)
-{
- scm_t_uint16 idx;
- scm_t_ptrdiff nkw;
- int kw_and_rest_flags;
- SCM kw;
- idx = FETCH () << 8;
- idx += FETCH ();
- /* XXX: We don't actually use NKW. */
- nkw = FETCH () << 8;
- nkw += FETCH ();
- kw_and_rest_flags = FETCH ();
-
- VM_ASSERT ((kw_and_rest_flags & F_REST)
- || ((sp - (fp - 1) - nkw) % 2) == 0,
- vm_error_kwargs_length_not_even (program))
-
- CHECK_OBJECT (idx);
- kw = OBJECT_REF (idx);
-
- /* Switch NKW to be a negative index below SP. */
- for (nkw = -(sp - (fp - 1) - nkw) + 1; nkw < 0; nkw++)
- {
- SCM walk;
-
- if (scm_is_keyword (sp[nkw]))
- {
- for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk))
- {
- if (scm_is_eq (SCM_CAAR (walk), sp[nkw]))
- {
- SCM si = SCM_CDAR (walk);
- LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_long (si),
- sp[nkw + 1]);
- break;
- }
- }
- VM_ASSERT (scm_is_pair (walk)
- || (kw_and_rest_flags & F_ALLOW_OTHER_KEYS),
- vm_error_kwargs_unrecognized_keyword (program, sp[nkw]));
- nkw++;
- }
- else
- VM_ASSERT (kw_and_rest_flags & F_REST,
- vm_error_kwargs_invalid_keyword (program, sp[nkw]));
- }
-
- NEXT;
-}
-
-#undef F_ALLOW_OTHER_KEYS
-#undef F_REST
-
-
-VM_DEFINE_INSTRUCTION (51, push_rest, "push-rest", 2, -1, -1)
-{
- scm_t_ptrdiff n;
- SCM rest = SCM_EOL;
- n = FETCH () << 8;
- n += FETCH ();
- SYNC_BEFORE_GC ();
- while (sp - (fp - 1) > n)
- /* No need to check for underflow. */
- rest = scm_cons (*sp--, rest);
- PUSH (rest);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (52, bind_rest, "bind-rest", 4, -1, -1)
-{
- scm_t_ptrdiff n;
- scm_t_uint32 i;
- SCM rest = SCM_EOL;
- n = FETCH () << 8;
- n += FETCH ();
- i = FETCH () << 8;
- i += FETCH ();
- SYNC_BEFORE_GC ();
- while (sp - (fp - 1) > n)
- /* No need to check for underflow. */
- rest = scm_cons (*sp--, rest);
- LOCAL_SET (i, rest);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (53, reserve_locals, "reserve-locals", 2, -1, -1)
-{
- SCM *old_sp;
- scm_t_int32 n;
- n = FETCH () << 8;
- n += FETCH ();
- old_sp = sp;
- sp = (fp - 1) + n;
-
- if (old_sp < sp)
- {
- CHECK_OVERFLOW ();
- while (old_sp < sp)
- *++old_sp = SCM_UNDEFINED;
- }
- else
- NULLSTACK (old_sp - sp);
-
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (54, new_frame, "new-frame", 0, 0, 3)
-{
- /* NB: if you change this, see frames.c:vm-frame-num-locals */
- /* and frames.h, vm-engine.c, etc of course */
-
- /* We don't initialize the dynamic link here because we don't actually
- know that this frame will point to the current fp: it could be
- placed elsewhere on the stack if captured in a partial
- continuation, and invoked from some other context. */
- PUSH (SCM_PACK (0)); /* dynamic link */
- PUSH (SCM_PACK (0)); /* mvra */
- PUSH (SCM_PACK (0)); /* ra */
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (55, call, "call", 1, -1, 1)
-{
- nargs = FETCH ();
-
- vm_call:
- VM_HANDLE_INTERRUPTS;
-
- {
- SCM *old_fp = fp;
-
- fp = sp - nargs + 1;
-
- ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0);
- ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
- ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
- SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
- SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
- SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0);
- }
-
- PUSH_CONTINUATION_HOOK ();
-
- program = fp[-1];
-
- if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
- goto apply;
-
- CACHE_PROGRAM ();
- ip = SCM_C_OBJCODE_BASE (bp);
-
- APPLY_HOOK ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (56, tail_call, "tail-call", 1, -1, 1)
-{
- nargs = FETCH ();
-
- vm_tail_call:
- VM_HANDLE_INTERRUPTS;
-
- {
- int i;
-#ifdef VM_ENABLE_STACK_NULLING
- SCM *old_sp = sp;
- CHECK_STACK_LEAK ();
-#endif
-
- /* shuffle down the program and the arguments */
- for (i = -1, sp = sp - nargs + 1; i < nargs; i++)
- SCM_FRAME_STACK_ADDRESS (fp)[i] = sp[i];
-
- sp = fp + i - 1;
-
- NULLSTACK (old_sp - sp);
- }
-
- program = fp[-1];
-
- if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
- goto apply;
-
- CACHE_PROGRAM ();
- ip = SCM_C_OBJCODE_BASE (bp);
-
- APPLY_HOOK ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (57, subr_call, "subr-call", 1, -1, -1)
-{
- SCM pointer, ret;
- SCM (*subr)();
-
- nargs = FETCH ();
- POP (pointer);
-
- subr = SCM_POINTER_VALUE (pointer);
-
- VM_HANDLE_INTERRUPTS;
- SYNC_REGISTER ();
-
- switch (nargs)
- {
- case 0:
- ret = subr ();
- break;
- case 1:
- ret = subr (sp[0]);
- break;
- case 2:
- ret = subr (sp[-1], sp[0]);
- break;
- case 3:
- ret = subr (sp[-2], sp[-1], sp[0]);
- break;
- case 4:
- ret = subr (sp[-3], sp[-2], sp[-1], sp[0]);
- break;
- case 5:
- ret = subr (sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
- break;
- case 6:
- ret = subr (sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
- break;
- case 7:
- ret = subr (sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
- break;
- case 8:
- ret = subr (sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
- break;
- case 9:
- ret = subr (sp[-8], sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
- break;
- case 10:
- ret = subr (sp[-9], sp[-8], sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
- break;
- default:
- abort ();
- }
-
- NULLSTACK_FOR_NONLOCAL_EXIT ();
-
- if (SCM_UNLIKELY (SCM_VALUESP (ret)))
- {
- /* multiple values returned to continuation */
- ret = scm_struct_ref (ret, SCM_INUM0);
- nvalues = scm_ilength (ret);
- PUSH_LIST (ret, scm_is_null);
- goto vm_return_values;
- }
- else
- {
- PUSH (ret);
- goto vm_return;
- }
-}
-
-/* Instruction 58 used to be smob-call. */
-
-VM_DEFINE_INSTRUCTION (59, foreign_call, "foreign-call", 1, -1, -1)
-{
- SCM foreign, ret;
- nargs = FETCH ();
- POP (foreign);
-
- VM_HANDLE_INTERRUPTS;
- SYNC_REGISTER ();
-
- ret = scm_i_foreign_call (foreign, sp - nargs + 1);
-
- NULLSTACK_FOR_NONLOCAL_EXIT ();
-
- if (SCM_UNLIKELY (SCM_VALUESP (ret)))
- {
- /* multiple values returned to continuation */
- ret = scm_struct_ref (ret, SCM_INUM0);
- nvalues = scm_ilength (ret);
- PUSH_LIST (ret, scm_is_null);
- goto vm_return_values;
- }
- else
- {
- PUSH (ret);
- goto vm_return;
- }
-}
-
-VM_DEFINE_INSTRUCTION (60, 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),
- sp - (fp - 1), fp);
- scm_i_reinstate_continuation (contregs);
-
- /* no NEXT */
- abort ();
-}
-
-VM_DEFINE_INSTRUCTION (61, partial_cont_call, "partial-cont-call", 0, -1, 0)
-{
- SCM vmcont;
- POP (vmcont);
- SYNC_REGISTER ();
- VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont),
- vm_error_continuation_not_rewindable (vmcont));
- vm_reinstate_partial_continuation (vm, vmcont, sp + 1 - fp, fp,
- &current_thread->dynstack,
- &registers);
-
- CACHE_REGISTER ();
- program = SCM_FRAME_PROGRAM (fp);
- CACHE_PROGRAM ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (62, tail_call_nargs, "tail-call/nargs", 0, 0, 1)
-{
- SCM x;
- POP (x);
- nargs = scm_to_int (x);
- /* FIXME: should truncate values? */
- goto vm_tail_call;
-}
-
-VM_DEFINE_INSTRUCTION (63, call_nargs, "call/nargs", 0, 0, 1)
-{
- SCM x;
- POP (x);
- nargs = scm_to_int (x);
- /* FIXME: should truncate values? */
- goto vm_call;
-}
-
-VM_DEFINE_INSTRUCTION (64, mv_call, "mv-call", 4, -1, 1)
-{
- scm_t_int32 offset;
- scm_t_uint8 *mvra;
- SCM *old_fp = fp;
-
- nargs = FETCH ();
- FETCH_OFFSET (offset);
- mvra = ip + offset;
-
- VM_HANDLE_INTERRUPTS;
-
- fp = sp - nargs + 1;
-
- ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0);
- ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
- ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
- SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
- SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
- SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
-
- PUSH_CONTINUATION_HOOK ();
-
- program = fp[-1];
-
- if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
- goto apply;
-
- CACHE_PROGRAM ();
- ip = SCM_C_OBJCODE_BASE (bp);
-
- APPLY_HOOK ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (65, apply, "apply", 1, -1, 1)
-{
- int len;
- SCM ls;
- POP (ls);
-
- nargs = FETCH ();
- ASSERT (nargs >= 2);
-
- len = scm_ilength (ls);
- VM_ASSERT (len >= 0,
- vm_error_apply_to_non_list (ls));
- PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
-
- nargs += len - 2;
- goto vm_call;
-}
-
-VM_DEFINE_INSTRUCTION (66, tail_apply, "tail-apply", 1, -1, 1)
-{
- int len;
- SCM ls;
- POP (ls);
-
- nargs = FETCH ();
- ASSERT (nargs >= 2);
-
- len = scm_ilength (ls);
- VM_ASSERT (len >= 0,
- vm_error_apply_to_non_list (ls));
- PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
-
- nargs += len - 2;
- goto vm_tail_call;
-}
-
-VM_DEFINE_INSTRUCTION (67, call_cc, "call/cc", 0, 1, 1)
-{
- int first;
- SCM proc, vm_cont, cont;
- scm_t_dynstack *dynstack;
- POP (proc);
- SYNC_ALL ();
- dynstack = scm_dynstack_capture_all (&current_thread->dynstack);
- vm_cont = scm_i_vm_capture_stack (vp->stack_base, fp, sp, ip, NULL,
- dynstack, 0);
- cont = scm_i_make_continuation (&first, vm, vm_cont);
- if (first)
- {
- PUSH (SCM_PACK (0)); /* dynamic link */
- PUSH (SCM_PACK (0)); /* mvra */
- PUSH (SCM_PACK (0)); /* ra */
- PUSH (proc);
- PUSH (cont);
- nargs = 1;
- goto vm_call;
- }
- else
- {
- /* Otherwise, the vm continuation was reinstated, and
- vm_return_to_continuation pushed on one value. We know only one
- value was returned because we are in value context -- the
- previous block jumped to vm_call, not vm_mv_call, after all.
-
- So, pull our regs back down from the vp, and march on to the
- next instruction. */
- CACHE_REGISTER ();
- program = SCM_FRAME_PROGRAM (fp);
- CACHE_PROGRAM ();
- RESTORE_CONTINUATION_HOOK ();
- NEXT;
- }
-}
-
-VM_DEFINE_INSTRUCTION (68, tail_call_cc, "tail-call/cc", 0, 1, 1)
-{
- int first;
- SCM proc, vm_cont, cont;
- scm_t_dynstack *dynstack;
- POP (proc);
- SYNC_ALL ();
- /* In contrast to call/cc, tail-call/cc captures the continuation without the
- stack frame. */
- dynstack = scm_dynstack_capture_all (&current_thread->dynstack);
- vm_cont = scm_i_vm_capture_stack (vp->stack_base,
- SCM_FRAME_DYNAMIC_LINK (fp),
- SCM_FRAME_LOWER_ADDRESS (fp) - 1,
- SCM_FRAME_RETURN_ADDRESS (fp),
- SCM_FRAME_MV_RETURN_ADDRESS (fp),
- dynstack,
- 0);
- cont = scm_i_make_continuation (&first, vm, vm_cont);
- if (first)
- {
- PUSH (proc);
- PUSH (cont);
- nargs = 1;
- goto vm_tail_call;
- }
- else
- {
- /* Otherwise, cache regs and NEXT, as above. Invoking the continuation
- does a return from the frame, either to the RA or
- MVRA. */
- CACHE_REGISTER ();
- program = SCM_FRAME_PROGRAM (fp);
- CACHE_PROGRAM ();
- /* Unfortunately we don't know whether we are at the RA, and thus
- have one value without an nvalues marker, or we are at the
- MVRA and thus have multiple values and the nvalues
- marker. Instead of adding heuristics here, we will let hook
- client code do that. */
- RESTORE_CONTINUATION_HOOK ();
- NEXT;
- }
-}
-
-VM_DEFINE_INSTRUCTION (69, return, "return", 0, 1, 1)
-{
- vm_return:
- POP_CONTINUATION_HOOK (sp, 1);
-
- VM_HANDLE_INTERRUPTS;
-
- {
- SCM ret;
-
- POP (ret);
-
-#ifdef VM_ENABLE_STACK_NULLING
- SCM *old_sp = sp;
-#endif
-
- /* Restore registers */
- sp = SCM_FRAME_LOWER_ADDRESS (fp);
- ip = SCM_FRAME_RETURN_ADDRESS (fp);
- fp = SCM_FRAME_DYNAMIC_LINK (fp);
-
-#ifdef VM_ENABLE_STACK_NULLING
- NULLSTACK (old_sp - sp);
-#endif
-
- /* Set return value (sp is already pushed) */
- *sp = ret;
- }
-
- /* Restore the last program */
- program = SCM_FRAME_PROGRAM (fp);
- CACHE_PROGRAM ();
- CHECK_IP ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (70, return_values, "return/values", 1, -1, -1)
-{
- /* nvalues declared at top level, because for some reason gcc seems to think
- that perhaps it might be used without declaration. Fooey to that, I say. */
- nvalues = FETCH ();
- vm_return_values:
- POP_CONTINUATION_HOOK (sp + 1 - nvalues, nvalues);
-
- VM_HANDLE_INTERRUPTS;
-
- if (nvalues != 1 && SCM_FRAME_MV_RETURN_ADDRESS (fp))
- {
- /* A multiply-valued continuation */
- SCM *vals = sp - nvalues;
- int i;
- /* Restore registers */
- sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
- ip = SCM_FRAME_MV_RETURN_ADDRESS (fp);
- fp = SCM_FRAME_DYNAMIC_LINK (fp);
-
- /* Push return values, and the number of values */
- for (i = 0; i < nvalues; i++)
- *++sp = vals[i+1];
- *++sp = SCM_I_MAKINUM (nvalues);
-
- /* Finally null the end of the stack */
- NULLSTACK (vals + nvalues - sp);
- }
- else if (nvalues >= 1)
- {
- /* Multiple values for a single-valued continuation -- here's where I
- break with guile tradition and try and do something sensible. (Also,
- this block handles the single-valued return to an mv
- continuation.) */
- SCM *vals = sp - nvalues;
- /* Restore registers */
- sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
- ip = SCM_FRAME_RETURN_ADDRESS (fp);
- fp = SCM_FRAME_DYNAMIC_LINK (fp);
-
- /* Push first value */
- *++sp = vals[1];
-
- /* Finally null the end of the stack */
- NULLSTACK (vals + nvalues - sp);
- }
- else
- {
- SYNC_ALL ();
- vm_error_no_values ();
- }
-
- /* Restore the last program */
- program = SCM_FRAME_PROGRAM (fp);
- CACHE_PROGRAM ();
- CHECK_IP ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (71, return_values_star, "return/values*", 1, -1, -1)
-{
- SCM l;
-
- nvalues = FETCH ();
- ASSERT (nvalues >= 1);
-
- nvalues--;
- POP (l);
- while (scm_is_pair (l))
- {
- PUSH (SCM_CAR (l));
- l = SCM_CDR (l);
- nvalues++;
- }
- VM_ASSERT (SCM_NULL_OR_NIL_P (l), vm_error_improper_list (l));
-
- goto vm_return_values;
-}
-
-VM_DEFINE_INSTRUCTION (72, return_nvalues, "return/nvalues", 0, 1, -1)
-{
- SCM n;
- POP (n);
- nvalues = scm_to_int (n);
- ASSERT (nvalues >= 0);
- goto vm_return_values;
-}
-
-VM_DEFINE_INSTRUCTION (73, truncate_values, "truncate-values", 2, -1, -1)
-{
- SCM x;
- int nbinds, rest;
- POP (x);
- nvalues = scm_to_int (x);
- nbinds = FETCH ();
- rest = FETCH ();
-
- if (rest)
- nbinds--;
-
- VM_ASSERT (nvalues >= nbinds, vm_error_not_enough_values ());
-
- if (rest)
- POP_LIST (nvalues - nbinds);
- else
- DROPN (nvalues - nbinds);
-
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (74, box, "box", 1, 1, 0)
-{
- SCM val;
- POP (val);
- SYNC_BEFORE_GC ();
- LOCAL_SET (FETCH (), scm_cell (scm_tc7_variable, SCM_UNPACK (val)));
- NEXT;
-}
-
-/* for letrec:
- (let ((a *undef*) (b *undef*) ...)
- (set! a (lambda () (b ...)))
- ...)
- */
-VM_DEFINE_INSTRUCTION (75, empty_box, "empty-box", 1, 0, 0)
-{
- SYNC_BEFORE_GC ();
- LOCAL_SET (FETCH (),
- scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (76, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
-{
- SCM v = LOCAL_REF (FETCH ());
- ASSERT_BOUND_VARIABLE (v);
- PUSH (VARIABLE_REF (v));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (77, local_boxed_set, "local-boxed-set", 1, 1, 0)
-{
- SCM v, val;
- v = LOCAL_REF (FETCH ());
- POP (val);
- ASSERT_VARIABLE (v);
- VARIABLE_SET (v, val);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (78, free_ref, "free-ref", 1, 0, 1)
-{
- scm_t_uint8 idx = FETCH ();
-
- CHECK_FREE_VARIABLE (idx);
- PUSH (FREE_VARIABLE_REF (idx));
- NEXT;
-}
-
-/* no free-set -- if a var is assigned, it should be in a box */
-
-VM_DEFINE_INSTRUCTION (79, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
-{
- SCM v;
- scm_t_uint8 idx = FETCH ();
- CHECK_FREE_VARIABLE (idx);
- v = FREE_VARIABLE_REF (idx);
- ASSERT_BOUND_VARIABLE (v);
- PUSH (VARIABLE_REF (v));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (80, free_boxed_set, "free-boxed-set", 1, 1, 0)
-{
- SCM v, val;
- scm_t_uint8 idx = FETCH ();
- POP (val);
- CHECK_FREE_VARIABLE (idx);
- v = FREE_VARIABLE_REF (idx);
- ASSERT_BOUND_VARIABLE (v);
- VARIABLE_SET (v, val);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (81, make_closure, "make-closure", 2, -1, 1)
-{
- size_t n, len;
- SCM closure;
-
- len = FETCH ();
- len <<= 8;
- len += FETCH ();
- SYNC_BEFORE_GC ();
- closure = scm_words (scm_tc7_program | (len<<16), len + 3);
- SCM_SET_CELL_OBJECT_1 (closure, SCM_PROGRAM_OBJCODE (sp[-len]));
- SCM_SET_CELL_OBJECT_2 (closure, SCM_PROGRAM_OBJTABLE (sp[-len]));
- sp[-len] = closure;
- for (n = 0; n < len; n++)
- SCM_PROGRAM_FREE_VARIABLE_SET (closure, n, sp[-len + 1 + n]);
- DROPN (len);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (82, make_variable, "make-variable", 0, 0, 1)
-{
- SYNC_BEFORE_GC ();
- /* fixme underflow */
- PUSH (scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (83, fix_closure, "fix-closure", 2, -1, 0)
-{
- SCM x;
- unsigned int i = FETCH ();
- size_t n, len;
- i <<= 8;
- i += FETCH ();
- /* FIXME CHECK_LOCAL (i) */
- x = LOCAL_REF (i);
- /* FIXME ASSERT_PROGRAM (x); */
- len = SCM_PROGRAM_NUM_FREE_VARIABLES (x);
- for (n = 0; n < len; n++)
- SCM_PROGRAM_FREE_VARIABLE_SET (x, n, sp[-len + 1 + n]);
- DROPN (len);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (84, define, "define", 0, 0, 2)
-{
- SCM sym, val;
- POP2 (sym, val);
- SYNC_REGISTER ();
- scm_define (sym, val);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (85, make_keyword, "make-keyword", 0, 1, 1)
-{
- CHECK_UNDERFLOW ();
- SYNC_REGISTER ();
- *sp = scm_symbol_to_keyword (*sp);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (86, make_symbol, "make-symbol", 0, 1, 1)
-{
- CHECK_UNDERFLOW ();
- SYNC_REGISTER ();
- *sp = scm_string_to_symbol (*sp);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (87, prompt, "prompt", 4, 2, 0)
-{
- scm_t_int32 offset;
- scm_t_uint8 escape_only_p;
- SCM k;
- scm_t_dynstack_prompt_flags flags;
-
- escape_only_p = FETCH ();
- FETCH_OFFSET (offset);
- POP (k);
-
- SYNC_REGISTER ();
- /* Push the prompt onto the dynamic stack. */
- flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0;
- flags |= SCM_F_DYNSTACK_PROMPT_PUSH_NARGS;
- scm_dynstack_push_prompt (&current_thread->dynstack, flags, k,
- fp, sp, ip + offset, &registers);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (88, wind, "wind", 0, 2, 0)
-{
- SCM wind, unwind;
- POP2 (unwind, wind);
- SYNC_REGISTER ();
- /* Push wind and unwind procedures onto the dynamic stack. Note that neither
- are actually called; the compiler should emit calls to wind and unwind for
- the normal dynamic-wind control flow. Also note that the compiler
- should have inserted checks that they wind and unwind procs are
- thunks, if it could not prove that to be the case. */
- scm_dynstack_push_dynwind (&current_thread->dynstack, wind, unwind);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (89, abort, "abort", 1, -1, -1)
-{
- ptrdiff_t n = FETCH ();
- SCM tag, *stack_args, tail;
- PRE_CHECK_UNDERFLOW (n + 2);
- SYNC_REGISTER ();
- tail = sp[0];
- stack_args = sp - n;
- tag = sp[-(n + 1)];
- /* Partial continuations are now RTL programs, and therefore not
- resumable. Pass NULL as registers to indicate that fact. */
- vm_abort (vm, tag, n, stack_args, tail, sp - (n + 2), NULL);
- /* vm_abort should not return */
- abort ();
-}
-
-VM_DEFINE_INSTRUCTION (90, unwind, "unwind", 0, 0, 0)
-{
- /* A normal exit from the dynamic extent of an expression. Pop the top entry
- off of the dynamic stack. */
- scm_dynstack_pop (&current_thread->dynstack);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (91, push_fluid, "push-fluid", 0, 2, 0)
-{
- SCM fluid, val;
- POP2 (val, fluid);
- SYNC_REGISTER ();
- scm_dynstack_push_fluid (&current_thread->dynstack, fluid, val,
- current_thread->dynamic_state);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (92, pop_fluid, "pop-fluid", 0, 0, 0)
-{
- /* This function must not allocate. */
- scm_dynstack_unwind_fluid (&current_thread->dynstack,
- current_thread->dynamic_state);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (93, fluid_ref, "fluid-ref", 0, 1, 1)
-{
- size_t num;
- SCM fluids;
-
- CHECK_UNDERFLOW ();
- fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state);
- if (SCM_UNLIKELY (!SCM_FLUID_P (*sp))
- || ((num = SCM_I_FLUID_NUM (*sp)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
- {
- /* Punt dynstate expansion and error handling to the C proc. */
- SYNC_REGISTER ();
- *sp = scm_fluid_ref (*sp);
- }
- else
- {
- SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num);
- if (scm_is_eq (val, SCM_UNDEFINED))
- val = SCM_I_FLUID_DEFAULT (*sp);
- VM_ASSERT (!scm_is_eq (val, SCM_UNDEFINED),
- vm_error_unbound_fluid (program, *sp));
- *sp = val;
- }
-
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (94, fluid_set, "fluid-set", 0, 2, 0)
-{
- size_t num;
- SCM val, fluid, fluids;
-
- POP2 (val, fluid);
- fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state);
- if (SCM_UNLIKELY (!SCM_FLUID_P (fluid))
- || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
- {
- /* Punt dynstate expansion and error handling to the C proc. */
- SYNC_REGISTER ();
- scm_fluid_set_x (fluid, val);
- }
- else
- SCM_SIMPLE_VECTOR_SET (fluids, num, val);
-
- 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 ();
-
- VM_ASSERT (sp - (fp - 1) == (n & 0x7),
- vm_error_wrong_num_args (program));
-
- old_sp = sp;
- sp += (n >> 3);
- CHECK_OVERFLOW ();
- while (old_sp < sp)
- *++old_sp = SCM_UNDEFINED;
-
- NEXT;
-}
-
-/* Like bind-optionals/shuffle, but if there are too many positional
- arguments, jumps to the next case-lambda clause. */
-VM_DEFINE_INSTRUCTION (96, bind_optionals_shuffle_or_br, "bind-optionals/shuffle-or-br", 9, -1, -1)
-{
- SCM *walk;
- scm_t_ptrdiff nreq, nreq_and_opt, ntotal;
- scm_t_int32 offset;
- nreq = FETCH () << 8;
- nreq += FETCH ();
- nreq_and_opt = FETCH () << 8;
- nreq_and_opt += FETCH ();
- ntotal = FETCH () << 8;
- ntotal += FETCH ();
- FETCH_OFFSET (offset);
-
- /* look in optionals for first keyword or last positional */
- /* starting after the last required positional arg */
- walk = fp + nreq;
- while (/* while we have args */
- walk <= sp
- /* and we still have positionals to fill */
- && walk - fp < nreq_and_opt
- /* and we haven't reached a keyword yet */
- && !scm_is_keyword (*walk))
- /* bind this optional arg (by leaving it in place) */
- walk++;
- if (/* If we have filled all the positionals */
- walk - fp == nreq_and_opt
- /* and there are still more arguments */
- && walk <= sp
- /* and the next argument is not a keyword, */
- && !scm_is_keyword (*walk))
- {
- /* Jump to the next case-lambda* clause. */
- ip += offset;
- }
- else
- {
- /* Otherwise, finish as in bind-optionals/shuffle: shuffle up,
- from walk to ntotal */
- scm_t_ptrdiff nshuf = sp - walk + 1, i;
- sp = (fp - 1) + ntotal + nshuf;
- CHECK_OVERFLOW ();
- for (i = 0; i < nshuf; i++)
- sp[-i] = walk[nshuf-i-1];
-
- /* and fill optionals & keyword args with SCM_UNDEFINED */
- while (walk <= (fp - 1) + ntotal)
- *walk++ = SCM_UNDEFINED;
- }
-
- NEXT;
-}
-
-
-/*
-(defun renumber-ops ()
- "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
- (interactive "")
- (save-excursion
- (let ((counter -1)) (goto-char (point-min))
- (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
- (replace-match
- (number-to-string (setq counter (1+ counter)))
- t t nil 1)))))
-(renumber-ops)
-*/
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/