void pic_print_backtrace(pic_state *pic, xFILE *file) { assert(! pic_invalid_p(pic->err)); if (! pic_error_p(pic->err)) { xfprintf(file, "raise: "); pic_fwrite(pic, pic->err, file); } else { struct pic_error *e; e = pic_error_ptr(pic->err); if (e->type != pic_intern_cstr(pic, "")) { pic_fwrite(pic, pic_obj_value(e->type), file); xfprintf(file, " "); } xfprintf(file, "error: "); pic_fwrite(pic, pic_obj_value(e->msg), file); xfprintf(file, "\n"); /* TODO: print error irritants */ xfputs(pic_str_cstr(pic, e->stack), file); } }
static pic_value pic_system_getenvs(pic_state *pic) { char **envp; pic_value data = pic_nil_value(); size_t ai = pic_gc_arena_preserve(pic); pic_get_args(pic, ""); if (! pic->envp) { return pic_nil_value(); } for (envp = pic->envp; *envp; ++envp) { pic_str *key, *val; size_t i; for (i = 0; (*envp)[i] != '='; ++i) ; key = pic_make_str(pic, *envp, i); val = pic_make_str_cstr(pic, getenv(pic_str_cstr(key))); /* push */ data = pic_acons(pic, pic_obj_value(key), pic_obj_value(val), data); pic_gc_arena_restore(pic, ai); pic_gc_protect(pic, data); } return data; }
static pic_value pic_regexp_regexp_match(pic_state *pic) { pic_value reg; const char *input; regmatch_t match[100]; pic_value matches, positions; pic_str *str; int i, offset; pic_get_args(pic, "oz", ®, &input); pic_assert_type(pic, reg, regexp); matches = pic_nil_value(); positions = pic_nil_value(); if (strchr(pic_regexp_data_ptr(reg)->flags, 'g') != NULL) { /* global search */ offset = 0; while (regexec(&pic_regexp_data_ptr(reg)->reg, input, 1, match, 0) != REG_NOMATCH) { pic_push(pic, pic_obj_value(pic_str_new(pic, input, match[0].rm_eo - match[0].rm_so)), matches); pic_push(pic, pic_int_value(offset), positions); offset += match[0].rm_eo; input += match[0].rm_eo; } } else { /* local search */ if (regexec(&pic_regexp_data_ptr(reg)->reg, input, 100, match, 0) == 0) { for (i = 0; i < 100; ++i) { if (match[i].rm_so == -1) { break; } str = pic_str_new(pic, input + match[i].rm_so, match[i].rm_eo - match[i].rm_so); pic_push(pic, pic_obj_value(str), matches); pic_push(pic, pic_int_value(match[i].rm_so), positions); } } } if (pic_nil_p(matches)) { matches = pic_false_value(); positions = pic_false_value(); } else { matches = pic_reverse(pic, matches); positions = pic_reverse(pic, positions); } return pic_values2(pic, matches, positions); }
void pic_init_port(pic_state *pic) { pic_defvar(pic, "current-input-port", pic_obj_value(pic->xSTDIN), NULL); pic_defvar(pic, "current-output-port", pic_obj_value(pic->xSTDOUT), NULL); pic_defvar(pic, "current-error-port", pic_obj_value(pic->xSTDERR), NULL); pic_defun(pic, "call-with-port", pic_port_call_with_port); pic_defun(pic, "input-port?", pic_port_input_port_p); pic_defun(pic, "output-port?", pic_port_output_port_p); pic_defun(pic, "textual-port?", pic_port_textual_port_p); pic_defun(pic, "binary-port?", pic_port_binary_port_p); pic_defun(pic, "port?", pic_port_port_p); pic_defun(pic, "port-open?", pic_port_port_open_p); pic_defun(pic, "close-port", pic_port_close_port); /* string I/O */ pic_defun(pic, "open-input-string", pic_port_open_input_string); pic_defun(pic, "open-output-string", pic_port_open_output_string); pic_defun(pic, "get-output-string", pic_port_get_output_string); pic_defun(pic, "open-input-bytevector", pic_port_open_input_blob); pic_defun(pic, "open-output-bytevector", pic_port_open_output_bytevector); pic_defun(pic, "get-output-bytevector", pic_port_get_output_bytevector); /* input */ pic_defun(pic, "read-char", pic_port_read_char); pic_defun(pic, "peek-char", pic_port_peek_char); pic_defun(pic, "read-line", pic_port_read_line); pic_defun(pic, "eof-object?", pic_port_eof_object_p); pic_defun(pic, "eof-object", pic_port_eof_object); pic_defun(pic, "char-ready?", pic_port_char_ready_p); pic_defun(pic, "read-string", pic_port_read_string); pic_defun(pic, "read-u8", pic_port_read_byte); pic_defun(pic, "peek-u8", pic_port_peek_byte); pic_defun(pic, "u8-ready?", pic_port_byte_ready_p); pic_defun(pic, "read-bytevector", pic_port_read_blob); pic_defun(pic, "read-bytevector!", pic_port_read_blob_ip); /* output */ pic_defun(pic, "newline", pic_port_newline); pic_defun(pic, "write-char", pic_port_write_char); pic_defun(pic, "write-string", pic_port_write_string); pic_defun(pic, "write-u8", pic_port_write_byte); pic_defun(pic, "write-bytevector", pic_port_write_blob); pic_defun(pic, "flush-output-port", pic_port_flush); }
static pic_value pic_vec_vector_to_string(pic_state *pic) { pic_vec *vec; char *buf; int n, start, end, i; pic_str *str; n = pic_get_args(pic, "v|ii", &vec, &start, &end); switch (n) { case 1: start = 0; case 2: end = vec->len; } if (end < start) { pic_errorf(pic, "vector->string: end index must not be less than start index"); } buf = pic_malloc(pic, end - start); for (i = start; i < end; ++i) { pic_assert_type(pic, vec->data[i], char); buf[i - start] = pic_char(vec->data[i]); } str = pic_make_str(pic, buf, end - start); pic_free(pic, buf); return pic_obj_value(str); }
static pic_value pic_vec_string_to_vector(pic_state *pic) { pic_str *str; int n, start, end, i; pic_vec *vec; n = pic_get_args(pic, "s|ii", &str, &start, &end); switch (n) { case 1: start = 0; case 2: end = pic_str_len(str); } if (end < start) { pic_errorf(pic, "string->vector: end index must not be less than start index"); } vec = pic_make_vec(pic, end - start); for (i = 0; i < end - start; ++i) { vec->data[i] = pic_char_value(pic_str_ref(pic, str, i + start)); } return pic_obj_value(vec); }
static pic_value pic_vec_vector_append(pic_state *pic) { pic_value *argv; int argc, i, j, len; pic_vec *vec; pic_get_args(pic, "*", &argc, &argv); len = 0; for (i = 0; i < argc; ++i) { pic_assert_type(pic, argv[i], vec); len += pic_vec_ptr(argv[i])->len; } vec = pic_make_vec(pic, len); len = 0; for (i = 0; i < argc; ++i) { for (j = 0; j < pic_vec_ptr(argv[i])->len; ++j) { vec->data[len + j] = pic_vec_ptr(argv[i])->data[j]; } len += pic_vec_ptr(argv[i])->len; } return pic_obj_value(vec); }
static pic_value pic_str_list_to_string(pic_state *pic) { pic_str *str; pic_value list, e, it; int i; char *buf; pic_get_args(pic, "o", &list); if (pic_length(pic, list) == 0) { return pic_obj_value(pic_make_str(pic, NULL, 0)); } buf = pic_malloc(pic, pic_length(pic, list)); pic_try { i = 0; pic_for_each (e, list, it) { pic_assert_type(pic, e, char); buf[i++] = pic_char(e); } str = pic_make_str(pic, buf, i); }
static pic_value pic_blob_bytevector(pic_state *pic) { pic_value *argv; size_t argc, i; pic_blob *blob; unsigned char *data; pic_get_args(pic, "*", &argc, &argv); blob = pic_make_blob(pic, argc); data = blob->data; for (i = 0; i < argc; ++i) { pic_assert_type(pic, argv[i], int); if (pic_int(argv[i]) < 0 || pic_int(argv[i]) > 255) { pic_errorf(pic, "byte out of range"); } *data++ = (unsigned char)pic_int(argv[i]); } return pic_obj_value(blob); }
static pic_value pic_blob_bytevector_append(pic_state *pic) { size_t argc, i, j, len; pic_value *argv; pic_blob *blob; pic_get_args(pic, "*", &argc, &argv); len = 0; for (i = 0; i < argc; ++i) { pic_assert_type(pic, argv[i], blob); len += pic_blob_ptr(argv[i])->len; } blob = pic_make_blob(pic, len); len = 0; for (i = 0; i < argc; ++i) { for (j = 0; j < pic_blob_ptr(argv[i])->len; ++j) { blob->data[len + j] = pic_blob_ptr(argv[i])->data[j]; } len += pic_blob_ptr(argv[i])->len; } return pic_obj_value(blob); }
static pic_value pic_blob_bytevector_copy(pic_state *pic) { pic_blob *from, *to; int n; size_t start, end, i = 0; n = pic_get_args(pic, "b|kk", &from, &start, &end); switch (n) { case 1: start = 0; case 2: end = from->len; } if (end < start) { pic_errorf(pic, "make-bytevector: end index must not be less than start index"); } to = pic_make_blob(pic, end - start); while (start < end) { to->data[i++] = from->data[start++]; } return pic_obj_value(to); }
static pic_value pic_port_read_string(pic_state *pic){ struct pic_port *port = pic_stdin(pic), *buf; pic_str *str; int k, i; int c; pic_get_args(pic, "i|p", &k, &port); assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "read-stritg"); c = EOF; buf = pic_open_output_string(pic); for(i = 0; i < k; ++i) { if((c = xfgetc(port->file)) == EOF){ break; } xfputc(c, buf->file); } str = pic_get_output_string(pic, buf); if (pic_strlen(str) == 0 && c == EOF) { return pic_eof_object(); } else { return pic_obj_value(str); } }
struct pic_lib * pic_open_library(pic_state *pic, pic_value name) { struct pic_lib *lib; struct pic_senv *senv; struct pic_dict *exports; if ((lib = pic_find_library(pic, name)) != NULL) { #if DEBUG printf("* reopen library: "); pic_debug(pic, name); puts(""); #endif return lib; } senv = pic_null_syntactic_environment(pic); exports = pic_make_dict(pic); lib = (struct pic_lib *)pic_obj_alloc(pic, sizeof(struct pic_lib), PIC_TT_LIB); lib->name = name; lib->env = senv; lib->exports = exports; /* register! */ pic->libs = pic_acons(pic, name, pic_obj_value(lib), pic->libs); return lib; }
static pic_value pic_vec_vector_map(pic_state *pic) { struct pic_proc *proc; int argc, i, len, j; pic_value *argv, vals; pic_vec *vec; 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; } vec = pic_make_vec(pic, 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); } vec->data[i] = pic_apply_list(pic, proc, vals); } return pic_obj_value(vec); }
static pic_value pic_vec_vector_copy(pic_state *pic) { pic_vec *vec, *to; int n, start, end, i = 0; n = pic_get_args(pic, "v|ii", &vec, &start, &end); switch (n) { case 1: start = 0; case 2: end = vec->len; } if (end < start) { pic_errorf(pic, "vector-copy: end index must not be less than start index"); } to = pic_make_vec(pic, end - start); while (start < end) { to->data[i++] = vec->data[start++]; } return pic_obj_value(to); }
pic_str * pic_get_backtrace(pic_state *pic) { size_t ai = pic_gc_arena_preserve(pic); pic_callinfo *ci; pic_str *trace; trace = pic_make_str(pic, NULL, 0); for (ci = pic->ci; ci != pic->cibase; --ci) { struct pic_proc *proc = pic_proc_ptr(ci->fp[0]); trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, " at ")); trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, pic_symbol_name(pic, pic_proc_name(proc)))); if (pic_proc_func_p(proc)) { trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, " (native function)\n")); } else if (pic_proc_irep_p(proc)) { trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, " (unknown location)\n")); /* TODO */ } } pic_gc_arena_restore(pic, ai); pic_gc_protect(pic, pic_obj_value(trace)); return trace; }
static pic_value pic_reg_make_register(pic_state *pic) { struct pic_reg *reg; struct pic_proc *proc; pic_get_args(pic, ""); reg = pic_make_reg(pic); proc = pic_make_proc(pic, reg_call); pic_proc_env_set(pic, proc, "reg", pic_obj_value(reg)); return pic_obj_value(proc); }
static pic_value reg_get(pic_state *pic, struct pic_reg *reg, void *key) { if (! pic_reg_has(pic, reg, key)) { return pic_false_value(); } return pic_cons(pic, pic_obj_value(key), pic_reg_ref(pic, reg, key)); }
void pic_raise(pic_state *pic, pic_value obj) { pic_value a; struct pic_proc *handler; if (pic->ridx == 0) { pic_abort(pic, "logic flaw: no exception handler remains"); } handler = pic->rescue[--pic->ridx]; pic_gc_protect(pic, pic_obj_value(handler)); a = pic_apply_argv(pic, handler, 1, obj); /* when the handler returns */ pic_errorf(pic, "handler returned", 2, pic_obj_value(handler), a); }
pic_value pic_record_ref(pic_state *pic, struct pic_record *rec, pic_sym *slot) { if (! pic_dict_has(pic, rec->data, slot)) { pic_errorf(pic, "slot named ~s is not found for record: ~s", pic_obj_value(slot), rec); } return pic_dict_ref(pic, rec->data, slot); }
static pic_value pic_attr_attribute(pic_state *pic) { pic_value obj; pic_get_args(pic, "o", &obj); return pic_obj_value(pic_attr(pic, obj)); }
static pic_value pic_error_error_object_type(pic_state *pic) { struct pic_error *e; pic_get_args(pic, "e", &e); return pic_obj_value(e->type); }
pic_value pic_box(pic_state *pic, pic_value value) { struct pic_box *box; box = (struct pic_box *)pic_obj_alloc(pic, sizeof(struct pic_box), PIC_TT_BOX); box->value = value; return pic_obj_value(box); }
static pic_value pic_error_error_object_message(pic_state *pic) { struct pic_error *e; pic_get_args(pic, "e", &e); return pic_obj_value(pic_str_new_cstr(pic, e->msg)); }
void pic_error(pic_state *pic, const char *msg, pic_value irrs) { struct pic_error *e; e = pic_make_error(pic, pic_intern(pic, ""), msg, irrs); pic_raise(pic, pic_obj_value(e)); }
PIC_NORETURN static void file_error(pic_state *pic, const char *msg) { struct pic_error *e; e = pic_make_error(pic, pic_intern(pic, "file"), msg, pic_nil_value()); pic_raise(pic, pic_obj_value(e)); }
void pic_throw(pic_state *pic, pic_sym *type, const char *msg, pic_value irrs) { struct pic_error *e; e = pic_make_error(pic, type, msg, irrs); pic_raise(pic, pic_obj_value(e)); }
pic_value pic_file_open_input_file(pic_state *pic) { static const short flags = PIC_PORT_IN | PIC_PORT_TEXT; char *fname; pic_get_args(pic, "z", &fname); return pic_obj_value(pic_open_file(pic, fname, flags)); }
pic_value pic_file_open_binary_output_file(pic_state *pic) { static const short flags = PIC_PORT_OUT | PIC_PORT_BINARY; char *fname; pic_get_args(pic, "z", &fname); return pic_obj_value(pic_open_file(pic, fname, flags)); }
static pic_value pic_port_get_output_string(pic_state *pic) { struct pic_port *port = pic_stdout(pic); pic_get_args(pic, "|p", &port); assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "get-output-string"); return pic_obj_value(pic_get_output_string(pic, port)); }