code:
/* Copyright (C) 2001, 2009, 2010 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.c multiple times */

#if (VM_ENGINE == SCM_VM_REGULAR_ENGINE)
#define VM_USE_HOOKS		0	/* Various hooks */
#define VM_CHECK_OBJECT         1       /* Check object table */
#define VM_CHECK_FREE_VARIABLES 1       /* Check free variable access */
#elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE)
#define VM_USE_HOOKS		1
#define VM_CHECK_OBJECT         1
#define VM_CHECK_FREE_VARIABLES 1
#else
#error unknown debug engine VM_ENGINE
#endif

#include "vm-engine.h"

static SCM
VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
{
  /* VM registers */
  register scm_t_uint8 *ip IP_REG;	/* instruction pointer */
  register SCM *sp SP_REG;		/* stack pointer */
  register SCM *fp FP_REG;		/* frame pointer */
  struct scm_vm *vp = SCM_VM_DATA (vm);

  /* Cache variables */
  struct scm_objcode *bp = NULL;	/* program base pointer */
  SCM *objects = NULL;			/* constant objects */
  size_t object_count = 0;              /* length of OBJECTS */
  SCM *stack_limit = vp->stack_limit;	/* stack limit address */

  SCM dynstate = SCM_I_CURRENT_THREAD->dynamic_state;
  scm_t_int64 vm_cookie = vp->cookie++;

  /* Internal variables */
  int nvalues = 0;
  const char *func_name = NULL;         /* used for error reporting */
  SCM finish_args;                      /* used both for returns: both in error
                                           and normal situations */
#ifdef HAVE_LABELS_AS_VALUES
  static void **jump_table = NULL;
#endif

#ifdef HAVE_LABELS_AS_VALUES
  if (SCM_UNLIKELY (!jump_table))
    {
      int i;
      jump_table = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof(void*));
      for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
        jump_table[i] = &&vm_error_bad_instruction;
#define VM_INSTRUCTION_TO_LABEL 1
#include <libguile/vm-expand.h>
#include <libguile/vm-i-system.i>
#include <libguile/vm-i-scheme.i>
#include <libguile/vm-i-loader.i>
#undef VM_INSTRUCTION_TO_LABEL
    }
#endif

  /* Initialization */
  {
    SCM prog = program;

    /* Boot program */
    program = vm_make_boot_program (nargs);

    /* Initial frame */
    CACHE_REGISTER ();
    PUSH ((SCM)fp); /* dynamic link */
    PUSH (0); /* mvra */
    PUSH ((SCM)ip); /* ra */
    CACHE_PROGRAM ();
    PUSH (program);
    fp = sp + 1;
    ip = SCM_C_OBJCODE_BASE (bp);
    /* MV-call frame, function & arguments */
    PUSH ((SCM)fp); /* dynamic link */
    PUSH (0); /* mvra */
    PUSH (0); /* ra */
    PUSH (prog);
    if (SCM_UNLIKELY (sp + nargs >= stack_limit))
      goto vm_error_too_many_args;
    while (nargs--)
      PUSH (*argv++);
  }

  /* Let's go! */
  BOOT_HOOK ();
  NEXT;

#ifndef HAVE_LABELS_AS_VALUES
 vm_start:
  switch ((*ip++) & SCM_VM_INSTRUCTION_MASK) {
#endif

#include "vm-expand.h"
#include "vm-i-system.c"
#include "vm-i-scheme.c"
#include "vm-i-loader.c"

#ifndef HAVE_LABELS_AS_VALUES
  default:
    goto vm_error_bad_instruction;
  }
#endif

 vm_done:
  SYNC_ALL ();
  return finish_args;

  /* Errors */
  {
    SCM err_msg;

    /* FIXME: need to sync regs before allocating anything, in each case. */

  vm_error_bad_instruction:
    err_msg  = scm_from_locale_string ("VM: Bad instruction: ~s");
    finish_args = scm_list_1 (scm_from_uchar (ip[-1]));
    goto vm_error;

  vm_error_unbound:
    /* At this point FINISH_ARGS should be a one-element list containing
       the name of the unbound variable.  */
    err_msg  = scm_from_locale_string ("VM: Unbound variable: ~s");
    goto vm_error;

  vm_error_unbound_fluid:
    err_msg = scm_from_locale_string ("VM: Unbound fluid: ~s");
    goto vm_error;

  vm_error_apply_to_non_list:
    scm_error (scm_arg_type_key, "apply", "Apply to non-list: ~S",
               finish_args, finish_args);
    goto vm_error;

  vm_error_kwargs_length_not_even:
    SYNC_ALL ();
    err_msg = scm_from_locale_string ("Odd length of keyword argument list");
    scm_error_scm (sym_keyword_argument_error, program, err_msg,
                   SCM_EOL, SCM_BOOL_F);

  vm_error_kwargs_invalid_keyword:
    /* FIXME say which one it was */
    SYNC_ALL ();
    err_msg = scm_from_locale_string ("Invalid keyword");
    scm_error_scm (sym_keyword_argument_error, program, err_msg,
                   SCM_EOL, SCM_BOOL_F);

  vm_error_kwargs_unrecognized_keyword:
    /* FIXME say which one it was */
    SYNC_ALL ();
    err_msg = scm_from_locale_string ("Unrecognized keyword");
    scm_error_scm (sym_keyword_argument_error, program, err_msg,
                   SCM_EOL, SCM_BOOL_F);

  vm_error_too_many_args:
    err_msg  = scm_from_locale_string ("VM: Too many arguments");
    finish_args = scm_list_1 (scm_from_int (nargs));
    goto vm_error;

  vm_error_wrong_num_args:
    /* nargs and program are valid */
    SYNC_ALL ();
    scm_wrong_num_args (program);
    /* shouldn't get here */
    goto vm_error;

  vm_error_wrong_type_apply:
    SYNC_ALL ();
    scm_error (scm_arg_type_key, NULL, "Wrong type to apply: ~S",
               scm_list_1 (program), scm_list_1 (program));
    goto vm_error;

  vm_error_stack_overflow:
    err_msg  = scm_from_locale_string ("VM: Stack overflow");
    finish_args = SCM_EOL;
    if (stack_limit < vp->stack_base + vp->stack_size)
      /* There are VM_STACK_RESERVE_SIZE bytes left.  Make them available so
	 that `throw' below can run on this VM.  */
      vp->stack_limit = vp->stack_base + vp->stack_size;
    goto vm_error;

  vm_error_stack_underflow:
    err_msg  = scm_from_locale_string ("VM: Stack underflow");
    finish_args = SCM_EOL;
    goto vm_error;

  vm_error_improper_list:
    err_msg  = scm_from_locale_string ("Expected a proper list, but got object with tail ~s");
    goto vm_error;

  vm_error_not_a_pair:
    SYNC_ALL ();
    scm_wrong_type_arg_msg (func_name, 1, finish_args, "pair");
    /* shouldn't get here */
    goto vm_error;

  vm_error_not_a_bytevector:
    SYNC_ALL ();
    scm_wrong_type_arg_msg (func_name, 1, finish_args, "bytevector");
    /* shouldn't get here */
    goto vm_error;

  vm_error_not_a_struct:
    SYNC_ALL ();
    scm_wrong_type_arg_msg (func_name, 1, finish_args, "struct");
    /* shouldn't get here */
    goto vm_error;

  vm_error_not_a_thunk:
    SYNC_ALL ();
    scm_wrong_type_arg_msg ("dynamic-wind", 1, finish_args, "thunk");
    /* shouldn't get here */
    goto vm_error;

  vm_error_no_values:
    err_msg  = scm_from_locale_string ("Zero values returned to single-valued continuation");
    finish_args = SCM_EOL;
    goto vm_error;

  vm_error_not_enough_values:
    err_msg  = scm_from_locale_string ("Too few values returned to continuation");
    finish_args = SCM_EOL;
    goto vm_error;

  vm_error_continuation_not_rewindable:
    err_msg  = scm_from_locale_string ("Unrewindable partial continuation");
    finish_args = scm_cons (finish_args, SCM_EOL);
    goto vm_error;

  vm_error_bad_wide_string_length:
    err_msg  = scm_from_locale_string ("VM: Bad wide string length: ~S");
    goto vm_error;

#ifdef VM_CHECK_IP
  vm_error_invalid_address:
    err_msg  = scm_from_locale_string ("VM: Invalid program address");
    finish_args = SCM_EOL;
    goto vm_error;
#endif

#if VM_CHECK_OBJECT
  vm_error_object:
    err_msg = scm_from_locale_string ("VM: Invalid object table access");
    finish_args = SCM_EOL;
    goto vm_error;
#endif

#if VM_CHECK_FREE_VARIABLES
  vm_error_free_variable:
    err_msg = scm_from_locale_string ("VM: Invalid free variable access");
    finish_args = SCM_EOL;
    goto vm_error;
#endif

  vm_error:
    SYNC_ALL ();

    scm_ithrow (sym_vm_error, scm_list_3 (sym_vm_run, err_msg, finish_args),
		1);
  }

  abort (); /* never reached */
}

#undef VM_USE_HOOKS
#undef VM_CHECK_OBJECT
#undef VM_CHECK_FREE_VARIABLE

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* Copyright (C) 2001, 2009, 2010 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 */

/*
 * Registers
 */

/* Register optimization. [ stolen from librep/src/lispmach.h,v 1.3 ]

   Some compilers underestimate the use of the local variables representing
   the abstract machine registers, and don't put them in hardware registers,
   which slows down the interpreter considerably.
   For GCC, I have hand-assigned hardware registers for several architectures.
*/

#ifdef __GNUC__
#ifdef __mips__
#define IP_REG asm("$16")
#define SP_REG asm("$17")
#define FP_REG asm("$18")
#endif
#ifdef __sparc__
#define IP_REG asm("%l0")
#define SP_REG asm("%l1")
#define FP_REG asm("%l2")
#endif
#ifdef __alpha__
#ifdef __CRAY__
#define IP_REG asm("r9")
#define SP_REG asm("r10")
#define FP_REG asm("r11")
#else
#define IP_REG asm("$9")
#define SP_REG asm("$10")
#define FP_REG asm("$11")
#endif
#endif
#ifdef __i386__
/* too few registers! because of register allocation errors with various gcs,
   just punt on explicit assignments on i386, hoping that the "register"
   declaration will be sufficient. */
#endif
#if defined(PPC) || defined(_POWER) || defined(_IBMR2)
#define IP_REG asm("26")
#define SP_REG asm("27")
#define FP_REG asm("28")
#endif
#ifdef __hppa__
#define IP_REG asm("%r18")
#define SP_REG asm("%r17")
#define FP_REG asm("%r16")
#endif
#ifdef __mc68000__
#define IP_REG asm("a5")
#define SP_REG asm("a4")
#define FP_REG
#endif
#ifdef __arm__
#define IP_REG asm("r9")
#define SP_REG asm("r8")
#define FP_REG asm("r7")
#endif
#endif

#ifndef IP_REG
#define IP_REG
#endif
#ifndef SP_REG
#define SP_REG
#endif
#ifndef FP_REG
#define FP_REG
#endif

/*
 * Cache/Sync
 */

#ifdef VM_ENABLE_ASSERTIONS
# define ASSERT(condition) if (SCM_UNLIKELY (!(condition))) abort()
#else
# define ASSERT(condition)
#endif

/* Cache the VM's instruction, stack, and frame pointer in local variables.  */
#define CACHE_REGISTER()			\
{						\
  ip = vp->ip;					\
  sp = vp->sp;					\
  fp = vp->fp;					\
}

/* Update the registers in VP, a pointer to the current VM.  This must be done
   at least before any GC invocation so that `vp->sp' is up-to-date and the
   whole stack gets marked.  */
#define SYNC_REGISTER()				\
{						\
  vp->ip = ip;					\
  vp->sp = sp;					\
  vp->fp = fp;					\
}

/* FIXME */
#define ASSERT_VARIABLE(x)                                              \
  do { if (!SCM_VARIABLEP (x)) { SYNC_REGISTER (); abort(); }           \
  } while (0)
#define ASSERT_BOUND_VARIABLE(x)                                        \
  do { ASSERT_VARIABLE (x);                                             \
    if (SCM_VARIABLE_REF (x) == SCM_UNDEFINED)                          \
      { SYNC_REGISTER (); abort(); }                                    \
  } while (0)

#ifdef VM_ENABLE_PARANOID_ASSERTIONS
#define CHECK_IP() \
  do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0)
#define ASSERT_ALIGNED_PROCEDURE() \
  do { if ((scm_t_bits)bp % 8) abort (); } while (0)
#define ASSERT_BOUND(x) \
  do { if ((x) == SCM_UNDEFINED) { SYNC_REGISTER (); abort(); } \
  } while (0)
#else
#define CHECK_IP()
#define ASSERT_ALIGNED_PROCEDURE()
#define ASSERT_BOUND(x)
#endif

/* Cache the object table and free variables.  */
#define CACHE_PROGRAM()							\
{									\
  if (bp != SCM_PROGRAM_DATA (program)) {                               \
    bp = SCM_PROGRAM_DATA (program);					\
    ASSERT_ALIGNED_PROCEDURE ();                                        \
    if (SCM_I_IS_VECTOR (SCM_PROGRAM_OBJTABLE (program))) {             \
      objects = SCM_I_VECTOR_WELTS (SCM_PROGRAM_OBJTABLE (program));    \
      object_count = SCM_I_VECTOR_LENGTH (SCM_PROGRAM_OBJTABLE (program)); \
    } else {                                                            \
      objects = NULL;                                                   \
      object_count = 0;                                                 \
    }                                                                   \
  }                                                                     \
}

#define SYNC_BEFORE_GC()			\
{						\
  SYNC_REGISTER ();				\
}

#define SYNC_ALL()				\
{						\
  SYNC_REGISTER ();				\
}

/*
 * Error check
 */

/* Accesses to a program's object table.  */
#if VM_CHECK_OBJECT
#define CHECK_OBJECT(_num) \
  do { if (SCM_UNLIKELY ((_num) >= object_count)) goto vm_error_object; } while (0)
#else
#define CHECK_OBJECT(_num)
#endif

#if VM_CHECK_FREE_VARIABLES
#define CHECK_FREE_VARIABLE(_num)                                       \
  do {                                                                  \
    if (SCM_UNLIKELY ((_num) >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))) \
      goto vm_error_free_variable;                                      \
  } while (0)
#else
#define CHECK_FREE_VARIABLE(_num)
#endif

/*
 * Hooks
 */

#undef RUN_HOOK
#undef RUN_HOOK1
#if VM_USE_HOOKS
#define RUN_HOOK(h)                                     \
  {                                                     \
    if (SCM_UNLIKELY (vp->trace_level > 0))             \
      {                                                 \
        SYNC_REGISTER ();				\
        vm_dispatch_hook (vm, h);                       \
      }                                                 \
  }
#define RUN_HOOK1(h, x)                                 \
  {                                                     \
    if (SCM_UNLIKELY (vp->trace_level > 0))             \
      {                                                 \
        PUSH (x);                                       \
        SYNC_REGISTER ();				\
        vm_dispatch_hook (vm, h);                       \
        DROP();                                         \
      }                                                 \
  }
#else
#define RUN_HOOK(h)
#define RUN_HOOK1(h, x)
#endif

#define BOOT_HOOK()	RUN_HOOK (SCM_VM_BOOT_HOOK)
#define HALT_HOOK()	RUN_HOOK (SCM_VM_HALT_HOOK)
#define NEXT_HOOK()	RUN_HOOK (SCM_VM_NEXT_HOOK)
#define BREAK_HOOK()	RUN_HOOK (SCM_VM_BREAK_HOOK)
#define ENTER_HOOK()	RUN_HOOK (SCM_VM_ENTER_HOOK)
#define APPLY_HOOK()	RUN_HOOK (SCM_VM_APPLY_HOOK)
#define EXIT_HOOK()	RUN_HOOK (SCM_VM_EXIT_HOOK)
#define RETURN_HOOK(n)	RUN_HOOK1 (SCM_VM_RETURN_HOOK, SCM_I_MAKINUM (n))

#define VM_HANDLE_INTERRUPTS                     \
  SCM_ASYNC_TICK_WITH_CODE (SYNC_REGISTER ())

/*
 * Stack operation
 */

#ifdef VM_ENABLE_STACK_NULLING
# define CHECK_STACK_LEAKN(_n) ASSERT (!sp[_n]);
# define CHECK_STACK_LEAK() CHECK_STACK_LEAKN(1)
# define NULLSTACK(_n) { int __x = _n; CHECK_STACK_LEAKN (_n+1); while (__x > 0) sp[__x--] = NULL; }
/* If you have a nonlocal exit in a pre-wind proc while invoking a continuation
   inside a dynwind (phew!), the stack is fully rewound but vm_reset_stack for
   that continuation doesn't have a chance to run. It's not important on a
   semantic level, but it does mess up our stack nulling -- so this macro is to
   fix that. */
# define NULLSTACK_FOR_NONLOCAL_EXIT() if (vp->sp > sp) NULLSTACK (vp->sp - sp);
#else
# define CHECK_STACK_LEAKN(_n)
# define CHECK_STACK_LEAK()
# define NULLSTACK(_n)
# define NULLSTACK_FOR_NONLOCAL_EXIT()
#endif

#define CHECK_OVERFLOW()			\
  if (SCM_UNLIKELY (sp >= stack_limit))         \
    goto vm_error_stack_overflow

#define CHECK_UNDERFLOW()                       \
  if (SCM_UNLIKELY (sp <= SCM_FRAME_UPPER_ADDRESS (fp)))        \
    goto vm_error_stack_underflow;

#define PRE_CHECK_UNDERFLOW(N)                  \
  if (SCM_UNLIKELY (sp - N <= SCM_FRAME_UPPER_ADDRESS (fp)))    \
    goto vm_error_stack_underflow;

#define PUSH(x)	do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0)
#define DROP()	do { sp--; CHECK_UNDERFLOW (); NULLSTACK (1); } while (0)
#define DROPN(_n) do { sp -= (_n); CHECK_UNDERFLOW (); NULLSTACK (_n); } while (0)
#define POP(x)	do { PRE_CHECK_UNDERFLOW (1); x = *sp--; NULLSTACK (1); } while (0)

/* A fast CONS.  This has to be fast since its used, for instance, by
   POP_LIST when fetching a function's argument list.  Note: `scm_cell' is an
   inlined function in Guile 1.7.  Unfortunately, it calls
   `scm_gc_for_newcell ()' which is _not_ inlined and allocated cells on the
   heap.  XXX  */
#define CONS(x,y,z)					\
{							\
  SYNC_BEFORE_GC ();					\
  x = scm_cell (SCM_UNPACK (y), SCM_UNPACK (z));	\
}

/* Pop the N objects on top of the stack and push a list that contains
   them.  */
#define POP_LIST(n)				\
do						\
{						\
  int i;					\
  SCM l = SCM_EOL, x;				\
  for (i = n; i; i--)                           \
    {                                           \
      POP (x);                                  \
      CONS (l, x, l);                           \
    }                                           \
  PUSH (l);					\
} while (0)

/* The opposite: push all of the elements in L onto the list. */
#define PUSH_LIST(l, NILP)			\
do						\
{						\
  for (; scm_is_pair (l); l = SCM_CDR (l))      \
    PUSH (SCM_CAR (l));                         \
  if (SCM_UNLIKELY (!NILP (l))) {               \
    finish_args = scm_list_1 (l);               \
    goto vm_error_improper_list;                \
  }                                             \
} while (0)

#define POP_LIST_MARK()				\
do {						\
  SCM o;					\
  SCM l = SCM_EOL;				\
  POP (o);					\
  while (!SCM_UNBNDP (o))			\
    {						\
      CONS (l, o, l);				\
      POP (o);					\
    }						\
  PUSH (l);					\
} while (0)

#define POP_CONS_MARK()				\
do {						\
  SCM o, l;					\
  POP (l);                                      \
  POP (o);					\
  while (!SCM_UNBNDP (o))			\
    {						\
      CONS (l, o, l);				\
      POP (o);					\
    }						\
  PUSH (l);					\
} while (0)

/*
 * Instruction operation
 */

#define FETCH()		(*ip++)
#define FETCH_LENGTH(len) do { len=*ip++; len<<=8; len+=*ip++; len<<=8; len+=*ip++; } while (0)

#undef NEXT_JUMP
#ifdef HAVE_LABELS_AS_VALUES
#define NEXT_JUMP()		goto *jump_table[FETCH () & SCM_VM_INSTRUCTION_MASK]
#else
#define NEXT_JUMP()		goto vm_start
#endif

#define NEXT					\
{						\
  NEXT_HOOK ();					\
  CHECK_STACK_LEAK ();                          \
  NEXT_JUMP ();					\
}

/* See frames.h for the layout of stack frames */
/* When this is called, bp points to the new program data,
   and the arguments are already on the stack */
#define DROP_FRAME()                            \
  {                                             \
    sp -= 3;                                    \
    NULLSTACK (3);                              \
    CHECK_UNDERFLOW ();                         \
  }

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/

license: mit


code:
/* Copyright (C) 2001 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
 */

#ifndef VM_LABEL
#define VM_LABEL(tag) l_##tag
#define VM_OPCODE(tag) scm_op_##tag

#ifdef HAVE_LABELS_AS_VALUES
#define VM_TAG(tag) VM_LABEL(tag):
#define VM_ADDR(tag) &&VM_LABEL(tag)
#else /* not HAVE_LABELS_AS_VALUES */
#define VM_TAG(tag) case VM_OPCODE(tag):
#define VM_ADDR(tag) NULL
#endif /* not HAVE_LABELS_AS_VALUES */
#endif /* VM_LABEL */

#undef VM_DEFINE_FUNCTION
#undef VM_DEFINE_LOADER
#define VM_DEFINE_FUNCTION(code,tag,name,nargs) \
  VM_DEFINE_INSTRUCTION(code,tag,name,0,nargs,1)
#define VM_DEFINE_LOADER(code,tag,name)         \
  VM_DEFINE_INSTRUCTION(code,tag,name,-1,0,1)

#undef VM_DEFINE_INSTRUCTION
/*
 * These will go to scm_instruction_table in instructions.c
 */
#ifdef VM_INSTRUCTION_TO_TABLE
#define VM_DEFINE_INSTRUCTION(code_,tag_,name_,len_,npop_,npush_) \
  table[VM_OPCODE (tag_)].opcode = code_;                          \
  table[VM_OPCODE (tag_)].name = name_;                            \
  table[VM_OPCODE (tag_)].len = len_;                              \
  table[VM_OPCODE (tag_)].npop = npop_;                            \
  table[VM_OPCODE (tag_)].npush = npush_;

#else
#ifdef VM_INSTRUCTION_TO_LABEL
/*
 * These will go to jump_table in vm_engine.c
 */
#define VM_DEFINE_INSTRUCTION(code,tag,name,len,npop,npush)	jump_table[code] = VM_ADDR (tag);

#else
#ifdef VM_INSTRUCTION_TO_OPCODE
/*
 * These will go to scm_opcode in instructions.h
 */
#define VM_DEFINE_INSTRUCTION(code,tag,name,len,npop,npush)	VM_OPCODE (tag) = code,

#else /* Otherwise */
/*
 * These are directly included in vm_engine.c
 */
#define VM_DEFINE_INSTRUCTION(code,tag,name,len,npop,npush)	VM_TAG (tag)

#endif /* VM_INSTRUCTION_TO_OPCODE */
#endif /* VM_INSTRUCTION_TO_LABEL */
#endif /* VM_INSTRUCTION_TO_TABLE */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* Copyright (C) 2001,2008,2009,2010 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
 */

/* FIXME! Need to check that the fetch is within the current program */

/* This file is included in vm_engine.c */

VM_DEFINE_LOADER (101, load_number, "load-number")
{
  size_t len;

  FETCH_LENGTH (len);
  SYNC_REGISTER ();
  PUSH (scm_string_to_number (scm_from_locale_stringn ((char *)ip, len),
			      SCM_UNDEFINED /* radix = 10 */));
  /* Was: scm_istring2number (ip, len, 10)); */
  ip += len;
  NEXT;
}

VM_DEFINE_LOADER (102, load_string, "load-string")
{
  size_t len;
  char *buf;

  FETCH_LENGTH (len);
  SYNC_REGISTER ();
  PUSH (scm_i_make_string (len, &buf));
  memcpy (buf, (char *) ip, len);
  ip += len;
  NEXT;
}

VM_DEFINE_LOADER (103, load_symbol, "load-symbol")
{
  size_t len;
  FETCH_LENGTH (len);
  SYNC_REGISTER ();
  /* FIXME: should be scm_from_latin1_symboln */
  PUSH (scm_from_locale_symboln ((const char*)ip, len));
  ip += len;
  NEXT;
}

VM_DEFINE_LOADER (104, load_program, "load-program")
{
  scm_t_uint32 len;
  SCM objs, objcode;

  POP (objs);
  SYNC_REGISTER ();

  if (scm_is_vector (objs) && scm_is_false (scm_c_vector_ref (objs, 0)))
    scm_c_vector_set_x (objs, 0, scm_current_module ());

  objcode = scm_c_make_objcode_slice (SCM_PROGRAM_OBJCODE (fp[-1]), ip);
  len = sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);

  PUSH (scm_make_program (objcode, objs, SCM_BOOL_F));

  ip += len;

  NEXT;
}

VM_DEFINE_INSTRUCTION (105, link_now, "link-now", 0, 1, 1)
{
  SCM what;
  POP (what);
  SYNC_REGISTER ();
  PUSH (resolve_variable (what, scm_current_module ()));
  NEXT;
}

VM_DEFINE_LOADER (106, load_array, "load-array")
{
  SCM type, shape;
  size_t len;
  FETCH_LENGTH (len);
  POP (shape);
  POP (type);
  SYNC_REGISTER ();
  PUSH (scm_from_contiguous_typed_array (type, shape, ip, len));
  ip += len;
  NEXT;
}

VM_DEFINE_LOADER (107, load_wide_string, "load-wide-string")
{
  size_t len;
  scm_t_wchar *wbuf;

  FETCH_LENGTH (len);
  if (SCM_UNLIKELY (len % 4))
    {
      finish_args = scm_list_1 (scm_from_size_t (len));
      goto vm_error_bad_wide_string_length;
    }

  SYNC_REGISTER ();
  PUSH (scm_i_make_wide_string (len / 4, &wbuf));
  memcpy ((char *) wbuf, (char *) ip, len);
  ip += len;
  NEXT;
}

/*
(defun renumber-ops ()
  "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
  (interactive "")
  (save-excursion
    (let ((counter 100)) (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)))))
*/

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* Copyright (C) 2001, 2009, 2010 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 */

/*
 * Predicates
 */

#define ARGS1(a1)	SCM a1 = sp[0];
#define ARGS2(a1,a2)	SCM a1 = sp[-1], a2 = sp[0]; sp--; NULLSTACK (1);
#define ARGS3(a1,a2,a3)	SCM a1 = sp[-2], a2 = sp[-1], a3 = sp[0]; sp -= 2; NULLSTACK (2);

#define RETURN(x)	do { *sp = x; NEXT; } while (0)

VM_DEFINE_FUNCTION (128, not, "not", 1)
{
  ARGS1 (x);
  RETURN (scm_from_bool (scm_is_false (x)));
}

VM_DEFINE_FUNCTION (129, not_not, "not-not", 1)
{
  ARGS1 (x);
  RETURN (scm_from_bool (!scm_is_false (x)));
}

VM_DEFINE_FUNCTION (130, eq, "eq?", 2)
{
  ARGS2 (x, y);
  RETURN (scm_from_bool (scm_is_eq (x, y)));
}

VM_DEFINE_FUNCTION (131, not_eq, "not-eq?", 2)
{
  ARGS2 (x, y);
  RETURN (scm_from_bool (!scm_is_eq (x, y)));
}

VM_DEFINE_FUNCTION (132, nullp, "null?", 1)
{
  ARGS1 (x);
  RETURN (scm_from_bool (scm_is_null (x)));
}

VM_DEFINE_FUNCTION (133, not_nullp, "not-null?", 1)
{
  ARGS1 (x);
  RETURN (scm_from_bool (!scm_is_null (x)));
}

VM_DEFINE_FUNCTION (134, eqv, "eqv?", 2)
{
  ARGS2 (x, y);
  if (scm_is_eq (x, y))
    RETURN (SCM_BOOL_T);
  if (SCM_IMP (x) || SCM_IMP (y))
    RETURN (SCM_BOOL_F);
  SYNC_REGISTER ();
  RETURN (scm_eqv_p (x, y));
}

VM_DEFINE_FUNCTION (135, equal, "equal?", 2)
{
  ARGS2 (x, y);
  if (scm_is_eq (x, y))
    RETURN (SCM_BOOL_T);
  if (SCM_IMP (x) || SCM_IMP (y))
    RETURN (SCM_BOOL_F);
  SYNC_REGISTER ();
  RETURN (scm_equal_p (x, y));
}

VM_DEFINE_FUNCTION (136, pairp, "pair?", 1)
{
  ARGS1 (x);
  RETURN (scm_from_bool (scm_is_pair (x)));
}

VM_DEFINE_FUNCTION (137, listp, "list?", 1)
{
  ARGS1 (x);
  RETURN (scm_from_bool (scm_ilength (x) >= 0));
}

/*
 * Basic data
 */

VM_DEFINE_FUNCTION (138, cons, "cons", 2)
{
  ARGS2 (x, y);
  CONS (x, x, y);
  RETURN (x);
}

#define VM_VALIDATE_CONS(x, proc)		\
  if (SCM_UNLIKELY (!scm_is_pair (x)))          \
    { func_name = proc;                         \
      finish_args = x;                          \
      goto vm_error_not_a_pair;                 \
    }

VM_DEFINE_FUNCTION (139, car, "car", 1)
{
  ARGS1 (x);
  VM_VALIDATE_CONS (x, "car");
  RETURN (SCM_CAR (x));
}

VM_DEFINE_FUNCTION (140, cdr, "cdr", 1)
{
  ARGS1 (x);
  VM_VALIDATE_CONS (x, "cdr");
  RETURN (SCM_CDR (x));
}

VM_DEFINE_INSTRUCTION (141, set_car, "set-car!", 0, 2, 0)
{
  SCM x, y;
  POP (y);
  POP (x);
  VM_VALIDATE_CONS (x, "set-car!");
  SCM_SETCAR (x, y);
  NEXT;
}

VM_DEFINE_INSTRUCTION (142, set_cdr, "set-cdr!", 0, 2, 0)
{
  SCM x, y;
  POP (y);
  POP (x);
  VM_VALIDATE_CONS (x, "set-cdr!");
  SCM_SETCDR (x, y);
  NEXT;
}

/*
 * Numeric relational tests
 */

#undef REL
#define REL(crel,srel)						\
{								\
  ARGS2 (x, y);							\
  if (SCM_I_INUMP (x) && SCM_I_INUMP (y))			\
    RETURN (scm_from_bool (SCM_I_INUM (x) crel SCM_I_INUM (y)));  \
  SYNC_REGISTER ();                                             \
  RETURN (srel (x, y));                                         \
}

VM_DEFINE_FUNCTION (143, ee, "ee?", 2)
{
  REL (==, scm_num_eq_p);
}

VM_DEFINE_FUNCTION (144, lt, "lt?", 2)
{
  REL (<, scm_less_p);
}

VM_DEFINE_FUNCTION (145, le, "le?", 2)
{
  REL (<=, scm_leq_p);
}

VM_DEFINE_FUNCTION (146, gt, "gt?", 2)
{
  REL (>, scm_gr_p);
}

VM_DEFINE_FUNCTION (147, ge, "ge?", 2)
{
  REL (>=, scm_geq_p);
}

/*
 * Numeric functions
 */

#undef FUNC2
#define FUNC2(CFUNC,SFUNC)				\
{							\
  ARGS2 (x, y);						\
  if (SCM_I_INUMP (x) && SCM_I_INUMP (y))		\
    {							\
      scm_t_int64 n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y);\
      if (SCM_FIXABLE (n))				\
	RETURN (SCM_I_MAKINUM (n));			\
    }							\
  SYNC_REGISTER ();					\
  RETURN (SFUNC (x, y));				\
}

VM_DEFINE_FUNCTION (148, add, "add", 2)
{
  FUNC2 (+, scm_sum);
}

VM_DEFINE_FUNCTION (149, add1, "add1", 1)
{
  ARGS1 (x);
  if (SCM_I_INUMP (x))
    {
      scm_t_int64 n = SCM_I_INUM (x) + 1;
      if (SCM_FIXABLE (n))
	RETURN (SCM_I_MAKINUM (n));
    }
  SYNC_REGISTER ();
  RETURN (scm_sum (x, SCM_I_MAKINUM (1)));
}

VM_DEFINE_FUNCTION (150, sub, "sub", 2)
{
  FUNC2 (-, scm_difference);
}

VM_DEFINE_FUNCTION (151, sub1, "sub1", 1)
{
  ARGS1 (x);
  if (SCM_I_INUMP (x))
    {
      scm_t_int64 n = SCM_I_INUM (x) - 1;
      if (SCM_FIXABLE (n))
	RETURN (SCM_I_MAKINUM (n));
    }
  SYNC_REGISTER ();
  RETURN (scm_difference (x, SCM_I_MAKINUM (1)));
}

VM_DEFINE_FUNCTION (152, mul, "mul", 2)
{
  ARGS2 (x, y);
  SYNC_REGISTER ();
  RETURN (scm_product (x, y));
}

VM_DEFINE_FUNCTION (153, div, "div", 2)
{
  ARGS2 (x, y);
  SYNC_REGISTER ();
  RETURN (scm_divide (x, y));
}

VM_DEFINE_FUNCTION (154, quo, "quo", 2)
{
  ARGS2 (x, y);
  SYNC_REGISTER ();
  RETURN (scm_quotient (x, y));
}

VM_DEFINE_FUNCTION (155, rem, "rem", 2)
{
  ARGS2 (x, y);
  SYNC_REGISTER ();
  RETURN (scm_remainder (x, y));
}

VM_DEFINE_FUNCTION (156, mod, "mod", 2)
{
  ARGS2 (x, y);
  SYNC_REGISTER ();
  RETURN (scm_modulo (x, y));
}

VM_DEFINE_FUNCTION (157, ash, "ash", 2)
{
  ARGS2 (x, y);
  if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
    {
      if (SCM_I_INUM (y) < 0)
        /* Right shift, will be a fixnum. */
        RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) >> -SCM_I_INUM (y)));
      else
        /* Left shift. See comments in scm_ash. */
        {
          long nn, bits_to_shift;

          nn = SCM_I_INUM (x);
          bits_to_shift = SCM_I_INUM (y);

          if (bits_to_shift < SCM_I_FIXNUM_BIT-1
              && ((unsigned long)
                  (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1)
                  <= 1))
            RETURN (SCM_I_MAKINUM (nn << bits_to_shift));
          /* fall through */
        }
      /* fall through */
    }
  SYNC_REGISTER ();
  RETURN (scm_ash (x, y));
}

VM_DEFINE_FUNCTION (158, logand, "logand", 2)
{
  ARGS2 (x, y);
  if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
    RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) & SCM_I_INUM (y)));
  SYNC_REGISTER ();
  RETURN (scm_logand (x, y));
}

VM_DEFINE_FUNCTION (159, logior, "logior", 2)
{
  ARGS2 (x, y);
  if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
    RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) | SCM_I_INUM (y)));
  SYNC_REGISTER ();
  RETURN (scm_logior (x, y));
}

VM_DEFINE_FUNCTION (160, logxor, "logxor", 2)
{
  ARGS2 (x, y);
  if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
    RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) ^ SCM_I_INUM (y)));
  SYNC_REGISTER ();
  RETURN (scm_logxor (x, y));
}

/*
 * Vectors and arrays
 */

VM_DEFINE_FUNCTION (161, vector_ref, "vector-ref", 2)
{
  long i = 0;
  ARGS2 (vect, idx);
  if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
                  && SCM_I_INUMP (idx)
                  && ((i = SCM_I_INUM (idx)) >= 0)
                  && i < SCM_I_VECTOR_LENGTH (vect)))
    RETURN (SCM_I_VECTOR_ELTS (vect)[i]);
  else
    {
      SYNC_REGISTER ();
      RETURN (scm_vector_ref (vect, idx));
    }
}

VM_DEFINE_INSTRUCTION (162, vector_set, "vector-set", 0, 3, 0)
{
  long i = 0;
  SCM vect, idx, val;
  POP (val); POP (idx); POP (vect);
  if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
                  && SCM_I_INUMP (idx)
                  && ((i = SCM_I_INUM (idx)) >= 0)
                  && i < SCM_I_VECTOR_LENGTH (vect)))
    SCM_I_VECTOR_WELTS (vect)[i] = val;
  else
    {
      SYNC_REGISTER ();
      scm_vector_set_x (vect, idx, val);
    }
  NEXT;
}

VM_DEFINE_INSTRUCTION (163, make_array, "make-array", 3, -1, 1)
{
  scm_t_uint32 len;
  SCM shape, ret;

  len = FETCH ();
  len = (len << 8) + FETCH ();
  len = (len << 8) + FETCH ();
  POP (shape);
  SYNC_REGISTER ();
  PRE_CHECK_UNDERFLOW (len);
  ret = scm_from_contiguous_array (shape, sp - len + 1, len);
  DROPN (len);
  PUSH (ret);
  NEXT;
}

/*
 * Structs
 */
#define VM_VALIDATE_STRUCT(obj, proc)           \
  if (SCM_UNLIKELY (!SCM_STRUCTP (obj)))	\
    {						\
      func_name = proc;                         \
      finish_args = (obj);			\
      goto vm_error_not_a_struct;		\
    }

VM_DEFINE_FUNCTION (164, struct_p, "struct?", 1)
{
  ARGS1 (obj);
  RETURN (scm_from_bool (SCM_STRUCTP (obj)));
}

VM_DEFINE_FUNCTION (165, struct_vtable, "struct-vtable", 1)
{
  ARGS1 (obj);
  VM_VALIDATE_STRUCT (obj, "struct_vtable");
  RETURN (SCM_STRUCT_VTABLE (obj));
}

VM_DEFINE_INSTRUCTION (166, make_struct, "make-struct", 2, -1, 1)
{
  unsigned h = FETCH ();
  unsigned l = FETCH ();
  scm_t_bits n = ((h << 8U) + l);
  SCM vtable = sp[-(n - 1)];
  const SCM *inits = sp - n + 2;
  SCM ret;

  SYNC_REGISTER ();

  if (SCM_LIKELY (SCM_STRUCTP (vtable)
  		  && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
                  && (SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size) + 1
                      == n)
                  && !SCM_VTABLE_INSTANCE_FINALIZER (vtable)))
    {
      /* Verily, we are making a simple struct with the right number of
         initializers, and no finalizer. */
      ret = scm_words ((scm_t_bits)SCM_STRUCT_DATA (vtable) | scm_tc3_struct,
                       n + 1);
      SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2));
      memcpy (SCM_STRUCT_DATA (ret), inits, (n - 1) * sizeof (SCM));
    }
  else
    ret = scm_c_make_structv (vtable, 0, n - 1, (scm_t_bits *) inits);

  DROPN (n);
  PUSH (ret);

  NEXT;
}

VM_DEFINE_FUNCTION (167, struct_ref, "struct-ref", 2)
{
  ARGS2 (obj, pos);

  if (SCM_LIKELY (SCM_STRUCTP (obj)
  		  && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
  						    SCM_VTABLE_FLAG_SIMPLE)
  		  && SCM_I_INUMP (pos)))
    {
      SCM vtable;
      scm_t_bits index, len;

      index = SCM_I_INUM (pos);
      vtable = SCM_STRUCT_VTABLE (obj);
      len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);

      if (SCM_LIKELY (index < len))
  	{
  	  scm_t_bits *data = SCM_STRUCT_DATA (obj);
  	  RETURN (SCM_PACK (data[index]));
  	}
    }

  SYNC_REGISTER ();
  RETURN (scm_struct_ref (obj, pos));
}

VM_DEFINE_FUNCTION (168, struct_set, "struct-set", 3)
{
  ARGS3 (obj, pos, val);

  if (SCM_LIKELY (SCM_STRUCTP (obj)
  		  && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
  						    SCM_VTABLE_FLAG_SIMPLE)
  		  && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
  						    SCM_VTABLE_FLAG_SIMPLE_RW)
  		  && SCM_I_INUMP (pos)))
    {
      SCM vtable;
      scm_t_bits index, len;

      index = SCM_I_INUM (pos);
      vtable = SCM_STRUCT_VTABLE (obj);
      len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
      if (SCM_LIKELY (index < len))
  	{
  	  scm_t_bits *data = SCM_STRUCT_DATA (obj);
  	  data[index] = SCM_UNPACK (val);
  	  RETURN (val);
  	}
    }

  SYNC_REGISTER ();
  RETURN (scm_struct_set_x (obj, pos, val));
}

/*
 * GOOPS support
 */
VM_DEFINE_FUNCTION (169, class_of, "class-of", 1)
{
  ARGS1 (obj);
  if (SCM_INSTANCEP (obj))
    RETURN (SCM_CLASS_OF (obj));
  SYNC_REGISTER ();
  RETURN (scm_class_of (obj));
}

VM_DEFINE_FUNCTION (170, slot_ref, "slot-ref", 2)
{
  size_t slot;
  ARGS2 (instance, idx);
  slot = SCM_I_INUM (idx);
  RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
}

VM_DEFINE_INSTRUCTION (171, slot_set, "slot-set", 0, 3, 0)
{
  SCM instance, idx, val;
  size_t slot;
  POP (val);
  POP (idx);
  POP (instance);
  slot = SCM_I_INUM (idx);
  SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (val);
  NEXT;
}

/*
 * Bytevectors
 */
#define VM_VALIDATE_BYTEVECTOR(x, proc)		\
  do						\
    {						\
      if (SCM_UNLIKELY (!SCM_BYTEVECTOR_P (x)))	\
	{					\
          func_name = proc;                     \
	  finish_args = x;			\
	  goto vm_error_not_a_bytevector;	\
	}					\
    }						\
  while (0)

#define BV_REF_WITH_ENDIANNESS(stem, fn_stem)                           \
{                                                                       \
  SCM endianness;                                                       \
  POP (endianness);                                                     \
  if (scm_is_eq (endianness, scm_i_native_endianness))                  \
    goto VM_LABEL (bv_##stem##_native_ref);                             \
  {                                                                     \
    ARGS2 (bv, idx);                                                    \
    SYNC_REGISTER ();							\
    RETURN (scm_bytevector_##fn_stem##_ref (bv, idx, endianness));      \
  }                                                                     \
}

/* Return true (non-zero) if PTR has suitable alignment for TYPE.  */
#define ALIGNED_P(ptr, type)			\
  ((scm_t_uintptr) (ptr) % alignof (type) == 0)

VM_DEFINE_FUNCTION (172, bv_u16_ref, "bv-u16-ref", 3)
BV_REF_WITH_ENDIANNESS (u16, u16)
VM_DEFINE_FUNCTION (173, bv_s16_ref, "bv-s16-ref", 3)
BV_REF_WITH_ENDIANNESS (s16, s16)
VM_DEFINE_FUNCTION (174, bv_u32_ref, "bv-u32-ref", 3)
BV_REF_WITH_ENDIANNESS (u32, u32)
VM_DEFINE_FUNCTION (175, bv_s32_ref, "bv-s32-ref", 3)
BV_REF_WITH_ENDIANNESS (s32, s32)
VM_DEFINE_FUNCTION (176, bv_u64_ref, "bv-u64-ref", 3)
BV_REF_WITH_ENDIANNESS (u64, u64)
VM_DEFINE_FUNCTION (177, bv_s64_ref, "bv-s64-ref", 3)
BV_REF_WITH_ENDIANNESS (s64, s64)
VM_DEFINE_FUNCTION (178, bv_f32_ref, "bv-f32-ref", 3)
BV_REF_WITH_ENDIANNESS (f32, ieee_single)
VM_DEFINE_FUNCTION (179, bv_f64_ref, "bv-f64-ref", 3)
BV_REF_WITH_ENDIANNESS (f64, ieee_double)

#undef BV_REF_WITH_ENDIANNESS

#define BV_FIXABLE_INT_REF(stem, fn_stem, type, size)			\
{									\
  long i;								\
  const scm_t_ ## type *int_ptr;					\
  ARGS2 (bv, idx);							\
									\
  VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref");                      \
  i = SCM_I_INUM (idx);							\
  int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i);	\
									\
  if (SCM_LIKELY (SCM_I_INUMP (idx)					\
                  && (i >= 0)						\
                  && (i + size <= SCM_BYTEVECTOR_LENGTH (bv))		\
                  && (ALIGNED_P (int_ptr, scm_t_ ## type))))		\
    RETURN (SCM_I_MAKINUM (*int_ptr));					\
  else									\
    {									\
      SYNC_REGISTER ();							\
      RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx));		\
    }									\
}

#define BV_INT_REF(stem, type, size)					\
{									\
  long i;								\
  const scm_t_ ## type *int_ptr;					\
  ARGS2 (bv, idx);							\
									\
  VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref");                      \
  i = SCM_I_INUM (idx);							\
  int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i);	\
									\
  if (SCM_LIKELY (SCM_I_INUMP (idx)					\
                  && (i >= 0)						\
                  && (i + size <= SCM_BYTEVECTOR_LENGTH (bv))		\
                  && (ALIGNED_P (int_ptr, scm_t_ ## type))))		\
    {									\
      scm_t_ ## type x = *int_ptr;					\
      if (SCM_FIXABLE (x))						\
        RETURN (SCM_I_MAKINUM (x));					\
      else								\
	{								\
	  SYNC_REGISTER ();						\
	  RETURN (scm_from_ ## type (x));				\
	}								\
    }									\
  else									\
    {									\
      SYNC_REGISTER ();							\
      RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx));	\
    }									\
}

#define BV_FLOAT_REF(stem, fn_stem, type, size)				\
{									\
  long i;								\
  const type *float_ptr;						\
  ARGS2 (bv, idx);							\
									\
  VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref");                      \
  i = SCM_I_INUM (idx);							\
  float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i);		\
									\
  SYNC_REGISTER ();							\
  if (SCM_LIKELY (SCM_I_INUMP (idx)					\
                  && (i >= 0)						\
                  && (i + size <= SCM_BYTEVECTOR_LENGTH (bv))		\
                  && (ALIGNED_P (float_ptr, type))))			\
    RETURN (scm_from_double (*float_ptr));				\
  else									\
    RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx));	\
}

VM_DEFINE_FUNCTION (180, bv_u8_ref, "bv-u8-ref", 2)
BV_FIXABLE_INT_REF (u8, u8, uint8, 1)
VM_DEFINE_FUNCTION (181, bv_s8_ref, "bv-s8-ref", 2)
BV_FIXABLE_INT_REF (s8, s8, int8, 1)
VM_DEFINE_FUNCTION (182, bv_u16_native_ref, "bv-u16-native-ref", 2)
BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2)
VM_DEFINE_FUNCTION (183, bv_s16_native_ref, "bv-s16-native-ref", 2)
BV_FIXABLE_INT_REF (s16, s16_native, int16, 2)
VM_DEFINE_FUNCTION (184, bv_u32_native_ref, "bv-u32-native-ref", 2)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4)
#else
BV_INT_REF (u32, uint32, 4)
#endif
VM_DEFINE_FUNCTION (185, bv_s32_native_ref, "bv-s32-native-ref", 2)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_REF (s32, s32_native, int32, 4)
#else
BV_INT_REF (s32, int32, 4)
#endif
VM_DEFINE_FUNCTION (186, bv_u64_native_ref, "bv-u64-native-ref", 2)
BV_INT_REF (u64, uint64, 8)
VM_DEFINE_FUNCTION (187, bv_s64_native_ref, "bv-s64-native-ref", 2)
BV_INT_REF (s64, int64, 8)
VM_DEFINE_FUNCTION (188, bv_f32_native_ref, "bv-f32-native-ref", 2)
BV_FLOAT_REF (f32, ieee_single, float, 4)
VM_DEFINE_FUNCTION (189, bv_f64_native_ref, "bv-f64-native-ref", 2)
BV_FLOAT_REF (f64, ieee_double, double, 8)

#undef BV_FIXABLE_INT_REF
#undef BV_INT_REF
#undef BV_FLOAT_REF

#define BV_SET_WITH_ENDIANNESS(stem, fn_stem)                           \
{                                                                       \
  SCM endianness;                                                       \
  POP (endianness);                                                     \
  if (scm_is_eq (endianness, scm_i_native_endianness))                  \
    goto VM_LABEL (bv_##stem##_native_set);                             \
  {                                                                     \
    SCM bv, idx, val; POP (val); POP (idx); POP (bv);                   \
    scm_bytevector_##fn_stem##_set_x (bv, idx, val, endianness);        \
    NEXT;                                                               \
  }                                                                     \
}

VM_DEFINE_INSTRUCTION (190, bv_u16_set, "bv-u16-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (u16, u16)
VM_DEFINE_INSTRUCTION (191, bv_s16_set, "bv-s16-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (s16, s16)
VM_DEFINE_INSTRUCTION (192, bv_u32_set, "bv-u32-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (u32, u32)
VM_DEFINE_INSTRUCTION (193, bv_s32_set, "bv-s32-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (s32, s32)
VM_DEFINE_INSTRUCTION (194, bv_u64_set, "bv-u64-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (u64, u64)
VM_DEFINE_INSTRUCTION (195, bv_s64_set, "bv-s64-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (s64, s64)
VM_DEFINE_INSTRUCTION (196, bv_f32_set, "bv-f32-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (f32, ieee_single)
VM_DEFINE_INSTRUCTION (197, bv_f64_set, "bv-f64-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (f64, ieee_double)

#undef BV_SET_WITH_ENDIANNESS

#define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size)		\
{									\
  long i, j = 0;							\
  SCM bv, idx, val;							\
  scm_t_ ## type *int_ptr;						\
									\
  POP (val); POP (idx); POP (bv);					\
  VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set");                      \
  i = SCM_I_INUM (idx);							\
  int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i);	\
									\
  if (SCM_LIKELY (SCM_I_INUMP (idx)					\
                  && (i >= 0)						\
                  && (i + size <= SCM_BYTEVECTOR_LENGTH (bv))		\
                  && (ALIGNED_P (int_ptr, scm_t_ ## type))		\
                  && (SCM_I_INUMP (val))				\
                  && ((j = SCM_I_INUM (val)) >= min)			\
                  && (j <= max)))					\
    *int_ptr = (scm_t_ ## type) j;					\
  else									\
    scm_bytevector_ ## fn_stem ## _set_x (bv, idx, val);		\
  NEXT;									\
}

#define BV_INT_SET(stem, type, size)					\
{									\
  long i = 0;								\
  SCM bv, idx, val;							\
  scm_t_ ## type *int_ptr;						\
									\
  POP (val); POP (idx); POP (bv);					\
  VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set");                      \
  i = SCM_I_INUM (idx);							\
  int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i);	\
									\
  if (SCM_LIKELY (SCM_I_INUMP (idx)					\
                  && (i >= 0)						\
                  && (i + size <= SCM_BYTEVECTOR_LENGTH (bv))		\
                  && (ALIGNED_P (int_ptr, scm_t_ ## type))))		\
    *int_ptr = scm_to_ ## type (val);					\
  else									\
    scm_bytevector_ ## stem ## _native_set_x (bv, idx, val);		\
  NEXT;									\
}

#define BV_FLOAT_SET(stem, fn_stem, type, size)			\
{								\
  long i = 0;							\
  SCM bv, idx, val;						\
  type *float_ptr;						\
								\
  POP (val); POP (idx); POP (bv);				\
  VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set");              \
  i = SCM_I_INUM (idx);						\
  float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i);	\
								\
  if (SCM_LIKELY (SCM_I_INUMP (idx)				\
                  && (i >= 0)					\
                  && (i + size <= SCM_BYTEVECTOR_LENGTH (bv))	\
                  && (ALIGNED_P (float_ptr, type))))		\
    *float_ptr = scm_to_double (val);				\
  else								\
    scm_bytevector_ ## fn_stem ## _native_set_x (bv, idx, val);	\
  NEXT;								\
}

VM_DEFINE_INSTRUCTION (198, bv_u8_set, "bv-u8-set", 0, 3, 0)
BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1)
VM_DEFINE_INSTRUCTION (199, bv_s8_set, "bv-s8-set", 0, 3, 0)
BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1)
VM_DEFINE_INSTRUCTION (200, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0)
BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2)
VM_DEFINE_INSTRUCTION (201, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2)
VM_DEFINE_INSTRUCTION (202, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4)
#else
BV_INT_SET (u32, uint32, 4)
#endif
VM_DEFINE_INSTRUCTION (203, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4)
#else
BV_INT_SET (s32, int32, 4)
#endif
VM_DEFINE_INSTRUCTION (204, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
BV_INT_SET (u64, uint64, 8)
VM_DEFINE_INSTRUCTION (205, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
BV_INT_SET (s64, int64, 8)
VM_DEFINE_INSTRUCTION (206, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0)
BV_FLOAT_SET (f32, ieee_single, float, 4)
VM_DEFINE_INSTRUCTION (207, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
BV_FLOAT_SET (f64, ieee_double, double, 8)

#undef BV_FIXABLE_INT_SET
#undef BV_INT_SET
#undef BV_FLOAT_SET

/*
(defun renumber-ops ()
  "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
  (interactive "")
  (save-excursion
    (let ((counter 127)) (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)))))
*/

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* Copyright (C) 2001,2008,2009,2010 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)
{
  HALT_HOOK ();
  nvalues = SCM_I_INUM (*sp--);
  NULLSTACK (1);
  if (nvalues == 1)
    POP (finish_args);
  else
    {
      POP_LIST (nvalues);
      POP (finish_args);
      SYNC_REGISTER ();
      finish_args = scm_values (finish_args);
    }

  {
#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);
  }

  goto vm_done;
}

VM_DEFINE_INSTRUCTION (2, break, "break", 0, 0, 0)
{
  BREAK_HOOK ();
  NEXT;
}

VM_DEFINE_INSTRUCTION (3, drop, "drop", 0, 1, 0)
{
  DROP ();
  NEXT;
}

VM_DEFINE_INSTRUCTION (4, dup, "dup", 0, 0, 1)
{
  SCM x = *sp;
  PUSH (x);
  NEXT;
}

/*
 * Object creation
 */

VM_DEFINE_INSTRUCTION (5, void, "void", 0, 0, 1)
{
  PUSH (SCM_UNSPECIFIED);
  NEXT;
}

VM_DEFINE_INSTRUCTION (6, make_true, "make-true", 0, 0, 1)
{
  PUSH (SCM_BOOL_T);
  NEXT;
}

VM_DEFINE_INSTRUCTION (7, make_false, "make-false", 0, 0, 1)
{
  PUSH (SCM_BOOL_F);
  NEXT;
}

VM_DEFINE_INSTRUCTION (8, make_nil, "make-nil", 0, 0, 1)
{
  PUSH (SCM_ELISP_NIL);
  NEXT;
}

VM_DEFINE_INSTRUCTION (9, make_eol, "make-eol", 0, 0, 1)
{
  PUSH (SCM_EOL);
  NEXT;
}

VM_DEFINE_INSTRUCTION (10, make_int8, "make-int8", 1, 0, 1)
{
  PUSH (SCM_I_MAKINUM ((signed char) FETCH ()));
  NEXT;
}

VM_DEFINE_INSTRUCTION (11, make_int8_0, "make-int8:0", 0, 0, 1)
{
  PUSH (SCM_INUM0);
  NEXT;
}

VM_DEFINE_INSTRUCTION (12, make_int8_1, "make-int8:1", 0, 0, 1)
{
  PUSH (SCM_I_MAKINUM (1));
  NEXT;
}

VM_DEFINE_INSTRUCTION (13, 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 (14, 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 (15, 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 (16, 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 (17, 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 (18, list, "list", 2, -1, 1)
{
  unsigned h = FETCH ();
  unsigned l = FETCH ();
  unsigned len = ((h << 8) + l);
  POP_LIST (len);
  NEXT;
}

VM_DEFINE_INSTRUCTION (19, 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)      (VARIABLE_REF (v) != SCM_UNDEFINED)

#define FREE_VARIABLE_REF(i)	SCM_PROGRAM_FREE_VARIABLE_REF (program, i)

/* ref */

VM_DEFINE_INSTRUCTION (20, 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 (21, 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 (22, local_ref, "local-ref", 1, 0, 1)
{
  PUSH (LOCAL_REF (FETCH ()));
  ASSERT_BOUND (*sp);
  NEXT;
}

VM_DEFINE_INSTRUCTION (23, 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 (24, local_bound, "local-bound?", 1, 0, 1)
{
  if (LOCAL_REF (FETCH ()) == SCM_UNDEFINED)
    PUSH (SCM_BOOL_F);
  else
    PUSH (SCM_BOOL_T);
  NEXT;
}

VM_DEFINE_INSTRUCTION (25, long_local_bound, "long-local-bound?", 2, 0, 1)
{
  unsigned int i = FETCH ();
  i <<= 8;
  i += FETCH ();
  if (LOCAL_REF (i) == SCM_UNDEFINED)
    PUSH (SCM_BOOL_F);
  else
    PUSH (SCM_BOOL_T);
  NEXT;
}

VM_DEFINE_INSTRUCTION (26, variable_ref, "variable-ref", 0, 1, 1)
{
  SCM x = *sp;

  if (SCM_UNLIKELY (!VARIABLE_BOUNDP (x)))
    {
      SCM var_name;

      /* Attempt to provide the variable name in the error message.  */
      var_name = scm_module_reverse_lookup (scm_current_module (), x);
      finish_args = scm_list_1 (scm_is_true (var_name) ? var_name : x);
      goto vm_error_unbound;
    }
  else
    {
      SCM o = VARIABLE_REF (x);
      *sp = o;
    }

  NEXT;
}

VM_DEFINE_INSTRUCTION (27, variable_bound, "variable-bound?", 0, 1, 1)
{
  if (VARIABLE_BOUNDP (*sp))
    *sp = SCM_BOOL_T;
  else
    *sp = SCM_BOOL_F;
  NEXT;
}

VM_DEFINE_INSTRUCTION (28, toplevel_ref, "toplevel-ref", 1, 0, 1)
{
  unsigned objnum = FETCH ();
  SCM what;
  CHECK_OBJECT (objnum);
  what = OBJECT_REF (objnum);

  if (!SCM_VARIABLEP (what))
    {
      SYNC_REGISTER ();
      what = resolve_variable (what, scm_program_module (program));
      if (!VARIABLE_BOUNDP (what))
        {
          finish_args = scm_list_1 (what);
          goto vm_error_unbound;
        }
      OBJECT_SET (objnum, what);
    }

  PUSH (VARIABLE_REF (what));
  NEXT;
}

VM_DEFINE_INSTRUCTION (29, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
{
  SCM what;
  unsigned int objnum = FETCH ();
  objnum <<= 8;
  objnum += FETCH ();
  CHECK_OBJECT (objnum);
  what = OBJECT_REF (objnum);

  if (!SCM_VARIABLEP (what))
    {
      SYNC_REGISTER ();
      what = resolve_variable (what, scm_program_module (program));
      if (!VARIABLE_BOUNDP (what))
        {
          finish_args = scm_list_1 (what);
          goto vm_error_unbound;
        }
      OBJECT_SET (objnum, what);
    }

  PUSH (VARIABLE_REF (what));
  NEXT;
}

/* set */

VM_DEFINE_INSTRUCTION (30, local_set, "local-set", 1, 1, 0)
{
  LOCAL_SET (FETCH (), *sp);
  DROP ();
  NEXT;
}

VM_DEFINE_INSTRUCTION (31, long_local_set, "long-local-set", 2, 1, 0)
{
  unsigned int i = FETCH ();
  i <<= 8;
  i += FETCH ();
  LOCAL_SET (i, *sp);
  DROP ();
  NEXT;
}

VM_DEFINE_INSTRUCTION (32, variable_set, "variable-set", 0, 2, 0)
{
  VARIABLE_SET (sp[0], sp[-1]);
  DROPN (2);
  NEXT;
}

VM_DEFINE_INSTRUCTION (33, 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 (34, 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;                       \
  NULLSTACK (1);				\
  DROP ();					\
  NEXT;						\
}

VM_DEFINE_INSTRUCTION (35, br, "br", 3, 0, 0)
{
  scm_t_int32 offset;
  FETCH_OFFSET (offset);
  ip += offset;
  if (offset < 0)
    VM_HANDLE_INTERRUPTS;
  NEXT;
}

VM_DEFINE_INSTRUCTION (36, br_if, "br-if", 3, 0, 0)
{
  BR (scm_is_true (*sp));
}

VM_DEFINE_INSTRUCTION (37, br_if_not, "br-if-not", 3, 0, 0)
{
  BR (scm_is_false (*sp));
}

VM_DEFINE_INSTRUCTION (38, br_if_eq, "br-if-eq", 3, 0, 0)
{
  sp--; /* underflow? */
  BR (scm_is_eq (sp[0], sp[1]));
}

VM_DEFINE_INSTRUCTION (39, br_if_not_eq, "br-if-not-eq", 3, 0, 0)
{
  sp--; /* underflow? */
  BR (!scm_is_eq (sp[0], sp[1]));
}

VM_DEFINE_INSTRUCTION (40, br_if_null, "br-if-null", 3, 0, 0)
{
  BR (scm_is_null (*sp));
}

VM_DEFINE_INSTRUCTION (41, br_if_not_null, "br-if-not-null", 3, 0, 0)
{
  BR (!scm_is_null (*sp));
}

/*
 * Subprogram call
 */

VM_DEFINE_INSTRUCTION (42, 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 (43, 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 (44, 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 (45, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0)
{
  scm_t_ptrdiff n;
  n = FETCH () << 8;
  n += FETCH ();
  if (sp - (fp - 1) != n)
    goto vm_error_wrong_num_args;
  NEXT;
}

VM_DEFINE_INSTRUCTION (46, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0)
{
  scm_t_ptrdiff n;
  n = FETCH () << 8;
  n += FETCH ();
  if (sp - (fp - 1) < n)
    goto vm_error_wrong_num_args;
  NEXT;
}

VM_DEFINE_INSTRUCTION (47, 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 (48, 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;
}

/* 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 (49, 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 ();

  if (!(kw_and_rest_flags & F_REST)
      && ((sp - (fp - 1) - nkw) % 2))
    goto vm_error_kwargs_length_not_even;

  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;
		}
	    }
	  if (!(kw_and_rest_flags & F_ALLOW_OTHER_KEYS) && !scm_is_pair (walk))
	    goto vm_error_kwargs_unrecognized_keyword;

	  nkw++;
	}
      else if (!(kw_and_rest_flags & F_REST))
        goto vm_error_kwargs_invalid_keyword;
    }

  NEXT;
}

#undef F_ALLOW_OTHER_KEYS
#undef F_REST

VM_DEFINE_INSTRUCTION (50, 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 (51, 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 (52, 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 (53, 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 */
  PUSH ((SCM)fp); /* dynamic link */
  PUSH (0);  /* mvra */
  PUSH (0);  /* ra */
  NEXT;
}

VM_DEFINE_INSTRUCTION (54, call, "call", 1, -1, 1)
{
  nargs = FETCH ();

 vm_call:
  program = sp[-nargs];

  VM_HANDLE_INTERRUPTS;

  if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
    {
      if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
        {
          sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
          goto vm_call;
        }
      else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
               && SCM_SMOB_APPLICABLE_P (program))
        {
          SYNC_REGISTER ();
          sp[-nargs] = scm_i_smob_apply_trampoline (program);
          goto vm_call;
        }
      else
        goto vm_error_wrong_type_apply;
    }

  CACHE_PROGRAM ();
  fp = sp - nargs + 1;
  ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
  ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
  SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
  SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0);
  ip = SCM_C_OBJCODE_BASE (bp);
  ENTER_HOOK ();
  APPLY_HOOK ();
  NEXT;
}

VM_DEFINE_INSTRUCTION (55, tail_call, "tail-call", 1, -1, 1)
{
  nargs = FETCH ();

 vm_tail_call:
  program = sp[-nargs];

  VM_HANDLE_INTERRUPTS;

  if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
    {
      if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
        {
          sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
          goto vm_tail_call;
        }
      else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
               && SCM_SMOB_APPLICABLE_P (program))
        {
          SYNC_REGISTER ();
          sp[-nargs] = scm_i_smob_apply_trampoline (program);
          goto vm_tail_call;
        }
      else
        goto vm_error_wrong_type_apply;
    }
  else
    {
      int i;
#ifdef VM_ENABLE_STACK_NULLING
      SCM *old_sp = sp;
      CHECK_STACK_LEAK ();
#endif

      EXIT_HOOK ();

      /* switch programs */
      CACHE_PROGRAM ();
      /* 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);

      ip = SCM_C_OBJCODE_BASE (bp);

      ENTER_HOOK ();
      APPLY_HOOK ();
      NEXT;
    }
}

VM_DEFINE_INSTRUCTION (56, 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 (57, 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 (58, 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 (89, 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 (94, partial_cont_call, "partial-cont-call", 0, -1, 0)
{
  SCM vmcont, intwinds, prevwinds;
  POP (intwinds);
  POP (vmcont);
  SYNC_REGISTER ();
  if (SCM_UNLIKELY (!SCM_VM_CONT_REWINDABLE_P (vmcont)))
    { finish_args = vmcont;
      goto vm_error_continuation_not_rewindable;
    }
  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 (59, 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 (60, 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 (61, mv_call, "mv-call", 4, -1, 1)
{
  scm_t_int32 offset;
  scm_t_uint8 *mvra;

  nargs = FETCH ();
  FETCH_OFFSET (offset);
  mvra = ip + offset;

 vm_mv_call:
  program = sp[-nargs];

  VM_HANDLE_INTERRUPTS;

  if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
    {
      if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
        {
          sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
          goto vm_mv_call;
        }
      else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
               && SCM_SMOB_APPLICABLE_P (program))
        {
          SYNC_REGISTER ();
          sp[-nargs] = scm_i_smob_apply_trampoline (program);
          goto vm_mv_call;
        }
      else
        goto vm_error_wrong_type_apply;
    }

  CACHE_PROGRAM ();
  fp = sp - nargs + 1;
  ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
  ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
  SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
  SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
  ip = SCM_C_OBJCODE_BASE (bp);
  ENTER_HOOK ();
  APPLY_HOOK ();
  NEXT;
}

VM_DEFINE_INSTRUCTION (62, apply, "apply", 1, -1, 1)
{
  int len;
  SCM ls;
  POP (ls);

  nargs = FETCH ();
  ASSERT (nargs >= 2);

  len = scm_ilength (ls);
  if (SCM_UNLIKELY (len < 0))
    {
      finish_args = ls;
      goto vm_error_apply_to_non_list;
    }

  PUSH_LIST (ls, SCM_NULL_OR_NIL_P);

  nargs += len - 2;
  goto vm_call;
}

VM_DEFINE_INSTRUCTION (63, tail_apply, "tail-apply", 1, -1, 1)
{
  int len;
  SCM ls;
  POP (ls);

  nargs = FETCH ();
  ASSERT (nargs >= 2);

  len = scm_ilength (ls);
  if (SCM_UNLIKELY (len < 0))
    {
      finish_args = ls;
      goto vm_error_apply_to_non_list;
    }

  PUSH_LIST (ls, SCM_NULL_OR_NIL_P);

  nargs += len - 2;
  goto vm_tail_call;
}

VM_DEFINE_INSTRUCTION (64, 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)fp); /* dynamic link */
      PUSH (0);  /* mvra */
      PUSH (0);  /* ra */
      PUSH (proc);
      PUSH (cont);
      nargs = 1;
      goto vm_call;
    }
  else
    {
      /* otherwise, the vm continuation was reinstated, and
         scm_i_vm_return_to_continuation pushed on one value. 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 ();
      NEXT;
    }
}

VM_DEFINE_INSTRUCTION (65, 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 ();
      NEXT;
    }
}

VM_DEFINE_INSTRUCTION (66, return, "return", 0, 1, 1)
{
 vm_return:
  EXIT_HOOK ();
  RETURN_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 (67, 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:
  EXIT_HOOK ();
  RETURN_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
    goto vm_error_no_values;

  /* Restore the last program */
  program = SCM_FRAME_PROGRAM (fp);
  CACHE_PROGRAM ();
  CHECK_IP ();
  NEXT;
}

VM_DEFINE_INSTRUCTION (68, 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++;
    }
  if (SCM_UNLIKELY (!SCM_NULL_OR_NIL_P (l))) {
    finish_args = scm_list_1 (l);
    goto vm_error_improper_list;
  }

  goto vm_return_values;
}

VM_DEFINE_INSTRUCTION (88, 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 (69, 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--;

  if (nvalues < nbinds)
    goto vm_error_not_enough_values;

  if (rest)
    POP_LIST (nvalues - nbinds);
  else
    DROPN (nvalues - nbinds);

  NEXT;
}

VM_DEFINE_INSTRUCTION (70, 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 (71, 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 (72, 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 (73, 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 (74, 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 (75, 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 (76, 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 (77, 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 (78, 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 (79, 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 (80, define, "define", 0, 0, 2)
{
  SCM sym, val;
  POP (sym);
  POP (val);
  SYNC_REGISTER ();
  VARIABLE_SET (scm_sym2var (sym, scm_current_module_lookup_closure (),
                             SCM_BOOL_T),
                val);
  NEXT;
}

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

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

VM_DEFINE_INSTRUCTION (83, 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 ();
      NEXT;
    }

  /* Otherwise setjmp returned for the first time, so we go to execute the
     prompt's body. */
  NEXT;
}

VM_DEFINE_INSTRUCTION (85, wind, "wind", 0, 2, 0)
{
  SCM wind, unwind;
  POP (unwind);
  POP (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. */
  if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (wind))))
    {
      finish_args = wind;
      goto vm_error_not_a_thunk;
    }
  if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (unwind))))
    {
      finish_args = unwind;
      goto vm_error_not_a_thunk;
    }
  scm_i_set_dynwinds (scm_cons (scm_cons (wind, unwind), scm_i_dynwinds ()));
  NEXT;
}

VM_DEFINE_INSTRUCTION (86, abort, "abort", 1, -1, -1)
{
  unsigned n = FETCH ();
  SYNC_REGISTER ();
  if (sp - n - 2 <= SCM_FRAME_UPPER_ADDRESS (fp))
    goto vm_error_stack_underflow;
  vm_abort (vm, n, vm_cookie);
  /* vm_abort should not return */
  abort ();
}

VM_DEFINE_INSTRUCTION (87, 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 (90, wind_fluids, "wind-fluids", 1, -1, 0)
{
  unsigned n = FETCH ();
  SCM wf;

  if (sp - 2*n < SCM_FRAME_UPPER_ADDRESS (fp))
    goto vm_error_stack_underflow;

  SYNC_REGISTER ();
  wf = scm_i_make_with_fluids (n, sp + 1 - 2*n, sp + 1 - n);
  scm_i_swap_with_fluids (wf, dynstate);
  scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
  NEXT;
}

VM_DEFINE_INSTRUCTION (91, 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, dynstate);
  NEXT;
}

VM_DEFINE_INSTRUCTION (92, fluid_ref, "fluid-ref", 0, 1, 1)
{
  size_t num;
  SCM fluids, val;

  CHECK_UNDERFLOW ();
  fluids = SCM_I_DYNAMIC_STATE_FLUIDS (dynstate);
  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
    {
      val = SCM_SIMPLE_VECTOR_REF (fluids, num);
      if (val == SCM_UNDEFINED)
        {
          finish_args = scm_list_1 (*sp);
          goto vm_error_unbound_fluid;
        }
      *sp = val;
    }

  NEXT;
}

VM_DEFINE_INSTRUCTION (93, fluid_set, "fluid-set", 0, 2, 0)
{
  size_t num;
  SCM val, fluid, fluids;

  POP (val);
  POP (fluid);
  fluids = SCM_I_DYNAMIC_STATE_FLUIDS (dynstate);
  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 ();

  if (SCM_UNLIKELY (sp - (fp - 1) != (n & 0x7)))
    goto vm_error_wrong_num_args;

  old_sp = sp;
  sp += (n >> 3);
  CHECK_OVERFLOW ();
  while (old_sp < sp)
    *++old_sp = 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:
*/