Esempio n. 1
0
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;
    }
  }
}
Esempio n. 2
0
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();
}
Esempio n. 3
0
File: pair.c Progetto: hiromu/picrin
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);
}
Esempio n. 4
0
File: pair.c Progetto: hiromu/picrin
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));
}
Esempio n. 5
0
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, ")");
}
Esempio n. 6
0
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;
}
Esempio n. 7
0
File: pair.c Progetto: hiromu/picrin
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;
}
Esempio n. 8
0
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, ")");
}
Esempio n. 9
0
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;
  }
}
Esempio n. 10
0
File: pair.c Progetto: hiromu/picrin
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();
}
Esempio n. 11
0
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);
  }
}
Esempio n. 12
0
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);
  }
}
Esempio n. 13
0
File: lib.c Progetto: omasanori/benz
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)));
      }
Esempio n. 14
0
File: bool.c Progetto: KeenS/benz
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;
  }
}