text: /*  vm.c -- stack-based virtual machine backend               */
  /*  Copyright (c) 2009-2015 Alex Shinn.  All rights reserved. */
  /*  BSD-style license: http://synthcode.com/license.txt       */
  
  #if SEXP_USE_NATIVE_X86
  #include "opt/x86.c"
  #else
  /* ... the rest of this file ... */
  
  #include "chibi/eval.h"
  
  #if SEXP_USE_DEBUG_VM > 1
  static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) {
    int i;
    if (! sexp_oportp(out)) out = sexp_current_error_port(ctx);
    for (i=0; i<top; i++) {
      sexp_write_char(ctx, ((i==fp) ? '*' : ' '), out);
      if (i < 10) sexp_write_char(ctx, '0', out);
      sexp_write(ctx, sexp_make_fixnum(i), out);
      sexp_write_string(ctx, ": ", out);
      sexp_write(ctx, stack[i], out);
      sexp_newline(ctx, out);
    }
  }
  #else
  #define sexp_print_stack(ctx, stack, top, fp, out)
  #endif
  
  #if SEXP_USE_FULL_SOURCE_INFO
  static sexp sexp_lookup_source_info (sexp src, int ip) {
    int i;
    if (src && sexp_procedurep(src))
      src = sexp_procedure_source(src);
    if (src && sexp_vectorp(src) && sexp_vector_length(src) > 0) {
      for (i=1; i<(int)sexp_vector_length(src); i++)
        if (sexp_unbox_fixnum(sexp_car(sexp_vector_ref(src, sexp_make_fixnum(i)))) > ip)
          return sexp_cdr(sexp_vector_ref(src, sexp_make_fixnum(i-1)));
      return sexp_cdr(sexp_vector_ref(src, sexp_make_fixnum(sexp_vector_length(src)-1)));
    }
    return SEXP_FALSE;
  }
  #endif
  
  void sexp_stack_trace (sexp ctx, sexp out) {
    int i, fp=sexp_context_last_fp(ctx);
    sexp self, bc, src, *stack=sexp_stack_data(sexp_context_stack(ctx));
    if (! sexp_oportp(out))
      out = sexp_current_error_port(ctx);
    for (i=fp; i>4; i=sexp_unbox_fixnum(stack[i+3])) {
      self = stack[i+2];
      if (self && sexp_procedurep(self)) {
        sexp_write_string(ctx, "  called from ", out);
        bc = sexp_procedure_code(self);
        if (sexp_symbolp(sexp_bytecode_name(bc)))
          sexp_write(ctx, sexp_bytecode_name(bc), out);
        else
          sexp_write_string(ctx, "<anonymous>", out);
        src = sexp_bytecode_source(bc);
  #if SEXP_USE_FULL_SOURCE_INFO
        if (src && sexp_vectorp(src))
          src = sexp_lookup_source_info(src, sexp_unbox_fixnum(stack[i+3]));
  #endif
        if (src && sexp_pairp(src)) {
          if (sexp_fixnump(sexp_cdr(src)) && (sexp_cdr(src) >= SEXP_ZERO)) {
            sexp_write_string(ctx, " on line ", out);
            sexp_write(ctx, sexp_cdr(src), out);
          }
          if (sexp_stringp(sexp_car(src))) {
            sexp_write_string(ctx, " of file ", out);
            sexp_write_string(ctx, sexp_string_data(sexp_car(src)), out);
          }
        }
        sexp_write_char(ctx, '\n', out);
      }
    }
  }
  
  sexp sexp_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp out) {
    sexp_stack_trace(ctx, out);
    return SEXP_VOID;
  }
  
  /************************* code generation ****************************/
  
  #if SEXP_USE_ALIGNED_BYTECODE
  void sexp_context_align_pos(sexp ctx) {
    sexp_uint_t i, pos = sexp_unbox_fixnum(sexp_context_pos(ctx));
    sexp_uint_t new_pos = sexp_word_align(pos);
    if (new_pos > pos) {
      sexp_expand_bcode(ctx, (sexp_sint_t)new_pos - pos);
      if (pos > 0)
        for (i=pos; i<new_pos; ++i)
          sexp_bytecode_data(sexp_context_bc(ctx))[i] =
            sexp_bytecode_data(sexp_context_bc(ctx))[pos-1];
      sexp_context_pos(ctx) = sexp_make_fixnum(new_pos);
    }
  }
  #endif
  
  static void sexp_inc_context_pos(sexp ctx, sexp_sint_t off) {
    sexp_expand_bcode(ctx, off);
    sexp_context_pos(ctx) = sexp_fx_add(sexp_context_pos(ctx), sexp_make_fixnum(off));
  }
  
  static void sexp_inc_context_depth(sexp ctx, sexp_sint_t off) {
    sexp_context_depth(ctx) = sexp_fx_add(sexp_context_depth(ctx), sexp_make_fixnum(off));
    if (sexp_unbox_fixnum(sexp_context_depth(ctx))
        > sexp_unbox_fixnum(sexp_context_max_depth(ctx)))
      sexp_context_max_depth(ctx) = sexp_context_depth(ctx);
  }
  
  static void bytecode_preserve (sexp ctx, sexp obj) {
    sexp ls = sexp_bytecode_literals(sexp_context_bc(ctx));
    if (sexp_pointerp(obj) && !sexp_symbolp(obj)
        && sexp_not(sexp_memq(ctx, obj, ls)))
      sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), obj);
  }
  
  static void sexp_emit_word (sexp ctx, sexp_uint_t val)  {
    unsigned char *data;
    sexp_context_align_pos(ctx);
    sexp_expand_bcode(ctx, sizeof(sexp));
    if (sexp_exceptionp(sexp_context_exception(ctx)))
      return;
    data = sexp_bytecode_data(sexp_context_bc(ctx));
    *((sexp_uint_t*)(&(data[sexp_unbox_fixnum(sexp_context_pos(ctx))]))) = val;
    sexp_inc_context_pos(ctx, sizeof(sexp));
  }
  
  static void sexp_emit_push (sexp ctx, sexp obj) {
    sexp_emit(ctx, SEXP_OP_PUSH);
    sexp_emit_word(ctx, (sexp_uint_t)obj);
    sexp_inc_context_depth(ctx, 1);
    bytecode_preserve(ctx, obj);
  }
  
  void sexp_emit_return (sexp ctx) {
    sexp_emit(ctx, SEXP_OP_RET);
  }
  
  static void sexp_push_source (sexp ctx, sexp source) {
  #if SEXP_USE_FULL_SOURCE_INFO
    sexp src, bc = sexp_context_bc(ctx);
    sexp_gc_var1(tmp);
    if (source && sexp_pairp(source)) {
      src = sexp_bytecode_source(bc);
      if (!src) src = sexp_bytecode_source(bc) = SEXP_NULL;
      if (!sexp_pairp(src)
          || sexp_unbox_fixnum(sexp_context_pos(ctx)) > sexp_unbox_fixnum(sexp_caar(src))) {
        sexp_gc_preserve1(ctx, tmp);
        tmp = sexp_cons(ctx, sexp_context_pos(ctx), source);
        if (sexp_pairp(tmp)) {
          tmp = sexp_cons(ctx, tmp, src);
          if (sexp_pairp(tmp)) sexp_bytecode_source(bc) = tmp;
        }
        sexp_gc_release1(ctx);
      }
    }
  #endif
  }
  
  static sexp_sint_t sexp_context_make_label (sexp ctx) {
    sexp_sint_t label;
    sexp_context_align_pos(ctx);
    label = sexp_unbox_fixnum(sexp_context_pos(ctx));
    sexp_inc_context_pos(ctx, sizeof(sexp_uint_t));
    return label;
  }
  
  static void sexp_context_patch_label (sexp ctx, sexp_sint_t label) {
    sexp bc = sexp_context_bc(ctx);
    unsigned char *data = sexp_bytecode_data(bc)+label;
    if (!sexp_exceptionp(sexp_context_exception(ctx)))
      *((sexp_sint_t*)data) = sexp_unbox_fixnum(sexp_context_pos(ctx))-label;
  }
  
  static void generate_lit (sexp ctx, sexp value) {
    sexp_emit_push(ctx, value);
  }
  
  static void generate_drop_prev (sexp ctx, sexp prev) {
  #if ! SEXP_USE_ALIGNED_BYTECODE
    if ((sexp_pairp(prev) && sexp_opcodep(sexp_car(prev))
         && (sexp_opcode_code(sexp_car(prev)) == SEXP_OP_PUSH))
        || sexp_setp(prev) || sexp_litp(prev) || prev == SEXP_VOID)
      sexp_inc_context_pos(ctx, -(1 + sizeof(sexp)));
    else
  #endif
      sexp_emit(ctx, SEXP_OP_DROP);
  }
  
  static void generate_seq (sexp ctx, sexp name, sexp loc, sexp lam, sexp app) {
    sexp head=app, tail=sexp_cdr(app);
    sexp_uint_t tailp = sexp_context_tailp(ctx);
    sexp_push_source(ctx, sexp_pair_source(app));
    sexp_context_tailp(ctx) = 0;
    for ( ; sexp_pairp(tail); head=tail, tail=sexp_cdr(tail))
      if (sexp_pointerp(sexp_car(head)) && (! sexp_litp(sexp_car(head)))) {
        sexp_generate(ctx, name, loc, lam, sexp_car(head));
        generate_drop_prev(ctx, sexp_car(head));
        sexp_inc_context_depth(ctx, -1);
      }
    sexp_context_tailp(ctx) = (char)tailp;
    sexp_generate(ctx, name, loc, lam, sexp_car(head));
  }
  
  static void generate_cnd (sexp ctx, sexp name, sexp loc, sexp lam, sexp cnd) {
    sexp_sint_t label1, label2, tailp=sexp_context_tailp(ctx);
    sexp_push_source(ctx, sexp_cnd_source(cnd));
    sexp_context_tailp(ctx) = 0;
    sexp_generate(ctx, name, loc, lam, sexp_cnd_test(cnd));
    sexp_context_tailp(ctx) = (char)tailp;
    sexp_emit(ctx, SEXP_OP_JUMP_UNLESS);
    sexp_inc_context_depth(ctx, -1);
    label1 = sexp_context_make_label(ctx);
    sexp_generate(ctx, name, loc, lam, sexp_cnd_pass(cnd));
    sexp_context_tailp(ctx) = (char)tailp;
    sexp_emit(ctx, SEXP_OP_JUMP);
    sexp_inc_context_depth(ctx, -1);
    label2 = sexp_context_make_label(ctx);
    sexp_context_patch_label(ctx, label1);
    sexp_generate(ctx, name, loc, lam, sexp_cnd_fail(cnd));
    sexp_context_patch_label(ctx, label2);
  }
  
  static void generate_non_global_ref (sexp ctx, sexp name, sexp cell,
                                       sexp lambda, sexp fv, int unboxp) {
    sexp_uint_t i;
    sexp loc = sexp_cdr(cell);
    if (loc == lambda && sexp_lambdap(lambda)) {
      /* local ref */
      sexp_emit(ctx, SEXP_OP_LOCAL_REF);
      sexp_emit_word(ctx, sexp_param_index(ctx, lambda, name));
    } else {
      /* closure ref */
      for (i=0; sexp_pairp(fv); fv=sexp_cdr(fv), i++)
        if ((name == sexp_ref_name(sexp_car(fv)))
            && (loc == sexp_ref_loc(sexp_car(fv))))
          break;
      sexp_emit(ctx, SEXP_OP_CLOSURE_REF);
      sexp_emit_word(ctx, i);
    }
    if (unboxp && (sexp_truep(sexp_memq(ctx, name, sexp_lambda_sv(loc)))))
      sexp_emit(ctx, SEXP_OP_CDR);
    sexp_inc_context_depth(ctx, +1);
  }
  
  static void generate_ref (sexp ctx, sexp ref, int unboxp) {
    sexp lam;
    sexp_push_source(ctx, sexp_ref_source(ref));
    if (! sexp_lambdap(sexp_ref_loc(ref))) {
      /* global ref */
      if (unboxp) {
        sexp_emit(ctx, (sexp_cdr(sexp_ref_cell(ref)) == SEXP_UNDEF)
  		? SEXP_OP_GLOBAL_REF : SEXP_OP_GLOBAL_KNOWN_REF);
        sexp_emit_word(ctx, (sexp_uint_t)sexp_ref_cell(ref));
        bytecode_preserve(ctx, sexp_ref_cell(ref));
      } else
        sexp_emit_push(ctx, sexp_ref_cell(ref));
    } else {
      lam = sexp_context_lambda(ctx);
      if (!lam || !sexp_lambdap(lam)) {
        sexp_warn(ctx, "variable out of phase: ", sexp_ref_name(ref));
        sexp_emit_push(ctx, SEXP_VOID);
      } else {
        generate_non_global_ref(ctx, sexp_ref_name(ref), sexp_ref_cell(ref),
                                lam, sexp_lambda_fv(lam), unboxp);
      }
    }
  }
  
  static void generate_set (sexp ctx, sexp set) {
    sexp ref = sexp_set_var(set), lambda;
    sexp_push_source(ctx, sexp_set_source(set));
    /* compile the value */
    sexp_context_tailp(ctx) = 0;
    if (sexp_lambdap(sexp_set_value(set))) {
      sexp_lambda_name(sexp_set_value(set)) = sexp_ref_name(ref);
      sexp_generate(ctx, sexp_ref_name(ref), sexp_ref_loc(ref), sexp_set_value(set), sexp_set_value(set));
    } else {
      sexp_generate(ctx, 0, 0, 0, sexp_set_value(set));
    }
    if (! sexp_lambdap(sexp_ref_loc(ref))) {
      /* global vars are set directly */
      if (sexp_cdr(sexp_ref_cell(ref)) == SEXP_UNDEF) {
        /* force an undefined variable error if still undef at runtime */
        generate_ref(ctx, ref, 1);
        sexp_emit(ctx, SEXP_OP_DROP);
      }
      sexp_emit_push(ctx, sexp_ref_cell(ref));
      sexp_emit(ctx, SEXP_OP_SET_CDR);
    } else {
      lambda = sexp_ref_loc(ref);
      if (sexp_truep(sexp_memq(ctx, sexp_ref_name(ref), sexp_lambda_sv(lambda)))) {
        /* stack or closure mutable vars are boxed */
        generate_ref(ctx, ref, 0);
        sexp_emit(ctx, SEXP_OP_SET_CDR);
      } else {
        /* internally defined variable */
        sexp_emit(ctx, SEXP_OP_LOCAL_SET);
        sexp_emit_word(ctx, sexp_param_index(ctx, lambda, sexp_ref_name(ref)));
      }
    }
    sexp_emit_push(ctx, SEXP_VOID);
    sexp_inc_context_depth(ctx, +1);
  }
  
  static void generate_opcode_app (sexp ctx, sexp app) {
    sexp op = sexp_car(app);
    sexp_sint_t i, num_args, inv_default=0;
    sexp_gc_var1(ls);
    sexp_gc_preserve1(ctx, ls);
  
    if (sexp_opcode_tail_call_p(op) && !sexp_context_tailp(ctx)) {
      sexp_warn(ctx, "tail-call only opcode in non-tail position: ", app);
      generate_lit(ctx, SEXP_VOID);
      return;
    }
  
    num_args = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app)));
    sexp_context_tailp(ctx) = 0;
  
    if (sexp_opcode_class(op) != SEXP_OPC_PARAMETER) {
  
      /* maybe push the default for an optional argument */
      if ((num_args == sexp_opcode_num_args(op))
          && sexp_opcode_variadic_p(op) && sexp_opcode_data(op)) {
        if (sexp_opcode_inverse(op)) {
          inv_default = 1;
        } else {
          if (sexp_opcode_opt_param_p(op) && sexp_opcodep(sexp_opcode_data(op))) {
  #if SEXP_USE_GREEN_THREADS
            sexp_emit(ctx, SEXP_OP_PARAMETER_REF);
            sexp_emit_word(ctx, (sexp_uint_t)sexp_opcode_data(op));
            bytecode_preserve(ctx, sexp_opcode_data(op));
  #else
            sexp_emit_push(ctx, sexp_opcode_data(sexp_opcode_data(op)));
  #endif
            sexp_emit(ctx, SEXP_OP_CDR);
          } else {
            sexp_emit_push(ctx, sexp_opcode_data(op));
          }
          sexp_inc_context_depth(ctx, +1);
          num_args++;
        }
      }
  
      /* push the arguments onto the stack in reverse order */
      if (!sexp_opcode_static_param_p(op)) {
        ls = ((sexp_opcode_inverse(op)
               && (sexp_opcode_class(op) != SEXP_OPC_ARITHMETIC))
              ? sexp_cdr(app) : sexp_reverse(ctx, sexp_cdr(app)));
        for ( ; sexp_pairp(ls); ls = sexp_cdr(ls)) {
          sexp_generate(ctx, 0, 0, 0, sexp_car(ls));
  #if SEXP_USE_AUTO_FORCE
          if (((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR)
               || sexp_opcode_code(op) == SEXP_OP_MAKE_VECTOR)
              && !(sexp_opcode_class(op) == SEXP_OPC_TYPE_PREDICATE
                   && sexp_unbox_fixnum(sexp_opcode_data(op)) == SEXP_PROMISE))
            sexp_emit(ctx, SEXP_OP_FORCE);
  #endif
        }
      }
  
    }
  
    /* push the default for inverse opcodes */
    if (inv_default) {
      sexp_emit_push(ctx, sexp_opcode_data(op));
      if (sexp_opcode_opt_param_p(op)) sexp_emit(ctx, SEXP_OP_CDR);
      sexp_inc_context_depth(ctx, +1);
      num_args++;
    }
  
    /* emit the actual operator call */
    switch (sexp_opcode_class(op)) {
    case SEXP_OPC_ARITHMETIC:
      /* fold variadic arithmetic operators */
      for (i=num_args-1; i>0; i--)
        sexp_emit(ctx, sexp_opcode_code(op));
      break;
    case SEXP_OPC_ARITHMETIC_CMP:
      /* With [<true-value>, x] on the stack, and x boolean, */
      /* AND is equivalent to ROT+DROP.  Note one AND for every STACK_REF. */
      if (num_args > 2) {
        sexp_emit(ctx, SEXP_OP_STACK_REF);
        sexp_emit_word(ctx, 2);
        sexp_emit(ctx, SEXP_OP_STACK_REF);
        sexp_emit_word(ctx, 2);
        sexp_emit(ctx, sexp_opcode_code(op));
        sexp_emit(ctx, SEXP_OP_AND);
        for (i=num_args-2; i>0; i--) {
          sexp_emit(ctx, SEXP_OP_STACK_REF);
          sexp_emit_word(ctx, 3);
          sexp_emit(ctx, SEXP_OP_STACK_REF);
          sexp_emit_word(ctx, 3);
          sexp_emit(ctx, sexp_opcode_code(op));
          sexp_emit(ctx, SEXP_OP_AND);
          sexp_emit(ctx, SEXP_OP_AND);
        }
        sexp_emit(ctx, SEXP_OP_AND);
      } else
        sexp_emit(ctx, sexp_opcode_code(op));
      break;
    case SEXP_OPC_FOREIGN:
      sexp_emit(ctx, sexp_opcode_code(op));
      sexp_emit_word(ctx, (sexp_uint_t)op);
      bytecode_preserve(ctx, op);
      break;
    case SEXP_OPC_TYPE_PREDICATE:
    case SEXP_OPC_GETTER:
    case SEXP_OPC_SETTER:
    case SEXP_OPC_CONSTRUCTOR:
      sexp_emit(ctx, sexp_opcode_code(op));
      if ((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR)
          || sexp_opcode_code(op) == SEXP_OP_MAKE) {
        if (sexp_opcode_data(op))
          sexp_emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data(op)));
        if (sexp_opcode_data2(op))
          sexp_emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data2(op)));
        if (sexp_opcode_data(op) || sexp_opcode_data2(op))
          bytecode_preserve(ctx, op);
      }
      break;
    case SEXP_OPC_PARAMETER:
  #if SEXP_USE_GREEN_THREADS
      if (num_args > 0) {
        if (sexp_opcode_data2(op) && sexp_applicablep(sexp_opcode_data2(op))) {
          ls = sexp_list2(ctx, sexp_opcode_data2(op), sexp_cadr(app));
          sexp_generate(ctx, 0, 0, 0, ls);
        } else {
          sexp_generate(ctx, 0, 0, 0, sexp_cadr(app));
        }
      }
      sexp_emit(ctx, SEXP_OP_PARAMETER_REF);
      sexp_emit_word(ctx, (sexp_uint_t)op);
      bytecode_preserve(ctx, op);
  #else
      if (num_args > 0) sexp_generate(ctx, 0, 0, 0, sexp_cadr(app));
      sexp_emit_push(ctx, sexp_opcode_data(op));
  #endif
      sexp_emit(ctx, ((num_args == 0) ? SEXP_OP_CDR : SEXP_OP_SET_CDR));
      if (num_args > 0) sexp_emit_push(ctx, SEXP_VOID);
      break;
    default:
      sexp_emit(ctx, sexp_opcode_code(op));
    }
  
    if (sexp_opcode_static_param_p(op))
      for (ls=sexp_cdr(app); sexp_pairp(ls); ls=sexp_cdr(ls))
        sexp_emit_word(ctx, sexp_unbox_fixnum(sexp_litp(sexp_car(ls)) ?
  					    sexp_lit_value(sexp_car(ls)) :
  					    sexp_car(ls)));
  
    if (sexp_opcode_return_type(op) == SEXP_VOID
        && sexp_opcode_class(op) != SEXP_OPC_FOREIGN)
      sexp_emit_push(ctx, SEXP_VOID);
  
    sexp_inc_context_depth(ctx, -(num_args-1));
    sexp_gc_release1(ctx);
  }
  
  static void generate_general_app (sexp ctx, sexp app) {
    sexp_uint_t len = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app))),
      tailp = sexp_context_tailp(ctx);
    sexp_gc_var1(ls);
    sexp_gc_preserve1(ctx, ls);
  
    /* push the arguments onto the stack */
    sexp_context_tailp(ctx) = 0;
    for (ls=sexp_reverse(ctx, sexp_cdr(app)); sexp_pairp(ls); ls=sexp_cdr(ls))
      sexp_generate(ctx, 0, 0, 0, sexp_car(ls));
  
    /* push the operator onto the stack */
    sexp_generate(ctx, 0, 0, 0, sexp_car(app));
  
    /* maybe overwrite the current frame */
    sexp_emit(ctx, ((tailp && sexp_not(sexp_global(ctx, SEXP_G_NO_TAIL_CALLS_P))) ? SEXP_OP_TAIL_CALL : SEXP_OP_CALL));
    sexp_emit_word(ctx, (sexp_uint_t)sexp_make_fixnum(len));
  
    sexp_context_tailp(ctx) = (char)tailp;
    sexp_inc_context_depth(ctx, -len);
    sexp_gc_release1(ctx);
  }
  
  #if SEXP_USE_TAIL_JUMPS
  static void generate_tail_jump (sexp ctx, sexp name, sexp loc, sexp lam, sexp app) {
    sexp_gc_var3(ls1, ls2, ls3);
    sexp_gc_preserve3(ctx, ls1, ls2, ls3);
  
    /* overwrite the arguments that differ */
    sexp_context_tailp(ctx) = 0;
    for (ls1=sexp_cdr(app), ls2=sexp_lambda_params(lam), ls3=SEXP_NULL;
         sexp_pairp(ls1); ls1=sexp_cdr(ls1), ls2=sexp_cdr(ls2)) {
      if (!(sexp_refp(sexp_car(ls1))
            && sexp_ref_name(sexp_car(ls1)) == sexp_car(ls2)
            && sexp_ref_loc(sexp_car(ls1)) == lam
            && sexp_not(sexp_memq(ctx, sexp_car(ls2), sexp_lambda_sv(lam))))) {
        sexp_generate(ctx, 0, 0, 0, sexp_car(ls1));
        ls3 = sexp_cons(ctx, sexp_car(ls2), ls3);
      }
    }
    for (ls1=ls3; sexp_pairp(ls1); ls1=sexp_cdr(ls1)) {
      sexp_emit(ctx, SEXP_OP_LOCAL_SET);
      sexp_emit_word(ctx, sexp_param_index(ctx, lam, sexp_car(ls1)));
    }
  
    /* drop the current result and jump */
    sexp_emit(ctx, SEXP_OP_JUMP);
    sexp_context_align_pos(ctx);
    sexp_emit_word(ctx, (sexp_uint_t) (-sexp_unbox_fixnum(sexp_context_pos(ctx)) +
  				     (sexp_pairp(sexp_lambda_locals(lam))
  				      ? 1 + sizeof(sexp) : 0)));
  
    sexp_context_tailp(ctx) = 1;
    sexp_gc_release3(ctx);
  }
  #endif
  
  static void generate_app (sexp ctx, sexp name, sexp loc, sexp lam, sexp app) {
    sexp_push_source(ctx, sexp_pair_source(app));
    if (sexp_opcodep(sexp_car(app)))
      generate_opcode_app(ctx, app);
  #if SEXP_USE_TAIL_JUMPS
    else if (sexp_context_tailp(ctx) && sexp_refp(sexp_car(app))
             && name == sexp_ref_name(sexp_car(app))
             && loc == sexp_ref_loc(sexp_car(app))
             && (sexp_length(ctx, sexp_cdr(app))
                 == sexp_length(ctx, sexp_lambda_params(lam))))
      generate_tail_jump(ctx, name, loc, lam, app);
  #endif
    else
      generate_general_app(ctx, app);
  }
  
  #if SEXP_USE_UNBOXED_LOCALS
  static int sexp_internal_definep(sexp ctx, sexp x) {
    return sexp_lambdap(sexp_ref_loc(x))
      && sexp_truep(sexp_memq(ctx, sexp_ref_name(x),
                              sexp_lambda_locals(sexp_ref_loc(x))));
  }
  
  static int sexp_mutual_internal_definep(sexp ctx, sexp x, sexp fv) {
    return sexp_internal_definep(ctx, x)
      && sexp_ref_loc(x) == sexp_ref_loc(fv) && sexp_internal_definep(ctx, fv)
      && sexp_not(sexp_memq(ctx, sexp_ref_name(fv),
                            sexp_lambda_sv(sexp_ref_loc(fv))));
  }
  
  static int generate_lambda_locals (sexp ctx, sexp name, sexp loc, sexp lam, sexp x) {
    sexp ls;
    if (sexp_seqp(x)) {
      for (ls=sexp_seq_ls(x); sexp_pairp(ls); ls=sexp_cdr(ls))
        if (!generate_lambda_locals(ctx, name, loc, lam, sexp_car(ls)))
          return 0;
      return 1;
    } else if (sexp_setp(x) && sexp_internal_definep(ctx, sexp_set_var(x))) {
      sexp_generate(ctx, name, loc, lam, x);
      sexp_inc_context_pos(ctx, -(1 + sizeof(sexp)));
      return 1;
    }
    return 0;
  }
  
  static int generate_lambda_body (sexp ctx, sexp name, sexp loc, sexp lam, sexp x, sexp prev_lam) {
    sexp_uint_t k, updatep, tailp;
    sexp ls, ref, fv, prev_fv;
    if (sexp_exceptionp(sexp_context_exception(ctx)))
      return 0;
    if (sexp_seqp(x)) {
      tailp = sexp_context_tailp(ctx);
      sexp_context_tailp(ctx) = 0;
      for (ls=sexp_seq_ls(x); sexp_pairp(ls); ls=sexp_cdr(ls)) {
        if (sexp_nullp(sexp_cdr(ls))) sexp_context_tailp(ctx) = tailp;
        if (!generate_lambda_body(ctx, name, loc, lam, sexp_car(ls), prev_lam)) {
          if (sexp_pairp(sexp_cdr(ls))) {
            generate_drop_prev(ctx, sexp_car(ls));
            for (ls=sexp_cdr(ls); sexp_pairp(ls) && sexp_pairp(sexp_cdr(ls));
                 ls=sexp_cdr(ls)) {
              sexp_generate(ctx, name, loc, lam, sexp_car(ls));
              generate_drop_prev(ctx, sexp_car(ls));
            }
            sexp_context_tailp(ctx) = tailp;
            sexp_generate(ctx, name, loc, lam, sexp_car(ls));
          }
          return 0;
        }
      }
      return 1;
    } else if (sexp_setp(x) && sexp_internal_definep(ctx, sexp_set_var(x))) {
      updatep = 0;
      if (sexp_lambdap(sexp_set_value(x))) {
        /* update potentially changed bindings */
        fv = sexp_lambda_fv(sexp_set_value(x));
        prev_fv = sexp_lambdap(prev_lam) ? sexp_lambda_fv(prev_lam) : SEXP_NULL;
        for (k=0; fv && sexp_pairp(fv); fv=sexp_cdr(fv), k++) {
          ref = sexp_car(fv);
          if (sexp_mutual_internal_definep(ctx, sexp_set_var(x), ref)) {
            if (!updatep) {
              updatep = 1;
              generate_non_global_ref(ctx, sexp_ref_name(sexp_set_var(x)),
                                      sexp_ref_cell(sexp_set_var(x)),
                                      lam, sexp_lambda_fv(lam), 1);
              sexp_emit(ctx, SEXP_OP_CLOSURE_VARS);
            }
            generate_non_global_ref(ctx, sexp_ref_name(ref), sexp_ref_cell(ref),
                                    lam, sexp_lambda_fv(lam), 1);
            sexp_emit_push(ctx, sexp_make_fixnum(k));
            sexp_emit(ctx, SEXP_OP_STACK_REF);
            sexp_emit_word(ctx, 3);
            sexp_emit(ctx, SEXP_OP_VECTOR_SET);
            sexp_inc_context_depth(ctx, -1);
          }
        }
      }
      if (updatep) sexp_emit(ctx, SEXP_OP_DROP);
      return 1;
    }
    sexp_generate(ctx, name, loc, lam, x);
    return 0;
  }
  #endif
  
  static void generate_lambda (sexp ctx, sexp name, sexp loc, sexp lam, sexp lambda) {
    sexp ctx2, fv, ls, flags, len, ref, prev_lambda, prev_fv;
    sexp_sint_t k;
    sexp_gc_var2(tmp, bc);
    if (sexp_exceptionp(sexp_context_exception(ctx)))
      return;
    prev_lambda = sexp_context_lambda(ctx);
    prev_fv = sexp_lambdap(prev_lambda) ? sexp_lambda_fv(prev_lambda) : SEXP_NULL;
    fv = sexp_lambda_fv(lambda);
    ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx), 0, 0);
    if (sexp_exceptionp(ctx2)) {
      sexp_context_exception(ctx) = ctx2;
      return;
    }
    sexp_context_lambda(ctx2) = lambda;
    sexp_gc_preserve2(ctx, tmp, bc);
    tmp = sexp_cons(ctx2, SEXP_ZERO, sexp_lambda_source(lambda));
    /* allocate space for local vars */
    k = sexp_unbox_fixnum(sexp_length(ctx, sexp_lambda_locals(lambda)));
    if (k > 0) {
  #if SEXP_USE_RESERVE_OPCODE
      sexp_emit(ctx2, SEXP_OP_RESERVE);
      sexp_emit_word(ctx2, k);
  #else
      while (k--) sexp_emit_push(ctx2, SEXP_UNDEF);
  #endif
    }
    /* box mutable vars */
    for (ls=sexp_lambda_sv(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) {
      k = sexp_param_index(ctx, lambda, sexp_car(ls));
      sexp_emit(ctx2, SEXP_OP_LOCAL_REF);
      sexp_emit_word(ctx2, k);
      sexp_emit_push(ctx2, sexp_car(ls));
      sexp_emit(ctx2, SEXP_OP_CONS);
      sexp_emit(ctx2, SEXP_OP_LOCAL_SET);
      sexp_emit_word(ctx2, k);
    }
    if (lam != lambda) loc = 0;
  #if SEXP_USE_UNBOXED_LOCALS
    sexp_context_tailp(ctx2) = 0;
    generate_lambda_locals(ctx2, name, loc, lambda, sexp_lambda_body(lambda));
    sexp_context_tailp(ctx2) = 1;
    generate_lambda_body(ctx2, name, loc, lambda, sexp_lambda_body(lambda), prev_lambda);
  #else
    sexp_context_tailp(ctx2) = 1;
    sexp_generate(ctx2, name, loc, lam, sexp_lambda_body(lambda));
  #endif
    flags = sexp_make_fixnum(sexp_not(sexp_listp(ctx, sexp_lambda_params(lambda)))
                             ? (SEXP_PROC_VARIADIC + (sexp_rest_unused_p(lambda)
                                                      ? SEXP_PROC_UNUSED_REST: 0))
                             : SEXP_PROC_NONE);
    len = sexp_length(ctx2, sexp_lambda_params(lambda));
    bc = sexp_complete_bytecode(ctx2);
    if (sexp_exceptionp(bc)) {
      sexp_context_exception(ctx) = bc;
    } else {
    sexp_bytecode_name(bc) = sexp_lambda_name(lambda);
  #if ! SEXP_USE_FULL_SOURCE_INFO
    sexp_bytecode_source(bc) = sexp_lambda_source(lambda);
  #endif
    if (sexp_nullp(fv)) {
      /* shortcut, no free vars */
      tmp = sexp_make_vector(ctx2, SEXP_ZERO, SEXP_VOID);
      tmp = sexp_make_procedure(ctx2, flags, len, bc, tmp);
      bytecode_preserve(ctx, tmp);
      generate_lit(ctx, tmp);
    } else {
      /* push the closed vars */
      sexp_emit_push(ctx, SEXP_VOID);
      sexp_emit_push(ctx, sexp_length(ctx, fv));
      sexp_emit(ctx, SEXP_OP_MAKE_VECTOR);
      sexp_inc_context_depth(ctx, -1);
      for (k=0; sexp_pairp(fv); fv=sexp_cdr(fv), k++) {
        ref = sexp_car(fv);
        generate_non_global_ref(ctx, sexp_ref_name(ref), sexp_ref_cell(ref),
                                prev_lambda, prev_fv, 0);
        sexp_emit_push(ctx, sexp_make_fixnum(k));
        sexp_emit(ctx, SEXP_OP_STACK_REF);
        sexp_emit_word(ctx, 3);
        sexp_emit(ctx, SEXP_OP_VECTOR_SET);
        sexp_inc_context_depth(ctx, -1);
      }
      /* push the additional procedure info and make the closure */
      sexp_emit(ctx, SEXP_OP_MAKE_PROCEDURE);
      sexp_emit_word(ctx, (sexp_uint_t)flags);
      sexp_emit_word(ctx, (sexp_uint_t)len);
      sexp_emit_word(ctx, (sexp_uint_t)bc);
      bytecode_preserve(ctx, bc);
    }
    }
    sexp_gc_release2(ctx);
  }
  
  void sexp_generate (sexp ctx, sexp name, sexp loc, sexp lam, sexp x) {
    if (sexp_exceptionp(sexp_context_exception(ctx)))
      return;
    if (sexp_pointerp(x)) {
      switch (sexp_pointer_tag(x)) {
      case SEXP_PAIR:   generate_app(ctx, name, loc, lam, x); break;
      case SEXP_LAMBDA: generate_lambda(ctx, name, loc, lam, x); break;
      case SEXP_CND:    generate_cnd(ctx, name, loc, lam, x); break;
      case SEXP_REF:    generate_ref(ctx, x, 1); break;
      case SEXP_SET:    generate_set(ctx, x); break;
      case SEXP_SEQ:    generate_seq(ctx, name, loc, lam, sexp_seq_ls(x)); break;
      case SEXP_LIT:    generate_lit(ctx, sexp_lit_value(x)); break;
      default:          generate_lit(ctx, x);
      }
    } else {
      generate_lit(ctx, x);
    }
  }
  
  static sexp make_param_list (sexp ctx, sexp_uint_t i) {
    sexp_gc_var1(res);
    sexp_gc_preserve1(ctx, res);
    res = SEXP_NULL;
    for ( ; i>0; i--)
      res = sexp_cons(ctx, sexp_make_fixnum(i), res);
    sexp_gc_release1(ctx);
    return res;
  }
  
  static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
    sexp ls, res, env;
    sexp_gc_var6(bc, params, ref, refs, lambda, ctx2);
    if (i == sexp_opcode_num_args(op)) { /* return before preserving */
      if (sexp_opcode_proc(op)) return sexp_opcode_proc(op);
    } else if (i < sexp_opcode_num_args(op)) {
      return sexp_compile_error(ctx, "not enough args for opcode", op);
    } else if (! sexp_opcode_variadic_p(op)) { /* i > num_args */
      return sexp_compile_error(ctx, "too many args for opcode", op);
    }
    sexp_gc_preserve6(ctx, bc, params, ref, refs, lambda, ctx2);
    params = make_param_list(ctx, i);
    lambda = sexp_make_lambda(ctx, params);
    ctx2 = sexp_make_child_context(ctx, lambda);
    env = sexp_extend_env(ctx2, sexp_context_env(ctx), params, lambda);
    if (sexp_exceptionp(env)) {
      res = env;
    } else {
      sexp_context_env(ctx2) = env;
      for (ls=params, refs=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) {
        ref = sexp_make_ref(ctx2, sexp_car(ls), sexp_env_cell(ctx, env, sexp_car(ls), 0));
        if (!sexp_exceptionp(ref)) sexp_push(ctx2, refs, ref);
      }
      if (!sexp_exceptionp(refs))
        refs = sexp_reverse(ctx2, refs);
      refs = sexp_cons(ctx2, op, refs);
      if (sexp_exceptionp(refs)) {
        res = refs;
      } else {
        generate_opcode_app(ctx2, refs);
        bc = sexp_complete_bytecode(ctx2);
        sexp_bytecode_name(bc) = sexp_opcode_name(op);
        res=sexp_make_procedure(ctx2, SEXP_ZERO, sexp_make_fixnum(i), bc, SEXP_VOID);
        if (i == sexp_opcode_num_args(op))
          sexp_opcode_proc(op) = res;
      }
    }
    sexp_gc_release6(ctx);
    return res;
  }
  
  /*********************** the virtual machine **************************/
  
  sexp sexp_make_trampoline (sexp ctx, sexp proc, sexp args) {
    return sexp_make_exception(ctx, SEXP_TRAMPOLINE, SEXP_FALSE, args, proc, SEXP_FALSE);
  }
  
  #if SEXP_USE_GROW_STACK
  static int sexp_grow_stack (sexp ctx, int min_size) {
    sexp stack, old_stack = sexp_context_stack(ctx), *from, *to;
    int i, size = sexp_stack_length(old_stack), new_size;
    new_size = size * 2;
    if (new_size < min_size) new_size = min_size;
    if (new_size > SEXP_MAX_STACK_SIZE) {
      if (size == SEXP_MAX_STACK_SIZE)
        return 0;
      new_size = SEXP_MAX_STACK_SIZE;
    }
    stack = sexp_alloc_tagged(ctx, (sexp_sizeof(stack)+sizeof(sexp)*new_size),
                              SEXP_STACK);
    if (!stack || sexp_exceptionp(stack))
      return 0;
    sexp_stack_length(stack) = new_size;
    sexp_stack_top(stack) = sexp_context_top(ctx);
    from = sexp_stack_data(old_stack);
    to = sexp_stack_data(stack);
    for (i=sexp_context_top(ctx)+1; i>=0; i--)
      to[i] = from[i];
    for (; ctx; ctx=sexp_context_parent(ctx))
      if (sexp_context_stack(ctx) == old_stack)
        sexp_context_stack(ctx) = stack;
    return 1;
  }
  #else
  #define sexp_grow_stack(ctx, min_size) 0
  #endif
  
  static sexp sexp_save_stack (sexp ctx, sexp *stack, sexp_uint_t to) {
    sexp res, *data;
    sexp_uint_t i;
    res = sexp_make_vector(ctx, sexp_make_fixnum(to), SEXP_VOID);
    data = sexp_vector_data(res);
    for (i=0; i<to; i++)
      data[i] = stack[i];
    return res;
  }
  
  static sexp sexp_restore_stack (sexp ctx, sexp saved) {
    sexp_uint_t len = sexp_vector_length(saved), i;
    sexp *from = sexp_vector_data(saved), *to;
  #if SEXP_USE_CHECK_STACK
    if ((len+64 >= sexp_stack_length(sexp_context_stack(ctx)))
        && !sexp_grow_stack(ctx, len+64))
      return sexp_global(ctx, SEXP_G_OOS_ERROR);
  #endif
    to = sexp_stack_data(sexp_context_stack(ctx));
    for (i=0; i<len; i++)
      to[i] = from[i];
    sexp_context_top(ctx) = len;
    return SEXP_VOID;
  }
  
  #define _ARG1 stack[top-1]
  #define _ARG2 stack[top-2]
  #define _ARG3 stack[top-3]
  #define _ARG4 stack[top-4]
  #define _ARG5 stack[top-5]
  #define _ARG6 stack[top-6]
  #define _PUSH(x) (stack[top++]=(x))
  #define _POP() (stack[--top])
  
  #if SEXP_USE_ALIGNED_BYTECODE
  #define _ALIGN_IP() ip = (unsigned char *)sexp_word_align((sexp_uint_t)ip)
  #else
  #define _ALIGN_IP()
  #endif
  
  #define _WORD0 ((sexp*)ip)[0]
  #define _UWORD0 ((sexp_uint_t*)ip)[0]
  #define _SWORD0 ((sexp_sint_t*)ip)[0]
  #define _WORD1 ((sexp*)ip)[1]
  #define _UWORD1 ((sexp_uint_t*)ip)[1]
  #define _SWORD1 ((sexp_sint_t*)ip)[1]
  #define _WORD2 ((sexp*)ip)[2]
  
  #define sexp_raise(msg, args)                                       \
    do {sexp_context_top(ctx) = top+1;                                \
        stack[top] = args;                                            \
        stack[top] = sexp_user_exception(ctx, self, msg, stack[top]); \
        top++;                                                        \
        goto call_error_handler;}                                     \
    while (0)
  
  #define sexp_check_exception()                                 \
    do {if (sexp_exceptionp(_ARG1)) {                            \
        goto call_error_handler;}}                               \
      while (0)
  
  static int sexp_check_type(sexp ctx, sexp a, sexp b) {
    int d;
    sexp t, v;
    if (! sexp_pointerp(a))
      return 0;
    if (sexp_isa(a, b))
      return 1;
    t = sexp_object_type(ctx, a);
    v = sexp_type_cpl(t);
    if (! sexp_vectorp(v))
      return 0;
    if (b == sexp_type_by_index(ctx, SEXP_OBJECT))
      return 1;
    d = sexp_type_depth(b);
    return (d < (int)sexp_vector_length(v))
      && sexp_vector_ref(v, sexp_make_fixnum(d)) == b;
  }
  
  #if SEXP_USE_GREEN_THREADS
  #define sexp_fcall_return(x, i)                             \
    if (sexp_exceptionp(x)) {                                 \
      if (x == sexp_global(ctx, SEXP_G_IO_BLOCK_ERROR)) {     \
        fuel = 0; ip--; goto loop;                            \
      } else if (x == sexp_global(ctx, SEXP_G_IO_BLOCK_ONCE_ERROR)) { \
        stack[top-i+1] = SEXP_ZERO;                                   \
        fuel = 0; ip--; goto loop;                            \
      } else {                                                \
        top -= i;                                             \
        _ARG1 = x;                                            \
        ip += sizeof(sexp);                                   \
        goto call_error_handler;                              \
      }                                                       \
    } else {                                                  \
      top -= i;                                               \
      _ARG1 = x;                                              \
      ip += sizeof(sexp);                                     \
    }
  #else
  #define sexp_fcall_return(x, i)                                 \
    top -= i; _ARG1 = x; ip += sizeof(sexp); sexp_check_exception();
  #endif
  
  #if SEXP_USE_EXTENDED_FCALL
  #include "opt/fcall.c"
  #endif
  
  #if SEXP_USE_PROFILE_VM
  sexp_uint_t profile1[SEXP_OP_NUM_OPCODES];
  sexp_uint_t profile2[SEXP_OP_NUM_OPCODES][SEXP_OP_NUM_OPCODES];
  
  sexp sexp_reset_vm_profile (sexp ctx, sexp self, sexp_sint_t n) {
    int i, j;
    for (i=0; i<SEXP_OP_NUM_OPCODES; i++) {
      profile1[i] = 0;
      for (j=0; j<SEXP_OP_NUM_OPCODES; j++) profile2[i][j] = 0;
    }
    return SEXP_VOID;
  }
  
  sexp sexp_print_vm_profile (sexp ctx, sexp self, sexp_sint_t n) {
    int i, j;
    for (i=0; i<SEXP_OP_NUM_OPCODES; i++)
      fprintf(stderr, "%s %lu\n", sexp_opcode_names[i], profile1[i]);
    for (i=0; i<SEXP_OP_NUM_OPCODES; i++)
      for (j=0; j<SEXP_OP_NUM_OPCODES; j++)
        fprintf(stderr, "%s %s %lu\n", sexp_opcode_names[i],
                sexp_opcode_names[j], profile2[i][j]);
    return SEXP_VOID;
  }
  #endif
  
  #if SEXP_USE_DEBUG_THREADS
  static const char* sexp_thread_debug_name(sexp ctx) {
    if (sexp_stringp(sexp_context_name(ctx)))
      return sexp_string_data(sexp_context_name(ctx));
    return "?";
  }
  
  static char* sexp_thread_debug_event_type(sexp ctx) {
    sexp evt = sexp_context_event(ctx);
    return sexp_portp(evt) ? "p" : sexp_contextp(evt) ? "c" : "?";
  }
  
  static void* sexp_thread_debug_event(sexp ctx) {
    return (void*)sexp_context_event(ctx);
  }
  #endif
  
  #if SEXP_USE_CHECK_STACK
  #define sexp_ensure_stack(n)                                            \
    if (top+(n) >= sexp_stack_length(sexp_context_stack(ctx))) {          \
      sexp_context_top(ctx) = top;                                        \
      if (sexp_grow_stack(ctx, (n))) {                                    \
        stack = sexp_stack_data(sexp_context_stack(ctx));                 \
      } else {                                                            \
        _ARG1 = sexp_global(ctx, SEXP_G_OOS_ERROR);                       \
        goto end_loop;                                                    \
      }                                                                   \
    }
  #else
  #define sexp_ensure_stack(n)
  #endif
  
  /* used only when no thread scheduler has been loaded */
  #if SEXP_USE_POLL_PORT
  int sexp_poll_port(sexp ctx, sexp port, int inputp) {
    fd_set fds;
    int fd = sexp_port_fileno(port);
    if (fd < 0) {
      usleep(SEXP_POLL_SLEEP_TIME);
      return -1;
    }
    FD_ZERO(&fds);
    FD_SET(fd, &fds);
    return select(1, (inputp ? &fds : NULL), (inputp ? NULL : &fds), NULL, NULL);
  }
  #endif
  
  sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
    unsigned char *ip;
    sexp bc, cp, *stack = sexp_stack_data(sexp_context_stack(ctx));
    sexp_sint_t i, j, k, fp, top = sexp_stack_top(sexp_context_stack(ctx));
  #if SEXP_USE_GREEN_THREADS
    sexp root_thread = ctx;
    sexp_sint_t fuel = sexp_context_refuel(ctx);
  #endif
  #if SEXP_USE_PROFILE_VM
    unsigned char last_op = SEXP_OP_NOOP;
  #endif
  #if SEXP_USE_BIGNUMS
    sexp_lsint_t prod;
  #endif
    sexp_gc_var3(self, tmp1, tmp2);
    sexp_gc_preserve3(ctx, self, tmp1, tmp2);
    fp = top - 4;
    self = sexp_global(ctx, SEXP_G_FINAL_RESUMER);
    bc = sexp_procedure_code(self);
    cp = sexp_procedure_vars(self);
    ip = sexp_bytecode_data(bc) - sizeof(sexp);
    tmp1 = proc, tmp2 = args;
    i = sexp_unbox_fixnum(sexp_length(ctx, tmp2));
    sexp_ensure_stack(i + 64 + (sexp_procedurep(tmp1) ? sexp_bytecode_max_depth(sexp_procedure_code(tmp1)) : 0));
    for (top += i; sexp_pairp(tmp2); tmp2=sexp_cdr(tmp2), top--)
      _ARG1 = sexp_car(tmp2);
    top += i+1;
    goto make_call;
  
   loop:
  #if SEXP_USE_GREEN_THREADS
    if (--fuel <= 0) {
      tmp1 = sexp_global(ctx, SEXP_G_THREADS_SCHEDULER);
      if (sexp_applicablep(tmp1) && sexp_not(sexp_global(ctx, SEXP_G_ATOMIC_P))) {
        /* save thread */
        sexp_context_top(ctx) = top;
        sexp_context_ip(ctx) = ip;
        sexp_context_last_fp(ctx) = fp;
        sexp_context_proc(ctx) = self;
        /* run scheduler */
  #if SEXP_USE_DEBUG_THREADS
        tmp2 = ctx;
  #endif
        ctx = sexp_apply1(ctx, tmp1, root_thread);
        /* restore thread */
        stack = sexp_stack_data(sexp_context_stack(ctx));
        top = sexp_context_top(ctx);
        fp = sexp_context_last_fp(ctx);
        ip = sexp_context_ip(ctx);
        self = sexp_context_proc(ctx);
        bc = sexp_procedure_code(self);
        cp = sexp_procedure_vars(self);
  #if SEXP_USE_DEBUG_THREADS
        if (ctx != tmp2) {
          fprintf(stderr, "****** schedule %p: %p (%s) active:",
                  root_thread, ctx, sexp_thread_debug_name(ctx));
          for (tmp1=sexp_global(ctx, SEXP_G_THREADS_FRONT); sexp_pairp(tmp1); tmp1=sexp_cdr(tmp1))
            fprintf(stderr, " %p (%s)", sexp_car(tmp1), sexp_thread_debug_name(sexp_car(tmp1)));
          fprintf(stderr, " paused:");
          for (tmp1=sexp_global(ctx, SEXP_G_THREADS_PAUSED); sexp_pairp(tmp1); tmp1=sexp_cdr(tmp1))
            fprintf(stderr, " %p (%s) [%s %p]", sexp_car(tmp1), sexp_thread_debug_name(sexp_car(tmp1)), sexp_thread_debug_event_type(sexp_car(tmp1)), sexp_thread_debug_event(sexp_car(tmp1)));
          fprintf(stderr, " ******\n");
        }
  #endif
      }
      fuel = sexp_context_refuel(ctx);
      if (fuel <= 0) goto end_loop;
    }
  #endif
  #if SEXP_USE_DEBUG_VM
    if (sexp_context_tracep(ctx)) {
      sexp_print_stack(ctx, stack, top, fp, SEXP_FALSE);
      fprintf(stderr, "****** VM %s %s ip: %p stack: %p top: %ld fp: %ld (%ld)\n",
              (*ip<=SEXP_OP_NUM_OPCODES) ? sexp_opcode_names[*ip] : "UNKNOWN",
              (SEXP_OP_FCALL0 <= *ip && *ip <= SEXP_OP_FCALL4
               ? sexp_string_data(sexp_opcode_name(((sexp*)(ip+1))[0])) : ""),
              ip, stack, top, fp, (fp<1024 ? sexp_unbox_fixnum(stack[fp+3]) : -1));
    }
  #endif
  #if SEXP_USE_PROFILE_VM
    profile1[*ip]++;
    profile2[last_op][*ip]++;
    last_op = *ip;
  #endif
    switch (*ip++) {
    case SEXP_OP_NOOP:
      break;
    call_error_handler:
      if (! sexp_exception_procedure(_ARG1))
        sexp_exception_procedure(_ARG1) = self;
  #if SEXP_USE_FULL_SOURCE_INFO
      if (sexp_not(sexp_exception_source(_ARG1))
          && sexp_procedurep(sexp_exception_procedure(_ARG1))
          && sexp_procedure_source(sexp_exception_procedure(_ARG1)))
        sexp_exception_source(_ARG1) = sexp_lookup_source_info(sexp_exception_procedure(_ARG1), (ip-sexp_bytecode_data(bc)));
  #endif
    case SEXP_OP_RAISE:
      sexp_context_top(ctx) = top;
      if (sexp_trampolinep(_ARG1)) {
        tmp1 = sexp_trampoline_procedure(_ARG1);
        tmp2 = sexp_trampoline_args(_ARG1);
        if (sexp_trampoline_abortp(_ARG1)) {      /* abort - do not catch */
          _ARG1 = tmp2;
          goto end_loop;
        }
        top--;
        if (sexp_not(tmp1) && sexp_pairp(tmp2)) { /* noop trampoline is */
          _PUSH(sexp_car(tmp2));                  /* a wrapped exception */
          goto loop;
        }
        goto apply1;
      }
      tmp1 = sexp_parameter_ref(ctx, sexp_global(ctx, SEXP_G_ERR_HANDLER));
      sexp_context_last_fp(ctx) = fp;
      if (! sexp_procedurep(tmp1)) {
  #if SEXP_USE_GREEN_THREADS
        sexp_context_errorp(ctx) = 1;
  #endif
        goto end_loop;
      }
      stack[top] = SEXP_ONE;
      stack[top+1] = sexp_make_fixnum(ip-sexp_bytecode_data(bc));
      stack[top+2] = self;
      stack[top+3] = sexp_make_fixnum(fp);
      top += 4;
      self = tmp1;
      bc = sexp_procedure_code(self);
      ip = sexp_bytecode_data(bc);
      cp = sexp_procedure_vars(self);
      fp = top-4;
      break;
    case SEXP_OP_RESUMECC:
      sexp_context_top(ctx) = top;
      tmp1 = stack[fp-1];
      tmp2 = sexp_restore_stack(ctx, sexp_vector_ref(cp, 0));
      if (sexp_exceptionp(tmp2)) {_ARG1 = tmp2; goto call_error_handler;}
      top = sexp_context_top(ctx);
      fp = sexp_unbox_fixnum(_ARG1);
      self = _ARG2;
      bc = sexp_procedure_code(self);
      cp = sexp_procedure_vars(self);
      ip = sexp_bytecode_data(bc) + sexp_unbox_fixnum(_ARG3);
      top -= 4;
      _ARG1 = tmp1;
      break;
    case SEXP_OP_CALLCC:
      stack[top] = SEXP_ONE;
      stack[top+1] = sexp_make_fixnum(ip-sexp_bytecode_data(bc));
      stack[top+2] = self;
      stack[top+3] = sexp_make_fixnum(fp);
      tmp1 = _ARG1;
      i = 1;
      sexp_context_top(ctx) = top;
      tmp2 = sexp_make_vector(ctx, SEXP_ONE, SEXP_UNDEF);
      sexp_vector_set(tmp2, SEXP_ZERO, sexp_save_stack(ctx, stack, top+4));
      _ARG1 = sexp_make_procedure(ctx,
                                  SEXP_ZERO,
                                  SEXP_ONE,
                                  sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE),
                                  tmp2);
      top++;
      ip -= sizeof(sexp);
      goto make_call;
    case SEXP_OP_APPLY1:
      tmp1 = _ARG1;
      tmp2 = _ARG2;
    apply1:
      i = sexp_unbox_fixnum(sexp_length(ctx, tmp2)); /* number of params */
      sexp_ensure_stack(i + 64 + (sexp_procedurep(tmp1) ? sexp_bytecode_max_depth(sexp_procedure_code(tmp1)) : 0));
      k = sexp_unbox_fixnum(stack[fp+3]);            /* previous fp */
      j = sexp_unbox_fixnum(stack[fp]);              /* previous num params */
      self = stack[fp+2];
      bc = sexp_procedure_code(self);
      cp = sexp_procedure_vars(self);
      ip = (sexp_bytecode_data(bc)+sexp_unbox_fixnum(stack[fp+1])) - sizeof(sexp);
      {
        int prev_top = top;
        for (top=fp-j+i-1; sexp_pairp(tmp2); tmp2=sexp_cdr(tmp2), top--)
          stack[top] = sexp_car(tmp2);
        top = fp+i-j+1;
        fp = k;
        /* if final cdr of tmp2 isn't null, then args list was improper */
        if (! sexp_nullp(tmp2)) {
          top = prev_top;
          sexp_raise("apply: improper args list", sexp_list1(ctx, stack[prev_top-2]));
        }
      }
      goto make_call;
    case SEXP_OP_TAIL_CALL:
      _ALIGN_IP();
      i = sexp_unbox_fixnum(_WORD0);             /* number of params */
      tmp1 = _ARG1;                              /* procedure to call */
      /* save frame info */
      tmp2 = stack[fp+3];                        /* previous fp */
      j = sexp_unbox_fixnum(stack[fp]);          /* previous num params */
      self = stack[fp+2];
      bc = sexp_procedure_code(self);
      cp = sexp_procedure_vars(self);
      ip = (sexp_bytecode_data(bc)+sexp_unbox_fixnum(stack[fp+1])) - sizeof(sexp);
      /* copy new args into place */
      for (k=0; k<i; k++)
        stack[fp-j+k] = stack[top-1-i+k];
      top = fp+i-j+1;
      fp = sexp_unbox_fixnum(tmp2);
      goto make_call;
    case SEXP_OP_CALL:
      _ALIGN_IP();
      i = sexp_unbox_fixnum(_WORD0);
      tmp1 = _ARG1;
    make_call:
      sexp_context_top(ctx) = top;
      if (sexp_opcodep(tmp1)) {
        /* compile non-inlined opcode applications on the fly */
        tmp1 = make_opcode_procedure(ctx, tmp1, i);
        if (sexp_exceptionp(tmp1)) {
          _ARG1 = tmp1;
          goto call_error_handler;
        }
      }
      if (! sexp_procedurep(tmp1))
        sexp_raise("non procedure application", sexp_list1(ctx, tmp1));
      j = i - sexp_procedure_num_args(tmp1);
      if (j < 0)
        sexp_raise("not enough args",
                   sexp_list2(ctx, tmp1, sexp_make_fixnum(i)));
      /* ensure there's sufficient stack space before pushing args */
      sexp_ensure_stack(sexp_bytecode_max_depth(sexp_procedure_code(tmp1))+64);
      if (j > 0) {
        if (sexp_procedure_variadic_p(tmp1)) {
          if (!sexp_procedure_unused_rest_p(tmp1)) {
            stack[top-i-1] = sexp_cons(ctx, stack[top-i-1], SEXP_NULL);
            for (k=top-i; k<top-(i-j)-1; k++)
              stack[top-i-1] = sexp_cons(ctx, stack[k], stack[top-i-1]);
            for ( ; k<top; k++)
              stack[k-j+1] = stack[k];
            top -= (j-1);
            i -= (j-1);
          }
        } else {
          sexp_raise("too many args", sexp_list2(ctx, tmp1, sexp_make_fixnum(i)));
        }
      } else if (sexp_procedure_variadic_p(tmp1) &&
                 !sexp_procedure_unused_rest_p(tmp1)) {
        /* shift stack, set extra arg to null */
        for (k=top; k>=top-i; k--)
          stack[k] = stack[k-1];
        stack[top-i-1] = SEXP_NULL;
        top++;
        i++;
      }
      _ARG1 = sexp_make_fixnum(i);
      stack[top] = sexp_make_fixnum(ip+sizeof(sexp)-sexp_bytecode_data(bc));
      stack[top+1] = self;
      stack[top+2] = sexp_make_fixnum(fp);
      top += 3;
      self = tmp1;
      bc = sexp_procedure_code(self);
      ip = sexp_bytecode_data(bc);
      cp = sexp_procedure_vars(self);
      fp = top-4;
      break;
    case SEXP_OP_FCALL0:
      _ALIGN_IP();
      sexp_context_top(ctx) = top;
      sexp_context_last_fp(ctx) = fp;
      tmp1 = ((sexp_proc1)sexp_opcode_func(_WORD0))(ctx, _WORD0, 0);
      sexp_fcall_return(tmp1, -1)
      break;
    case SEXP_OP_FCALL1:
      _ALIGN_IP();
      sexp_context_top(ctx) = top;
      sexp_context_last_fp(ctx) = fp;
      tmp1 = ((sexp_proc2)sexp_opcode_func(_WORD0))(ctx, _WORD0, 1, _ARG1);
      sexp_fcall_return(tmp1, 0)
      break;
    case SEXP_OP_FCALL2:
      _ALIGN_IP();
      sexp_context_top(ctx) = top;
      sexp_context_last_fp(ctx) = fp;
      tmp1 = ((sexp_proc3)sexp_opcode_func(_WORD0))(ctx, _WORD0, 2, _ARG1, _ARG2);
      sexp_fcall_return(tmp1, 1)
      break;
    case SEXP_OP_FCALL3:
      _ALIGN_IP();
      sexp_context_top(ctx) = top;
      sexp_context_last_fp(ctx) = fp;
      tmp1 = ((sexp_proc4)sexp_opcode_func(_WORD0))(ctx, _WORD0, 3, _ARG1, _ARG2, _ARG3);
      sexp_fcall_return(tmp1, 2)
      break;
    case SEXP_OP_FCALL4:
      _ALIGN_IP();
      sexp_context_top(ctx) = top;
      sexp_context_last_fp(ctx) = fp;
      tmp1 = ((sexp_proc5)sexp_opcode_func(_WORD0))(ctx, _WORD0, 4, _ARG1, _ARG2, _ARG3, _ARG4);
      sexp_fcall_return(tmp1, 3)
      break;
  #if SEXP_USE_EXTENDED_FCALL
    case SEXP_OP_FCALLN:
      _ALIGN_IP();
      sexp_context_top(ctx) = top;
      sexp_context_last_fp(ctx) = fp;
      i = sexp_opcode_num_args(_WORD0);
      tmp1 = sexp_fcall(ctx, self, i, _WORD0);
      sexp_fcall_return(tmp1, i-1)
      break;
  #endif
    case SEXP_OP_JUMP_UNLESS:
      _ALIGN_IP();
      if (stack[--top] == SEXP_FALSE)
        ip += _SWORD0;
      else
        ip += sizeof(sexp_sint_t);
      break;
    case SEXP_OP_JUMP:
      _ALIGN_IP();
      ip += _SWORD0;
      break;
    case SEXP_OP_PUSH:
      _ALIGN_IP();
      _PUSH(_WORD0);
      ip += sizeof(sexp);
      break;
  #if SEXP_USE_RESERVE_OPCODE
    case SEXP_OP_RESERVE:
      _ALIGN_IP();
      for (i=_SWORD0; i > 0; i--)
        stack[top++] = SEXP_VOID;
      ip += sizeof(sexp);
      break;
  #endif
    case SEXP_OP_DROP:
      top--;
      break;
    case SEXP_OP_GLOBAL_REF:
      _ALIGN_IP();
      if (sexp_cdr(_WORD0) == SEXP_UNDEF) {
        /* handle renamed forward references by doing a final delayed */
        /* lookup before throwing an undefined variable error */
        if (sexp_synclop(sexp_car(_WORD0))) {
          tmp1 = sexp_env_cell(ctx, sexp_synclo_env(sexp_car(_WORD0)), sexp_synclo_expr(sexp_car(_WORD0)), 0);
          if (tmp1 != NULL) _WORD0 = tmp1;
        }
        if (sexp_cdr(_WORD0) == SEXP_UNDEF)
          sexp_raise("undefined variable", sexp_list1(ctx, sexp_car(_WORD0)));
      }
      /* ... FALLTHROUGH ... */
    case SEXP_OP_GLOBAL_KNOWN_REF:
      _ALIGN_IP();
      _PUSH(sexp_cdr(_WORD0));
      ip += sizeof(sexp);
      break;
  #if SEXP_USE_GREEN_THREADS
    case SEXP_OP_PARAMETER_REF:
      _ALIGN_IP();
      sexp_context_top(ctx) = top;
      tmp2 = _WORD0;
      ip += sizeof(sexp);
      for (tmp1=sexp_context_params(ctx); sexp_pairp(tmp1); tmp1=sexp_cdr(tmp1))
        if (sexp_caar(tmp1) == tmp2) {
          _PUSH(sexp_car(tmp1));
          goto loop;
        }
      _PUSH(sexp_opcode_data(tmp2));
      break;
  #endif
    case SEXP_OP_STACK_REF:
      _ALIGN_IP();
      stack[top] = stack[top - _SWORD0];
      ip += sizeof(sexp);
      top++;
      break;
    case SEXP_OP_LOCAL_REF:
      _ALIGN_IP();
      stack[top] = stack[fp - 1 - _SWORD0];
      ip += sizeof(sexp);
      top++;
      break;
    case SEXP_OP_LOCAL_SET:
      _ALIGN_IP();
      stack[fp - 1 - _SWORD0] = _POP();
      ip += sizeof(sexp);
      break;
    case SEXP_OP_CLOSURE_REF:
      _ALIGN_IP();
      _PUSH(sexp_vector_ref(cp, sexp_make_fixnum(_SWORD0)));
      ip += sizeof(sexp);
      break;
    case SEXP_OP_CLOSURE_VARS:
      _ARG1 = sexp_procedure_vars(_ARG1);
      break;
    case SEXP_OP_VECTOR_REF:
      if (! sexp_vectorp(_ARG1))
        sexp_raise("vector-ref: not a vector", sexp_list1(ctx, _ARG1));
      else if (! sexp_fixnump(_ARG2))
        sexp_raise("vector-ref: not an integer", sexp_list1(ctx, _ARG2));
      i = sexp_unbox_fixnum(_ARG2);
      if ((i < 0) || (i >= (sexp_sint_t)sexp_vector_length(_ARG1)))
        sexp_raise("vector-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
      _ARG2 = sexp_vector_ref(_ARG1, _ARG2);
      top--;
      break;
    case SEXP_OP_VECTOR_SET:
      if (! sexp_vectorp(_ARG1))
        sexp_raise("vector-set!: not a vector", sexp_list1(ctx, _ARG1));
      else if (sexp_immutablep(_ARG1))
        sexp_raise("vector-set!: immutable vector", sexp_list1(ctx, _ARG1));
      else if (! sexp_fixnump(_ARG2))
        sexp_raise("vector-set!: not an integer", sexp_list1(ctx, _ARG2));
      i = sexp_unbox_fixnum(_ARG2);
      if ((i < 0) || (i >= (sexp_sint_t)sexp_vector_length(_ARG1)))
        sexp_raise("vector-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
      sexp_vector_set(_ARG1, _ARG2, _ARG3);
      top-=3;
      break;
    case SEXP_OP_VECTOR_LENGTH:
      if (! sexp_vectorp(_ARG1))
        sexp_raise("vector-length: not a vector", sexp_list1(ctx, _ARG1));
      _ARG1 = sexp_make_fixnum(sexp_vector_length(_ARG1));
      break;
    case SEXP_OP_BYTES_REF:
      if (! sexp_bytesp(_ARG1))
        sexp_raise("byte-vector-ref: not a byte-vector", sexp_list1(ctx, _ARG1));
      if (! sexp_fixnump(_ARG2))
        sexp_raise("byte-vector-ref: not an integer", sexp_list1(ctx, _ARG2));
      i = sexp_unbox_fixnum(_ARG2);
      if ((i < 0) || (i >= (sexp_sint_t)sexp_bytes_length(_ARG1)))
        sexp_raise("byte-vector-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
      _ARG2 = sexp_bytes_ref(_ARG1, _ARG2);
      top--;
      break;
    case SEXP_OP_STRING_REF:
      if (! sexp_stringp(_ARG1))
        sexp_raise("string-cursor-ref: not a string", sexp_list1(ctx, _ARG1));
      else if (! sexp_string_cursorp(_ARG2))
        sexp_raise("string-cursor-ref: not a string-cursor", sexp_list1(ctx, _ARG2));
      i = sexp_unbox_string_cursor(_ARG2);
      if ((i < 0) || (i >= (sexp_sint_t)sexp_string_size(_ARG1)))
        sexp_raise("string-ref: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
      _ARG2 = sexp_string_cursor_ref(ctx, _ARG1, _ARG2);
      top--;
      sexp_check_exception();
      break;
    case SEXP_OP_BYTES_SET:
      if (! sexp_bytesp(_ARG1))
        sexp_raise("byte-vector-set!: not a byte-vector", sexp_list1(ctx, _ARG1));
      else if (sexp_immutablep(_ARG1))
        sexp_raise("byte-vector-set!: immutable byte-vector", sexp_list1(ctx, _ARG1));
      else if (! sexp_fixnump(_ARG2))
        sexp_raise("byte-vector-set!: not an integer", sexp_list1(ctx, _ARG2));
      else if (!(sexp_fixnump(_ARG3) && sexp_unbox_fixnum(_ARG3)>=0
                 && sexp_unbox_fixnum(_ARG3)<0x100))
        sexp_raise("byte-vector-set!: not an octet", sexp_list1(ctx, _ARG3));
      i = sexp_unbox_fixnum(_ARG2);
      if ((i < 0) || (i >= (sexp_sint_t)sexp_bytes_length(_ARG1)))
        sexp_raise("byte-vector-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
      sexp_bytes_set(_ARG1, _ARG2, _ARG3);
      top-=3;
      break;
  #if SEXP_USE_MUTABLE_STRINGS
    case SEXP_OP_STRING_SET:
      if (! sexp_stringp(_ARG1))
        sexp_raise("string-cursor-set!: not a string", sexp_list1(ctx, _ARG1));
      else if (sexp_immutablep(_ARG1))
        sexp_raise("string-cursor-set!: immutable string", sexp_list1(ctx, _ARG1));
      else if (! sexp_string_cursorp(_ARG2))
        sexp_raise("string-cursor-set!: not a string-cursor", sexp_list1(ctx, _ARG2));
      else if (! sexp_charp(_ARG3))
        sexp_raise("string-cursor-set!: not a char", sexp_list1(ctx, _ARG3));
      i = sexp_unbox_string_cursor(_ARG2);
      if ((i < 0) || (i >= (sexp_sint_t)sexp_string_size(_ARG1)))
        sexp_raise("string-cursor-set!: index out of range", sexp_list2(ctx, _ARG1, _ARG2));
      sexp_context_top(ctx) = top;
      sexp_string_set(ctx, _ARG1, _ARG2, _ARG3);
      top-=3;
      break;
  #endif
  #if SEXP_USE_UTF8_STRINGS
    case SEXP_OP_STRING_CURSOR_NEXT:
      if (! sexp_stringp(_ARG1))
        sexp_raise("string-cursor-next: not a string", sexp_list1(ctx, _ARG1));
      else if (! sexp_string_cursorp(_ARG2))
        sexp_raise("string-cursor-next: not a string-cursor", sexp_list1(ctx, _ARG2));
      _ARG2 = sexp_string_cursor_next(_ARG1, _ARG2);
      top--;
      sexp_check_exception();
      break;
    case SEXP_OP_STRING_CURSOR_PREV:
      if (! sexp_stringp(_ARG1))
        sexp_raise("string-cursor-prev: not a string", sexp_list1(ctx, _ARG1));
      else if (! sexp_string_cursorp(_ARG2))
        sexp_raise("string-cursor-prev: not a string-cursor", sexp_list1(ctx, _ARG2));
      _ARG2 = sexp_string_cursor_prev(_ARG1, _ARG2);
      top--;
      sexp_check_exception();
      break;
    case SEXP_OP_STRING_CURSOR_END:
      if (! sexp_stringp(_ARG1))
        sexp_raise("string-cursor-end: not a string", sexp_list1(ctx, _ARG1));
      _ARG1 = sexp_make_string_cursor(sexp_string_size(_ARG1));
      break;
  #endif
    case SEXP_OP_BYTES_LENGTH:
      if (! sexp_bytesp(_ARG1))
        sexp_raise("bytes-length: not a byte-vector", sexp_list1(ctx, _ARG1));
      _ARG1 = sexp_make_fixnum(sexp_bytes_length(_ARG1));
      break;
    case SEXP_OP_STRING_LENGTH:
      if (! sexp_stringp(_ARG1))
        sexp_raise("string-length: not a string", sexp_list1(ctx, _ARG1));
      _ARG1 = sexp_make_fixnum(sexp_string_length(_ARG1));
      break;
    case SEXP_OP_MAKE_PROCEDURE:
      sexp_context_top(ctx) = top;
      _ALIGN_IP();
      _ARG1 = sexp_make_procedure(ctx, _WORD0, _WORD1, _WORD2, _ARG1);
      ip += (3 * sizeof(sexp));
      break;
    case SEXP_OP_MAKE_VECTOR:
      sexp_context_top(ctx) = top;
      if (! sexp_fixnump(_ARG1))
        sexp_raise("make-vector: not an integer", sexp_list1(ctx, _ARG1));
      if (sexp_unbox_fixnum(_ARG1) < 0)
        sexp_raise("make-vector: length must be non-negative", sexp_list1(ctx, _ARG1));
      _ARG2 = sexp_make_vector(ctx, _ARG1, _ARG2);
      top--;
      break;
    case SEXP_OP_MAKE_EXCEPTION:
      sexp_context_top(ctx) = top;
      _ARG5 = sexp_make_exception(ctx, _ARG1, _ARG2, _ARG3, _ARG4, _ARG5);
      top -= 4;
      break;
    case SEXP_OP_AND:
      _ARG2 = sexp_make_boolean((_ARG1 != SEXP_FALSE) && (_ARG2 != SEXP_FALSE));
      top--;
      break;
    case SEXP_OP_EOFP:
      _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break;
    case SEXP_OP_NULLP:
      _ARG1 = sexp_make_boolean(sexp_nullp(_ARG1)); break;
    case SEXP_OP_FIXNUMP:
      _ARG1 = sexp_make_boolean(sexp_fixnump(_ARG1)); break;
    case SEXP_OP_SYMBOLP:
      _ARG1 = sexp_make_boolean(sexp_symbolp(_ARG1)); break;
    case SEXP_OP_CHARP:
      _ARG1 = sexp_make_boolean(sexp_charp(_ARG1)); break;
    case SEXP_OP_ISA:
      tmp1 = _ARG1, tmp2 = _ARG2;
      if (! sexp_typep(tmp2)) sexp_raise("is-a?: not a type", tmp2);
      top--;
      goto do_check_type;
    case SEXP_OP_TYPEP:
      _ALIGN_IP();
      tmp1 = _ARG1, tmp2 = sexp_type_by_index(ctx, _UWORD0);
      ip += sizeof(sexp);
    do_check_type:
      _ARG1 = sexp_make_boolean(sexp_check_type(ctx, tmp1, tmp2));
      break;
    case SEXP_OP_MAKE:
      _ALIGN_IP();
      sexp_context_top(ctx) = top;
      _PUSH(sexp_alloc_tagged(ctx, _UWORD1, _UWORD0));
      /* initialize fields to void */
      for (i=(_UWORD1-sexp_sizeof_header)/sizeof(sexp_uint_t) - 1; i>=0; i--)
        sexp_slot_set(_ARG1, i, SEXP_VOID);
      ip += sizeof(sexp)*2;
      break;
    case SEXP_OP_SLOT_REF:
      _ALIGN_IP();
      if (! sexp_check_type(ctx, _ARG1, sexp_type_by_index(ctx, _UWORD0)))
        sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_type_name_by_index(ctx, _UWORD0), _ARG1));
      _ARG1 = sexp_slot_ref(_ARG1, _UWORD1);
      ip += sizeof(sexp)*2;
      break;
    case SEXP_OP_SLOT_SET:
      _ALIGN_IP();
      if (! sexp_check_type(ctx, _ARG1, sexp_type_by_index(ctx, _UWORD0)))
        sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_type_name_by_index(ctx, _UWORD0), _ARG1));
      else if (sexp_immutablep(_ARG1))
        sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1));
      sexp_slot_set(_ARG1, _UWORD1, _ARG2);
      ip += sizeof(sexp)*2;
      top-=2;
      break;
    case SEXP_OP_SLOTN_REF:
      if (! sexp_typep(_ARG1))
        sexp_raise("slotn-ref: not a record type", sexp_list1(ctx, _ARG1));
      else if (! sexp_check_type(ctx, _ARG2, _ARG1))
        sexp_raise("slotn-ref: bad type", sexp_list1(ctx, _ARG2));
      if (! sexp_fixnump(_ARG3))
        for (i = 0, tmp1 = sexp_type_slots(_ARG1); sexp_pairp(tmp1); tmp1 = sexp_cdr(tmp1), ++i)
          if (sexp_car(tmp1) == _ARG3) { _ARG3 = sexp_make_fixnum(i); break; }
      if (! sexp_fixnump(_ARG3))
        sexp_raise("slotn-ref: not an integer", sexp_list1(ctx, _ARG3));
      if (sexp_vectorp(sexp_type_getters(_ARG1))) {
        if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= (sexp_sint_t)sexp_vector_length(sexp_type_getters(_ARG1)))
          sexp_raise("slotn-ref: slot out of bounds", sexp_list2(ctx, _ARG3, sexp_make_fixnum(sexp_type_field_len_base(_ARG1))));
        tmp1 = sexp_vector_ref(sexp_type_getters(_ARG1), _ARG3);
        if (sexp_opcodep(tmp1))
          _ARG3 = ((sexp_proc2)sexp_opcode_func(tmp1))(ctx, tmp1, 1, _ARG2);
        else
          sexp_raise("slotn-ref: no getter defined", sexp_list1(ctx, _ARG3));
      } else {
        if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= sexp_type_field_len_base(_ARG1))
          sexp_raise("slotn-ref: slot out of bounds", sexp_list2(ctx, _ARG3, sexp_make_fixnum(sexp_type_field_len_base(_ARG1))));
        _ARG3 = sexp_slot_ref(_ARG2, sexp_unbox_fixnum(_ARG3));
      }
      top-=2;
      if (!_ARG1) _ARG1 = SEXP_VOID;
      else sexp_check_exception();
      break;
    case SEXP_OP_SLOTN_SET:
      if (! sexp_typep(_ARG1))
        sexp_raise("slotn-set!: not a record type", sexp_list1(ctx, _ARG1));
      else if (! sexp_check_type(ctx, _ARG2, _ARG1))
        sexp_raise("slotn-set!: bad type", sexp_list1(ctx, _ARG2));
      else if (sexp_immutablep(_ARG2))
        sexp_raise("slotn-set!: immutable object", sexp_list1(ctx, _ARG2));
      if (! sexp_fixnump(_ARG3))
        for (i = 0, tmp1 = sexp_type_slots(_ARG1); sexp_pairp(tmp1); tmp1 = sexp_cdr(tmp1), ++i)
          if (sexp_car(tmp1) == _ARG3) { _ARG3 = sexp_make_fixnum(i); break; }
      if (! sexp_fixnump(_ARG3))
        sexp_raise("slotn-set!: not an integer", sexp_list1(ctx, _ARG3));
      if (sexp_vectorp(sexp_type_setters(_ARG1))) {
        if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= (sexp_sint_t)sexp_vector_length(sexp_type_setters(_ARG1)))
          sexp_raise("slotn-set!: slot out of bounds", sexp_list2(ctx, _ARG3, sexp_make_fixnum(sexp_type_field_len_base(_ARG1))));
        tmp1 = sexp_vector_ref(sexp_type_setters(_ARG1), _ARG3);
        if (sexp_opcodep(tmp1))
          _ARG4 = ((sexp_proc3)sexp_opcode_func(tmp1))(ctx, tmp1, 2, _ARG2, _ARG4);
        else
          sexp_raise("slotn-set!: no setter defined", sexp_list1(ctx, _ARG3));
      } else {
        if (sexp_unbox_fixnum(_ARG3) < 0 || sexp_unbox_fixnum(_ARG3) >= sexp_type_field_len_base(_ARG1))
          sexp_raise("slotn-set!: slot out of bounds", sexp_list2(ctx, _ARG3, sexp_make_fixnum(sexp_type_field_len_base(_ARG1))));
        sexp_slot_set(_ARG2, sexp_unbox_fixnum(_ARG3), _ARG4);
      }
      top-=4;
      sexp_check_exception();
      break;
    case SEXP_OP_CAR:
      if (! sexp_pairp(_ARG1))
        sexp_raise("car: not a pair", sexp_list1(ctx, _ARG1));
      _ARG1 = sexp_car(_ARG1); break;
    case SEXP_OP_CDR:
      if (! sexp_pairp(_ARG1))
        sexp_raise("cdr: not a pair", sexp_list1(ctx, _ARG1));
      _ARG1 = sexp_cdr(_ARG1); break;
    case SEXP_OP_SET_CAR:
      if (! sexp_pairp(_ARG1))
        sexp_raise("set-car!: not a pair", sexp_list1(ctx, _ARG1));
      else if (sexp_immutablep(_ARG1))
        sexp_raise("set-car!: immutable pair", sexp_list1(ctx, _ARG1));
      sexp_car(_ARG1) = _ARG2;
      top-=2;
      break;
    case SEXP_OP_SET_CDR:
      if (! sexp_pairp(_ARG1))
        sexp_raise("set-cdr!: not a pair", sexp_list1(ctx, _ARG1));
      else if (sexp_immutablep(_ARG1))
        sexp_raise("set-cdr!: immutable pair", sexp_list1(ctx, _ARG1));
      sexp_cdr(_ARG1) = _ARG2;
      top-=2;
      break;
    case SEXP_OP_CONS:
      sexp_context_top(ctx) = top;
      _ARG2 = sexp_cons(ctx, _ARG1, _ARG2);
      top--;
      break;
    case SEXP_OP_ADD:
      tmp1 = _ARG1, tmp2 = _ARG2;
      sexp_context_top(ctx) = --top;
  #if SEXP_USE_BIGNUMS
      if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
        j = sexp_unbox_fixnum(tmp1) + sexp_unbox_fixnum(tmp2);
        if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM))
          _ARG1 = sexp_add(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2);
        else
          _ARG1 = sexp_make_fixnum(j);
      }
      else {
        _ARG1 = sexp_add(ctx, tmp1, tmp2);
        sexp_check_exception();
      }
  #else
      if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2))
        _ARG1 = sexp_fx_add(tmp1, tmp2);
  #if SEXP_USE_FLONUMS
      else if (sexp_flonump(tmp1) && sexp_flonump(tmp2))
        _ARG1 = sexp_fp_add(ctx, tmp1, tmp2);
      else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2))
        _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) + (double)sexp_unbox_fixnum(tmp2));
      else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2))
        _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) + sexp_flonum_value(tmp2));
  #endif
      else sexp_raise("+: not a number", sexp_list2(ctx, tmp1, tmp2));
  #endif
      break;
    case SEXP_OP_SUB:
      tmp1 = _ARG1, tmp2 = _ARG2;
      sexp_context_top(ctx) = --top;
  #if SEXP_USE_BIGNUMS
      if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
        j = sexp_unbox_fixnum(tmp1) - sexp_unbox_fixnum(tmp2);
        if ((j < SEXP_MIN_FIXNUM) || (j > SEXP_MAX_FIXNUM))
          _ARG1 = sexp_sub(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2);
        else
          _ARG1 = sexp_make_fixnum(j);
      }
      else {
        _ARG1 = sexp_sub(ctx, tmp1, tmp2);
        sexp_check_exception();
      }
  #else
      if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2))
        _ARG1 = sexp_fx_sub(tmp1, tmp2);
  #if SEXP_USE_FLONUMS
      else if (sexp_flonump(tmp1) && sexp_flonump(tmp2))
        _ARG1 = sexp_fp_sub(ctx, tmp1, tmp2);
      else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2))
        _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) - (double)sexp_unbox_fixnum(tmp2));
      else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2))
        _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) - sexp_flonum_value(tmp2));
  #endif
      else sexp_raise("-: not a number", sexp_list2(ctx, tmp1, tmp2));
  #endif
      break;
    case SEXP_OP_MUL:
      tmp1 = _ARG1, tmp2 = _ARG2;
      sexp_context_top(ctx) = --top;
  #if SEXP_USE_BIGNUMS
      if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
        prod = lsint_mul_sint(lsint_from_sint(sexp_unbox_fixnum(tmp1)), sexp_unbox_fixnum(tmp2));
        if (!lsint_is_fixnum(prod))
          _ARG1 = sexp_mul(ctx, tmp1=sexp_fixnum_to_bignum(ctx, tmp1), tmp2);
        else
          _ARG1 = sexp_make_fixnum(lsint_to_sint(prod));
      }
      else {
        _ARG1 = sexp_mul(ctx, tmp1, tmp2);
        sexp_check_exception();
      }
  #else
      if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2))
        _ARG1 = sexp_fx_mul(tmp1, tmp2);
  #if SEXP_USE_FLONUMS
      else if (sexp_flonump(tmp1) && sexp_flonump(tmp2))
        _ARG1 = sexp_fp_mul(ctx, tmp1, tmp2);
      else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2))
        _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) * (double)sexp_unbox_fixnum(tmp2));
      else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2))
        _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) * sexp_flonum_value(tmp2));
  #endif
      else sexp_raise("*: not a number", sexp_list2(ctx, tmp1, tmp2));
  #endif
      break;
    case SEXP_OP_DIV:
      tmp1 = _ARG1, tmp2 = _ARG2;
      sexp_context_top(ctx) = --top;
      if (tmp2 == SEXP_ZERO) {
  #if SEXP_USE_FLONUMS
        if (sexp_flonump(tmp1) && sexp_flonum_value(tmp1) == 0.0)
          _ARG1 = sexp_make_flonum(ctx, 0.0);
        else
  #endif
          sexp_raise("divide by zero", SEXP_NULL);
      } else if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
  #if SEXP_USE_RATIOS
        _ARG1 = sexp_make_ratio(ctx, tmp1, tmp2);
        _ARG1 = sexp_ratio_normalize(ctx, _ARG1, SEXP_FALSE);
  #else
  #if SEXP_USE_FLONUMS
        tmp1 = sexp_fixnum_to_flonum(ctx, tmp1);
        tmp2 = sexp_fixnum_to_flonum(ctx, tmp2);
        _ARG1 = sexp_fp_div(ctx, tmp1, tmp2);
        if (sexp_flonum_value(_ARG1) == trunc(sexp_flonum_value(_ARG1)))
          _ARG1 = sexp_make_fixnum(sexp_flonum_value(_ARG1));
  #else
        _ARG1 = sexp_fx_div(tmp1, tmp2);
  #endif
  #endif
      }
  #if SEXP_USE_BIGNUMS
      else {
        _ARG1 = sexp_div(ctx, tmp1, tmp2);
        sexp_check_exception();
      }
  #else
  #if SEXP_USE_FLONUMS
      else if (sexp_flonump(tmp1) && sexp_flonump(tmp2))
        _ARG1 = sexp_fp_div(ctx, tmp1, tmp2);
      else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2))
        _ARG1 = sexp_make_flonum(ctx, sexp_flonum_value(tmp1) / (double)sexp_unbox_fixnum(tmp2));
      else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2))
        _ARG1 = sexp_make_flonum(ctx, (double)sexp_unbox_fixnum(tmp1) / sexp_flonum_value(tmp2));
  #endif
      else sexp_raise("/: not a number", sexp_list2(ctx, tmp1, tmp2));
  #endif
      break;
    case SEXP_OP_QUOTIENT:
      tmp1 = _ARG1, tmp2 = _ARG2;
      sexp_context_top(ctx) = --top;
      if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
        if (tmp2 == SEXP_ZERO)
          sexp_raise("divide by zero", SEXP_NULL);
        _ARG1 = sexp_fx_div(tmp1, tmp2);
      }
  #if SEXP_USE_BIGNUMS
      else {
        _ARG1 = sexp_quotient(ctx, tmp1, tmp2);
        sexp_check_exception();
      }
  #else
      else sexp_raise("quotient: not an integer", sexp_list2(ctx, _ARG1, tmp2));
  #endif
      break;
    case SEXP_OP_REMAINDER:
      tmp1 = _ARG1, tmp2 = _ARG2;
      sexp_context_top(ctx) = --top;
      if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
        if (tmp2 == SEXP_ZERO)
          sexp_raise("divide by zero", SEXP_NULL);
        _ARG1 = sexp_fx_rem(tmp1, tmp2);
      }
  #if SEXP_USE_BIGNUMS
      else {
        _ARG1 = sexp_remainder(ctx, tmp1, tmp2);
        sexp_check_exception();
      }
  #else
      else sexp_raise("remainder: not an integer", sexp_list2(ctx, _ARG1, tmp2));
  #endif
      break;
    case SEXP_OP_LT:
      tmp1 = _ARG1, tmp2 = _ARG2;
      sexp_context_top(ctx) = --top;
      if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
        i = (sexp_sint_t)tmp1 < (sexp_sint_t)tmp2;
  #if SEXP_USE_BIGNUMS
        _ARG1 = sexp_make_boolean(i);
      } else {
        _ARG1 = sexp_compare(ctx, tmp1, tmp2);
        if (sexp_exceptionp(_ARG1)) {
          if (strcmp("can't compare NaN", sexp_string_data(sexp_exception_message(_ARG1))) == 0)
            _ARG1 = SEXP_FALSE;
          else
            goto call_error_handler;
        } else {
          _ARG1 = sexp_make_boolean(sexp_unbox_fixnum(_ARG1) < 0);
        }
      }
  #else
  #if SEXP_USE_FLONUMS
      } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) {
        i = sexp_flonum_value(tmp1) < sexp_flonum_value(tmp2);
      } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) {
        i = sexp_flonum_value(tmp1) < (double)sexp_unbox_fixnum(tmp2); 
      } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) {
        i = (double)sexp_unbox_fixnum(tmp1) < sexp_flonum_value(tmp2);
  #endif
      } else sexp_raise("<: not a number", sexp_list2(ctx, tmp1, tmp2));
      _ARG1 = sexp_make_boolean(i);
  #endif
      break;
    case SEXP_OP_LE:
      tmp1 = _ARG1, tmp2 = _ARG2;
      sexp_context_top(ctx) = --top;
      if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
        i = (sexp_sint_t)tmp1 <= (sexp_sint_t)tmp2;
  #if SEXP_USE_BIGNUMS
        _ARG1 = sexp_make_boolean(i);
      } else {
        _ARG1 = sexp_compare(ctx, tmp1, tmp2);
        if (sexp_exceptionp(_ARG1)) {
          if (strcmp("can't compare NaN", sexp_string_data(sexp_exception_message(_ARG1))) == 0)
            _ARG1 = SEXP_FALSE;
          else
            goto call_error_handler;
        } else {
          _ARG1 = sexp_make_boolean(sexp_unbox_fixnum(_ARG1) <= 0);
        }
      }
  #else
  #if SEXP_USE_FLONUMS
      } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) {
        i = sexp_flonum_value(tmp1) <= sexp_flonum_value(tmp2);
      } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) {
        i = sexp_flonum_value(tmp1) <= (double)sexp_unbox_fixnum(tmp2);
      } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) {
        i = (double)sexp_unbox_fixnum(tmp1) <= sexp_flonum_value(tmp2);
  #endif
      } else sexp_raise("<=: not a number", sexp_list2(ctx, tmp1, tmp2));
      _ARG1 = sexp_make_boolean(i);
  #endif
      break;
    case SEXP_OP_EQN:
      tmp1 = _ARG1, tmp2 = _ARG2;
      sexp_context_top(ctx) = --top;
      if (sexp_fixnump(tmp1) && sexp_fixnump(tmp2)) {
        i = tmp1 == tmp2;
  #if SEXP_USE_BIGNUMS
        _ARG1 = sexp_make_boolean(i);
      } else {
  #if SEXP_USE_COMPLEX
        if (sexp_complexp(tmp1)) {
          if (sexp_flonump(sexp_complex_imag(tmp1))
              && sexp_flonum_value(sexp_complex_imag(tmp1)) == 0.0) {
            tmp1 = sexp_complex_real(tmp1);
          } else if (sexp_complexp(tmp2)) { /* both complex */
            _ARG1 = sexp_make_boolean(
              (sexp_compare(ctx, sexp_complex_real(tmp1), sexp_complex_real(tmp2))
               == SEXP_ZERO)
              && (sexp_compare(ctx, sexp_complex_imag(tmp1), sexp_complex_imag(tmp2))
                  == SEXP_ZERO));
            break;
          } else if (sexp_numberp(tmp2)) {
            _ARG1 = SEXP_FALSE;
            break;
          }
        }
        if (sexp_complexp(tmp2)) {
          if (sexp_flonump(sexp_complex_imag(tmp2))
              && sexp_flonum_value(sexp_complex_imag(tmp2)) == 0.0) {
            tmp2 = sexp_complex_real(tmp2);
          } else if (sexp_numberp(tmp1)) {
            _ARG1 = SEXP_FALSE;
            break;
          }
        }
  #endif
        /* neither is complex */
        _ARG1 = sexp_compare(ctx, tmp1, tmp2);
        if (sexp_exceptionp(_ARG1)) {
          if (strcmp("can't compare NaN", sexp_string_data(sexp_exception_message(_ARG1))) == 0)
            _ARG1 = SEXP_FALSE;
          else
            goto call_error_handler;
        } else {
          _ARG1 = sexp_make_boolean(_ARG1 == SEXP_ZERO);
        }
      }
  #else
  #if SEXP_USE_FLONUMS
      } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) {
        i = sexp_flonum_value(tmp1) == sexp_flonum_value(tmp2);
      } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) {
        i = sexp_flonum_value(tmp1) == (double)sexp_unbox_fixnum(tmp2);
      } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) {
        i = (double)sexp_unbox_fixnum(tmp1) == sexp_flonum_value(tmp2);
  #endif
      } else sexp_raise("=: not a number", sexp_list2(ctx, tmp1, tmp2));
      _ARG1 = sexp_make_boolean(i);
  #endif
      break;
    case SEXP_OP_EQ:
      _ARG2 = sexp_make_boolean(_ARG1 == _ARG2);
      top--;
      break;
    case SEXP_OP_SCP:
      _ARG1 = sexp_make_boolean(sexp_string_cursorp(_ARG1));
      break;
    case SEXP_OP_SC_LT:
      tmp1 = _ARG1, tmp2 = _ARG2;
      sexp_context_top(ctx) = --top;
      _ARG1 = sexp_make_boolean((sexp_sint_t)tmp1 < (sexp_sint_t)tmp2);
      break;
    case SEXP_OP_SC_LE:
      tmp1 = _ARG1, tmp2 = _ARG2;
      sexp_context_top(ctx) = --top;
      _ARG1 = sexp_make_boolean((sexp_sint_t)tmp1 <= (sexp_sint_t)tmp2);
      break;
    case SEXP_OP_CHAR2INT:
      if (! sexp_charp(_ARG1))
        sexp_raise("char->integer: not a character", sexp_list1(ctx, _ARG1));
      _ARG1 = sexp_make_fixnum(sexp_unbox_character(_ARG1));
      break;
    case SEXP_OP_INT2CHAR:
      if (! sexp_fixnump(_ARG1))
        sexp_raise("integer->char: not an integer", sexp_list1(ctx, _ARG1));
      _ARG1 = sexp_make_character(sexp_unbox_fixnum(_ARG1));
      break;
    case SEXP_OP_CHAR_UPCASE:
      if (! sexp_charp(_ARG1))
        sexp_raise("char-upcase: not a character", sexp_list1(ctx, _ARG1));
      _ARG1 = sexp_make_character(sexp_toupper(sexp_unbox_character(_ARG1)));
      break;
    case SEXP_OP_CHAR_DOWNCASE:
      if (! sexp_charp(_ARG1))
        sexp_raise("char-downcase: not a character", sexp_list1(ctx, _ARG1));
      _ARG1 = sexp_make_character(sexp_tolower(sexp_unbox_character(_ARG1)));
      break;
    case SEXP_OP_WRITE_CHAR:
      if (! sexp_charp(_ARG1))
        sexp_raise("write-char: not a character", sexp_list1(ctx, _ARG1));
      if (! sexp_oportp(_ARG2))
        sexp_raise("write-char: not an output-port", sexp_list1(ctx, _ARG2));
      sexp_context_top(ctx) = top;
  #if SEXP_USE_GREEN_THREADS
      errno = 0;
  #endif
  #if SEXP_USE_UTF8_STRINGS
      if (sexp_unbox_character(_ARG1) >= 0x80)
        i = sexp_write_utf8_char(ctx, sexp_unbox_character(_ARG1), _ARG2);
      else
  #endif
      i = sexp_write_char(ctx, sexp_unbox_character(_ARG1), _ARG2);
      if (i == EOF) {
        if (!sexp_port_openp(_ARG2))
          sexp_raise("write-char: port is closed", _ARG2);
        else
  #if SEXP_USE_GREEN_THREADS
        if ((sexp_port_stream(_ARG2) ? ferror(sexp_port_stream(_ARG2)) : 1)
            && (errno == EAGAIN)) {
          if (sexp_port_stream(_ARG2)) clearerr(sexp_port_stream(_ARG2));
          if (sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER)))
            sexp_apply2(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG2, SEXP_FALSE);
          else
            sexp_poll_output(ctx, _ARG2);
          fuel = 0;
          ip--;      /* try again */
          goto loop;
        } else
  #endif
        sexp_raise("failed to write char to port", _ARG2);
      }
      top--;
      _ARG1 = SEXP_VOID;
      break;
    case SEXP_OP_WRITE_STRING:
      if (sexp_stringp(_ARG1))
  #if SEXP_USE_PACKED_STRINGS
        tmp1 = _ARG1;
  #else
        tmp1 = sexp_string_bytes(_ARG1);
  #endif
      else if (sexp_bytesp(_ARG1))
        tmp1 = _ARG1;
      else
        sexp_raise("write-string: not a string or bytes", sexp_list1(ctx, _ARG1));
      if (_ARG2 == SEXP_TRUE)
        _ARG2 = sexp_make_fixnum(sexp_bytes_length(tmp1));
      else if (! sexp_fixnump(_ARG2))
        sexp_raise("write-string: not an integer", sexp_list1(ctx, _ARG2));
      if (sexp_unbox_fixnum(_ARG2) < 0 || sexp_unbox_fixnum(_ARG2) > (sexp_sint_t)sexp_bytes_length(tmp1))
        sexp_raise("write-string: not a valid string count", sexp_list2(ctx, tmp1, _ARG2));
      if (! sexp_oportp(_ARG3))
        sexp_raise("write-string: not an output-port", sexp_list1(ctx, _ARG3));
      if (!sexp_port_openp(_ARG3))
        sexp_raise("write-string: port is closed", _ARG3);
      sexp_context_top(ctx) = top;
  #if SEXP_USE_GREEN_THREADS
      errno = 0;
  #endif
      i = sexp_write_string_n(ctx, sexp_bytes_data(tmp1), sexp_unbox_fixnum(_ARG2), _ARG3);
  #if SEXP_USE_GREEN_THREADS
      if (i < sexp_unbox_fixnum(_ARG2) && errno == EAGAIN) {
        if (sexp_port_stream(_ARG3)) clearerr(sexp_port_stream(_ARG3));
        /* modify stack in-place so we continue where we left off next time */
        if (i > 0) {
          _ARG1 = sexp_subbytes(ctx, tmp1, sexp_make_fixnum(i), SEXP_FALSE);
          _ARG2 = sexp_make_fixnum(sexp_unbox_fixnum(_ARG2) - i);
        }
        /* yield if threads are enabled (otherwise busy loop) */
        /* TODO: the wait seems necessary on OS X to stop a print loop to ptys */
        if (sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER)))
          sexp_apply2(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG3, SEXP_FALSE);
        else
          sexp_poll_output(ctx, _ARG3);
        fuel = 0;
        ip--;      /* try again */
        goto loop;
      }
  #endif
      tmp1 = sexp_make_fixnum(i);     /* return the number of bytes written */
      top-=2;
      _ARG1 = tmp1;
      break;
    case SEXP_OP_READ_CHAR:
      if (! sexp_iportp(_ARG1))
        sexp_raise("read-char: not an input-port", sexp_list1(ctx, _ARG1));
      sexp_context_top(ctx) = top;
  #if SEXP_USE_GREEN_THREADS
      errno = 0;
  #endif
      i = sexp_read_char(ctx, _ARG1);
  #if SEXP_USE_UTF8_STRINGS
      if (i >= 0x80)
        _ARG1 = sexp_read_utf8_char(ctx, _ARG1, i);
      else
  #endif
      if (i == EOF) {
        if (!sexp_port_openp(_ARG1))
          sexp_raise("read-char: port is closed", _ARG1);
        else
  #if SEXP_USE_GREEN_THREADS
        if ((sexp_port_stream(_ARG1) ? ferror(sexp_port_stream(_ARG1)) : 1)
            && (errno == EAGAIN)) {
          if (sexp_port_stream(_ARG1)) clearerr(sexp_port_stream(_ARG1));
          /* TODO: block and unblock */
          if (sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER)))
            sexp_apply2(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG1, SEXP_FALSE);
          else
            sexp_poll_input(ctx, _ARG1);
          fuel = 0;
          ip--;      /* try again */
        } else
  #endif
          _ARG1 = SEXP_EOF;
      } else {
        if (i == '\n') sexp_port_line(_ARG1)++;
        _ARG1 = sexp_make_character(i);
      }
      sexp_check_exception();
      break;
    case SEXP_OP_PEEK_CHAR:
      if (! sexp_iportp(_ARG1))
        sexp_raise("peek-char: not an input-port", sexp_list1(ctx, _ARG1));
      sexp_context_top(ctx) = top;
  #if SEXP_USE_GREEN_THREADS
      errno = 0;
  #endif
      i = sexp_read_char(ctx, _ARG1);
      if (i == EOF) {
        if (!sexp_port_openp(_ARG1))
          sexp_raise("peek-char: port is closed", _ARG1);
        else
  #if SEXP_USE_GREEN_THREADS
        if ((sexp_port_stream(_ARG1) ? ferror(sexp_port_stream(_ARG1)) : 1)
            && (errno == EAGAIN)) {
          if (sexp_port_stream(_ARG1)) clearerr(sexp_port_stream(_ARG1));
          if (sexp_applicablep(sexp_global(ctx, SEXP_G_THREADS_BLOCKER)))
            sexp_apply2(ctx, sexp_global(ctx, SEXP_G_THREADS_BLOCKER), _ARG1, SEXP_FALSE);
          else
            sexp_poll_input(ctx, _ARG1);
          fuel = 0;
          ip--;      /* try again */
        } else
  #endif
          _ARG1 = SEXP_EOF;
  #if SEXP_USE_UTF8_STRINGS
      } else if (i >= 0x80) {
        tmp1 = sexp_read_utf8_char(ctx, _ARG1, i);
        sexp_push_utf8_char(ctx, sexp_unbox_character(tmp1), _ARG1);
        _ARG1 = tmp1;
  #endif
      } else {
        sexp_push_char(ctx, i, _ARG1);
        _ARG1 = sexp_make_character(i);
      }
      sexp_check_exception();
      break;
    case SEXP_OP_YIELD:
  #if SEXP_USE_GREEN_THREADS
      fuel = 0;
  #endif
      break;
    case SEXP_OP_FORCE:
  #if SEXP_USE_AUTO_FORCE
      sexp_context_top(ctx) = top;
      while (sexp_promisep(_ARG1)) {
        if (sexp_promise_donep(_ARG1)) {
          _ARG1 = sexp_promise_value(_ARG1);
        } else {
          sexp_context_top(ctx) = top;
          tmp1 = sexp_apply(ctx, sexp_promise_value(_ARG1), SEXP_NULL);
          if (!sexp_promise_donep(_ARG1)) {
            sexp_promise_value(_ARG1) = tmp1;
            sexp_promise_donep(_ARG1) = 1;
          }
          _ARG1 = tmp1;
        }
      }
  #endif
      break;
    case SEXP_OP_RET:
      i = sexp_unbox_fixnum(stack[fp]);
      stack[fp-i] = _ARG1;
      top = fp-i+1;
      self = stack[fp+2];
      bc = sexp_procedure_code(self);
      ip = sexp_bytecode_data(bc) + sexp_unbox_fixnum(stack[fp+1]);
      cp = sexp_procedure_vars(self);
      fp = sexp_unbox_fixnum(stack[fp+3]);
      break;
    case SEXP_OP_DONE:
      sexp_context_last_fp(ctx) = fp;
      goto end_loop;
    default:
      sexp_raise("unknown opcode", sexp_list1(ctx, sexp_make_fixnum(*(ip-1))));
    }
  #if SEXP_USE_DEBUG_VM
    if (sexp_context_tracep(ctx))
      fprintf(stderr, "****** VM => %p (%d)\n", _ARG1,
              sexp_pointerp(_ARG1) && sexp_in_heap_p(ctx, _ARG1)
              ? sexp_pointer_tag(_ARG1) : -1);
  #endif
    goto loop;
  
   end_loop:
  #if SEXP_USE_GREEN_THREADS
    sexp_context_result(ctx) = _ARG1;
    if (ctx != root_thread) {
      if (sexp_context_refuel(root_thread) <= 0) {
        /* the root already terminated */
        _ARG1 = sexp_context_result(root_thread);
      } else {
        /* don't return from child threads */
        if (sexp_exceptionp(_ARG1)) {
          tmp1 = sexp_current_error_port(ctx);
          sexp_write_string(ctx, "ERROR in child thread: ", tmp1);
          sexp_write(ctx, ctx, tmp1);
          sexp_newline(ctx, tmp1);
          sexp_print_exception(ctx, _ARG1, tmp1);
        }
  #if SEXP_USE_DEBUG_THREADS
        fprintf(stderr, "****** schedule %p: terminating %p (%s)\n",
                root_thread, ctx, sexp_thread_debug_name(ctx));
  #endif
        sexp_context_refuel(ctx) = fuel = 0;
        goto loop;
      }
    }
  #endif
    sexp_gc_release3(ctx);
    tmp1 = _ARG1;
    sexp_context_top(ctx) = --top;
    return tmp1;
  }
  
  sexp sexp_apply1 (sexp ctx, sexp f, sexp x) {
    sexp res;
    sexp_gc_var1(args);
    if (sexp_opcodep(f) && sexp_opcode_func(f)) {
      res = ((sexp_proc2)sexp_opcode_func(f))(ctx, f, 1, x);
    } else {
      sexp_gc_preserve1(ctx, args);
      res = sexp_apply(ctx, f, args=sexp_list1(ctx, x));
      sexp_gc_release1(ctx);
    }
    return res;
  }
  
  sexp sexp_apply2 (sexp ctx, sexp f, sexp x, sexp y) {
    sexp res;
    sexp_gc_var1(args);
    if (sexp_opcodep(f) && sexp_opcode_func(f)) {
      res = ((sexp_proc3)sexp_opcode_func(f))(ctx, f, 2, x, y);
    } else {
      sexp_gc_preserve1(ctx, args);
      res = sexp_apply(ctx, f, args=sexp_list2(ctx, x, y));
      sexp_gc_release1(ctx);
    }
    return res;
  }
  
  sexp sexp_apply3 (sexp ctx, sexp f, sexp x, sexp y, sexp z) {
    sexp res;
    sexp_gc_var1(args);
    if (sexp_opcodep(f) && sexp_opcode_func(f)) {
      res = ((sexp_proc4)sexp_opcode_func(f))(ctx, f, 3, x, y, z);
    } else {
      sexp_gc_preserve1(ctx, args);
      res = sexp_apply(ctx, f, args=sexp_list3(ctx, x, y, z));
      sexp_gc_release1(ctx);
    }
    return res;
  }
  
  sexp sexp_apply_no_err_handler (sexp ctx, sexp proc, sexp args) {
    sexp res, err_cell;
    sexp_gc_var2(handler, params);
    sexp_gc_preserve2(ctx, handler, params);
  #if SEXP_USE_GREEN_THREADS
    params = sexp_context_params(ctx);
    sexp_context_params(ctx) = SEXP_NULL;
    ++sexp_context_refuel(ctx);
  #endif
    err_cell = sexp_global(ctx, SEXP_G_ERR_HANDLER);
    err_cell = sexp_opcodep(err_cell) ? sexp_opcode_data(err_cell) : SEXP_FALSE;
    handler = sexp_pairp(err_cell) ? sexp_cdr(err_cell) : SEXP_FALSE;
    if (sexp_pairp(err_cell)) sexp_cdr(err_cell) = SEXP_FALSE;
    res = sexp_apply(ctx, proc, args);
    if (sexp_pairp(err_cell)) sexp_cdr(err_cell) = handler;
  #if SEXP_USE_GREEN_THREADS
    sexp_context_params(ctx) = params;
  #endif
    sexp_gc_release2(ctx);
    return res;
  }
  
  #endif
  