static void traverse(pic_state *pic, pic_value obj, struct writer_control *p) { pic_value shared = p->shared; if (p->op == OP_WRITE_SIMPLE) { return; } switch (pic_type(pic, obj)) { case PIC_TYPE_PAIR: case PIC_TYPE_VECTOR: case PIC_TYPE_DICT: { if (! pic_weak_has(pic, shared, obj)) { /* first time */ pic_weak_set(pic, shared, obj, pic_int_value(pic, 0)); if (pic_pair_p(pic, obj)) { /* pair */ traverse(pic, pic_car(pic, obj), p); traverse(pic, pic_cdr(pic, obj), p); } else if (pic_vec_p(pic, obj)) { /* vector */ int i, len = pic_vec_len(pic, obj); for (i = 0; i < len; ++i) { traverse(pic, pic_vec_ref(pic, obj, i), p); } } else { /* dictionary */ int it = 0; pic_value val; while (pic_dict_next(pic, obj, &it, NULL, &val)) { traverse(pic, val, p); } } if (p->op == OP_WRITE) { if (pic_int(pic, pic_weak_ref(pic, shared, obj)) == 0) { pic_weak_del(pic, shared, obj); } } } else { /* second time */ pic_weak_set(pic, shared, obj, pic_int_value(pic, 1)); } break; } default: break; } }
static pic_value pic_regexp_regexp_match(pic_state *pic) { pic_value reg; const char *input; regmatch_t match[100]; pic_value matches, positions; pic_str *str; int i, offset; pic_get_args(pic, "oz", ®, &input); pic_assert_type(pic, reg, regexp); matches = pic_nil_value(); positions = pic_nil_value(); if (strchr(pic_regexp_data_ptr(reg)->flags, 'g') != NULL) { /* global search */ offset = 0; while (regexec(&pic_regexp_data_ptr(reg)->reg, input, 1, match, 0) != REG_NOMATCH) { pic_push(pic, pic_obj_value(pic_str_new(pic, input, match[0].rm_eo - match[0].rm_so)), matches); pic_push(pic, pic_int_value(offset), positions); offset += match[0].rm_eo; input += match[0].rm_eo; } } else { /* local search */ if (regexec(&pic_regexp_data_ptr(reg)->reg, input, 100, match, 0) == 0) { for (i = 0; i < 100; ++i) { if (match[i].rm_so == -1) { break; } str = pic_str_new(pic, input + match[i].rm_so, match[i].rm_eo - match[i].rm_so); pic_push(pic, pic_obj_value(str), matches); pic_push(pic, pic_int_value(match[i].rm_so), positions); } } } if (pic_nil_p(matches)) { matches = pic_false_value(); positions = pic_false_value(); } else { matches = pic_reverse(pic, matches); positions = pic_reverse(pic, positions); } return pic_values2(pic, matches, positions); }
static pic_value pic_jiffies_per_second(pic_state *pic) { pic_get_args(pic, ""); return pic_int_value(pic, CLOCKS_PER_SEC); }
static pic_value pic_blob_bytevector_length(pic_state *pic) { int len; pic_get_args(pic, "b", NULL, &len); return pic_int_value(pic, len); }
static pic_value pic_number_exact(pic_state *pic) { double f; pic_get_args(pic, "f", &f); return pic_int_value(pic, (int)f); }
static pic_value pic_dict_dictionary_size(pic_state *pic) { struct pic_dict *dict; pic_get_args(pic, "d", &dict); return pic_int_value(pic_dict_size(pic, dict)); }
static pic_value pic_str_string_length(pic_state *pic) { pic_str *str; pic_get_args(pic, "s", &str); return pic_int_value(pic_str_len(str)); }
static pic_value pic_vec_vector_length(pic_state *pic) { struct pic_vector *v; pic_get_args(pic, "v", &v); return pic_int_value(v->len); }
static pic_value pic_char_char_to_integer(pic_state *pic) { char c; pic_get_args(pic, "c", &c); assert((c & 0x80) == 0); return pic_int_value(pic, c); }
static pic_value pic_current_jiffy(pic_state *pic) { clock_t c; pic_get_args(pic, ""); c = clock(); return pic_int_value(pic, (int)c); /* The year 2038 problem :-| */ }
static pic_value pic_blob_bytevector_u8_ref(pic_state *pic) { struct pic_blob *bv; int k; pic_get_args(pic, "bi", &bv, &k); return pic_int_value(bv->data[k]); }
static pic_value pic_number_trunc2(pic_state *pic) { int i, j; bool e1, e2; pic_get_args(pic, "II", &i, &e1, &j, &e2); if (e1 && e2) { return pic_return(pic, 2, pic_int_value(pic, i/j), pic_int_value(pic, i - (i/j) * j)); } else { double q, r; q = trunc((double)i/j); r = i - j * q; return pic_return(pic, 2, pic_float_value(pic, q), pic_float_value(pic, r)); } }
static pic_value pic_blob_bytevector_u8_ref(pic_state *pic) { unsigned char *buf; int len, k; pic_get_args(pic, "bi", &buf, &len, &k); VALID_INDEX(pic, len, k); return pic_int_value(pic, buf[k]); }
static pic_value pic_char_integer_to_char(pic_state *pic) { int i; pic_get_args(pic, "i", &i); if (i < 0 || i > 127) { pic_error(pic, "integer->char: integer out of char range", 1, pic_int_value(pic, i)); } return pic_char_value(pic, (char)i); }
static pic_value pic_port_read_byte(pic_state *pic){ struct pic_port *port = pic_stdin(pic); int c; pic_get_args(pic, "|p", &port); assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-u8"); if ((c = xfgetc(port->file)) == EOF) { return pic_eof_object(); } return pic_int_value(c); }
static pic_value pic_number_round(pic_state *pic) { double f; bool e; pic_get_args(pic, "F", &f, &e); if (e) { return pic_int_value(pic, (int)f); } else { return pic_float_value(pic, round(f)); } }
static pic_value pic_number_floor2(pic_state *pic) { int i, j; bool e1, e2; pic_get_args(pic, "II", &i, &e1, &j, &e2); if (e1 && e2) { int k; k = (i < 0 && j < 0) || (0 <= i && 0 <= j) ? i / j : (i / j) - 1; return pic_return(pic, 2, pic_int_value(pic, k), pic_int_value(pic, i - k * j)); } else { double q, r; q = floor((double)i/j); r = i - j * q; return pic_return(pic, 2, pic_float_value(pic, q), pic_float_value(pic, r)); } }
static pic_value pic_number_abs(pic_state *pic) { double f; bool e; pic_get_args(pic, "F", &f, &e); if (e) { return pic_int_value(pic, f < 0 ? -f : f); } else { return pic_float_value(pic, fabs(f)); } }
static pic_value pic_number_expt(pic_state *pic) { double f, g, h; bool e1, e2; pic_get_args(pic, "FF", &f, &e1, &g, &e2); h = pow(f, g); if (e1 && e2) { if (h <= INT_MAX) { return pic_int_value(pic, (int)h); } } return pic_float_value(pic, h); }
struct pic_proc * pic_make_cont(pic_state *pic, struct pic_cont *cont) { static const pic_data_type cont_type = { "cont", NULL, NULL }; struct pic_proc *c; struct pic_data *e; c = pic_make_proc(pic, cont_call); e = pic_data_alloc(pic, &cont_type, cont); /* save the escape continuation in proc */ pic_proc_env_set(pic, c, "escape", pic_obj_value(e)); pic_proc_env_set(pic, c, "id", pic_int_value(cont->id)); return c; }
static pic_value pic_port_peek_byte(pic_state *pic) { int c; struct pic_port *port = pic_stdin(pic); pic_get_args(pic, "|p", &port); assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "peek-u8"); c = xfgetc(port->file); if (c == EOF) { return pic_eof_object(); } else { xungetc(c, port->file); return pic_int_value(c); } }
static pic_value pic_blob_make_bytevector(pic_state *pic) { pic_value blob; int k, b = 0; pic_get_args(pic, "i|i", &k, &b); if (b < 0 || b > 255) pic_error(pic, "byte out of range", 0); if (k < 0) { pic_error(pic, "make-bytevector: negative length given", 1, pic_int_value(pic, k)); } blob = pic_blob_value(pic, 0, k); memset(pic_blob(pic, blob, NULL), (unsigned char)b, k); return blob; }
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; }
static void write_core(pic_state *pic, pic_value obj, pic_value port, struct writer_control *p) { pic_value labels = p->labels; int i; /* shared objects */ if (is_shared_object(pic, obj, p)) { if (pic_weak_has(pic, labels, obj)) { pic_fprintf(pic, port, "#%d#", pic_int(pic, pic_weak_ref(pic, labels, obj))); return; } i = p->cnt++; pic_fprintf(pic, port, "#%d=", i); pic_weak_set(pic, labels, obj, pic_int_value(pic, i)); } switch (pic_type(pic, obj)) { case PIC_TYPE_UNDEF: pic_fprintf(pic, port, "#undefined"); break; case PIC_TYPE_NIL: pic_fprintf(pic, port, "()"); break; case PIC_TYPE_TRUE: pic_fprintf(pic, port, "#t"); break; case PIC_TYPE_FALSE: pic_fprintf(pic, port, "#f"); break; case PIC_TYPE_ID: pic_fprintf(pic, port, "#<identifier %s>", pic_str(pic, pic_id_name(pic, obj))); break; case PIC_TYPE_EOF: pic_fprintf(pic, port, "#.(eof-object)"); break; case PIC_TYPE_INT: pic_fprintf(pic, port, "%d", pic_int(pic, obj)); break; case PIC_TYPE_SYMBOL: pic_fprintf(pic, port, "%s", pic_sym(pic, obj)); break; case PIC_TYPE_FLOAT: write_float(pic, obj, port); break; case PIC_TYPE_BLOB: write_blob(pic, obj, port); break; case PIC_TYPE_CHAR: write_char(pic, obj, port, p); break; case PIC_TYPE_STRING: write_str(pic, obj, port, p); break; case PIC_TYPE_PAIR: write_pair(pic, obj, port, p); break; case PIC_TYPE_VECTOR: write_vec(pic, obj, port, p); break; case PIC_TYPE_DICT: write_dict(pic, obj, port, p); break; default: pic_fprintf(pic, port, "#<%s %p>", pic_typename(pic, pic_type(pic, obj)), pic_obj_ptr(obj)); break; } if (p->op == OP_WRITE) { if (is_shared_object(pic, obj, p)) { pic_weak_del(pic, labels, obj); } } }