bool
pic_list_p(pic_value obj)
{
pic_value local, rapid;
int i;
/* Floyd's cycle-finding algorithm. */
local = rapid = obj;
while (true) {
/* advance rapid fast-forward; runs 2x faster than local */
for (i = 0; i < 2; ++i) {
if (pic_pair_p(rapid)) {
rapid = pic_pair_ptr(rapid)->cdr;
}
else {
return pic_nil_p(rapid);
}
}
/* advance local */
local = pic_pair_ptr(local)->cdr;
if (pic_eq_p(local, rapid)) {
return false;
}
}
}
static pic_value
pic_proc_for_each(pic_state *pic)
{
struct pic_proc *proc;
size_t argc;
pic_value *args;
int i;
pic_value cars;
pic_get_args(pic, "l*", &proc, &argc, &args);
do {
cars = pic_nil_value();
for (i = argc - 1; i >= 0; --i) {
if (! pic_pair_p(args[i])) {
break;
}
cars = pic_cons(pic, pic_car(pic, args[i]), cars);
args[i] = pic_cdr(pic, args[i]);
}
if (i >= 0)
break;
pic_apply(pic, proc, cars);
} while (1);
return pic_none_value();
}
bool
pic_list_p(pic_state *pic, pic_value obj)
{
while (pic_pair_p(obj))
obj = pic_pair_ptr(obj)->cdr;
return pic_nil_p(obj);
}
static pic_value
pic_pair_pair_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_bool_value(pic_pair_p(v));
}
static void
write_pair(struct writer_control *p, struct pic_pair *pair)
{
pic_state *pic = p->pic;
xFILE *file = p->file;
pic_sym *tag;
if (pic_pair_p(pair->cdr) && pic_nil_p(pic_cdr(pic, pair->cdr)) && pic_sym_p(pair->car)) {
tag = pic_sym_ptr(pair->car);
if (tag == pic->sQUOTE) {
xfprintf(pic, file, "'");
write_core(p, pic_car(pic, pair->cdr));
return;
}
else if (tag == pic->sUNQUOTE) {
xfprintf(pic, file, ",");
write_core(p, pic_car(pic, pair->cdr));
return;
}
else if (tag == pic->sUNQUOTE_SPLICING) {
xfprintf(pic, file, ",@");
write_core(p, pic_car(pic, pair->cdr));
return;
}
else if (tag == pic->sQUASIQUOTE) {
xfprintf(pic, file, "`");
write_core(p, pic_car(pic, pair->cdr));
return;
}
else if (tag == pic->sSYNTAX_QUOTE) {
xfprintf(pic, file, "#'");
write_core(p, pic_car(pic, pair->cdr));
return;
}
else if (tag == pic->sSYNTAX_UNQUOTE) {
xfprintf(pic, file, "#,");
write_core(p, pic_car(pic, pair->cdr));
return;
}
else if (tag == pic->sSYNTAX_UNQUOTE_SPLICING) {
xfprintf(pic, file, "#,@");
write_core(p, pic_car(pic, pair->cdr));
return;
}
else if (tag == pic->sSYNTAX_QUASIQUOTE) {
xfprintf(pic, file, "#`");
write_core(p, pic_car(pic, pair->cdr));
return;
}
}
xfprintf(pic, file, "(");
write_pair_help(p, pair);
xfprintf(pic, file, ")");
}
void
pic_set_cdr(pic_state *pic, pic_value obj, pic_value val)
{
struct pic_pair *pair;
if (! pic_pair_p(obj)) {
pic_errorf(pic, "pair required");
}
pair = pic_pair_ptr(obj);
pair->cdr = val;
}
pic_value
pic_cdr(pic_state *pic, pic_value obj)
{
struct pic_pair *pair;
if (! pic_pair_p(obj)) {
pic_error(pic, "pair required");
}
pair = pic_pair_ptr(obj);
return pair->cdr;
}
static void
write_pair(pic_state *pic, pic_value pair, pic_value port, struct writer_control *p)
{
pic_value tag;
if (pic_pair_p(pic, pic_cdr(pic, pair)) && pic_nil_p(pic, pic_cddr(pic, pair)) && pic_sym_p(pic, pic_car(pic, pair))) {
tag = pic_car(pic, pair);
if (EQ(tag, "quote")) {
pic_fprintf(pic, port, "'");
write_core(pic, pic_cadr(pic, pair), port, p);
return;
}
else if (EQ(tag, "unquote")) {
pic_fprintf(pic, port, ",");
write_core(pic, pic_cadr(pic, pair), port, p);
return;
}
else if (EQ(tag, "unquote-splicing")) {
pic_fprintf(pic, port, ",@");
write_core(pic, pic_cadr(pic, pair), port, p);
return;
}
else if (EQ(tag, "quasiquote")) {
pic_fprintf(pic, port, "`");
write_core(pic, pic_cadr(pic, pair), port, p);
return;
}
else if (EQ(tag, "syntax-quote")) {
pic_fprintf(pic, port, "#'");
write_core(pic, pic_cadr(pic, pair), port, p);
return;
}
else if (EQ(tag, "syntax-unquote")) {
pic_fprintf(pic, port, "#,");
write_core(pic, pic_cadr(pic, pair), port, p);
return;
}
else if (EQ(tag, "syntax-unquote-splicing")) {
pic_fprintf(pic, port, "#,@");
write_core(pic, pic_cadr(pic, pair), port, p);
return;
}
else if (EQ(tag, "syntax-quasiquote")) {
pic_fprintf(pic, port, "#`");
write_core(pic, pic_cadr(pic, pair), port, p);
return;
}
}
pic_fprintf(pic, port, "(");
write_pair_help(pic, pair, port, p);
pic_fprintf(pic, port, ")");
}
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_pair_set_cdr(pic_state *pic)
{
pic_value v,w;
pic_get_args(pic, "oo", &v, &w);
if (! pic_pair_p(v))
pic_error(pic, "pair expected");
pic_pair_ptr(v)->cdr = w;
return pic_true_value();
}
static void
write_pair_help(struct writer_control *p, struct pic_pair *pair)
{
pic_state *pic = p->pic;
khash_t(l) *lh = &p->labels;
khash_t(v) *vh = &p->visited;
khiter_t it;
int ret;
write_core(p, pair->car);
if (pic_nil_p(pair->cdr)) {
return;
}
else if (pic_pair_p(pair->cdr)) {
/* shared objects */
if ((it = kh_get(l, lh, pic_ptr(pair->cdr))) != kh_end(lh) && kh_val(lh, it) != -1) {
xfprintf(pic, p->file, " . ");
kh_put(v, vh, pic_ptr(pair->cdr), &ret);
if (ret == 0) { /* if exists */
xfprintf(pic, p->file, "#%d#", kh_val(lh, it));
return;
}
xfprintf(pic, p->file, "#%d=", kh_val(lh, it));
}
else {
xfprintf(pic, p->file, " ");
}
write_pair_help(p, pic_pair_ptr(pair->cdr));
if (p->op == OP_WRITE) {
if ((it = kh_get(l, lh, pic_ptr(pair->cdr))) != kh_end(lh) && kh_val(lh, it) != -1) {
it = kh_get(v, vh, pic_ptr(pair->cdr));
kh_del(v, vh, it);
}
}
return;
}
else {
xfprintf(pic, p->file, " . ");
write_core(p, pair->cdr);
}
}
static void
write_pair_help(pic_state *pic, pic_value pair, pic_value port, struct writer_control *p)
{
pic_value cdr = pic_cdr(pic, pair);
write_core(pic, pic_car(pic, pair), port, p);
if (pic_nil_p(pic, cdr)) {
return;
}
else if (pic_pair_p(pic, cdr) && ! is_shared_object(pic, cdr, p)) {
pic_fprintf(pic, port, " ");
write_pair_help(pic, cdr, port, p);
}
else {
pic_fprintf(pic, port, " . ");
write_core(pic, cdr, port, p);
}
}
static void
import_table(pic_state *pic, pic_value spec, struct pic_dict *imports)
{
struct pic_lib *lib;
struct pic_dict *table;
pic_value val, tmp, prefix;
pic_sym *sym, *id, *tag;
table = pic_make_dict(pic);
if (pic_pair_p(spec) && pic_sym_p(pic_car(pic, spec))) {
tag = pic_sym_ptr(pic_car(pic, spec));
if (tag == pic->sONLY) {
import_table(pic, pic_cadr(pic, spec), table);
pic_for_each (val, pic_cddr(pic, spec)) {
pic_dict_set(pic, imports, pic_sym_ptr(val), pic_dict_ref(pic, table, pic_sym_ptr(val)));
}
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;
}
}