Beispiel #1
0
static pic_value
pic_vec_vector_p(pic_state *pic)
{
  pic_value v;

  pic_get_args(pic, "o", &v);

  return pic_bool_value(pic_vec_p(v));
}
Beispiel #2
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;
  }
}
Beispiel #3
0
Datei: vm.c Projekt: krig/picrin
int
pic_get_args(pic_state *pic, const char *format, ...)
{
  char c;
  int i = 1, argc = pic->ci->argc;
  va_list ap;
  bool opt = false;

  va_start(ap, format);
  while ((c = *format++)) {
    switch (c) {
    default:
      if (argc <= i && ! opt) {
	pic_error(pic, "wrong number of arguments");
      }
      break;
    case '|':
      break;
    case '*':
      break;
    }

    /* in order to run out of all arguments passed to this function
       (i.e. do va_arg for each argument), optional argument existence
       check is done in every case closure */

    if (c == '*')
      break;

    switch (c) {
    case '|':
      opt = true;
      break;
    case 'o': {
      pic_value *p;

      p = va_arg(ap, pic_value*);
      if (i < argc) {
        *p = GET_OPERAND(pic,i);
        i++;
      }
      break;
    }
    case 'f': {
      double *f;

      f = va_arg(ap, double *);
      if (i < argc) {
        pic_value v;

        v = GET_OPERAND(pic, i);
        switch (pic_type(v)) {
        case PIC_TT_FLOAT:
          *f = pic_float(v);
          break;
        case PIC_TT_INT:
          *f = pic_int(v);
          break;
        default:
          pic_error(pic, "pic_get_args: expected float or int");
        }
        i++;
      }
      break;
    }
    case 'F': {
      double *f;
      bool *e;

      f = va_arg(ap, double *);
      e = va_arg(ap, bool *);
      if (i < argc) {
        pic_value v;

        v = GET_OPERAND(pic, i);
        switch (pic_type(v)) {
        case PIC_TT_FLOAT:
          *f = pic_float(v);
          *e = false;
          break;
        case PIC_TT_INT:
          *f = pic_int(v);
          *e = true;
          break;
        default:
          pic_error(pic, "pic_get_args: expected float or int");
        }
        i++;
      }
      break;
    }
    case 'I': {
      int *k;
      bool *e;

      k = va_arg(ap, int *);
      e = va_arg(ap, bool *);
      if (i < argc) {
        pic_value v;

        v = GET_OPERAND(pic, i);
        switch (pic_type(v)) {
        case PIC_TT_FLOAT:
          *k = (int)pic_float(v);
          *e = false;
          break;
        case PIC_TT_INT:
          *k = pic_int(v);
          *e = true;
          break;
        default:
          pic_error(pic, "pic_get_args: expected float or int");
        }
        i++;
      }
      break;
    }
    case 'i': {
      int *k;

      k = va_arg(ap, int *);
      if (i < argc) {
        pic_value v;

        v = GET_OPERAND(pic, i);
        switch (pic_type(v)) {
        case PIC_TT_FLOAT:
          *k = (int)pic_float(v);
          break;
        case PIC_TT_INT:
          *k = pic_int(v);
          break;
        default:
          pic_error(pic, "pic_get_args: expected int");
        }
        i++;
      }
      break;
    }
    case 's': {
      pic_str **str;
      pic_value v;

      str = va_arg(ap, pic_str **);
      if (i < argc) {
        v = GET_OPERAND(pic,i);
        if (pic_str_p(v)) {
          *str = pic_str_ptr(v);
        }
        else {
          pic_error(pic, "pic_get_args: expected string");
        }
        i++;
      }
      break;
    }
    case 'z': {
      pic_value str;
      const char **cstr;

      cstr = va_arg(ap, const char **);
      if (i < argc) {
        str = GET_OPERAND(pic,i);
        if (! pic_str_p(str)) {
          pic_error(pic, "pic_get_args: expected string");
        }
        *cstr = pic_str_cstr(pic_str_ptr(str));
        i++;
      }
      break;
    }
    case 'm': {
      pic_sym *m;
      pic_value v;

      m = va_arg(ap, pic_sym *);
      if (i < argc) {
        v = GET_OPERAND(pic,i);
        if (pic_sym_p(v)) {
          *m = pic_sym(v);
        }
        else {
          pic_error(pic, "pic_get_args: expected symbol");
        }
        i++;
      }
      break;
    }
    case 'v': {
      struct pic_vector **vec;
      pic_value v;

      vec = va_arg(ap, struct pic_vector **);
      if (i < argc) {
        v = GET_OPERAND(pic,i);
        if (pic_vec_p(v)) {
          *vec = pic_vec_ptr(v);
        }
        else {
          pic_error(pic, "pic_get_args: expected vector");
        }
        i++;
      }
      break;
    }
    case 'b': {
      struct pic_blob **b;
      pic_value v;

      b = va_arg(ap, struct pic_blob **);
      if (i < argc) {
        v = GET_OPERAND(pic,i);
        if (pic_blob_p(v)) {
          *b = pic_blob_ptr(v);
        }
        else {
          pic_error(pic, "pic_get_args: expected bytevector");
        }
        i++;
      }
      break;
    }
    case 'c': {
      char *c;
      pic_value v;

      c = va_arg(ap, char *);
      if (i < argc) {
        v = GET_OPERAND(pic,i);
        if (pic_char_p(v)) {
          *c = pic_char(v);
        }
        else {
          pic_error(pic, "pic_get_args: expected char");
        }
        i++;
      }
      break;
    }
    case 'l': {
      struct pic_proc **l;
      pic_value v;

      l = va_arg(ap, struct pic_proc **);
      if (i < argc) {
        v = GET_OPERAND(pic,i);
        if (pic_proc_p(v)) {
          *l = pic_proc_ptr(v);
        }
        else {
          pic_error(pic, "pic_get_args, expected procedure");
        }
        i++;
      }
      break;
    }
    case 'p': {
      struct pic_port **p;
      pic_value v;

      p = va_arg(ap, struct pic_port **);
      if (i < argc) {
        v = GET_OPERAND(pic,i);
        if (pic_port_p(v)) {
          *p = pic_port_ptr(v);
        }
        else {
          pic_error(pic, "pic_get_args, expected port");
        }
        i++;
      }
      break;
    }
    default:
      pic_error(pic, "pic_get_args: invalid argument specifier given");
    }
  }
  if ('*' == c) {
    size_t *n;
    pic_value **argv;

    n = va_arg(ap, size_t *);
    argv = va_arg(ap, pic_value **);
    if (i <= argc) {
      *n = argc - i;
      *argv = &GET_OPERAND(pic, i);
      i = argc;
    }
  }
Beispiel #4
0
Datei: bool.c Projekt: 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;
  }
}
Beispiel #5
0
int
pic_get_args(pic_state *pic, const char *format, ...)
{
  char c;
  int i = 1, argc = pic->ci->argc;
  va_list ap;
  bool opt = false;

  va_start(ap, format);
  while ((c = *format++)) {
    switch (c) {
    default:
      if (argc <= i && ! opt) {
	pic_error(pic, "wrong number of arguments");
      }
      break;
    case '|':
      break;
    }

    /* in order to run out of all arguments passed to this function
       (i.e. do va_arg for each argument), optional argument existence
       check is done in every case closure */

    switch (c) {
    case '|':
      opt = true;
      break;
    case 'o':
      {
	pic_value *p;

	p = va_arg(ap, pic_value*);
	if (i < argc) {
	  *p = GET_OPERAND(pic,i);
	  i++;
	}
      }
      break;
    case 'f':
      {
	double *f;

	f = va_arg(ap, double *);
	if (i < argc) {
	  pic_value v;

	  v = GET_OPERAND(pic, i);
	  switch (pic_type(v)) {
	  case PIC_TT_FLOAT:
	    *f = pic_float(v);
	    break;
	  case PIC_TT_INT:
	    *f = pic_int(v);
	    break;
	  default:
	    pic_error(pic, "pic_get_args: expected float or int");
	  }
	  i++;
	}
      }
      break;
    case 'F':
      {
	double *f;
	bool *e;

	f = va_arg(ap, double *);
	e = va_arg(ap, bool *);
	if (i < argc) {
	  pic_value v;

	  v = GET_OPERAND(pic, i);
	  switch (pic_type(v)) {
	  case PIC_TT_FLOAT:
	    *f = pic_float(v);
	    *e = false;
	    break;
	  case PIC_TT_INT:
	    *f = pic_int(v);
	    *e = true;
	    break;
	  default:
	    pic_error(pic, "pic_get_args: expected float or int");
	  }
	  i++;
	}
      }
      break;
    case 'I':
      {
	int *k;
	bool *e;

	k = va_arg(ap, int *);
	e = va_arg(ap, bool *);
	if (i < argc) {
	  pic_value v;

	  v = GET_OPERAND(pic, i);
	  switch (pic_type(v)) {
	  case PIC_TT_FLOAT:
	    *k = (int)pic_float(v);
	    *e = false;
	    break;
	  case PIC_TT_INT:
	    *k = pic_int(v);
	    *e = true;
	    break;
	  default:
	    pic_error(pic, "pic_get_args: expected float or int");
	  }
	  i++;
	}
      }
      break;
    case 'i':
      {
	int *k;

	k = va_arg(ap, int *);
	if (i < argc) {
	  pic_value v;

	  v = GET_OPERAND(pic, i);
	  switch (pic_type(v)) {
	  case PIC_TT_FLOAT:
	    *k = (int)pic_float(v);
	    break;
	  case PIC_TT_INT:
	    *k = pic_int(v);
	    break;
	  default:
	    pic_error(pic, "pic_get_args: expected int");
	  }
	  i++;
	}
      }
      break;
    case 's':
      {
	pic_value str;
	char **cstr;
	size_t *len;

	cstr = va_arg(ap, char **);
	len = va_arg(ap, size_t *);
	if (i < argc) {
	  str = GET_OPERAND(pic,i);
	  if (! pic_str_p(str)) {
	    pic_error(pic, "pic_get_args: expected string");
	  }
	  *cstr = pic_str_ptr(str)->str;
	  *len = pic_str_ptr(str)->len;
	  i++;
	}
      }
      break;
    case 'v':
      {
	struct pic_vector **vec;
	pic_value v;

	vec = va_arg(ap, struct pic_vector **);
	if (i < argc) {
	  v = GET_OPERAND(pic,i);
	  if (pic_vec_p(v)) {
	    *vec = pic_vec_ptr(v);
	  }
	  else {
	    pic_error(pic, "pic_get_args: expected vector");
	  }
	  i++;
	}
      }
      break;
    case 'b':
      {
	struct pic_blob **b;
	pic_value v;

	b = va_arg(ap, struct pic_blob **);
	if (i < argc) {
	  v = GET_OPERAND(pic,i);
	  if (pic_blob_p(v)) {
	    *b = pic_blob_ptr(v);
	  }
	  else {
	    pic_error(pic, "pic_get_args: expected bytevector");
	  }
	  i++;
	}
      }
      break;
    default:
      {
	pic_error(pic, "pic_get_args: invalid argument specifier given");
      }
    }
  }
  if (argc > i) {
    pic_error(pic, "wrong number of arguments");
  }
  va_end(ap);
  return i;
}