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));
}