bool pic_eq_p(pic_state *PIC_UNUSED(pic), pic_value x, pic_value y) { if (pic_type(pic, x) != pic_type(pic, y)) return false; switch (pic_type(pic, x)) { case PIC_TYPE_NIL: return true; case PIC_TYPE_TRUE: case PIC_TYPE_FALSE: return pic_type(pic, x) == pic_type(pic, y); default: return pic_obj_ptr(x) == pic_obj_ptr(y); } }
bool pic_weak_has(pic_state *pic, pic_value weak, pic_value key) { khash_t(weak) *h = &pic_weak_ptr(pic, weak)->hash; return kh_get(weak, h, pic_obj_ptr(key)) != kh_end(h); }
void pic_weak_set(pic_state *pic, pic_value weak, pic_value key, pic_value val) { khash_t(weak) *h = &pic_weak_ptr(pic, weak)->hash; int ret; int it; it = kh_put(weak, h, pic_obj_ptr(key), &ret); kh_val(h, it) = val; }
void pic_end_try(pic_state *pic, pic_value cookie) { struct checkpoint *here = (struct checkpoint *)pic_obj_ptr(pic_car(pic, cookie)); pic_value out = pic_cdr(pic, cookie); pic->cp = here; pic_call(pic, out, 0); /* exit */ pic_exit_point(pic); }
void pic_weak_del(pic_state *pic, pic_value weak, pic_value key) { khash_t(weak) *h = &pic_weak_ptr(pic, weak)->hash; int it; it = kh_get(weak, h, pic_obj_ptr(key)); if (it == kh_end(h)) { pic_error(pic, "element not found for given key", 1, key); } kh_del(weak, h, it); }
static pic_value reg_call(pic_state *pic) { struct pic_proc *self = pic_get_proc(pic); struct pic_reg *reg; pic_value key, val; int n; n = pic_get_args(pic, "o|o", &key, &val); if (! pic_obj_p(key)) { pic_errorf(pic, "attempted to set a non-object key '~s' in a register", key); } reg = pic_reg_ptr(pic_proc_env_ref(pic, self, "reg")); if (n == 1) { return reg_get(pic, reg, pic_obj_ptr(key)); } else { return reg_set(pic, reg, pic_obj_ptr(key), val); } }
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); } } }
static bool internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *ht) { pic_value local = pic_nil_value(); size_t c; if (depth > 10) { if (depth > 200) { pic_errorf(pic, "Stack overflow in equal\n"); } if (pic_pair_p(x) || pic_vec_p(x)) { if (xh_get_ptr(ht, pic_obj_ptr(x)) != NULL) { return true; /* `x' was seen already. */ } else { xh_put_ptr(ht, pic_obj_ptr(x), NULL); } } } c = 0; LOOP: if (pic_eqv_p(x, y)) return true; if (pic_type(x) != pic_type(y)) return false; switch (pic_type(x)) { case PIC_TT_STRING: return str_equal_p(pic_str_ptr(x), pic_str_ptr(y)); case PIC_TT_BLOB: return blob_equal_p(pic_blob_ptr(x), pic_blob_ptr(y)); case PIC_TT_PAIR: { if (pic_nil_p(local)) { local = x; } if (internal_equal_p(pic, pic_car(pic, x), pic_car(pic, y), depth + 1, ht)) { x = pic_cdr(pic, x); y = pic_cdr(pic, y); c++; if (c == 2) { c = 0; local = pic_cdr(pic, local); if (pic_eq_p(local, x)) { return true; } } goto LOOP; } else { return false; } } case PIC_TT_VECTOR: { size_t i; struct pic_vector *u, *v; u = pic_vec_ptr(x); v = pic_vec_ptr(y); if (u->len != v->len) { return false; } for (i = 0; i < u->len; ++i) { if (! internal_equal_p(pic, u->data[i], v->data[i], depth + 1, ht)) return false; } return true; } default: return false; } }