Exemple #1
0
static pic_value
pic_vec_vector_copy_i(pic_state *pic)
{
  pic_vec *to, *from;
  int n, at, start, end;

  n = pic_get_args(pic, "viv|ii", &to, &at, &from, &start, &end);

  switch (n) {
  case 3:
    start = 0;
  case 4:
    end = from->len;
  }

  if (to == from && (start <= at && at < end)) {
    /* copy in reversed order */
    at += end - start;
    while (start < end) {
      to->data[--at] = from->data[--end];
    }
    return pic_undef_value();
  }

  while (start < end) {
    to->data[at++] = from->data[start++];
  }

  return pic_undef_value();
}
Exemple #2
0
static pic_value
pic_vec_vector_for_each(pic_state *pic)
{
  struct pic_proc *proc;
  int argc, i, len, j;
  pic_value *argv, vals;

  pic_get_args(pic, "l*", &proc, &argc, &argv);

  len = INT_MAX;
  for (i = 0; i < argc; ++i) {
    pic_assert_type(pic, argv[i], vec);

    len = len < pic_vec_ptr(argv[i])->len
      ? len
      : pic_vec_ptr(argv[i])->len;
  }

  for (i = 0; i < len; ++i) {
    vals = pic_nil_value();
    for (j = 0; j < argc; ++j) {
      pic_push(pic, pic_vec_ptr(argv[j])->data[i], vals);
    }
    pic_apply_list(pic, proc, vals);
  }

  return pic_undef_value();
}
Exemple #3
0
static pic_value
pic_str_string_for_each(pic_state *pic)
{
  struct pic_proc *proc;
  int argc, len, i, j;
  pic_value *argv, vals;

  pic_get_args(pic, "l*", &proc, &argc, &argv);

  if (argc == 0) {
    pic_errorf(pic, "string-map: one or more strings expected, but got zero");
  } else {
    pic_assert_type(pic, argv[0], str);
    len = pic_str_len(pic_str_ptr(argv[0]));
  }
  for (i = 1; i < argc; ++i) {
    pic_assert_type(pic, argv[i], str);

    len = len < pic_str_len(pic_str_ptr(argv[i]))
      ? len
      : pic_str_len(pic_str_ptr(argv[i]));
  }

  for (i = 0; i < len; ++i) {
    vals = pic_nil_value();
    for (j = 0; j < argc; ++j) {
      pic_push(pic, pic_char_value(pic_str_ref(pic, pic_str_ptr(argv[j]), i)), vals);
    }
    pic_apply_list(pic, proc, vals);
  }

  return pic_undef_value();
}
Exemple #4
0
static pic_value
weak_call(pic_state *pic)
{
  pic_value key, val, weak;
  int n;

  n = pic_get_args(pic, "o|o", &key, &val);

  if (! pic_obj_p(pic, key)) {
    pic_error(pic, "attempted to set a non-object key", 1, key);
  }

  weak = pic_closure_ref(pic, 0);

  if (n == 1) {
    if (! pic_weak_has(pic, weak, key)) {
      return pic_false_value(pic);
    }
    return pic_cons(pic, key, pic_weak_ref(pic, weak, key));
  } else {
    if (pic_undef_p(pic, val)) {
      if (pic_weak_has(pic, weak, key)) {
        pic_weak_del(pic, weak, key);
      }
    } else {
      pic_weak_set(pic, weak, key, val);
    }
    return pic_undef_value(pic);
  }
}
Exemple #5
0
static pic_value
pic_write_display(pic_state *pic)
{
  pic_value v, port = pic_stdout(pic);

  pic_get_args(pic, "o|p", &v, &port);
  write_value(pic, v, port, DISPLAY_MODE, OP_WRITE);
  return pic_undef_value(pic);
}
Exemple #6
0
static pic_value
pic_write_write_shared(pic_state *pic)
{
  pic_value v, port = pic_stdout(pic);

  pic_get_args(pic, "o|p", &v, &port);
  write_value(pic, v, port, WRITE_MODE, OP_WRITE_SHARED);
  return pic_undef_value(pic);
}
Exemple #7
0
void
pic_close(pic_state *pic)
{
  xh_entry *it;

  /* invoke exit handlers */
  while (pic->wind) {
    if (pic->wind->out) {
      pic_apply0(pic, pic->wind->out);
    }
    pic->wind = pic->wind->prev;
  }

  /* free symbol names */
  for (it = xh_begin(&pic->syms); it != NULL; it = xh_next(it)) {
    free(xh_key(it, char *));
  }

  /* clear out root objects */
  pic->sp = pic->stbase;
  pic->ci = pic->cibase;
  pic->xp = pic->xpbase;
  pic->arena_idx = 0;
  pic->err = pic_undef_value();
  pic->globals = NULL;
  pic->macros = NULL;
  xh_clear(&pic->syms);
  xh_clear(&pic->attrs);
  pic->features = pic_nil_value();
  pic->libs = pic_nil_value();

  /* free all heap objects */
  pic_gc_run(pic);

  /* free heaps */
  pic_heap_close(pic->heap);

  /* free runtime context */
  free(pic->stbase);
  free(pic->cibase);
  free(pic->xpbase);

  /* free reader struct */
  xh_destroy(&pic->reader->labels);
  pic_trie_delete(pic, pic->reader->trie);
  free(pic->reader);

  /* free global stacks */
  xh_destroy(&pic->syms);
  xh_destroy(&pic->attrs);

  /* free GC arena */
  free(pic->arena);

  free(pic);
}
Exemple #8
0
pic_value
pic_values(pic_state *pic, int argc, pic_value *argv)
{
  int i;

  for (i = 0; i < argc; ++i) {
    pic->sp[i] = argv[i];
  }
  pic->ci->retc = (int)argc;

  return argc == 0 ? pic_undef_value() : pic->sp[0];
}
Exemple #9
0
pic_value
pic_values_by_array(pic_state *pic, size_t argc, pic_value *argv)
{
  size_t i;

  for (i = 0; i < argc; ++i) {
    pic->sp[i] = argv[i];
  }
  pic->ci->retc = (int)argc;

  return argc == 0 ? pic_undef_value() : pic->sp[0];
}
Exemple #10
0
static pic_value
pic_str_string_set(pic_state *pic)
{
  pic_str *str;
  char c;
  int k;

  pic_get_args(pic, "sic", &str, &k, &c);

  pic_str_set(pic, str, k, c);
  return pic_undef_value();
}
Exemple #11
0
static pic_value
pic_load_load(pic_state *pic)
{
  pic_value envid;
  char *fn;

  pic_get_args(pic, "z|o", &fn, &envid);

  pic_load(pic, fn);

  return pic_undef_value();
}
Exemple #12
0
pic_value
pic_file_delete(pic_state *pic)
{
  char *fname;

  pic_get_args(pic, "z", &fname);

  if (remove(fname) != 0) {
    file_error(pic, "file cannot be deleted");
  }
  return pic_undef_value();
}
Exemple #13
0
static pic_value
pic_record_record_set(pic_state *pic)
{
  struct pic_record *rec;
  pic_sym *slot;
  pic_value val;

  pic_get_args(pic, "rmo", &rec, &slot, &val);

  pic_record_set(pic, rec, slot, val);

  return pic_undef_value();
}
Exemple #14
0
static pic_value
reg_set(pic_state *pic, struct pic_reg *reg, void *key, pic_value val)
{
  if (pic_undef_p(val)) {
    if (pic_reg_has(pic, reg, key)) {
      pic_reg_del(pic, reg, key);
    }
  } else {
    pic_reg_set(pic, reg, key, val);
  }

  return pic_undef_value();
}
Exemple #15
0
pic_value
pic_values_by_list(pic_state *pic, pic_value list)
{
  pic_value v, it;
  int i;

  i = 0;
  pic_for_each (v, list, it) {
    pic->sp[i++] = v;
  }
  pic->ci->retc = i;

  return pic_nil_p(list) ? pic_undef_value() : pic->sp[0];
}
Exemple #16
0
struct pic_vector *
pic_make_vec(pic_state *pic, int len)
{
  struct pic_vector *vec;
  int i;

  vec = (struct pic_vector *)pic_obj_alloc(pic, sizeof(struct pic_vector), PIC_TT_VECTOR);
  vec->len = len;
  vec->data = (pic_value *)pic_malloc(pic, sizeof(pic_value) * len);
  for (i = 0; i < len; ++i) {
    vec->data[i] = pic_undef_value();
  }
  return vec;
}
Exemple #17
0
static pic_value
dynamic_set(pic_state *pic)
{
  pic_value var, val;

  pic_get_args(pic, "");

  var = pic_closure_ref(pic, 0);
  val = pic_closure_ref(pic, 1);

  pic_proc_ptr(pic, var)->locals[0] = val;

  return pic_undef_value(pic);
}
Exemple #18
0
static pic_value
pic_vec_vector_set(pic_state *pic)
{
  struct pic_vector *v;
  int k;
  pic_value o;

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

  if (v->len <= k) {
    pic_errorf(pic, "vector-set!: index out of range");
  }
  v->data[k] = o;
  return pic_undef_value();
}
Exemple #19
0
static pic_value
pic_load_load(pic_state *pic)
{
  pic_value envid;
  char *fn;
  struct pic_port *port;

  pic_get_args(pic, "z|o", &fn, &envid);

  port = pic_open_file(pic, fn, PIC_PORT_IN | PIC_PORT_TEXT);

  pic_load(pic, port);

  pic_close_port(pic, port);

  return pic_undef_value();
}
Exemple #20
0
static pic_value
pic_blob_bytevector_u8_set(pic_state *pic)
{
  unsigned char *buf;
  int len, k, v;

  pic_get_args(pic, "bii", &buf, &len, &k, &v);

  if (v < 0 || v > 255)
    pic_error(pic, "byte out of range", 0);

  VALID_INDEX(pic, len, k);

  buf[k] = (unsigned char)v;

  return pic_undef_value(pic);
}
Exemple #21
0
void
pic_save_point(pic_state *pic, struct pic_cont *cont)
{
  cont->jmp.prev = pic->jmp;
  pic->jmp = &cont->jmp;

  /* save runtime context */
  cont->cp = pic->cp;
  cont->sp_offset = pic->sp - pic->stbase;
  cont->ci_offset = pic->ci - pic->cibase;
  cont->xp_offset = pic->xp - pic->xpbase;
  cont->arena_idx = pic->arena_idx;
  cont->ip = pic->ip;
  cont->ptable = pic->ptable;

  cont->results = pic_undef_value();
}
Exemple #22
0
static pic_value
pic_dict_dictionary_set(pic_state *pic)
{
  struct pic_dict *dict;
  pic_sym *key;
  pic_value val;

  pic_get_args(pic, "dmo", &dict, &key, &val);

  if (pic_undef_p(val)) {
    if (pic_dict_has(pic, dict, key)) {
      pic_dict_del(pic, dict, key);
    }
  }
  else {
    pic_dict_set(pic, dict, key, val);
  }
  return pic_undef_value();
}
Exemple #23
0
static pic_value
pic_dict_dictionary_for_each(pic_state *pic)
{
  struct pic_proc *proc;
  struct pic_dict *dict;
  khiter_t it;
  khash_t(dict) *kh;

  pic_get_args(pic, "ld", &proc, &dict);

  kh = &dict->hash;

  for (it = kh_begin(kh); it != kh_end(kh); ++it) {
    if (kh_exist(kh, it)) {
      pic_apply1(pic, proc, pic_obj_value(kh_key(kh, it)));
    }
  }

  return pic_undef_value();
}
Exemple #24
0
static pic_value
pic_str_string_fill_ip(pic_state *pic)
{
  pic_str *str;
  char c;
  int n, start, end;

  n = pic_get_args(pic, "sc|ii", &str, &c, &start, &end);

  switch (n) {
  case 2:
    start = 0;
  case 3:
    end = pic_str_len(str);
  }

  while (start < end) {
    pic_str_set(pic, str, start++, c);
  }
  return pic_undef_value();
}
Exemple #25
0
static pic_value
pic_blob_bytevector_copy_i(pic_state *pic)
{
  unsigned char *to, *from;
  int n, at, start, end, tolen, fromlen;

  n = pic_get_args(pic, "bib|ii", &to, &tolen, &at, &from, &fromlen, &start, &end);

  switch (n) {
  case 3:
    start = 0;
  case 4:
    end = fromlen;
  }

  VALID_ATRANGE(pic, tolen, at, fromlen, start, end);

  memmove(to + at, from + start, end - start);

  return pic_undef_value(pic);
}
Exemple #26
0
static pic_value
pic_load_load(pic_state *pic)
{
  pic_value envid, port;
  char *fn;
  FILE *fp;

  pic_get_args(pic, "z|o", &fn, &envid);

  fp = fopen(fn, "r");
  if (fp == NULL) {
    pic_error(pic, "load: could not open file", 1, pic_cstr_value(pic, fn));
  }

  port = pic_fopen(pic, fp, "r");

  pic_load(pic, port);

  pic_fclose(pic, port);

  return pic_undef_value(pic);
}
Exemple #27
0
static pic_value
pic_vec_vector_fill_i(pic_state *pic)
{
  pic_vec *vec;
  pic_value obj;
  int n, start, end;

  n = pic_get_args(pic, "vo|ii", &vec, &obj, &start, &end);

  switch (n) {
  case 2:
    start = 0;
  case 3:
    end = vec->len;
  }

  while (start < end) {
    vec->data[start++] = obj;
  }

  return pic_undef_value();
}
Exemple #28
0
static pic_value
pic_str_string_copy_ip(pic_state *pic)
{
  pic_str *to, *from;
  int n, at, start, end;

  n = pic_get_args(pic, "sis|ii", &to, &at, &from, &start, &end);

  switch (n) {
  case 3:
    start = 0;
  case 4:
    end = pic_str_len(from);
  }
  if (to == from) {
    from = pic_str_sub(pic, from, 0, end);
  }

  while (start < end) {
    pic_str_set(pic, to, at++, pic_str_ref(pic, from, start++));
  }
  return pic_undef_value();
}
Exemple #29
0
void
pic_close(pic_state *pic)
{
  size_t i;

  /* free global stacks */
  free(pic->stbase);
  free(pic->cibase);
  free(pic->rescue);
  free(pic->globals);

  xh_destroy(pic->sym_tbl);
  xh_destroy(pic->global_tbl);

  pic->glen = 0;
  pic->rlen = 0;
  pic->arena_idx = 0;
  pic->lib_tbl = pic_undef_value();

  /* free all values */
  pic_gc_run(pic);

  /* free heaps */
  finalize_heap(pic->heap);
  free(pic->heap);

  /* free symbol names */
  for (i = 0; i < pic->slen; ++i) {
    free((void *)pic->sym_pool[i]);
  }
  free(pic->sym_pool);

  PIC_BLK_DECREF(pic, pic->blk);

  free(pic);
}
Exemple #30
0
pic_state *
pic_open(int argc, char *argv[], char **envp)
{
  struct pic_port *pic_make_standard_port(pic_state *, xFILE *, short);
  char t;

  pic_state *pic;
  size_t ai;

  pic = malloc(sizeof(pic_state));

  /* turn off GC */
  pic->gc_enable = false;

  /* root block */
  pic->wind = NULL;

  /* command line */
  pic->argc = argc;
  pic->argv = argv;
  pic->envp = envp;

  /* prepare VM stack */
  pic->stbase = pic->sp = calloc(PIC_STACK_SIZE, sizeof(pic_value));
  pic->stend = pic->stbase + PIC_STACK_SIZE;

  /* callinfo */
  pic->cibase = pic->ci = calloc(PIC_STACK_SIZE, sizeof(pic_callinfo));
  pic->ciend = pic->cibase + PIC_STACK_SIZE;

  /* exception handler */
  pic->xpbase = pic->xp = calloc(PIC_RESCUE_SIZE, sizeof(struct pic_proc *));
  pic->xpend = pic->xpbase + PIC_RESCUE_SIZE;

  /* memory heap */
  pic->heap = pic_heap_open();

  /* symbol table */
  xh_init_str(&pic->syms, sizeof(pic_sym *));

  /* global variables */
  pic->globals = NULL;

  /* macros */
  pic->macros = NULL;

  /* attributes */
  xh_init_ptr(&pic->attrs, sizeof(struct pic_dict *));

  /* features */
  pic->features = pic_nil_value();

  /* libraries */
  pic->libs = pic_nil_value();
  pic->lib = NULL;

  /* GC arena */
  pic->arena = calloc(PIC_ARENA_SIZE, sizeof(struct pic_object **));
  pic->arena_size = PIC_ARENA_SIZE;
  pic->arena_idx = 0;

  /* raised error object */
  pic->err = pic_undef_value();

  /* standard ports */
  pic->xSTDIN = NULL;
  pic->xSTDOUT = NULL;
  pic->xSTDERR = NULL;

  /* native stack marker */
  pic->native_stack_start = &t;

  ai = pic_gc_arena_preserve(pic);

#define S(slot,name) pic->slot = pic_intern_cstr(pic, name);

  S(sDEFINE, "define");
  S(sLAMBDA, "lambda");
  S(sIF, "if");
  S(sBEGIN, "begin");
  S(sSETBANG, "set!");
  S(sQUOTE, "quote");
  S(sQUASIQUOTE, "quasiquote");
  S(sUNQUOTE, "unquote");
  S(sUNQUOTE_SPLICING, "unquote-splicing");
  S(sDEFINE_SYNTAX, "define-syntax");
  S(sIMPORT, "import");
  S(sEXPORT, "export");
  S(sDEFINE_LIBRARY, "define-library");
  S(sIN_LIBRARY, "in-library");
  S(sCOND_EXPAND, "cond-expand");
  S(sAND, "and");
  S(sOR, "or");
  S(sELSE, "else");
  S(sLIBRARY, "library");
  S(sONLY, "only");
  S(sRENAME, "rename");
  S(sPREFIX, "prefix");
  S(sEXCEPT, "except");
  S(sCONS, "cons");
  S(sCAR, "car");
  S(sCDR, "cdr");
  S(sNILP, "null?");
  S(sSYMBOLP, "symbol?");
  S(sPAIRP, "pair?");
  S(sADD, "+");
  S(sSUB, "-");
  S(sMUL, "*");
  S(sDIV, "/");
  S(sMINUS, "minus");
  S(sEQ, "=");
  S(sLT, "<");
  S(sLE, "<=");
  S(sGT, ">");
  S(sGE, ">=");
  S(sNOT, "not");
  S(sREAD, "read");
  S(sFILE, "file");
  S(sCALL, "call");
  S(sTAILCALL, "tail-call");
  S(sGREF, "gref");
  S(sLREF, "lref");
  S(sCREF, "cref");
  S(sRETURN, "return");
  S(sCALL_WITH_VALUES, "call-with-values");
  S(sTAILCALL_WITH_VALUES, "tailcall-with-values");

  pic_gc_arena_restore(pic, ai);

#define R(slot,name) pic->slot = pic_gensym(pic, pic_intern_cstr(pic, name));

  R(rDEFINE, "define");
  R(rLAMBDA, "lambda");
  R(rIF, "if");
  R(rBEGIN, "begin");
  R(rSETBANG, "set!");
  R(rQUOTE, "quote");
  R(rDEFINE_SYNTAX, "define-syntax");
  R(rIMPORT, "import");
  R(rEXPORT, "export");
  R(rDEFINE_LIBRARY, "define-library");
  R(rIN_LIBRARY, "in-library");
  R(rCOND_EXPAND, "cond-expand");
  pic_gc_arena_restore(pic, ai);

  /* root tables */
  pic->globals = pic_make_dict(pic);
  pic->macros = pic_make_dict(pic);

  /* root block */
  pic->wind = pic_alloc(pic, sizeof(struct pic_winder));
  pic->wind->prev = NULL;
  pic->wind->depth = 0;
  pic->wind->in = pic->wind->out = NULL;

  /* reader */
  pic->reader = malloc(sizeof(struct pic_reader));
  pic->reader->typecase = PIC_CASE_DEFAULT;
  pic->reader->trie = pic_make_trie(pic);
  xh_init_int(&pic->reader->labels, sizeof(pic_value));

  /* init readers */
  pic_init_reader(pic);

  /* standard libraries */
  pic->PICRIN_BASE = pic_open_library(pic, pic_read_cstr(pic, "(picrin base)"));
  pic->PICRIN_USER = pic_open_library(pic, pic_read_cstr(pic, "(picrin user)"));
  pic->lib = pic->PICRIN_USER;

  /* standard I/O */
  pic->xSTDIN = pic_make_standard_port(pic, xstdin, PIC_PORT_IN);
  pic->xSTDOUT = pic_make_standard_port(pic, xstdout, PIC_PORT_OUT);
  pic->xSTDERR = pic_make_standard_port(pic, xstderr, PIC_PORT_OUT);

  pic_gc_arena_restore(pic, ai);

  /* turn on GC */
  pic->gc_enable = true;

  pic_init_core(pic);

  return pic;
}