Print the faulty object upon invalid-keyword errors.

[bpt/guile.git] / libguile / vm-i-system.c

/* 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 */

\f
/*
 * 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;
}

\f
/*
 * 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;
}

\f
/*
 * 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;
}

\f
/*
 * 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));
}

\f
/*
 * Subprogram call
 */

VM_DEFINE_INSTRUCTION (41, 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 (42, 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 (43, 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 (44, 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 (45, 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 (46, 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 (47, 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 (48, 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 (49, push_rest, "push-rest", 2, -1, -1)
{
  scm_t_ptrdiff n;
  SCM rest = SCM_EOL;
  n = FETCH () << 8;
  n += FETCH ();
  while (sp - (fp - 1) > n)
    /* No need to check for underflow. */
    CONS (rest, *sp--, rest);
  PUSH (rest);
  NEXT;
}

VM_DEFINE_INSTRUCTION (50, 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 ();
  while (sp - (fp - 1) > n)
    /* No need to check for underflow. */
    CONS (rest, *sp--, rest);
  LOCAL_SET (i, rest);
  NEXT;
}

VM_DEFINE_INSTRUCTION (51, 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 (52, 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 (53, 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 (54, 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 (55, 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;
    }
}

VM_DEFINE_INSTRUCTION (56, smob_call, "smob-call", 1, -1, -1)
{
  SCM smob, ret;
  SCM (*subr)();
  nargs = FETCH ();
  POP (smob);

  subr = SCM_SMOB_DESCRIPTOR (smob).apply;

  VM_HANDLE_INTERRUPTS;
  SYNC_REGISTER ();

  switch (nargs)
    {
    case 0:
      ret = subr (smob);
      break;
    case 1:
      ret = subr (smob, sp[0]);
      break;
    case 2:
      ret = subr (smob, sp[-1], sp[0]);
      break;
    case 3:
      ret = subr (smob, 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;
    }
}

VM_DEFINE_INSTRUCTION (57, 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 (58, 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 (59, partial_cont_call, "partial-cont-call", 0, -1, 0)
{
  SCM vmcont, intwinds, prevwinds;
  POP2 (intwinds, vmcont);
  SYNC_REGISTER ();
  VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont),
             vm_error_continuation_not_rewindable (vmcont));
  prevwinds = scm_i_dynwinds ();
  vm_reinstate_partial_continuation (vm, vmcont, intwinds, sp + 1 - fp, fp,
                                     vm_cookie);

  /* Rewind prompt jmpbuffers, if any. */
  {
    SCM winds = scm_i_dynwinds ();
    for (; !scm_is_eq (winds, prevwinds); winds = scm_cdr (winds))
      if (SCM_PROMPT_P (scm_car (winds)) && SCM_PROMPT_SETJMP (scm_car (winds)))
        break;
  }
    
  CACHE_REGISTER ();
  program = SCM_FRAME_PROGRAM (fp);
  CACHE_PROGRAM ();
  NEXT;
}

VM_DEFINE_INSTRUCTION (60, 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 (61, 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 (62, 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 (63, 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 (64, 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 (65, call_cc, "call/cc", 0, 1, 1)
{
  int first;
  SCM proc, vm_cont, cont;
  POP (proc);
  SYNC_ALL ();
  vm_cont = scm_i_vm_capture_stack (vp->stack_base, fp, sp, ip, NULL, 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 (66, tail_call_cc, "tail-call/cc", 0, 1, 1)
{
  int first;
  SCM proc, vm_cont, cont;
  POP (proc);
  SYNC_ALL ();
  /* In contrast to call/cc, tail-call/cc captures the continuation without the
     stack frame. */
  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),
                                    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 (67, return, "return", 0, 1, 1)
{
 vm_return:
  POP_CONTINUATION_HOOK (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 (68, 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 (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 (69, 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 (70, 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 (71, 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 (72, 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 (73, 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 (74, 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 (75, 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 (76, 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 (77, 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 (78, 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 (79, 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 (80, 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 (81, 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 (82, define, "define", 0, 0, 2)
{
  SCM sym, val;
  POP2 (sym, val);
  SYNC_REGISTER ();
  scm_define (sym, val);
  NEXT;
}

VM_DEFINE_INSTRUCTION (83, make_keyword, "make-keyword", 0, 1, 1)
{
  CHECK_UNDERFLOW ();
  SYNC_REGISTER ();
  *sp = scm_symbol_to_keyword (*sp);
  NEXT;
}

VM_DEFINE_INSTRUCTION (84, make_symbol, "make-symbol", 0, 1, 1)
{
  CHECK_UNDERFLOW ();
  SYNC_REGISTER ();
  *sp = scm_string_to_symbol (*sp);
  NEXT;
}

VM_DEFINE_INSTRUCTION (85, prompt, "prompt", 4, 2, 0)
{
  scm_t_int32 offset;
  scm_t_uint8 escape_only_p;
  SCM k, prompt;

  escape_only_p = FETCH ();
  FETCH_OFFSET (offset);
  POP (k);

  SYNC_REGISTER ();
  /* Push the prompt onto the dynamic stack. */
  prompt = scm_c_make_prompt (k, fp, sp, ip + offset, escape_only_p, vm_cookie,
                              scm_i_dynwinds ());
  scm_i_set_dynwinds (scm_cons (prompt, SCM_PROMPT_DYNWINDS (prompt)));
  if (SCM_PROMPT_SETJMP (prompt))
    {
      /* The prompt exited nonlocally. Cache the regs back from the vp, and go
         to the handler.

         Note, at this point, we must assume that any variable local to
         vm_engine that can be assigned *has* been assigned. So we need to pull
         all our state back from the ip/fp/sp.
      */
      CACHE_REGISTER ();
      program = SCM_FRAME_PROGRAM (fp);
      CACHE_PROGRAM ();
      /* The stack contains the values returned to this prompt, along
         with a number-of-values marker -- like an MV return. */
      ABORT_CONTINUATION_HOOK ();
      NEXT;
    }
      
  /* Otherwise setjmp returned for the first time, so we go to execute the
     prompt's body. */
  NEXT;
}

VM_DEFINE_INSTRUCTION (86, 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. */
  VM_ASSERT (scm_to_bool (scm_thunk_p (wind)),
	     vm_error_not_a_thunk ("dynamic-wind", wind));
  VM_ASSERT (scm_to_bool (scm_thunk_p (unwind)),
	     vm_error_not_a_thunk ("dynamic-wind", unwind));
  scm_i_set_dynwinds (scm_cons (scm_cons (wind, unwind), scm_i_dynwinds ()));
  NEXT;
}

VM_DEFINE_INSTRUCTION (87, abort, "abort", 1, -1, -1)
{
  unsigned n = FETCH ();
  SYNC_REGISTER ();
  PRE_CHECK_UNDERFLOW (n + 2);
  vm_abort (vm, n, vm_cookie);
  /* vm_abort should not return */
  abort ();
}

VM_DEFINE_INSTRUCTION (88, 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_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
  NEXT;
}

VM_DEFINE_INSTRUCTION (89, wind_fluids, "wind-fluids", 1, -1, 0)
{
  unsigned n = FETCH ();
  SCM wf;
  
  SYNC_REGISTER ();
  sp -= 2 * n;
  CHECK_UNDERFLOW ();
  wf = scm_i_make_with_fluids (n, sp + 1, sp + 1 + n);
  NULLSTACK (2 * n);

  scm_i_swap_with_fluids (wf, current_thread->dynamic_state);
  scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
  NEXT;
}

VM_DEFINE_INSTRUCTION (90, unwind_fluids, "unwind-fluids", 0, 0, 0)
{
  SCM wf;
  wf = scm_car (scm_i_dynwinds ());
  scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
  scm_i_swap_with_fluids (wf, current_thread->dynamic_state);
  NEXT;
}

VM_DEFINE_INSTRUCTION (91, 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 (92, 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 (93, 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 (94, 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:
*/