Beispiel #1
0
static pic_value
pic_system_getenvs(pic_state *pic)
{
  char **envp;
  pic_value data = pic_nil_value();
  size_t ai = pic_gc_arena_preserve(pic);

  pic_get_args(pic, "");

  if (! pic->envp) {
    return pic_nil_value();
  }

  for (envp = pic->envp; *envp; ++envp) {
    pic_str *key, *val;
    size_t i;

    for (i = 0; (*envp)[i] != '='; ++i)
      ;

    key = pic_make_str(pic, *envp, i);
    val = pic_make_str_cstr(pic, getenv(pic_str_cstr(key)));

    /* push */
    data = pic_acons(pic, pic_obj_value(key), pic_obj_value(val), data);

    pic_gc_arena_restore(pic, ai);
    pic_gc_protect(pic, data);
  }

  return data;
}
Beispiel #2
0
pic_str *
pic_get_backtrace(pic_state *pic)
{
  size_t ai = pic_gc_arena_preserve(pic);
  pic_callinfo *ci;
  pic_str *trace;

  trace = pic_make_str(pic, NULL, 0);

  for (ci = pic->ci; ci != pic->cibase; --ci) {
    struct pic_proc *proc = pic_proc_ptr(ci->fp[0]);

    trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, "  at "));
    trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, pic_symbol_name(pic, pic_proc_name(proc))));

    if (pic_proc_func_p(proc)) {
      trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, " (native function)\n"));
    } else if (pic_proc_irep_p(proc)) {
      trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, " (unknown location)\n")); /* TODO */
    }
  }

  pic_gc_arena_restore(pic, ai);
  pic_gc_protect(pic, pic_obj_value(trace));

  return trace;
}
Beispiel #3
0
pic_value
pic_list3(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3)
{
  size_t ai = pic_gc_arena_preserve(pic);
  pic_value val;

  val = pic_cons(pic, obj1, pic_list2(pic, obj2, obj3));

  pic_gc_arena_restore(pic, ai);
  pic_gc_protect(pic, val);
  return val;
}
Beispiel #4
0
pic_value
pic_list7(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5, pic_value obj6, pic_value obj7)
{
  size_t ai = pic_gc_arena_preserve(pic);
  pic_value val;

  val = pic_cons(pic, obj1, pic_list6(pic, obj2, obj3, obj4, obj5, obj6, obj7));

  pic_gc_arena_restore(pic, ai);
  pic_gc_protect(pic, val);
  return val;
}
Beispiel #5
0
pic_value
pic_list5(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5)
{
  int ai = pic_gc_arena_preserve(pic);
  pic_value val;

  val = pic_cons(pic, obj1, pic_list4(pic, obj2, obj3, obj4, obj5));

  pic_gc_arena_restore(pic, ai);
  pic_gc_protect(pic, val);
  return val;
}
Beispiel #6
0
void
pic_load(pic_state *pic, struct pic_port *port)
{
    pic_value form;
    size_t ai = pic_gc_arena_preserve(pic);

    while (! pic_eof_p(form = pic_read(pic, port))) {
        pic_eval(pic, form, pic->lib->env);

        pic_gc_arena_restore(pic, ai);
    }
}
Beispiel #7
0
pic_value
pic_reverse(pic_state *pic, pic_value list)
{
  size_t ai = pic_gc_arena_preserve(pic);
  pic_value v, acc, it;

  acc = pic_nil_value();
  pic_for_each(v, list, it) {
    acc = pic_cons(pic, v, acc);

    pic_gc_arena_restore(pic, ai);
    pic_gc_protect(pic, acc);
  }
Beispiel #8
0
static pic_value
pic_system_cmdline(pic_state *pic)
{
  pic_value v = pic_nil_value();
  int i;

  pic_get_args(pic, "");

  for (i = 0; i < pic->argc; ++i) {
    size_t ai = pic_gc_arena_preserve(pic);

    v = pic_cons(pic, pic_obj_value(pic_make_str_cstr(pic, pic->argv[i])), v);
    pic_gc_arena_restore(pic, ai);
  }

  return pic_reverse(pic, v);
}
Beispiel #9
0
pic_state *
pic_open(int argc, char *argv[], char **envp)
{
  pic_value t;

  pic_state *pic;
  int ai;

  pic = (pic_state *)malloc(sizeof(pic_state));

  /* command line */
  pic->argc = argc;
  pic->argv = argv;
  pic->envp = envp;

  /* root block */
  pic->blk = (struct pic_block *)malloc(sizeof(struct pic_block));
  pic->blk->prev = NULL;
  pic->blk->depth = 0;
  pic->blk->in = pic->blk->out = NULL;
  pic->blk->refcnt = 1;

  /* prepare VM stack */
  pic->stbase = pic->sp = (pic_value *)calloc(PIC_STACK_SIZE, sizeof(pic_value));
  pic->stend = pic->stbase + PIC_STACK_SIZE;

  /* callinfo */
  pic->cibase = pic->ci = (pic_callinfo *)calloc(PIC_STACK_SIZE, sizeof(pic_callinfo));
  pic->ciend = pic->cibase + PIC_STACK_SIZE;

  /* exception handlers */
  pic->rescue = (struct pic_proc **)calloc(PIC_RESCUE_SIZE, sizeof(struct pic_proc *));
  pic->ridx = 0;
  pic->rlen = PIC_RESCUE_SIZE;

  /* memory heap */
  pic->heap = (struct pic_heap *)calloc(1, sizeof(struct pic_heap));
  init_heap(pic->heap);

  /* symbol table */
  pic->sym_tbl = xh_new();
  pic->sym_pool = (const char **)calloc(PIC_SYM_POOL_SIZE, sizeof(const char *));
  pic->slen = 0;
  pic->scapa = pic->slen + PIC_SYM_POOL_SIZE;
  pic->uniq_sym_count = 0;

  /* global variables */
  pic->global_tbl = xh_new();
  pic->globals = (pic_value *)calloc(PIC_GLOBALS_SIZE, sizeof(pic_value));
  pic->glen = 0;
  pic->gcapa = PIC_GLOBALS_SIZE;

  /* libraries */
  pic->lib_tbl = pic_nil_value();
  pic->lib = NULL;

  /* error handling */
  pic->jmp = NULL;
  pic->errmsg = NULL;

  /* GC arena */
  pic->arena_idx = 0;

  /* native stack marker */
  pic->native_stack_start = &t;

#define register_core_symbol(pic,slot,name) do {	\
    pic->slot = pic_intern_cstr(pic, name);		\
  } while (0)

  ai = pic_gc_arena_preserve(pic);
  register_core_symbol(pic, sDEFINE, "define");
  register_core_symbol(pic, sLAMBDA, "lambda");
  register_core_symbol(pic, sIF, "if");
  register_core_symbol(pic, sBEGIN, "begin");
  register_core_symbol(pic, sSETBANG, "set!");
  register_core_symbol(pic, sQUOTE, "quote");
  register_core_symbol(pic, sQUASIQUOTE, "quasiquote");
  register_core_symbol(pic, sUNQUOTE, "unquote");
  register_core_symbol(pic, sUNQUOTE_SPLICING, "unquote-splicing");
  register_core_symbol(pic, sDEFINE_SYNTAX, "define-syntax");
  register_core_symbol(pic, sDEFINE_MACRO, "define-macro");
  register_core_symbol(pic, sDEFINE_LIBRARY, "define-library");
  register_core_symbol(pic, sIMPORT, "import");
  register_core_symbol(pic, sEXPORT, "export");
  register_core_symbol(pic, sCONS, "cons");
  register_core_symbol(pic, sCAR, "car");
  register_core_symbol(pic, sCDR, "cdr");
  register_core_symbol(pic, sNILP, "null?");
  register_core_symbol(pic, sADD, "+");
  register_core_symbol(pic, sSUB, "-");
  register_core_symbol(pic, sMUL, "*");
  register_core_symbol(pic, sDIV, "/");
  register_core_symbol(pic, sMINUS, "minus");
  register_core_symbol(pic, sEQ, "=");
  register_core_symbol(pic, sLT, "<");
  register_core_symbol(pic, sLE, "<=");
  register_core_symbol(pic, sGT, ">");
  register_core_symbol(pic, sGE, ">=");
  pic_gc_arena_restore(pic, ai);

  pic_init_core(pic);

  /* set library */
  pic_make_library(pic, pic_parse(pic, "user"));
  pic_in_library(pic, pic_parse(pic, "user"));

  return pic;
}
Beispiel #10
0
pic_state *
pic_open(int argc, char *argv[], char **envp)
{
  struct pic_port *pic_make_standard_port(pic_state *, xFILE *, short);
  char t;

  pic_state *pic;
  size_t ai;

  pic = malloc(sizeof(pic_state));

  /* turn off GC */
  pic->gc_enable = false;

  /* root block */
  pic->wind = NULL;

  /* command line */
  pic->argc = argc;
  pic->argv = argv;
  pic->envp = envp;

  /* prepare VM stack */
  pic->stbase = pic->sp = calloc(PIC_STACK_SIZE, sizeof(pic_value));
  pic->stend = pic->stbase + PIC_STACK_SIZE;

  /* callinfo */
  pic->cibase = pic->ci = calloc(PIC_STACK_SIZE, sizeof(pic_callinfo));
  pic->ciend = pic->cibase + PIC_STACK_SIZE;

  /* exception handler */
  pic->xpbase = pic->xp = calloc(PIC_RESCUE_SIZE, sizeof(struct pic_proc *));
  pic->xpend = pic->xpbase + PIC_RESCUE_SIZE;

  /* memory heap */
  pic->heap = pic_heap_open();

  /* symbol table */
  xh_init_str(&pic->syms, sizeof(pic_sym *));

  /* global variables */
  pic->globals = NULL;

  /* macros */
  pic->macros = NULL;

  /* attributes */
  xh_init_ptr(&pic->attrs, sizeof(struct pic_dict *));

  /* features */
  pic->features = pic_nil_value();

  /* libraries */
  pic->libs = pic_nil_value();
  pic->lib = NULL;

  /* GC arena */
  pic->arena = calloc(PIC_ARENA_SIZE, sizeof(struct pic_object **));
  pic->arena_size = PIC_ARENA_SIZE;
  pic->arena_idx = 0;

  /* raised error object */
  pic->err = pic_undef_value();

  /* standard ports */
  pic->xSTDIN = NULL;
  pic->xSTDOUT = NULL;
  pic->xSTDERR = NULL;

  /* native stack marker */
  pic->native_stack_start = &t;

  ai = pic_gc_arena_preserve(pic);

#define S(slot,name) pic->slot = pic_intern_cstr(pic, name);

  S(sDEFINE, "define");
  S(sLAMBDA, "lambda");
  S(sIF, "if");
  S(sBEGIN, "begin");
  S(sSETBANG, "set!");
  S(sQUOTE, "quote");
  S(sQUASIQUOTE, "quasiquote");
  S(sUNQUOTE, "unquote");
  S(sUNQUOTE_SPLICING, "unquote-splicing");
  S(sDEFINE_SYNTAX, "define-syntax");
  S(sIMPORT, "import");
  S(sEXPORT, "export");
  S(sDEFINE_LIBRARY, "define-library");
  S(sIN_LIBRARY, "in-library");
  S(sCOND_EXPAND, "cond-expand");
  S(sAND, "and");
  S(sOR, "or");
  S(sELSE, "else");
  S(sLIBRARY, "library");
  S(sONLY, "only");
  S(sRENAME, "rename");
  S(sPREFIX, "prefix");
  S(sEXCEPT, "except");
  S(sCONS, "cons");
  S(sCAR, "car");
  S(sCDR, "cdr");
  S(sNILP, "null?");
  S(sSYMBOLP, "symbol?");
  S(sPAIRP, "pair?");
  S(sADD, "+");
  S(sSUB, "-");
  S(sMUL, "*");
  S(sDIV, "/");
  S(sMINUS, "minus");
  S(sEQ, "=");
  S(sLT, "<");
  S(sLE, "<=");
  S(sGT, ">");
  S(sGE, ">=");
  S(sNOT, "not");
  S(sREAD, "read");
  S(sFILE, "file");
  S(sCALL, "call");
  S(sTAILCALL, "tail-call");
  S(sGREF, "gref");
  S(sLREF, "lref");
  S(sCREF, "cref");
  S(sRETURN, "return");
  S(sCALL_WITH_VALUES, "call-with-values");
  S(sTAILCALL_WITH_VALUES, "tailcall-with-values");

  pic_gc_arena_restore(pic, ai);

#define R(slot,name) pic->slot = pic_gensym(pic, pic_intern_cstr(pic, name));

  R(rDEFINE, "define");
  R(rLAMBDA, "lambda");
  R(rIF, "if");
  R(rBEGIN, "begin");
  R(rSETBANG, "set!");
  R(rQUOTE, "quote");
  R(rDEFINE_SYNTAX, "define-syntax");
  R(rIMPORT, "import");
  R(rEXPORT, "export");
  R(rDEFINE_LIBRARY, "define-library");
  R(rIN_LIBRARY, "in-library");
  R(rCOND_EXPAND, "cond-expand");
  pic_gc_arena_restore(pic, ai);

  /* root tables */
  pic->globals = pic_make_dict(pic);
  pic->macros = pic_make_dict(pic);

  /* root block */
  pic->wind = pic_alloc(pic, sizeof(struct pic_winder));
  pic->wind->prev = NULL;
  pic->wind->depth = 0;
  pic->wind->in = pic->wind->out = NULL;

  /* reader */
  pic->reader = malloc(sizeof(struct pic_reader));
  pic->reader->typecase = PIC_CASE_DEFAULT;
  pic->reader->trie = pic_make_trie(pic);
  xh_init_int(&pic->reader->labels, sizeof(pic_value));

  /* init readers */
  pic_init_reader(pic);

  /* standard libraries */
  pic->PICRIN_BASE = pic_open_library(pic, pic_read_cstr(pic, "(picrin base)"));
  pic->PICRIN_USER = pic_open_library(pic, pic_read_cstr(pic, "(picrin user)"));
  pic->lib = pic->PICRIN_USER;

  /* standard I/O */
  pic->xSTDIN = pic_make_standard_port(pic, xstdin, PIC_PORT_IN);
  pic->xSTDOUT = pic_make_standard_port(pic, xstdout, PIC_PORT_OUT);
  pic->xSTDERR = pic_make_standard_port(pic, xstderr, PIC_PORT_OUT);

  pic_gc_arena_restore(pic, ai);

  /* turn on GC */
  pic->gc_enable = true;

  pic_init_core(pic);

  return pic;
}
Beispiel #11
0
pic_value
pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
{
  struct pic_code *pc, c;
  int ai = pic_gc_arena_preserve(pic);
  jmp_buf jmp;
  size_t argc, i;
  struct pic_code boot[2];

#if PIC_DIRECT_THREADED_VM
  static void *oplabels[] = {
    &&L_OP_POP, &&L_OP_PUSHNIL, &&L_OP_PUSHTRUE, &&L_OP_PUSHFALSE, &&L_OP_PUSHFLOAT,
    &&L_OP_PUSHINT, &&L_OP_PUSHCHAR, &&L_OP_PUSHCONST,
    &&L_OP_GREF, &&L_OP_GSET, &&L_OP_LREF, &&L_OP_LSET, &&L_OP_CREF, &&L_OP_CSET,
    &&L_OP_JMP, &&L_OP_JMPIF, &&L_OP_CALL, &&L_OP_TAILCALL, &&L_OP_RET, &&L_OP_LAMBDA,
    &&L_OP_CONS, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_NILP,
    &&L_OP_ADD, &&L_OP_SUB, &&L_OP_MUL, &&L_OP_DIV,
    &&L_OP_EQ, &&L_OP_LT, &&L_OP_LE, &&L_OP_STOP
  };
#endif

  if (setjmp(jmp) == 0) {
    pic->jmp = &jmp;
  }
  else {
    goto L_RAISE;
  }

  argc = pic_length(pic, argv) + 1;

#if VM_DEBUG
  puts("== booting VM...");
  printf("  proc = ");
  pic_debug(pic, pic_obj_value(proc));
  puts("");
  printf("  argv = ");
  pic_debug(pic, argv);
  puts("");
  printf("  irep = ");
  print_irep(pic, proc->u.irep);
  puts("\nLet's go!");
#endif

  PUSH(pic_obj_value(proc));
  for (i = 1; i < argc; ++i) {
    PUSH(pic_car(pic, argv));
    argv = pic_cdr(pic, argv);
  }

  /* boot! */
  boot[0].insn = OP_CALL;
  boot[0].u.i = argc;
  boot[1].insn = OP_STOP;
  pc = boot;
  c = *pc;
  goto L_CALL;

  VM_LOOP {
    CASE(OP_POP) {
      POPN(1);
      NEXT;
    }
    CASE(OP_PUSHNIL) {
      PUSH(pic_nil_value());
      NEXT;
    }
    CASE(OP_PUSHTRUE) {
      PUSH(pic_true_value());
      NEXT;
    }
    CASE(OP_PUSHFALSE) {
      PUSH(pic_false_value());
      NEXT;
    }
    CASE(OP_PUSHFLOAT) {
      PUSH(pic_float_value(c.u.f));
      NEXT;
    }
    CASE(OP_PUSHINT) {
      PUSH(pic_int_value(c.u.i));
      NEXT;
    }
    CASE(OP_PUSHCHAR) {
      PUSH(pic_char_value(c.u.c));
      NEXT;
    }
    CASE(OP_PUSHCONST) {
      PUSH(pic->pool[c.u.i]);
      NEXT;
    }
    CASE(OP_GREF) {
      PUSH(pic->globals[c.u.i]);
      NEXT;
    }
    CASE(OP_GSET) {
      pic->globals[c.u.i] = POP();
      NEXT;
    }
    CASE(OP_LREF) {
      PUSH(pic->ci->fp[c.u.i]);
      NEXT;
    }
    CASE(OP_LSET) {
      pic->ci->fp[c.u.i] = POP();
      NEXT;
    }
    CASE(OP_CREF) {
      int depth = c.u.r.depth;
      struct pic_env *env;

      env = pic->ci->env;
      while (depth--) {
	env = env->up;
      }
      PUSH(env->values[c.u.r.idx]);
      NEXT;
    }
    CASE(OP_CSET) {
      int depth = c.u.r.depth;
      struct pic_env *env;

      env = pic->ci->env;
      while (depth--) {
	env = env->up;
      }
      env->values[c.u.r.idx] = POP();
      NEXT;
    }
    CASE(OP_JMP) {
      pc += c.u.i;
      JUMP;
    }
    CASE(OP_JMPIF) {
      pic_value v;

      v = POP();
      if (! pic_false_p(v)) {
	pc += c.u.i;
	JUMP;
      }
      NEXT;
    }
    CASE(OP_CALL) {
      pic_value x, v;
      pic_callinfo *ci;
      struct pic_proc *proc;

    L_CALL:
      x = pic->sp[-c.u.i];
      if (! pic_proc_p(x)) {
	pic->errmsg = "invalid application";
	goto L_RAISE;
      }
      proc = pic_proc_ptr(x);

      ci = PUSHCI();
      ci->argc = c.u.i;
      ci->pc = pc;
      ci->fp = pic->sp - c.u.i;
      ci->env = NULL;
      if (pic_proc_cfunc_p(x)) {
	v = proc->u.cfunc(pic);
	pic->sp = ci->fp;
	POPCI();
	PUSH(v);
	pic_gc_arena_restore(pic, ai);
	NEXT;
      }
      else {
	int i;
	pic_value rest;

	if (ci->argc != proc->u.irep->argc) {
	  if (! (proc->u.irep->varg && ci->argc >= proc->u.irep->argc)) {
	    pic->errmsg = "wrong number of arguments";
	    goto L_RAISE;
	  }
	}
	/* prepare rest args */
	if (proc->u.irep->varg) {
	  rest = pic_nil_value();
	  for (i = 0; i < ci->argc - proc->u.irep->argc; ++i) {
	    pic_gc_protect(pic, v = POP());
	    rest = pic_cons(pic, v, rest);
	  }
	  PUSH(rest);
	}

	/* prepare env */
	if (proc->u.irep->cv_num == 0) {
	  ci->env = proc->env;
	}
	else {
	  ci->env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV);
	  ci->env->up = proc->env;
	  ci->env->valuec = proc->u.irep->cv_num;
	  ci->env->values = (pic_value *)pic_calloc(pic, ci->env->valuec, sizeof(pic_value));
	  for (i = 0; i < ci->env->valuec; ++i) {
	    ci->env->values[i] = ci->fp[proc->u.irep->cv_tbl[i]];
	  }
	}

	pc = proc->u.irep->code;
	pic_gc_arena_restore(pic, ai);
	JUMP;
      }
    }
    CASE(OP_TAILCALL) {
      int argc;
      pic_value *argv;

      argc = c.u.i;
      argv = pic->sp - argc;
      for (i = 0; i < argc; ++i) {
	pic->ci->fp[i] = argv[i];
      }
      pic->sp = pic->ci->fp + argc;
      pc = POPCI()->pc;

      /* c is not changed */
      goto L_CALL;
    }
    CASE(OP_RET) {
      pic_value v;
      pic_callinfo *ci;

      if (pic->errmsg) {

      L_RAISE:
	goto L_STOP;
      }
      else {
	v = POP();
	ci = POPCI();
	pc = ci->pc;
	pic->sp = ci->fp;
	PUSH(v);
      }
      NEXT;
    }
    CASE(OP_LAMBDA) {
      struct pic_proc *proc;

      proc = pic_proc_new(pic, pic->irep[c.u.i], pic->ci->env);
      PUSH(pic_obj_value(proc));
      pic_gc_arena_restore(pic, ai);
      NEXT;
    }
    CASE(OP_CONS) {
      pic_value a, b;
      pic_gc_protect(pic, b = POP());
      pic_gc_protect(pic, a = POP());
      PUSH(pic_cons(pic, a, b));
      pic_gc_arena_restore(pic, ai);
      NEXT;
    }
    CASE(OP_CAR) {
      pic_value p;
      p = POP();
      PUSH(pic_car(pic, p));
      NEXT;
    }
    CASE(OP_CDR) {
      pic_value p;
      p = POP();
      PUSH(pic_cdr(pic, p));
      NEXT;
    }
    CASE(OP_NILP) {
      pic_value p;
      p = POP();
      PUSH(pic_bool_value(pic_nil_p(p)));
      NEXT;
    }

#define DEFINE_ARITH_OP(opcode, op)				\
    CASE(opcode) {						\
      pic_value a, b;						\
      b = POP();						\
      a = POP();						\
      if (pic_int_p(a) && pic_int_p(b)) {			\
	double f = (double)pic_int(a) op (double)pic_int(b);	\
	if (INT_MIN <= f && f <= INT_MAX) {			\
	  PUSH(pic_int_value((int)f));				\
	}							\
	else {							\
	  PUSH(pic_float_value(f));				\
	}							\
      }								\
      else if (pic_float_p(a) && pic_float_p(b)) {		\
	PUSH(pic_float_value(pic_float(a) op pic_float(b)));	\
      }								\
      else if (pic_int_p(a) && pic_float_p(b)) {		\
	PUSH(pic_float_value(pic_int(a) op pic_float(b)));	\
      }								\
      else if (pic_float_p(a) && pic_int_p(b)) {		\
	PUSH(pic_float_value(pic_float(a) op pic_int(b)));	\
      }								\
      else {							\
	pic->errmsg = #op " got non-number operands";		\
	goto L_RAISE;						\
      }								\
      NEXT;							\
    }

    DEFINE_ARITH_OP(OP_ADD, +);
    DEFINE_ARITH_OP(OP_SUB, -);
    DEFINE_ARITH_OP(OP_MUL, *);

    /* special care for (int / int) division */
    CASE(OP_DIV) {
      pic_value a, b;
      b = POP();
      a = POP();
      if (pic_int_p(a) && pic_int_p(b)) {
	PUSH(pic_float_value((double)pic_int(a) / pic_int(b)));
      }
      else if (pic_float_p(a) && pic_float_p(b)) {
	PUSH(pic_float_value(pic_float(a) / pic_float(b)));
      }
      else if (pic_int_p(a) && pic_float_p(b)) {
	PUSH(pic_float_value(pic_int(a) / pic_float(b)));
      }
      else if (pic_float_p(a) && pic_int_p(b)) {
	PUSH(pic_float_value(pic_float(a) / pic_int(b)));
      }
      else {
	pic->errmsg = "/ got non-number operands";
	goto L_RAISE;
      }
      NEXT;
    }

#define DEFINE_COMP_OP(opcode, op)				\
    CASE(opcode) {						\
      pic_value a, b;						\
      b = POP();						\
      a = POP();						\
      if (pic_int_p(a) && pic_int_p(b)) {			\
	PUSH(pic_bool_value(pic_int(a) op pic_int(b)));		\
      }								\
      else if (pic_float_p(a) && pic_float_p(b)) {		\
	PUSH(pic_bool_value(pic_float(a) op pic_float(b)));	\
      }								\
      else if (pic_int_p(a) && pic_int_p(b)) {			\
	PUSH(pic_bool_value(pic_int(a) op pic_float(b)));	\
      }								\
      else if (pic_float_p(a) && pic_int_p(b)) {		\
	PUSH(pic_bool_value(pic_float(a) op pic_int(b)));	\
      }								\
      else {							\
	pic->errmsg = #op " got non-number operands";		\
	goto L_RAISE;						\
      }								\
      NEXT;							\
    }

    DEFINE_COMP_OP(OP_EQ, ==);
    DEFINE_COMP_OP(OP_LT, <);
    DEFINE_COMP_OP(OP_LE, <=);

    CASE(OP_STOP) {
      pic_value val;

    L_STOP:
      val = POP();

      pic->jmp = NULL;
      if (pic->errmsg) {
	return pic_undef_value();
      }

#if VM_DEBUG
      puts("**VM END STATE**");
      printf("stbase\t= %p\nsp\t= %p\n", pic->stbase, pic->sp);
      printf("cibase\t= %p\nci\t= %p\n", pic->cibase, pic->ci);
      if (pic->stbase < pic->sp) {
	pic_value *sp;
	printf("* stack trace:");
	for (sp = pic->stbase; pic->sp != sp; ++sp) {
	  pic_debug(pic, *sp);
	  puts("");
	}
      }
      if (pic->stbase > pic->sp) {
	puts("*** stack underflow!");
      }
#endif

      pic_gc_protect(pic, val);

      return val;
    }
  } VM_LOOP_END;
}