From 83f580bfcf68f6ef75d42ac4bf2e878e5f7e9301 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 1 Sep 2014 09:33:28 +0900 Subject: [PATCH] initial benz integration --- CMakeLists.txt | 2 +- src/CMakeLists.txt | 13 +- src/blob.c | 196 ------ src/bool.c | 201 ------ src/char.c | 43 -- src/codegen.c | 1458 -------------------------------------------- src/cont.c | 371 ----------- src/data.c | 15 - src/debug.c | 74 --- src/dict.c | 169 ----- src/error.c | 286 --------- src/eval.c | 10 - src/gc.c | 872 -------------------------- src/init.c | 78 +-- src/lib.c | 273 --------- src/macro.c | 449 +------------- src/number.c | 944 ---------------------------- src/pair.c | 767 ----------------------- src/port.c | 749 ----------------------- src/proc.c | 183 ------ src/read.c | 976 ----------------------------- src/record.c | 115 ---- src/state.c | 205 ------- src/string.c | 424 ------------- src/symbol.c | 161 ----- src/var.c | 134 ---- src/vector.c | 283 --------- src/vm.c | 1069 -------------------------------- src/write.c | 506 --------------- 29 files changed, 12 insertions(+), 11014 deletions(-) delete mode 100644 src/blob.c delete mode 100644 src/bool.c delete mode 100644 src/char.c delete mode 100644 src/codegen.c delete mode 100644 src/cont.c delete mode 100644 src/data.c delete mode 100644 src/debug.c delete mode 100644 src/dict.c delete mode 100644 src/error.c delete mode 100644 src/gc.c delete mode 100644 src/lib.c delete mode 100644 src/number.c delete mode 100644 src/pair.c delete mode 100644 src/port.c delete mode 100644 src/proc.c delete mode 100644 src/read.c delete mode 100644 src/record.c delete mode 100644 src/state.c delete mode 100644 src/string.c delete mode 100644 src/symbol.c delete mode 100644 src/var.c delete mode 100644 src/vector.c delete mode 100644 src/vm.c delete mode 100644 src/write.c diff --git a/CMakeLists.txt b/CMakeLists.txt index 2ee8e462..cbc7883a 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -26,7 +26,7 @@ else() add_definitions(-std=c99) # at least c99 is required endif() -include_directories(include extlib) +include_directories(extlib/benz/include) # build picrin include(piclib/CMakeLists.txt) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index f3e51499..f4a62f1d 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -1,7 +1,10 @@ find_package(Perl REQUIRED) -# xfile -set(XFILE_SOURCES extlib/xfile/xfile.c) +# benz +file(GLOB BENZ_SOURCES extlib/benz/*.c) + +# srcs +file(GLOB PICRIN_SOURCES src/*.c) # piclib set(PICLIB_SOURCE ${PROJECT_SOURCE_DIR}/src/load_piclib.c) @@ -21,12 +24,10 @@ add_custom_command( WORKING_DIRECTORY ${PROJECT_SOURCE_DIR} ) -# build! -file(GLOB PICRIN_SOURCES ${PROJECT_SOURCE_DIR}/src/*.c) -add_library(picrin SHARED ${PICRIN_SOURCES} ${PICLIB_SOURCE} ${XFILE_SOURCES} ${PICRIN_CONTRIB_SOURCES} ${CONTRIB_INIT}) +add_library(picrin SHARED ${BENZ_SOURCES} ${PICRIN_SOURCES} ${PICLIB_SOURCE} ${PICRIN_CONTRIB_SOURCES} ${CONTRIB_INIT}) target_link_libraries(picrin m ${PICRIN_CONTRIB_LIBRARIES}) # install set(CMAKE_INSTALL_RPATH ${CMAKE_INSTALL_PREFIX}/lib) install(TARGETS picrin DESTINATION lib) -install(DIRECTORY include/ DESTINATION include FILES_MATCHING PATTERN "*.h") +install(DIRECTORY extlib/benz/include/ DESTINATION include FILES_MATCHING PATTERN "*.h") diff --git a/src/blob.c b/src/blob.c deleted file mode 100644 index 0bb28713..00000000 --- a/src/blob.c +++ /dev/null @@ -1,196 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include - -#include "picrin.h" -#include "picrin/blob.h" - -char * -pic_strndup(pic_state *pic, const char *s, size_t n) -{ - char *r; - - r = pic_alloc(pic, n + 1); - memcpy(r, s, n); - r[n] = '\0'; - return r; -} - -char * -pic_strdup(pic_state *pic, const char *s) -{ - return pic_strndup(pic, s, strlen(s)); -} - -struct pic_blob * -pic_blob_new(pic_state *pic, size_t len) -{ - struct pic_blob *bv; - - bv = (struct pic_blob *)pic_obj_alloc(pic, sizeof(struct pic_blob), PIC_TT_BLOB); - bv->data = pic_alloc(pic, len); - bv->len = len; - return bv; -} - -static pic_value -pic_blob_bytevector_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - return pic_bool_value(pic_blob_p(v)); -} - -static pic_value -pic_blob_make_bytevector(pic_state *pic) -{ - pic_blob *blob; - int k, b = 0, i; - - pic_get_args(pic, "i|i", &k, &b); - - if (b < 0 || b > 255) - pic_error(pic, "byte out of range"); - - blob = pic_blob_new(pic, k); - for (i = 0; i < k; ++i) { - blob->data[i] = b; - } - - return pic_obj_value(blob); -} - -static pic_value -pic_blob_bytevector_length(pic_state *pic) -{ - struct pic_blob *bv; - - pic_get_args(pic, "b", &bv); - - return pic_int_value(bv->len); -} - -static pic_value -pic_blob_bytevector_u8_ref(pic_state *pic) -{ - struct pic_blob *bv; - int k; - - pic_get_args(pic, "bi", &bv, &k); - - return pic_int_value(bv->data[k]); -} - -static pic_value -pic_blob_bytevector_u8_set(pic_state *pic) -{ - struct pic_blob *bv; - int k, v; - - pic_get_args(pic, "bii", &bv, &k, &v); - - if (v < 0 || v > 255) - pic_error(pic, "byte out of range"); - - bv->data[k] = v; - return pic_none_value(); -} - -static pic_value -pic_blob_bytevector_copy_i(pic_state *pic) -{ - pic_blob *to, *from; - int n, at, start, end; - - n = pic_get_args(pic, "bib|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_none_value(); - } - - while (start < end) { - to->data[at++] = from->data[start++]; - } - - return pic_none_value(); -} - -static pic_value -pic_blob_bytevector_copy(pic_state *pic) -{ - pic_blob *from, *to; - int n, start, end, i = 0; - - n = pic_get_args(pic, "b|ii", &from, &start, &end); - - switch (n) { - case 1: - start = 0; - case 2: - end = from->len; - } - - to = pic_blob_new(pic, end - start); - while (start < end) { - to->data[i++] = from->data[start++]; - } - - return pic_obj_value(to); -} - -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_blob_new(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); -} - -void -pic_init_blob(pic_state *pic) -{ - pic_defun(pic, "bytevector?", pic_blob_bytevector_p); - pic_defun(pic, "make-bytevector", pic_blob_make_bytevector); - pic_defun(pic, "bytevector-length", pic_blob_bytevector_length); - pic_defun(pic, "bytevector-u8-ref", pic_blob_bytevector_u8_ref); - pic_defun(pic, "bytevector-u8-set!", pic_blob_bytevector_u8_set); - pic_defun(pic, "bytevector-copy!", pic_blob_bytevector_copy_i); - pic_defun(pic, "bytevector-copy", pic_blob_bytevector_copy); - pic_defun(pic, "bytevector-append", pic_blob_bytevector_append); -} diff --git a/src/bool.c b/src/bool.c deleted file mode 100644 index 8f8c75f1..00000000 --- a/src/bool.c +++ /dev/null @@ -1,201 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include - -#include "picrin.h" -#include "picrin/pair.h" -#include "picrin/vector.h" -#include "picrin/blob.h" -#include "picrin/string.h" - -static bool -str_equal_p(struct pic_string *str1, struct pic_string *str2) -{ - return pic_strcmp(str1, str2) == 0; -} - -static bool -blob_equal_p(struct pic_blob *blob1, struct pic_blob *blob2) -{ - size_t i; - - if (blob1->len != blob2->len) { - return false; - } - for (i = 0; i < blob1->len; ++i) { - if (blob1->data[i] != blob2->data[i]) - return false; - } - return true; -} - -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; - } -} - -bool -pic_equal_p(pic_state *pic, pic_value x, pic_value y){ - xhash ht; - - xh_init_ptr(&ht, 0); - - return internal_equal_p(pic, x, y, 0, &ht); -} - -static pic_value -pic_bool_eq_p(pic_state *pic) -{ - pic_value x, y; - - pic_get_args(pic, "oo", &x, &y); - - return pic_bool_value(pic_eq_p(x, y)); -} - -static pic_value -pic_bool_eqv_p(pic_state *pic) -{ - pic_value x, y; - - pic_get_args(pic, "oo", &x, &y); - - return pic_bool_value(pic_eqv_p(x, y)); -} - -static pic_value -pic_bool_equal_p(pic_state *pic) -{ - pic_value x, y; - - pic_get_args(pic, "oo", &x, &y); - - return pic_bool_value(pic_equal_p(pic, x, y)); -} - -static pic_value -pic_bool_not(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - return pic_false_p(v) ? pic_true_value() : pic_false_value(); -} - -static pic_value -pic_bool_boolean_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - return (pic_true_p(v) || pic_false_p(v)) ? pic_true_value() : pic_false_value(); -} - -static pic_value -pic_bool_boolean_eq_p(pic_state *pic) -{ - size_t argc, i; - pic_value *argv; - - pic_get_args(pic, "*", &argc, &argv); - - for (i = 0; i < argc; ++i) { - if (! (pic_true_p(argv[i]) || pic_false_p(argv[i]))) { - return pic_false_value(); - } - if (! pic_eq_p(argv[i], argv[0])) { - return pic_false_value(); - } - } - return pic_true_value(); -} - -void -pic_init_bool(pic_state *pic) -{ - pic_defun(pic, "eq?", pic_bool_eq_p); - pic_defun(pic, "eqv?", pic_bool_eqv_p); - pic_defun(pic, "equal?", pic_bool_equal_p); - - pic_defun(pic, "not", pic_bool_not); - pic_defun(pic, "boolean?", pic_bool_boolean_p); - pic_defun(pic, "boolean=?", pic_bool_boolean_eq_p); -} diff --git a/src/char.c b/src/char.c deleted file mode 100644 index 6ec81c92..00000000 --- a/src/char.c +++ /dev/null @@ -1,43 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include "picrin.h" - -static pic_value -pic_char_char_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - return pic_char_p(v) ? pic_true_value() : pic_false_value(); -} - -static pic_value -pic_char_char_to_integer(pic_state *pic) -{ - char c; - - pic_get_args(pic, "c", &c); - - return pic_int_value(c); -} - -static pic_value -pic_char_integer_to_char(pic_state *pic) -{ - int i; - - pic_get_args(pic, "i", &i); - - return pic_char_value(i); -} - -void -pic_init_char(pic_state *pic) -{ - pic_defun(pic, "char?", pic_char_char_p); - pic_defun(pic, "char->integer", pic_char_char_to_integer); - pic_defun(pic, "integer->char", pic_char_integer_to_char); -} diff --git a/src/codegen.c b/src/codegen.c deleted file mode 100644 index c1264dfb..00000000 --- a/src/codegen.c +++ /dev/null @@ -1,1458 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include "picrin.h" -#include "picrin/pair.h" -#include "picrin/irep.h" -#include "picrin/proc.h" -#include "picrin/lib.h" -#include "picrin/macro.h" - -#if PIC_NONE_IS_FALSE -# define OP_PUSHNONE OP_PUSHFALSE -#else -# error enable PIC_NONE_IS_FALSE -#endif - -/** - * scope object - */ - -typedef struct analyze_scope { - int depth; - bool varg; - xvect args, locals, captures; /* rest args variable is counted as a local */ - struct analyze_scope *up; -} analyze_scope; - -/** - * global analyzer state - */ - -typedef struct analyze_state { - pic_state *pic; - analyze_scope *scope; - pic_sym rCONS, rCAR, rCDR, rNILP; - pic_sym rADD, rSUB, rMUL, rDIV; - pic_sym rEQ, rLT, rLE, rGT, rGE, rNOT; - pic_sym rVALUES, rCALL_WITH_VALUES; - pic_sym sCALL, sTAILCALL, sCALL_WITH_VALUES, sTAILCALL_WITH_VALUES; - pic_sym sGREF, sLREF, sCREF, sRETURN; -} analyze_state; - -static bool push_scope(analyze_state *, pic_value); -static void pop_scope(analyze_state *); - -#define register_symbol(pic, state, slot, name) do { \ - state->slot = pic_intern_cstr(pic, name); \ - } while (0) - -#define register_renamed_symbol(pic, state, slot, lib, id) do { \ - pic_sym sym, gsym; \ - sym = pic_intern_cstr(pic, id); \ - if (! pic_find_rename(pic, lib->env, sym, &gsym)) { \ - pic_error(pic, "internal error! native VM procedure not found"); \ - } \ - state->slot = gsym; \ - } while (0) - -static analyze_state * -new_analyze_state(pic_state *pic) -{ - analyze_state *state; - xh_iter it; - struct pic_lib *stdlib, *listlib; - - state = pic_alloc(pic, sizeof(analyze_state)); - state->pic = pic; - state->scope = NULL; - - stdlib = pic_find_library(pic, pic_read_cstr(pic, "(scheme base)")); - listlib = pic_find_library(pic, pic_read_cstr(pic, "(picrin base list)")); - - /* native VM procedures */ - register_renamed_symbol(pic, state, rCONS, listlib, "cons"); - register_renamed_symbol(pic, state, rCAR, listlib, "car"); - register_renamed_symbol(pic, state, rCDR, listlib, "cdr"); - register_renamed_symbol(pic, state, rNILP, listlib, "null?"); - register_renamed_symbol(pic, state, rADD, stdlib, "+"); - register_renamed_symbol(pic, state, rSUB, stdlib, "-"); - register_renamed_symbol(pic, state, rMUL, stdlib, "*"); - register_renamed_symbol(pic, state, rDIV, stdlib, "/"); - register_renamed_symbol(pic, state, rEQ, stdlib, "="); - register_renamed_symbol(pic, state, rLT, stdlib, "<"); - register_renamed_symbol(pic, state, rLE, stdlib, "<="); - register_renamed_symbol(pic, state, rGT, stdlib, ">"); - register_renamed_symbol(pic, state, rGE, stdlib, ">="); - register_renamed_symbol(pic, state, rNOT, stdlib, "not"); - register_renamed_symbol(pic, state, rVALUES, stdlib, "values"); - register_renamed_symbol(pic, state, rCALL_WITH_VALUES, stdlib, "call-with-values"); - - register_symbol(pic, state, sCALL, "call"); - register_symbol(pic, state, sTAILCALL, "tail-call"); - register_symbol(pic, state, sCALL_WITH_VALUES, "call-with-values"); - register_symbol(pic, state, sTAILCALL_WITH_VALUES, "tailcall-with-values"); - register_symbol(pic, state, sGREF, "gref"); - register_symbol(pic, state, sLREF, "lref"); - register_symbol(pic, state, sCREF, "cref"); - register_symbol(pic, state, sRETURN, "return"); - - /* push initial scope */ - push_scope(state, pic_nil_value()); - - xh_begin(&it, &pic->globals); - while (xh_next(&it)) { - pic_sym sym = xh_key(it.e, pic_sym); - xv_push(&state->scope->locals, &sym); - } - - return state; -} - -static void -destroy_analyze_state(analyze_state *state) -{ - pop_scope(state); - pic_free(state->pic, state); -} - -static bool -analyze_args(pic_state *pic, pic_value formals, bool *varg, xvect *args, xvect *locals) -{ - pic_value v, sym; - - for (v = formals; pic_pair_p(v); v = pic_cdr(pic, v)) { - sym = pic_car(pic, v); - if (! pic_sym_p(sym)) { - return false; - } - xv_push(args, &pic_sym(sym)); - } - if (pic_nil_p(v)) { - *varg = false; - } - else if (pic_sym_p(v)) { - *varg = true; - xv_push(locals, &pic_sym(v)); - } - else { - return false; - } - - return true; -} - -static bool -push_scope(analyze_state *state, pic_value formals) -{ - pic_state *pic = state->pic; - analyze_scope *scope; - bool varg; - xvect args, locals, captures; - - xv_init(&args, sizeof(pic_sym)); - xv_init(&locals, sizeof(pic_sym)); - xv_init(&captures, sizeof(pic_sym)); - - if (analyze_args(pic, formals, &varg, &args, &locals)) { - scope = pic_alloc(pic, sizeof(analyze_scope)); - scope->up = state->scope; - scope->depth = scope->up ? scope->up->depth + 1 : 0; - scope->varg = varg; - scope->args = args; - scope->locals = locals; - scope->captures = captures; - - state->scope = scope; - - return true; - } - else { - xv_destroy(&args); - xv_destroy(&locals); - return false; - } -} - -static void -pop_scope(analyze_state *state) -{ - analyze_scope *scope; - - scope = state->scope; - xv_destroy(&scope->args); - xv_destroy(&scope->locals); - xv_destroy(&scope->captures); - - scope = scope->up; - pic_free(state->pic, state->scope); - state->scope = scope; -} - -static bool -lookup_scope(analyze_scope *scope, pic_sym sym) -{ - pic_sym *arg, *local; - size_t i; - - /* args */ - for (i = 0; i < scope->args.size; ++i) { - arg = xv_get(&scope->args, i); - if (*arg == sym) - return true; - } - /* locals */ - for (i = 0; i < scope->locals.size; ++i) { - local = xv_get(&scope->locals, i); - if (*local == sym) - return true; - } - return false; -} - -static void -capture_var(analyze_scope *scope, pic_sym sym) -{ - pic_sym *var; - size_t i; - - for (i = 0; i < scope->captures.size; ++i) { - var = xv_get(&scope->captures, i); - if (*var == sym) { - break; - } - } - if (i == scope->captures.size) { - xv_push(&scope->captures, &sym); - } -} - -static int -find_var(analyze_state *state, pic_sym sym) -{ - analyze_scope *scope = state->scope; - int depth = 0; - - while (scope) { - if (lookup_scope(scope, sym)) { - if (depth > 0) { - capture_var(scope, sym); - } - return depth; - } - depth++; - scope = scope->up; - } - return -1; -} - -static void -define_var(analyze_state *state, pic_sym sym) -{ - pic_state *pic = state->pic; - analyze_scope *scope = state->scope; - - if (lookup_scope(scope, sym)) { - pic_warnf(pic, "redefining variable: ~s", pic_sym_value(sym)); - return; - } - - xv_push(&scope->locals, &sym); -} - -static pic_value analyze_node(analyze_state *, pic_value, bool); - -static pic_value -analyze(analyze_state *state, pic_value obj, bool tailpos) -{ - pic_state *pic = state->pic; - size_t ai = pic_gc_arena_preserve(pic); - pic_value res; - pic_sym tag; - - res = analyze_node(state, obj, tailpos); - - tag = pic_sym(pic_car(pic, res)); - if (tailpos) { - if (tag == pic->sIF || tag == pic->sBEGIN || tag == state->sTAILCALL || tag == state->sTAILCALL_WITH_VALUES || tag == state->sRETURN) { - /* pass through */ - } - else { - res = pic_list2(pic, pic_symbol_value(state->sRETURN), res); - } - } - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, res); - return res; -} - -static pic_value -analyze_global_var(analyze_state *state, pic_sym sym) -{ - pic_state *pic = state->pic; - - return pic_list2(pic, pic_symbol_value(state->sGREF), pic_sym_value(sym)); -} - -static pic_value -analyze_local_var(analyze_state *state, pic_sym sym) -{ - pic_state *pic = state->pic; - - return pic_list2(pic, pic_symbol_value(state->sLREF), pic_sym_value(sym)); -} - -static pic_value -analyze_free_var(analyze_state *state, pic_sym sym, int depth) -{ - pic_state *pic = state->pic; - - return pic_list3(pic, pic_symbol_value(state->sCREF), pic_int_value(depth), pic_sym_value(sym)); -} - -static pic_value -analyze_var(analyze_state *state, pic_sym sym) -{ - pic_state *pic = state->pic; - int depth; - - if ((depth = find_var(state, sym)) == -1) { - pic_errorf(pic, "unbound variable %s", pic_symbol_name(pic, sym)); - } - - if (depth == state->scope->depth) { - return analyze_global_var(state, sym); - } else if (depth == 0) { - return analyze_local_var(state, sym); - } else { - return analyze_free_var(state, sym, depth); - } -} - -static pic_value -analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_value body_exprs) -{ - pic_state *pic = state->pic; - pic_value args, locals, varg, captures, body; - - assert(pic_sym_p(name) || pic_false_p(name)); - - if (push_scope(state, formals)) { - analyze_scope *scope = state->scope; - pic_sym *var; - size_t i; - - args = pic_nil_value(); - for (i = scope->args.size; i > 0; --i) { - var = xv_get(&scope->args, i - 1); - pic_push(pic, pic_sym_value(*var), args); - } - - varg = scope->varg - ? pic_true_value() - : pic_false_value(); - - /* To know what kind of local variables are defined, analyze body at first. */ - body = analyze(state, pic_cons(pic, pic_sym_value(pic->rBEGIN), body_exprs), true); - - locals = pic_nil_value(); - for (i = scope->locals.size; i > 0; --i) { - var = xv_get(&scope->locals, i - 1); - pic_push(pic, pic_sym_value(*var), locals); - } - - captures = pic_nil_value(); - for (i = scope->captures.size; i > 0; --i) { - var = xv_get(&scope->captures, i - 1); - pic_push(pic, pic_sym_value(*var), captures); - } - - pop_scope(state); - } - else { - pic_errorf(pic, "invalid formal syntax: ~s", args); - } - - return pic_list7(pic, pic_sym_value(pic->sLAMBDA), name, args, locals, varg, captures, body); -} - -static pic_value -analyze_lambda(analyze_state *state, pic_value obj) -{ - pic_state *pic = state->pic; - pic_value formals, body_exprs; - - if (pic_length(pic, obj) < 2) { - pic_error(pic, "syntax error"); - } - - formals = pic_list_ref(pic, obj, 1); - body_exprs = pic_list_tail(pic, obj, 2); - - return analyze_procedure(state, pic_false_value(), formals, body_exprs); -} - -static pic_value -analyze_declare(analyze_state *state, pic_sym var) -{ - define_var(state, var); - - return analyze_var(state, var); -} - -static pic_value -analyze_define(analyze_state *state, pic_value obj) -{ - pic_state *pic = state->pic; - pic_value var, val; - pic_sym sym; - - if (pic_length(pic, obj) != 3) { - pic_error(pic, "syntax error"); - } - - var = pic_list_ref(pic, obj, 1); - if (! pic_sym_p(var)) { - pic_error(pic, "syntax error"); - } else { - sym = pic_sym(var); - } - var = analyze_declare(state, sym); - - if (pic_pair_p(pic_list_ref(pic, obj, 2)) - && pic_sym_p(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) - && pic_sym(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) == pic->rLAMBDA) { - pic_value formals, body_exprs; - - formals = pic_list_ref(pic, pic_list_ref(pic, obj, 2), 1); - body_exprs = pic_list_tail(pic, pic_list_ref(pic, obj, 2), 2); - - val = analyze_procedure(state, pic_sym_value(sym), formals, body_exprs); - } else { - if (pic_length(pic, obj) != 3) { - pic_error(pic, "syntax error"); - } - val = analyze(state, pic_list_ref(pic, obj, 2), false); - } - - return pic_list3(pic, pic_symbol_value(pic->sSETBANG), var, val); -} - -static pic_value -analyze_if(analyze_state *state, pic_value obj, bool tailpos) -{ - pic_state *pic = state->pic; - pic_value cond, if_true, if_false; - - if_false = pic_none_value(); - switch (pic_length(pic, obj)) { - default: - pic_error(pic, "syntax error"); - break; - case 4: - if_false = pic_list_ref(pic, obj, 3); - FALLTHROUGH; - case 3: - if_true = pic_list_ref(pic, obj, 2); - } - - /* analyze in order */ - cond = analyze(state, pic_list_ref(pic, obj, 1), false); - if_true = analyze(state, if_true, tailpos); - if_false = analyze(state, if_false, tailpos); - - return pic_list4(pic, pic_symbol_value(pic->sIF), cond, if_true, if_false); -} - -static pic_value -analyze_begin(analyze_state *state, pic_value obj, bool tailpos) -{ - pic_state *pic = state->pic; - pic_value seq; - bool tail; - - switch (pic_length(pic, obj)) { - case 1: - return analyze(state, pic_none_value(), tailpos); - case 2: - return analyze(state, pic_list_ref(pic, obj, 1), tailpos); - default: - seq = pic_list1(pic, pic_symbol_value(pic->sBEGIN)); - for (obj = pic_cdr(pic, obj); ! pic_nil_p(obj); obj = pic_cdr(pic, obj)) { - if (pic_nil_p(pic_cdr(pic, obj))) { - tail = tailpos; - } else { - tail = false; - } - seq = pic_cons(pic, analyze(state, pic_car(pic, obj), tail), seq); - } - return pic_reverse(pic, seq); - } -} - -static pic_value -analyze_set(analyze_state *state, pic_value obj) -{ - pic_state *pic = state->pic; - pic_value var, val; - - if (pic_length(pic, obj) != 3) { - pic_error(pic, "syntax error"); - } - - var = pic_list_ref(pic, obj, 1); - if (! pic_sym_p(var)) { - pic_error(pic, "syntax error"); - } - - val = pic_list_ref(pic, obj, 2); - - var = analyze(state, var, false); - val = analyze(state, val, false); - - return pic_list3(pic, pic_symbol_value(pic->sSETBANG), var, val); -} - -static pic_value -analyze_quote(analyze_state *state, pic_value obj) -{ - pic_state *pic = state->pic; - - if (pic_length(pic, obj) != 2) { - pic_error(pic, "syntax error"); - } - return pic_list2(pic, pic_sym_value(pic->sQUOTE), pic_list_ref(pic, obj, 1)); -} - -#define ARGC_ASSERT_GE(n) do { \ - if (pic_length(pic, obj) < (n) + 1) { \ - pic_error(pic, "wrong number of arguments"); \ - } \ - } while (0) - -#define FOLD_ARGS(sym) do { \ - obj = analyze(state, pic_car(pic, args), false); \ - pic_for_each (arg, pic_cdr(pic, args)) { \ - obj = pic_list3(pic, pic_symbol_value(sym), obj, \ - analyze(state, arg, false)); \ - } \ - } while (0) - -static pic_value -analyze_add(analyze_state *state, pic_value obj, bool tailpos) -{ - pic_state *pic = state->pic; - pic_value args, arg; - - ARGC_ASSERT_GE(0); - switch (pic_length(pic, obj)) { - case 1: - return pic_list2(pic, pic_symbol_value(pic->sQUOTE), pic_int_value(0)); - case 2: - return analyze(state, pic_car(pic, pic_cdr(pic, obj)), tailpos); - default: - args = pic_cdr(pic, obj); - FOLD_ARGS(pic->sADD); - return obj; - } -} - -static pic_value -analyze_sub(analyze_state *state, pic_value obj) -{ - pic_state *pic = state->pic; - pic_value args, arg; - - ARGC_ASSERT_GE(1); - switch (pic_length(pic, obj)) { - case 2: - return pic_list2(pic, pic_symbol_value(pic->sMINUS), - analyze(state, pic_car(pic, pic_cdr(pic, obj)), false)); - default: - args = pic_cdr(pic, obj); - FOLD_ARGS(pic->sSUB); - return obj; - } -} - -static pic_value -analyze_mul(analyze_state *state, pic_value obj, bool tailpos) -{ - pic_state *pic = state->pic; - pic_value args, arg; - - ARGC_ASSERT_GE(0); - switch (pic_length(pic, obj)) { - case 1: - return pic_list2(pic, pic_symbol_value(pic->sQUOTE), pic_int_value(1)); - case 2: - return analyze(state, pic_car(pic, pic_cdr(pic, obj)), tailpos); - default: - args = pic_cdr(pic, obj); - FOLD_ARGS(pic->sMUL); - return obj; - } -} - -static pic_value -analyze_div(analyze_state *state, pic_value obj) -{ - pic_state *pic = state->pic; - pic_value args, arg; - - ARGC_ASSERT_GE(1); - switch (pic_length(pic, obj)) { - case 2: - args = pic_cdr(pic, obj); - obj = pic_list3(pic, pic_car(pic, obj), pic_float_value(1), pic_car(pic, args)); - return analyze(state, obj, false); - default: - args = pic_cdr(pic, obj); - FOLD_ARGS(pic->sDIV); - return obj; - } -} - -static pic_value -analyze_call(analyze_state *state, pic_value obj, bool tailpos) -{ - pic_state *pic = state->pic; - pic_value seq, elt; - pic_sym call; - - if (! tailpos) { - call = state->sCALL; - } else { - call = state->sTAILCALL; - } - seq = pic_list1(pic, pic_symbol_value(call)); - pic_for_each (elt, obj) { - seq = pic_cons(pic, analyze(state, elt, false), seq); - } - return pic_reverse(pic, seq); -} - -static pic_value -analyze_values(analyze_state *state, pic_value obj, bool tailpos) -{ - pic_state *pic = state->pic; - pic_value v, seq; - - if (! tailpos) { - return analyze_call(state, obj, false); - } - - seq = pic_list1(pic, pic_symbol_value(state->sRETURN)); - pic_for_each (v, pic_cdr(pic, obj)) { - seq = pic_cons(pic, analyze(state, v, false), seq); - } - return pic_reverse(pic, seq); -} - -static pic_value -analyze_call_with_values(analyze_state *state, pic_value obj, bool tailpos) -{ - pic_state *pic = state->pic; - pic_value prod, cnsm; - pic_sym call; - - if (pic_length(pic, obj) != 3) { - pic_error(pic, "wrong number of arguments"); - } - - if (! tailpos) { - call = state->sCALL_WITH_VALUES; - } else { - call = state->sTAILCALL_WITH_VALUES; - } - prod = analyze(state, pic_list_ref(pic, obj, 1), false); - cnsm = analyze(state, pic_list_ref(pic, obj, 2), false); - return pic_list3(pic, pic_symbol_value(call), prod, cnsm); -} - -#define ARGC_ASSERT(n) do { \ - if (pic_length(pic, obj) != (n) + 1) { \ - pic_error(pic, "wrong number of arguments"); \ - } \ - } while (0) - -#define ARGC_ASSERT_WITH_FALLBACK(n) do { \ - if (pic_length(pic, obj) != (n) + 1) { \ - goto fallback; \ - } \ - } while (0) - -#define CONSTRUCT_OP1(op) \ - pic_list2(pic, \ - pic_symbol_value(op), \ - analyze(state, pic_list_ref(pic, obj, 1), false)) - -#define CONSTRUCT_OP2(op) \ - pic_list3(pic, \ - pic_symbol_value(op), \ - analyze(state, pic_list_ref(pic, obj, 1), false), \ - analyze(state, pic_list_ref(pic, obj, 2), false)) - -static pic_value -analyze_node(analyze_state *state, pic_value obj, bool tailpos) -{ - pic_state *pic = state->pic; - - switch (pic_type(obj)) { - case PIC_TT_SYMBOL: { - return analyze_var(state, pic_sym(obj)); - } - case PIC_TT_PAIR: { - pic_value proc; - - if (! pic_list_p(obj)) { - pic_errorf(pic, "invalid expression given: ~s", obj); - } - - proc = pic_list_ref(pic, obj, 0); - if (pic_sym_p(proc)) { - pic_sym sym = pic_sym(proc); - - if (sym == pic->rDEFINE) { - return analyze_define(state, obj); - } - else if (sym == pic->rLAMBDA) { - return analyze_lambda(state, obj); - } - else if (sym == pic->rIF) { - return analyze_if(state, obj, tailpos); - } - else if (sym == pic->rBEGIN) { - return analyze_begin(state, obj, tailpos); - } - else if (sym == pic->rSETBANG) { - return analyze_set(state, obj); - } - else if (sym == pic->rQUOTE) { - return analyze_quote(state, obj); - } - else if (sym == state->rCONS) { - ARGC_ASSERT(2); - return CONSTRUCT_OP2(pic->sCONS); - } - else if (sym == state->rCAR) { - ARGC_ASSERT(1); - return CONSTRUCT_OP1(pic->sCAR); - } - else if (sym == state->rCDR) { - ARGC_ASSERT(1); - return CONSTRUCT_OP1(pic->sCDR); - } - else if (sym == state->rNILP) { - ARGC_ASSERT(1); - return CONSTRUCT_OP1(pic->sNILP); - } - else if (sym == state->rADD) { - return analyze_add(state, obj, tailpos); - } - else if (sym == state->rSUB) { - return analyze_sub(state, obj); - } - else if (sym == state->rMUL) { - return analyze_mul(state, obj, tailpos); - } - else if (sym == state->rDIV) { - return analyze_div(state, obj); - } - else if (sym == state->rEQ) { - ARGC_ASSERT_WITH_FALLBACK(2); - return CONSTRUCT_OP2(pic->sEQ); - } - else if (sym == state->rLT) { - ARGC_ASSERT_WITH_FALLBACK(2); - return CONSTRUCT_OP2(pic->sLT); - } - else if (sym == state->rLE) { - ARGC_ASSERT_WITH_FALLBACK(2); - return CONSTRUCT_OP2(pic->sLE); - } - else if (sym == state->rGT) { - ARGC_ASSERT_WITH_FALLBACK(2); - return CONSTRUCT_OP2(pic->sGT); - } - else if (sym == state->rGE) { - ARGC_ASSERT_WITH_FALLBACK(2); - return CONSTRUCT_OP2(pic->sGE); - } - else if (sym == state->rNOT) { - ARGC_ASSERT(1); - return CONSTRUCT_OP1(pic->sNOT); - } - else if (sym == state->rVALUES) { - return analyze_values(state, obj, tailpos); - } - else if (sym == state->rCALL_WITH_VALUES) { - return analyze_call_with_values(state, obj, tailpos); - } - } - fallback: - - return analyze_call(state, obj, tailpos); - } - default: - return pic_list2(pic, pic_symbol_value(pic->sQUOTE), obj); - } -} - -pic_value -pic_analyze(pic_state *pic, pic_value obj) -{ - analyze_state *state; - - state = new_analyze_state(pic); - - obj = analyze(state, obj, true); - - destroy_analyze_state(state); - return obj; -} - -/** - * scope object - */ - -typedef struct codegen_context { - pic_sym name; - /* rest args variable is counted as a local */ - bool varg; - xvect args, locals, captures; - /* actual bit code sequence */ - pic_code *code; - size_t clen, ccapa; - /* child ireps */ - struct pic_irep **irep; - size_t ilen, icapa; - /* constant object pool */ - pic_value *pool; - size_t plen, pcapa; - - struct codegen_context *up; -} codegen_context; - -/** - * global codegen state - */ - -typedef struct codegen_state { - pic_state *pic; - codegen_context *cxt; - pic_sym sGREF, sCREF, sLREF; - pic_sym sCALL, sTAILCALL, sRETURN; - pic_sym sCALL_WITH_VALUES, sTAILCALL_WITH_VALUES; -} codegen_state; - -static void push_codegen_context(codegen_state *, pic_value, pic_value, pic_value, bool, pic_value); -static struct pic_irep *pop_codegen_context(codegen_state *); - -static codegen_state * -new_codegen_state(pic_state *pic) -{ - codegen_state *state; - - state = pic_alloc(pic, sizeof(codegen_state)); - state->pic = pic; - state->cxt = NULL; - - register_symbol(pic, state, sCALL, "call"); - register_symbol(pic, state, sTAILCALL, "tail-call"); - register_symbol(pic, state, sGREF, "gref"); - register_symbol(pic, state, sLREF, "lref"); - register_symbol(pic, state, sCREF, "cref"); - register_symbol(pic, state, sRETURN, "return"); - register_symbol(pic, state, sCALL_WITH_VALUES, "call-with-values"); - register_symbol(pic, state, sTAILCALL_WITH_VALUES, "tailcall-with-values"); - - push_codegen_context(state, pic_false_value(), pic_nil_value(), pic_nil_value(), false, pic_nil_value()); - - return state; -} - -static struct pic_irep * -destroy_codegen_state(codegen_state *state) -{ - pic_state *pic = state->pic; - struct pic_irep *irep; - - irep = pop_codegen_context(state); - pic_free(pic, state); - - return irep; -} - -static void -create_activation(codegen_context *cxt) -{ - size_t i, n; - xhash regs; - pic_sym *var; - size_t offset; - - xh_init_int(®s, sizeof(size_t)); - - offset = 1; - for (i = 0; i < cxt->args.size; ++i) { - var = xv_get(&cxt->args, i); - n = i + offset; - xh_put_int(®s, *var, &n); - } - offset += i; - for (i = 0; i < cxt->locals.size; ++i) { - var = xv_get(&cxt->locals, i); - n = i + offset; - xh_put_int(®s, *var, &n); - } - - for (i = 0; i < cxt->captures.size; ++i) { - var = xv_get(&cxt->captures, i); - if ((n = xh_val(xh_get_int(®s, *var), size_t)) <= cxt->args.size || (cxt->varg && n == cxt->args.size + 1)) { - /* copy arguments to capture variable area */ - cxt->code[cxt->clen].insn = OP_LREF; - cxt->code[cxt->clen].u.i = n; - cxt->clen++; - } else { - /* otherwise, just extend the stack */ - cxt->code[cxt->clen].insn = OP_PUSHNONE; - cxt->clen++; - } - } - - xh_destroy(®s); -} - -static void -push_codegen_context(codegen_state *state, pic_value name, pic_value args, pic_value locals, bool varg, pic_value captures) -{ - pic_state *pic = state->pic; - codegen_context *cxt; - pic_value var; - - assert(pic_sym_p(name) || pic_false_p(name)); - - cxt = pic_alloc(pic, sizeof(codegen_context)); - cxt->up = state->cxt; - cxt->name = pic_false_p(name) - ? pic_intern_cstr(pic, "(anonymous lambda)") - : pic_sym(name); - cxt->varg = varg; - - xv_init(&cxt->args, sizeof(pic_sym)); - xv_init(&cxt->locals, sizeof(pic_sym)); - xv_init(&cxt->captures, sizeof(pic_sym)); - - pic_for_each (var, args) { - xv_push(&cxt->args, &pic_sym(var)); - } - pic_for_each (var, locals) { - xv_push(&cxt->locals, &pic_sym(var)); - } - pic_for_each (var, captures) { - xv_push(&cxt->captures, &pic_sym(var)); - } - - cxt->code = pic_calloc(pic, PIC_ISEQ_SIZE, sizeof(pic_code)); - cxt->clen = 0; - cxt->ccapa = PIC_ISEQ_SIZE; - - cxt->irep = pic_calloc(pic, PIC_IREP_SIZE, sizeof(struct pic_irep *)); - cxt->ilen = 0; - cxt->icapa = PIC_IREP_SIZE; - - cxt->pool = pic_calloc(pic, PIC_POOL_SIZE, sizeof(pic_value)); - cxt->plen = 0; - cxt->pcapa = PIC_POOL_SIZE; - - state->cxt = cxt; - - create_activation(cxt); -} - -static struct pic_irep * -pop_codegen_context(codegen_state *state) -{ - pic_state *pic = state->pic; - codegen_context *cxt = state->cxt; - struct pic_irep *irep; - - /* create irep */ - irep = (struct pic_irep *)pic_obj_alloc(pic, sizeof(struct pic_irep), PIC_TT_IREP); - irep->name = state->cxt->name; - irep->varg = state->cxt->varg; - irep->argc = state->cxt->args.size + 1; - irep->localc = state->cxt->locals.size; - irep->capturec = state->cxt->captures.size; - irep->code = pic_realloc(pic, state->cxt->code, sizeof(pic_code) * state->cxt->clen); - irep->clen = state->cxt->clen; - irep->irep = pic_realloc(pic, state->cxt->irep, sizeof(struct pic_irep *) * state->cxt->ilen); - irep->ilen = state->cxt->ilen; - irep->pool = pic_realloc(pic, state->cxt->pool, sizeof(pic_value) * state->cxt->plen); - irep->plen = state->cxt->plen; - - /* finalize */ - xv_destroy(&cxt->args); - xv_destroy(&cxt->locals); - xv_destroy(&cxt->captures); - - /* destroy context */ - cxt = cxt->up; - pic_free(pic, state->cxt); - state->cxt = cxt; - - return irep; -} - -static int -index_capture(codegen_state *state, pic_sym sym, int depth) -{ - codegen_context *cxt = state->cxt; - size_t i; - pic_sym *var; - - while (depth-- > 0) { - cxt = cxt->up; - } - - for (i = 0; i < cxt->captures.size; ++i) { - var = xv_get(&cxt->captures, i); - if (*var == sym) - return i; - } - return -1; -} - -static int -index_local(codegen_state *state, pic_sym sym) -{ - codegen_context *cxt = state->cxt; - size_t i, offset; - pic_sym *var; - - offset = 1; - for (i = 0; i < cxt->args.size; ++i) { - var = xv_get(&cxt->args, i); - if (*var == sym) - return i + offset; - } - offset += i; - for (i = 0; i < cxt->locals.size; ++i) { - var = xv_get(&cxt->locals, i); - if (*var == sym) - return i + offset; - } - return -1; -} - -static struct pic_irep *codegen_lambda(codegen_state *, pic_value); - -static void -codegen(codegen_state *state, pic_value obj) -{ - pic_state *pic = state->pic; - codegen_context *cxt = state->cxt; - pic_sym sym; - - sym = pic_sym(pic_car(pic, obj)); - if (sym == state->sGREF) { - cxt->code[cxt->clen].insn = OP_GREF; - cxt->code[cxt->clen].u.i = pic_sym(pic_list_ref(pic, obj, 1)); - cxt->clen++; - return; - } else if (sym == state->sCREF) { - pic_sym name; - int depth; - - depth = pic_int(pic_list_ref(pic, obj, 1)); - name = pic_sym(pic_list_ref(pic, obj, 2)); - cxt->code[cxt->clen].insn = OP_CREF; - cxt->code[cxt->clen].u.r.depth = depth; - cxt->code[cxt->clen].u.r.idx = index_capture(state, name, depth); - cxt->clen++; - return; - } else if (sym == state->sLREF) { - pic_sym name; - int i; - - name = pic_sym(pic_list_ref(pic, obj, 1)); - if ((i = index_capture(state, name, 0)) != -1) { - cxt->code[cxt->clen].insn = OP_LREF; - cxt->code[cxt->clen].u.i = i + cxt->args.size + cxt->locals.size + 1; - cxt->clen++; - return; - } - cxt->code[cxt->clen].insn = OP_LREF; - cxt->code[cxt->clen].u.i = index_local(state, name); - cxt->clen++; - return; - } else if (sym == pic->sSETBANG) { - pic_value var, val; - pic_sym type; - - val = pic_list_ref(pic, obj, 2); - codegen(state, val); - - var = pic_list_ref(pic, obj, 1); - type = pic_sym(pic_list_ref(pic, var, 0)); - if (type == state->sGREF) { - cxt->code[cxt->clen].insn = OP_GSET; - cxt->code[cxt->clen].u.i = pic_int(pic_list_ref(pic, var, 1)); - cxt->clen++; - cxt->code[cxt->clen].insn = OP_PUSHNONE; - cxt->clen++; - return; - } - else if (type == state->sCREF) { - pic_sym name; - int depth; - - depth = pic_int(pic_list_ref(pic, var, 1)); - name = pic_sym(pic_list_ref(pic, var, 2)); - cxt->code[cxt->clen].insn = OP_CSET; - cxt->code[cxt->clen].u.r.depth = depth; - cxt->code[cxt->clen].u.r.idx = index_capture(state, name, depth); - cxt->clen++; - cxt->code[cxt->clen].insn = OP_PUSHNONE; - cxt->clen++; - return; - } - else if (type == state->sLREF) { - pic_sym name; - int i; - - name = pic_sym(pic_list_ref(pic, var, 1)); - if ((i = index_capture(state, name, 0)) != -1) { - cxt->code[cxt->clen].insn = OP_LSET; - cxt->code[cxt->clen].u.i = i + cxt->args.size + cxt->locals.size + 1; - cxt->clen++; - cxt->code[cxt->clen].insn = OP_PUSHNONE; - cxt->clen++; - return; - } - cxt->code[cxt->clen].insn = OP_LSET; - cxt->code[cxt->clen].u.i = index_local(state, name); - cxt->clen++; - cxt->code[cxt->clen].insn = OP_PUSHNONE; - cxt->clen++; - return; - } - } - else if (sym == pic->sLAMBDA) { - int k; - - if (cxt->ilen >= cxt->icapa) { - cxt->icapa *= 2; - cxt->irep = pic_realloc(pic, cxt->irep, sizeof(struct pic_irep *) * cxt->icapa); - } - k = cxt->ilen++; - cxt->code[cxt->clen].insn = OP_LAMBDA; - cxt->code[cxt->clen].u.i = k; - cxt->clen++; - - cxt->irep[k] = codegen_lambda(state, obj); - return; - } - else if (sym == pic->sIF) { - int s, t; - - codegen(state, pic_list_ref(pic, obj, 1)); - - cxt->code[cxt->clen].insn = OP_JMPIF; - s = cxt->clen++; - - /* if false branch */ - codegen(state, pic_list_ref(pic, obj, 3)); - cxt->code[cxt->clen].insn = OP_JMP; - t = cxt->clen++; - - cxt->code[s].u.i = cxt->clen - s; - - /* if true branch */ - codegen(state, pic_list_ref(pic, obj, 2)); - cxt->code[t].u.i = cxt->clen - t; - return; - } - else if (sym == pic->sBEGIN) { - pic_value elt; - int i = 0; - - pic_for_each (elt, pic_cdr(pic, obj)) { - if (i++ != 0) { - cxt->code[cxt->clen].insn = OP_POP; - cxt->clen++; - } - codegen(state, elt); - } - return; - } - else if (sym == pic->sQUOTE) { - int pidx; - - obj = pic_list_ref(pic, obj, 1); - switch (pic_type(obj)) { - case PIC_TT_BOOL: - if (pic_true_p(obj)) { - cxt->code[cxt->clen].insn = OP_PUSHTRUE; - } else { - cxt->code[cxt->clen].insn = OP_PUSHFALSE; - } - cxt->clen++; - return; - case PIC_TT_INT: - cxt->code[cxt->clen].insn = OP_PUSHINT; - cxt->code[cxt->clen].u.i = pic_int(obj); - cxt->clen++; - return; - case PIC_TT_NIL: - cxt->code[cxt->clen].insn = OP_PUSHNIL; - cxt->clen++; - return; - case PIC_TT_CHAR: - cxt->code[cxt->clen].insn = OP_PUSHCHAR; - cxt->code[cxt->clen].u.c = pic_char(obj); - cxt->clen++; - return; - default: - if (cxt->plen >= cxt->pcapa) { - cxt->pcapa *= 2; - cxt->pool = pic_realloc(pic, cxt->pool, sizeof(pic_value) * cxt->pcapa); - } - pidx = cxt->plen++; - cxt->pool[pidx] = obj; - cxt->code[cxt->clen].insn = OP_PUSHCONST; - cxt->code[cxt->clen].u.i = pidx; - cxt->clen++; - return; - } - } - else if (sym == pic->sCONS) { - codegen(state, pic_list_ref(pic, obj, 1)); - codegen(state, pic_list_ref(pic, obj, 2)); - cxt->code[cxt->clen].insn = OP_CONS; - cxt->clen++; - return; - } - else if (sym == pic->sCAR) { - codegen(state, pic_list_ref(pic, obj, 1)); - cxt->code[cxt->clen].insn = OP_CAR; - cxt->clen++; - return; - } - else if (sym == pic->sCDR) { - codegen(state, pic_list_ref(pic, obj, 1)); - cxt->code[cxt->clen].insn = OP_CDR; - cxt->clen++; - return; - } - else if (sym == pic->sNILP) { - codegen(state, pic_list_ref(pic, obj, 1)); - cxt->code[cxt->clen].insn = OP_NILP; - cxt->clen++; - return; - } - else if (sym == pic->sADD) { - codegen(state, pic_list_ref(pic, obj, 1)); - codegen(state, pic_list_ref(pic, obj, 2)); - cxt->code[cxt->clen].insn = OP_ADD; - cxt->clen++; - return; - } - else if (sym == pic->sSUB) { - codegen(state, pic_list_ref(pic, obj, 1)); - codegen(state, pic_list_ref(pic, obj, 2)); - cxt->code[cxt->clen].insn = OP_SUB; - cxt->clen++; - return; - } - else if (sym == pic->sMUL) { - codegen(state, pic_list_ref(pic, obj, 1)); - codegen(state, pic_list_ref(pic, obj, 2)); - cxt->code[cxt->clen].insn = OP_MUL; - cxt->clen++; - return; - } - else if (sym == pic->sDIV) { - codegen(state, pic_list_ref(pic, obj, 1)); - codegen(state, pic_list_ref(pic, obj, 2)); - cxt->code[cxt->clen].insn = OP_DIV; - cxt->clen++; - return; - } - else if (sym == pic->sMINUS) { - codegen(state, pic_list_ref(pic, obj, 1)); - cxt->code[cxt->clen].insn = OP_MINUS; - cxt->clen++; - return; - } - else if (sym == pic->sEQ) { - codegen(state, pic_list_ref(pic, obj, 1)); - codegen(state, pic_list_ref(pic, obj, 2)); - cxt->code[cxt->clen].insn = OP_EQ; - cxt->clen++; - return; - } - else if (sym == pic->sLT) { - codegen(state, pic_list_ref(pic, obj, 1)); - codegen(state, pic_list_ref(pic, obj, 2)); - cxt->code[cxt->clen].insn = OP_LT; - cxt->clen++; - return; - } - else if (sym == pic->sLE) { - codegen(state, pic_list_ref(pic, obj, 1)); - codegen(state, pic_list_ref(pic, obj, 2)); - cxt->code[cxt->clen].insn = OP_LE; - cxt->clen++; - return; - } - else if (sym == pic->sGT) { - codegen(state, pic_list_ref(pic, obj, 2)); - codegen(state, pic_list_ref(pic, obj, 1)); - cxt->code[cxt->clen].insn = OP_LT; - cxt->clen++; - return; - } - else if (sym == pic->sGE) { - codegen(state, pic_list_ref(pic, obj, 2)); - codegen(state, pic_list_ref(pic, obj, 1)); - cxt->code[cxt->clen].insn = OP_LE; - cxt->clen++; - return; - } - else if (sym == pic->sNOT) { - codegen(state, pic_list_ref(pic, obj, 1)); - cxt->code[cxt->clen].insn = OP_NOT; - cxt->clen++; - return; - } - else if (sym == state->sCALL || sym == state->sTAILCALL) { - int len = pic_length(pic, obj); - pic_value elt; - - pic_for_each (elt, pic_cdr(pic, obj)) { - codegen(state, elt); - } - cxt->code[cxt->clen].insn = (sym == state->sCALL) ? OP_CALL : OP_TAILCALL; - cxt->code[cxt->clen].u.i = len - 1; - cxt->clen++; - return; - } - else if (sym == state->sCALL_WITH_VALUES || sym == state->sTAILCALL_WITH_VALUES) { - /* stack consumer at first */ - codegen(state, pic_list_ref(pic, obj, 2)); - codegen(state, pic_list_ref(pic, obj, 1)); - /* call producer */ - cxt->code[cxt->clen].insn = OP_CALL; - cxt->code[cxt->clen].u.i = 1; - cxt->clen++; - /* call consumer */ - cxt->code[cxt->clen].insn = (sym == state->sCALL_WITH_VALUES) ? OP_CALL : OP_TAILCALL; - cxt->code[cxt->clen].u.i = -1; - cxt->clen++; - return; - } - else if (sym == state->sRETURN) { - int len = pic_length(pic, obj); - pic_value elt; - - pic_for_each (elt, pic_cdr(pic, obj)) { - codegen(state, elt); - } - cxt->code[cxt->clen].insn = OP_RET; - cxt->code[cxt->clen].u.i = len - 1; - cxt->clen++; - return; - } - pic_error(pic, "codegen: unknown AST type"); -} - -static struct pic_irep * -codegen_lambda(codegen_state *state, pic_value obj) -{ - pic_state *pic = state->pic; - pic_value name, args, locals, closes, body; - bool varg; - - name = pic_list_ref(pic, obj, 1); - args = pic_list_ref(pic, obj, 2); - locals = pic_list_ref(pic, obj, 3); - varg = pic_true_p(pic_list_ref(pic, obj, 4)); - closes = pic_list_ref(pic, obj, 5); - body = pic_list_ref(pic, obj, 6); - - /* inner environment */ - push_codegen_context(state, name, args, locals, varg, closes); - { - /* body */ - codegen(state, body); - } - return pop_codegen_context(state); -} - -struct pic_irep * -pic_codegen(pic_state *pic, pic_value obj) -{ - codegen_state *state; - - state = new_codegen_state(pic); - - codegen(state, obj); - - return destroy_codegen_state(state); -} - -struct pic_proc * -pic_compile(pic_state *pic, pic_value obj, struct pic_lib *lib) -{ - struct pic_irep *irep; - size_t ai = pic_gc_arena_preserve(pic); - -#if DEBUG - fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); - - fprintf(stdout, "# input expression\n"); - pic_debug(pic, obj); - fprintf(stdout, "\n"); - - fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); -#endif - - /* macroexpand */ - obj = pic_macroexpand(pic, obj, lib); -#if DEBUG - fprintf(stdout, "## macroexpand completed\n"); - pic_debug(pic, obj); - fprintf(stdout, "\n"); - fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); -#endif - - /* analyze */ - obj = pic_analyze(pic, obj); -#if DEBUG - fprintf(stdout, "## analyzer completed\n"); - pic_debug(pic, obj); - fprintf(stdout, "\n"); - fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); -#endif - - /* codegen */ - irep = pic_codegen(pic, obj); -#if DEBUG - fprintf(stdout, "## codegen completed\n"); - pic_dump_irep(irep); -#endif - -#if DEBUG - fprintf(stdout, "# compilation finished\n"); - puts(""); -#endif - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, pic_obj_value(irep)); - - return pic_proc_new_irep(pic, irep, NULL); -} diff --git a/src/cont.c b/src/cont.c deleted file mode 100644 index 6839c586..00000000 --- a/src/cont.c +++ /dev/null @@ -1,371 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include -#include -#include - -#include "picrin.h" -#include "picrin/proc.h" -#include "picrin/cont.h" -#include "picrin/pair.h" -#include "picrin/error.h" - -pic_value -pic_values0(pic_state *pic) -{ - return pic_values_by_list(pic, pic_nil_value()); -} - -pic_value -pic_values1(pic_state *pic, pic_value arg1) -{ - return pic_values_by_list(pic, pic_list1(pic, arg1)); -} - -pic_value -pic_values2(pic_state *pic, pic_value arg1, pic_value arg2) -{ - return pic_values_by_list(pic, pic_list2(pic, arg1, arg2)); -} - -pic_value -pic_values3(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3) -{ - return pic_values_by_list(pic, pic_list3(pic, arg1, arg2, arg3)); -} - -pic_value -pic_values4(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4) -{ - return pic_values_by_list(pic, pic_list4(pic, arg1, arg2, arg3, arg4)); -} - -pic_value -pic_values5(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4, pic_value arg5) -{ - return pic_values_by_list(pic, pic_list5(pic, arg1, arg2, arg3, arg4, arg5)); -} - -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 = argc; - - return argc == 0 ? pic_none_value() : pic->sp[0]; -} - -pic_value -pic_values_by_list(pic_state *pic, pic_value list) -{ - pic_value v; - size_t i; - - i = 0; - pic_for_each (v, list) { - pic->sp[i++] = v; - } - pic->ci->retc = i; - - return pic_nil_p(list) ? pic_none_value() : pic->sp[0]; -} - -size_t -pic_receive(pic_state *pic, size_t n, pic_value *argv) -{ - pic_callinfo *ci; - size_t i, retc; - - /* take info from discarded frame */ - ci = pic->ci + 1; - retc = ci->retc; - - for (i = 0; i < retc && i < n; ++i) { - argv[i] = ci->fp[i]; - } - - return retc; -} - -static void save_cont(pic_state *, struct pic_cont **); -static void restore_cont(pic_state *, struct pic_cont *); - -static ptrdiff_t -native_stack_length(pic_state *pic, char **pos) -{ - char t; - - *pos = (pic->native_stack_start > &t) - ? &t - : pic->native_stack_start; - - return (pic->native_stack_start > &t) - ? pic->native_stack_start - &t - : &t - pic->native_stack_start; -} - -static void -save_cont(pic_state *pic, struct pic_cont **c) -{ - void pic_vm_tear_off(pic_state *); - struct pic_cont *cont; - char *pos; - - pic_vm_tear_off(pic); /* tear off */ - - cont = *c = (struct pic_cont *)pic_obj_alloc(pic, sizeof(struct pic_cont), PIC_TT_CONT); - - cont->blk = pic->blk; - - cont->stk_len = native_stack_length(pic, &pos); - cont->stk_pos = pos; - assert(cont->stk_len > 0); - cont->stk_ptr = pic_alloc(pic, cont->stk_len); - memcpy(cont->stk_ptr, cont->stk_pos, cont->stk_len); - - cont->sp_offset = pic->sp - pic->stbase; - cont->st_len = pic->stend - pic->stbase; - cont->st_ptr = (pic_value *)pic_alloc(pic, sizeof(pic_value) * cont->st_len); - memcpy(cont->st_ptr, pic->stbase, sizeof(pic_value) * cont->st_len); - - cont->ci_offset = pic->ci - pic->cibase; - cont->ci_len = pic->ciend - pic->cibase; - cont->ci_ptr = (pic_callinfo *)pic_alloc(pic, sizeof(pic_callinfo) * cont->ci_len); - memcpy(cont->ci_ptr, pic->cibase, sizeof(pic_callinfo) * cont->ci_len); - - cont->ip = pic->ip; - - cont->arena_idx = pic->arena_idx; - cont->arena_size = pic->arena_size; - cont->arena = (struct pic_object **)pic_alloc(pic, sizeof(struct pic_object *) * pic->arena_size); - memcpy(cont->arena, pic->arena, sizeof(struct pic_object *) * pic->arena_size); - - cont->try_jmp_idx = pic->try_jmp_idx; - cont->try_jmp_size = pic->try_jmp_size; - cont->try_jmps = pic_alloc(pic, sizeof(struct pic_jmpbuf) * pic->try_jmp_size); - memcpy(cont->try_jmps, pic->try_jmps, sizeof(struct pic_jmpbuf) * pic->try_jmp_size); - - cont->results = pic_undef_value(); -} - -static void -native_stack_extend(pic_state *pic, struct pic_cont *cont) -{ - volatile pic_value v[1024]; - - ((void)v); - restore_cont(pic, cont); -} - -noreturn static void -restore_cont(pic_state *pic, struct pic_cont *cont) -{ - char v; - struct pic_cont *tmp = cont; - struct pic_block *blk; - - if (&v < pic->native_stack_start) { - if (&v > cont->stk_pos) native_stack_extend(pic, cont); - } - else { - if (&v > cont->stk_pos + cont->stk_len) native_stack_extend(pic, cont); - } - - blk = pic->blk; - pic->blk = cont->blk; - - pic->stbase = (pic_value *)pic_realloc(pic, pic->stbase, sizeof(pic_value) * cont->st_len); - memcpy(pic->stbase, cont->st_ptr, sizeof(pic_value) * cont->st_len); - pic->sp = pic->stbase + cont->sp_offset; - pic->stend = pic->stbase + cont->st_len; - - pic->cibase = (pic_callinfo *)pic_realloc(pic, pic->cibase, sizeof(pic_callinfo) * cont->ci_len); - memcpy(pic->cibase, cont->ci_ptr, sizeof(pic_callinfo) * cont->ci_len); - pic->ci = pic->cibase + cont->ci_offset; - pic->ciend = pic->cibase + cont->ci_len; - - pic->ip = cont->ip; - - pic->arena = (struct pic_object **)pic_realloc(pic, pic->arena, sizeof(struct pic_object *) * cont->arena_size); - memcpy(pic->arena, cont->arena, sizeof(struct pic_object *) * cont->arena_size); - pic->arena_size = cont->arena_size; - pic->arena_idx = cont->arena_idx; - - pic->try_jmps = pic_realloc(pic, pic->try_jmps, sizeof(struct pic_jmpbuf) * cont->try_jmp_size); - memcpy(pic->try_jmps, cont->try_jmps, sizeof(struct pic_jmpbuf) * cont->try_jmp_size); - pic->try_jmp_size = cont->try_jmp_size; - pic->try_jmp_idx = cont->try_jmp_idx; - - memcpy(cont->stk_pos, cont->stk_ptr, cont->stk_len); - - longjmp(tmp->jmp, 1); -} - -static void -walk_to_block(pic_state *pic, struct pic_block *here, struct pic_block *there) -{ - if (here == there) - return; - - if (here->depth < there->depth) { - walk_to_block(pic, here, there->prev); - pic_apply0(pic, there->in); - } - else { - pic_apply0(pic, there->out); - walk_to_block(pic, here->prev, there); - } -} - -static pic_value -pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, struct pic_proc *out) -{ - struct pic_block *here; - pic_value val; - - if (in != NULL) { - pic_apply0(pic, in); /* enter */ - } - - here = pic->blk; - pic->blk = (struct pic_block *)pic_obj_alloc(pic, sizeof(struct pic_block), PIC_TT_BLK); - pic->blk->prev = here; - pic->blk->depth = here->depth + 1; - pic->blk->in = in; - pic->blk->out = out; - - val = pic_apply0(pic, thunk); - - pic->blk = here; - - if (out != NULL) { - pic_apply0(pic, out); /* exit */ - } - - return val; -} - -noreturn static pic_value -cont_call(pic_state *pic) -{ - struct pic_proc *proc; - size_t argc; - pic_value *argv; - struct pic_cont *cont; - - proc = pic_get_proc(pic); - pic_get_args(pic, "*", &argc, &argv); - - cont = (struct pic_cont *)pic_ptr(pic_attr_ref(pic, proc, "@@cont")); - cont->results = pic_list_by_array(pic, argc, argv); - - /* execute guard handlers */ - walk_to_block(pic, pic->blk, cont->blk); - - restore_cont(pic, cont); -} - -pic_value -pic_callcc(pic_state *pic, struct pic_proc *proc) -{ - struct pic_cont *cont; - - save_cont(pic, &cont); - if (setjmp(cont->jmp)) { - return pic_values_by_list(pic, cont->results); - } - else { - struct pic_proc *c; - - c = pic_proc_new(pic, cont_call, ""); - - /* save the continuation object in proc */ - pic_attr_set(pic, c, "@@cont", pic_obj_value(cont)); - - return pic_apply1(pic, proc, pic_obj_value(c)); - } -} - -static pic_value -pic_callcc_trampoline(pic_state *pic, struct pic_proc *proc) -{ - struct pic_cont *cont; - - save_cont(pic, &cont); - if (setjmp(cont->jmp)) { - return pic_values_by_list(pic, cont->results); - } - else { - struct pic_proc *c; - - c = pic_proc_new(pic, cont_call, ""); - - /* save the continuation object in proc */ - pic_attr_set(pic, c, "@@cont", pic_obj_value(cont)); - - return pic_apply_trampoline(pic, proc, pic_list1(pic, pic_obj_value(c))); - } -} - -static pic_value -pic_cont_callcc(pic_state *pic) -{ - struct pic_proc *cb; - - pic_get_args(pic, "l", &cb); - - return pic_callcc_trampoline(pic, cb); -} - -static pic_value -pic_cont_dynamic_wind(pic_state *pic) -{ - struct pic_proc *in, *thunk, *out; - - pic_get_args(pic, "lll", &in, &thunk, &out); - - return pic_dynamic_wind(pic, in, thunk, out); -} - -static pic_value -pic_cont_values(pic_state *pic) -{ - size_t argc; - pic_value *argv; - - pic_get_args(pic, "*", &argc, &argv); - - return pic_values_by_array(pic, argc, argv); -} - -static pic_value -pic_cont_call_with_values(pic_state *pic) -{ - struct pic_proc *producer, *consumer; - size_t argc; - pic_value args[256]; - - pic_get_args(pic, "ll", &producer, &consumer); - - pic_apply(pic, producer, pic_nil_value()); - - argc = pic_receive(pic, 256, args); - - return pic_apply_trampoline(pic, consumer, pic_list_by_array(pic, argc, args)); -} - -void -pic_init_cont(pic_state *pic) -{ - pic_defun(pic, "call-with-current-continuation", pic_cont_callcc); - pic_defun(pic, "call/cc", pic_cont_callcc); - pic_defun(pic, "dynamic-wind", pic_cont_dynamic_wind); - pic_defun(pic, "values", pic_cont_values); - pic_defun(pic, "call-with-values", pic_cont_call_with_values); -} diff --git a/src/data.c b/src/data.c deleted file mode 100644 index 5d586c56..00000000 --- a/src/data.c +++ /dev/null @@ -1,15 +0,0 @@ -#include "picrin.h" -#include "picrin/data.h" - -struct pic_data * -pic_data_alloc(pic_state *pic, const pic_data_type *type, void *userdata) -{ - struct pic_data *data; - - data = (struct pic_data *)pic_obj_alloc(pic, sizeof(struct pic_data), PIC_TT_DATA); - data->type = type; - data->data = userdata; - xh_init_str(&data->storage, sizeof(pic_value)); - - return data; -} diff --git a/src/debug.c b/src/debug.c deleted file mode 100644 index f59a4125..00000000 --- a/src/debug.c +++ /dev/null @@ -1,74 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include "picrin.h" -#include "picrin/string.h" -#include "picrin/error.h" -#include "picrin/proc.h" - -pic_str * -pic_get_backtrace(pic_state *pic) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_callinfo *ci; - pic_str *trace; - - trace = pic_str_new(pic, NULL, 0); - - for (ci = pic->ci; ci != pic->cibase; --ci) { - struct pic_proc *proc = pic_proc_ptr(ci->fp[0]); - - trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, " at ")); - trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, pic_symbol_name(pic, pic_proc_name(proc)))); - - if (pic_proc_func_p(proc)) { - trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, " (native function)\n")); - } else if (pic_proc_irep_p(proc)) { - trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, " (unknown location)\n")); /* TODO */ - } - } - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, pic_obj_value(trace)); - - return trace; -} - -void -pic_print_backtrace(pic_state *pic, struct pic_error *e) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_str *trace; - - assert(pic->err != NULL); - - trace = pic_str_new(pic, NULL, 0); - - switch (e->type) { - case PIC_ERROR_OTHER: - trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, "error: ")); - break; - case PIC_ERROR_FILE: - trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, "file error: ")); - break; - case PIC_ERROR_READ: - trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, "read error: ")); - break; - case PIC_ERROR_RAISED: - trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, "raised: ")); - break; - } - - trace = pic_strcat(pic, trace, e->msg); - - /* TODO: print error irritants */ - - trace = pic_strcat(pic, trace, pic_str_new(pic, "\n", 1)); - trace = pic_strcat(pic, trace, e->stack); - - /* print! */ - printf("%s", pic_str_cstr(trace)); - - pic_gc_arena_restore(pic, ai); -} diff --git a/src/dict.c b/src/dict.c deleted file mode 100644 index 3c2a5964..00000000 --- a/src/dict.c +++ /dev/null @@ -1,169 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include "picrin.h" -#include "picrin/dict.h" -#include "picrin/cont.h" - -struct pic_dict * -pic_dict_new(pic_state *pic) -{ - struct pic_dict *dict; - - dict = (struct pic_dict *)pic_obj_alloc(pic, sizeof(struct pic_dict), PIC_TT_DICT); - xh_init_int(&dict->hash, sizeof(pic_value)); - - return dict; -} - -pic_value -pic_dict_ref(pic_state *pic, struct pic_dict *dict, pic_sym key) -{ - xh_entry *e; - - e = xh_get_int(&dict->hash, key); - if (! e) { - pic_errorf(pic, "element not found for a key: ~s", pic_sym_value(key)); - } - return xh_val(e, pic_value); -} - -void -pic_dict_set(pic_state *pic, struct pic_dict *dict, pic_sym key, pic_value val) -{ - UNUSED(pic); - - xh_put_int(&dict->hash, key, &val); -} - -size_t -pic_dict_size(pic_state *pic, struct pic_dict *dict) -{ - UNUSED(pic); - - return dict->hash.count; -} - -bool -pic_dict_has(pic_state *pic, struct pic_dict *dict, pic_sym key) -{ - UNUSED(pic); - - return xh_get_int(&dict->hash, key) != NULL; -} - -void -pic_dict_del(pic_state *pic, struct pic_dict *dict, pic_sym key) -{ - if (xh_get_int(&dict->hash, key) == NULL) { - pic_errorf(pic, "no slot named ~s found in dictionary", pic_sym_value(key)); - } - - xh_del_int(&dict->hash, key); -} - -static pic_value -pic_dict_dict(pic_state *pic) -{ - struct pic_dict *dict; - - pic_get_args(pic, ""); - - dict = pic_dict_new(pic); - - return pic_obj_value(dict); -} - -static pic_value -pic_dict_dict_p(pic_state *pic) -{ - pic_value obj; - - pic_get_args(pic, "o", &obj); - - return pic_bool_value(pic_dict_p(obj)); -} - -static pic_value -pic_dict_dict_ref(pic_state *pic) -{ - struct pic_dict *dict; - pic_sym key; - - pic_get_args(pic, "dm", &dict, &key); - - if (pic_dict_has(pic, dict, key)) { - return pic_values2(pic, pic_dict_ref(pic, dict , key), pic_true_value()); - } else { - return pic_values2(pic, pic_none_value(), pic_false_value()); - } -} - -static pic_value -pic_dict_dict_set(pic_state *pic) -{ - struct pic_dict *dict; - pic_sym key; - pic_value val; - - pic_get_args(pic, "dmo", &dict, &key, &val); - - pic_dict_set(pic, dict, key, val); - - return pic_none_value(); -} - -static pic_value -pic_dict_dict_del(pic_state *pic) -{ - struct pic_dict *dict; - pic_sym key; - - pic_get_args(pic, "dm", &dict, &key); - - pic_dict_del(pic, dict, key); - - return pic_none_value(); -} - -static pic_value -pic_dict_dict_size(pic_state *pic) -{ - struct pic_dict *dict; - - pic_get_args(pic, "d", &dict); - - return pic_int_value(pic_dict_size(pic, dict)); -} - -static pic_value -pic_dict_dict_for_each(pic_state *pic) -{ - struct pic_proc *proc; - struct pic_dict *dict; - xh_iter it; - - pic_get_args(pic, "ld", &proc, &dict); - - xh_begin(&it, &dict->hash); - while (xh_next(&it)) { - pic_apply2(pic, proc, pic_sym_value(xh_key(it.e, pic_sym)), xh_val(it.e, pic_value)); - } - - return pic_none_value(); -} - -void -pic_init_dict(pic_state *pic) -{ - pic_deflibrary (pic, "(picrin dictionary)") { - pic_defun(pic, "make-dictionary", pic_dict_dict); - pic_defun(pic, "dictionary?", pic_dict_dict_p); - pic_defun(pic, "dictionary-ref", pic_dict_dict_ref); - pic_defun(pic, "dictionary-set!", pic_dict_dict_set); - pic_defun(pic, "dictionary-delete", pic_dict_dict_del); - pic_defun(pic, "dictionary-size", pic_dict_dict_size); - pic_defun(pic, "dictionary-for-each", pic_dict_dict_for_each); - } -} diff --git a/src/error.c b/src/error.c deleted file mode 100644 index f4d46f5e..00000000 --- a/src/error.c +++ /dev/null @@ -1,286 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include -#include -#include - -#include "picrin.h" -#include "picrin/pair.h" -#include "picrin/string.h" -#include "picrin/error.h" - -void -pic_abort(pic_state *pic, const char *msg) -{ - UNUSED(pic); - - fprintf(stderr, "abort: %s\n", msg); - abort(); -} - -void -pic_warnf(pic_state *pic, const char *fmt, ...) -{ - va_list ap; - pic_value err_line; - - va_start(ap, fmt); - err_line = pic_vformat(pic, fmt, ap); - va_end(ap); - - fprintf(stderr, "warn: %s\n", pic_str_cstr(pic_str_ptr(pic_car(pic, err_line)))); -} - -void -pic_push_try(pic_state *pic, struct pic_proc *handler) -{ - struct pic_jmpbuf *try_jmp; - - if (pic->try_jmp_idx >= pic->try_jmp_size) { - pic->try_jmp_size *= 2; - pic->try_jmps = pic_realloc(pic, pic->try_jmps, sizeof(struct pic_jmpbuf) * pic->try_jmp_size); - } - - try_jmp = pic->try_jmps + pic->try_jmp_idx++; - - try_jmp->handler = handler; - - try_jmp->ci_offset = pic->ci - pic->cibase; - try_jmp->sp_offset = pic->sp - pic->stbase; - try_jmp->ip = pic->ip; - - try_jmp->prev_jmp = pic->jmp; - pic->jmp = &try_jmp->here; -} - -void -pic_pop_try(pic_state *pic) -{ - struct pic_jmpbuf *try_jmp; - - try_jmp = pic->try_jmps + --pic->try_jmp_idx; - - /* assert(pic->jmp == &try_jmp->here); */ - - pic->ci = try_jmp->ci_offset + pic->cibase; - pic->sp = try_jmp->sp_offset + pic->stbase; - pic->ip = try_jmp->ip; - - pic->jmp = try_jmp->prev_jmp; -} - -static struct pic_error * -error_new(pic_state *pic, short type, pic_str *msg, pic_value irrs) -{ - struct pic_error *e; - pic_str *stack; - - stack = pic_get_backtrace(pic); - - e = (struct pic_error *)pic_obj_alloc(pic, sizeof(struct pic_error), PIC_TT_ERROR); - e->type = type; - e->msg = msg; - e->irrs = irrs; - e->stack = stack; - - return e; -} - -noreturn void -pic_throw_error(pic_state *pic, struct pic_error *e) -{ - void pic_vm_tear_off(pic_state *); - - pic_vm_tear_off(pic); /* tear off */ - - pic->err = e; - if (! pic->jmp) { - puts(pic_errmsg(pic)); - abort(); - } - - longjmp(*pic->jmp, 1); -} - -noreturn void -pic_throw(pic_state *pic, short type, const char *msg, pic_value irrs) -{ - struct pic_error *e; - - e = error_new(pic, type, pic_str_new_cstr(pic, msg), irrs); - - pic_throw_error(pic, e); -} - -const char * -pic_errmsg(pic_state *pic) -{ - assert(pic->err != NULL); - - return pic_str_cstr(pic->err->msg); -} - -void -pic_errorf(pic_state *pic, const char *fmt, ...) -{ - va_list ap; - pic_value err_line, irrs; - const char *msg; - - va_start(ap, fmt); - err_line = pic_vformat(pic, fmt, ap); - va_end(ap); - - msg = pic_str_cstr(pic_str_ptr(pic_car(pic, err_line))); - irrs = pic_cdr(pic, err_line); - - pic_throw(pic, PIC_ERROR_OTHER, msg, irrs); -} - -static pic_value -pic_error_with_exception_handler(pic_state *pic) -{ - struct pic_proc *handler, *thunk; - pic_value v; - - pic_get_args(pic, "ll", &handler, &thunk); - - pic_try_with_handler(handler) { - v = pic_apply0(pic, thunk); - } - pic_catch { - struct pic_error *e = pic->err; - - pic->err = NULL; - - if (e->type == PIC_ERROR_RAISED) { - v = pic_list_ref(pic, e->irrs, 0); - } else { - v = pic_obj_value(e); - } - v = pic_apply1(pic, handler, v); - pic_errorf(pic, "error handler returned ~s, by error ~s", v, pic_obj_value(e)); - } - return v; -} - -noreturn static pic_value -pic_error_raise(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - pic_throw(pic, PIC_ERROR_RAISED, "object is raised", pic_list1(pic, v)); -} - -static pic_value -pic_error_raise_continuable(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - if (pic->try_jmp_idx == 0) { - pic_errorf(pic, "no exception handler registered"); - } - if (pic->try_jmps[pic->try_jmp_idx - 1].handler == NULL) { - pic_errorf(pic, "uncontinuable exception handler is on top"); - } - else { - pic->try_jmp_idx--; - v = pic_apply1(pic, pic->try_jmps[pic->try_jmp_idx].handler, v); - ++pic->try_jmp_idx; - } - return v; -} - -noreturn static pic_value -pic_error_error(pic_state *pic) -{ - const char *str; - size_t argc; - pic_value *argv; - - pic_get_args(pic, "z*", &str, &argc, &argv); - - pic_throw(pic, PIC_ERROR_OTHER, str, pic_list_by_array(pic, argc, argv)); -} - -static pic_value -pic_error_error_object_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - return pic_bool_value(pic_error_p(v)); -} - -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(e->msg); -} - -static pic_value -pic_error_error_object_irritants(pic_state *pic) -{ - struct pic_error *e; - - pic_get_args(pic, "e", &e); - - return e->irrs; -} - -static pic_value -pic_error_read_error_p(pic_state *pic) -{ - pic_value v; - struct pic_error *e; - - pic_get_args(pic, "o", &v); - - if (! pic_error_p(v)) { - return pic_false_value(); - } - - e = pic_error_ptr(v); - return pic_bool_value(e->type == PIC_ERROR_READ); -} - -static pic_value -pic_error_file_error_p(pic_state *pic) -{ - pic_value v; - struct pic_error *e; - - pic_get_args(pic, "o", &v); - - if (! pic_error_p(v)) { - return pic_false_value(); - } - - e = pic_error_ptr(v); - return pic_bool_value(e->type == PIC_ERROR_FILE); -} - -void -pic_init_error(pic_state *pic) -{ - pic_defun(pic, "with-exception-handler", pic_error_with_exception_handler); - pic_defun(pic, "raise", pic_error_raise); - pic_defun(pic, "raise-continuable", pic_error_raise_continuable); - pic_defun(pic, "error", pic_error_error); - pic_defun(pic, "error-object?", pic_error_error_object_p); - pic_defun(pic, "error-object-message", pic_error_error_object_message); - pic_defun(pic, "error-object-irritants", pic_error_error_object_irritants); - pic_defun(pic, "read-error?", pic_error_read_error_p); - pic_defun(pic, "file-error?", pic_error_file_error_p); -} diff --git a/src/eval.c b/src/eval.c index 5a037c94..dd31829c 100644 --- a/src/eval.c +++ b/src/eval.c @@ -5,16 +5,6 @@ #include "picrin.h" #include "picrin/macro.h" -pic_value -pic_eval(pic_state *pic, pic_value program, struct pic_lib *lib) -{ - struct pic_proc *proc; - - proc = pic_compile(pic, program, lib); - - return pic_apply(pic, proc, pic_nil_value()); -} - static pic_value pic_eval_eval(pic_state *pic) { diff --git a/src/gc.c b/src/gc.c deleted file mode 100644 index 9a947837..00000000 --- a/src/gc.c +++ /dev/null @@ -1,872 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include - -#include "picrin.h" -#include "picrin/gc.h" -#include "picrin/pair.h" -#include "picrin/string.h" -#include "picrin/vector.h" -#include "picrin/irep.h" -#include "picrin/proc.h" -#include "picrin/port.h" -#include "picrin/blob.h" -#include "picrin/cont.h" -#include "picrin/error.h" -#include "picrin/macro.h" -#include "picrin/lib.h" -#include "picrin/var.h" -#include "picrin/data.h" -#include "picrin/dict.h" -#include "picrin/record.h" -#include "picrin/read.h" - -#if GC_DEBUG -# include -#endif - -union header { - struct { - union header *ptr; - size_t size; - unsigned int mark : 1; - } s; - long alignment[4]; -}; - -struct heap_page { - union header *basep, *endp; - struct heap_page *next; -}; - -struct pic_heap { - union header base, *freep; - struct heap_page *pages; -}; - - -static void -heap_init(struct pic_heap *heap) -{ - heap->base.s.ptr = &heap->base; - heap->base.s.size = 0; /* not 1, since it must never be used for allocation */ - heap->base.s.mark = PIC_GC_UNMARK; - - heap->freep = &heap->base; - heap->pages = NULL; - -#if GC_DEBUG - printf("freep = %p\n", (void *)heap->freep); -#endif -} - -struct pic_heap * -pic_heap_open() -{ - struct pic_heap *heap; - - heap = (struct pic_heap *)calloc(1, sizeof(struct pic_heap)); - heap_init(heap); - return heap; -} - -void -pic_heap_close(struct pic_heap *heap) -{ - struct heap_page *page; - - while (heap->pages) { - page = heap->pages; - heap->pages = heap->pages->next; - free(page); - } -} - -static void gc_free(pic_state *, union header *); - -static void -add_heap_page(pic_state *pic) -{ - union header *up, *np; - struct heap_page *page; - size_t nu; - -#if GC_DEBUG - puts("adding heap page!"); -#endif - - nu = (PIC_HEAP_PAGE_SIZE + sizeof(union header) - 1) / sizeof(union header) + 1; - - up = (union header *)pic_calloc(pic, 1 + nu + 1, sizeof(union header)); - up->s.size = nu + 1; - up->s.mark = PIC_GC_UNMARK; - gc_free(pic, up); - - np = up + 1; - np->s.size = nu; - np->s.ptr = up->s.ptr; - up->s.size = 1; - up->s.ptr = np; - - page = (struct heap_page *)pic_alloc(pic, sizeof(struct heap_page)); - page->basep = up; - page->endp = up + nu + 1; - page->next = pic->heap->pages; - - pic->heap->pages = page; -} - -static void * -alloc(void *ptr, size_t size) -{ - if (size == 0) { - if (ptr) { - free(ptr); - } - return NULL; - } - if (ptr) { - return realloc(ptr, size); - } else { - return malloc(size); - } -} - -void * -pic_alloc(pic_state *pic, size_t size) -{ - void *ptr; - - ptr = alloc(NULL, size); - if (ptr == NULL && size > 0) { - pic_abort(pic, "memory exhausted"); - } - return ptr; -} - -void * -pic_realloc(pic_state *pic, void *ptr, size_t size) -{ - ptr = alloc(ptr, size); - if (ptr == NULL && size > 0) { - pic_abort(pic, "memory exhausted"); - } - return ptr; -} - -void * -pic_calloc(pic_state *pic, size_t count, size_t size) -{ - void *ptr; - - size *= count; - ptr = alloc(NULL, size); - if (ptr == NULL && size > 0) { - pic_abort(pic, "memory exhausted"); - } - memset(ptr, 0, size); - return ptr; -} - -void -pic_free(pic_state *pic, void *ptr) -{ - UNUSED(pic); - - free(ptr); -} - -static void -gc_protect(pic_state *pic, struct pic_object *obj) -{ - if (pic->arena_idx >= pic->arena_size) { - pic->arena_size = pic->arena_size * 2 + 1; - pic->arena = pic_realloc(pic, pic->arena, sizeof(struct pic_object *) * pic->arena_size); - } - pic->arena[pic->arena_idx++] = obj; -} - -pic_value -pic_gc_protect(pic_state *pic, pic_value v) -{ - struct pic_object *obj; - - if (pic_vtype(v) != PIC_VTYPE_HEAP) { - return v; - } - obj = pic_obj_ptr(v); - - gc_protect(pic, obj); - - return v; -} - -size_t -pic_gc_arena_preserve(pic_state *pic) -{ - return pic->arena_idx; -} - -void -pic_gc_arena_restore(pic_state *pic, size_t state) -{ - pic->arena_idx = state; -} - -static void * -gc_alloc(pic_state *pic, size_t size) -{ - union header *freep, *p, *prevp; - size_t nunits; - -#if GC_DEBUG - assert(size > 0); -#endif - - nunits = (size + sizeof(union header) - 1) / sizeof(union header) + 1; - - prevp = freep = pic->heap->freep; - for (p = prevp->s.ptr; ; prevp = p, p = p->s.ptr) { - if (p->s.size >= nunits) - break; - if (p == freep) { - return NULL; - } - } - -#if GC_DEBUG - { - unsigned char *c; - size_t s, i, j; - if (p->s.size == nunits) { - c = (unsigned char *)(p + p->s.size - nunits + 1); - s = nunits - 1; - } else { - c = (unsigned char *)(p + p->s.size - nunits); - s = nunits; - } - - for (i = 0; i < s; ++i) { - for (j = 0; j < sizeof(union header); ++j) { - assert(c[i * sizeof(union header) + j] == 0xAA); - } - } - } -#endif - - if (p->s.size == nunits) { - prevp->s.ptr = p->s.ptr; - } - else { - p->s.size -= nunits; - p += p->s.size; - p->s.size = nunits; - } - pic->heap->freep = prevp; - - p->s.mark = PIC_GC_UNMARK; - -#if GC_DEBUG - memset(p+1, 0, sizeof(union header) * (nunits - 1)); - p->s.ptr = (union header *)0xcafebabe; -#endif - - return (void *)(p + 1); -} - -static void -gc_free(pic_state *pic, union header *bp) -{ - union header *freep, *p; - -#if GC_DEBUG - assert(bp != NULL); - assert(bp->s.size > 1); -#endif - -#if GC_DEBUG - memset(bp + 1, 0xAA, (bp->s.size - 1) * sizeof(union header)); -#endif - - freep = pic->heap->freep; - for (p = freep; ! (bp > p && bp < p->s.ptr); p = p->s.ptr) { - if (p >= p->s.ptr && (bp > p || bp < p->s.ptr)) { - break; - } - } - if (bp + bp->s.size == p->s.ptr) { - bp->s.size += p->s.ptr->s.size; - bp->s.ptr = p->s.ptr->s.ptr; - -#if GC_DEBUG - memset(p->s.ptr, 0xAA, sizeof(union header)); -#endif - } - else { - bp->s.ptr = p->s.ptr; - } - if (p + p->s.size == bp && p->s.size > 1) { - p->s.size += bp->s.size; - p->s.ptr = bp->s.ptr; - -#if GC_DEBUG - memset(bp, 0xAA, sizeof(union header)); -#endif - } - else { - p->s.ptr = bp; - } - pic->heap->freep = p; -} - -static void gc_mark(pic_state *, pic_value); -static void gc_mark_object(pic_state *pic, struct pic_object *obj); - -static bool -gc_is_marked(union header *p) -{ - return p->s.mark == PIC_GC_MARK; -} - -static void -gc_unmark(union header *p) -{ - p->s.mark = PIC_GC_UNMARK; -} - -static void -gc_mark_object(pic_state *pic, struct pic_object *obj) -{ - union header *p; - - p = ((union header *)obj) - 1; - - if (gc_is_marked(p)) - return; - p->s.mark = PIC_GC_MARK; - - switch (obj->tt) { - case PIC_TT_PAIR: { - gc_mark(pic, ((struct pic_pair *)obj)->car); - gc_mark(pic, ((struct pic_pair *)obj)->cdr); - break; - } - case PIC_TT_ENV: { - struct pic_env *env = (struct pic_env *)obj; - int i; - - for (i = 0; i < env->regc; ++i) { - gc_mark(pic, env->regs[i]); - } - if (env->up) { - gc_mark_object(pic, (struct pic_object *)env->up); - } - break; - } - case PIC_TT_PROC: { - struct pic_proc *proc = (struct pic_proc *)obj; - if (proc->env) { - gc_mark_object(pic, (struct pic_object *)proc->env); - } - if (proc->attr) { - gc_mark_object(pic, (struct pic_object *)proc->attr); - } - if (pic_proc_irep_p(proc)) { - gc_mark_object(pic, (struct pic_object *)proc->u.irep); - } - break; - } - case PIC_TT_PORT: { - break; - } - case PIC_TT_ERROR: { - struct pic_error *err = (struct pic_error *)obj; - gc_mark_object(pic,(struct pic_object *)err->msg); - gc_mark(pic, err->irrs); - gc_mark_object(pic, (struct pic_object *)err->stack); - break; - } - case PIC_TT_STRING: { - break; - } - case PIC_TT_VECTOR: { - size_t i; - for (i = 0; i < ((struct pic_vector *)obj)->len; ++i) { - gc_mark(pic, ((struct pic_vector *)obj)->data[i]); - } - break; - } - case PIC_TT_BLOB: { - break; - } - case PIC_TT_CONT: { - struct pic_cont *cont = (struct pic_cont *)obj; - pic_value *stack; - pic_callinfo *ci; - size_t i; - - /* block */ - gc_mark_object(pic, (struct pic_object *)cont->blk); - - /* stack */ - for (stack = cont->st_ptr; stack != cont->st_ptr + cont->sp_offset; ++stack) { - gc_mark(pic, *stack); - } - - /* callinfo */ - for (ci = cont->ci_ptr + cont->ci_offset; ci != cont->ci_ptr; --ci) { - if (ci->env) { - gc_mark_object(pic, (struct pic_object *)ci->env); - } - } - - /* arena */ - for (i = 0; i < (size_t)cont->arena_idx; ++i) { - gc_mark_object(pic, cont->arena[i]); - } - - /* error handlers */ - for (i = 0; i < cont->try_jmp_idx; ++i) { - if (cont->try_jmps[i].handler) { - gc_mark_object(pic, (struct pic_object *)cont->try_jmps[i].handler); - } - } - - /* result values */ - gc_mark(pic, cont->results); - break; - } - case PIC_TT_MACRO: { - struct pic_macro *mac = (struct pic_macro *)obj; - - if (mac->proc) { - gc_mark_object(pic, (struct pic_object *)mac->proc); - } - if (mac->senv) { - gc_mark_object(pic, (struct pic_object *)mac->senv); - } - break; - } - case PIC_TT_SENV: { - struct pic_senv *senv = (struct pic_senv *)obj; - - if (senv->up) { - gc_mark_object(pic, (struct pic_object *)senv->up); - } - break; - } - case PIC_TT_LIB: { - struct pic_lib *lib = (struct pic_lib *)obj; - gc_mark(pic, lib->name); - gc_mark_object(pic, (struct pic_object *)lib->env); - break; - } - case PIC_TT_VAR: { - struct pic_var *var = (struct pic_var *)obj; - gc_mark(pic, var->stack); - if (var->conv) { - gc_mark_object(pic, (struct pic_object *)var->conv); - } - break; - } - case PIC_TT_IREP: { - struct pic_irep *irep = (struct pic_irep *)obj; - size_t i; - - for (i = 0; i < irep->ilen; ++i) { - gc_mark_object(pic, (struct pic_object *)irep->irep[i]); - } - for (i = 0; i < irep->plen; ++i) { - gc_mark(pic, irep->pool[i]); - } - break; - } - case PIC_TT_DATA: { - struct pic_data *data = (struct pic_data *)obj; - xh_iter it; - - xh_begin(&it, &data->storage); - while (xh_next(&it)) { - gc_mark(pic, xh_val(it.e, pic_value)); - } - break; - } - case PIC_TT_DICT: { - struct pic_dict *dict = (struct pic_dict *)obj; - xh_iter it; - - xh_begin(&it, &dict->hash); - while (xh_next(&it)) { - gc_mark(pic, xh_val(it.e, pic_value)); - } - break; - } - case PIC_TT_RECORD: { - struct pic_record *rec = (struct pic_record *)obj; - xh_iter it; - - xh_begin(&it, &rec->hash); - while (xh_next(&it)) { - gc_mark(pic, xh_val(it.e, pic_value)); - } - break; - } - case PIC_TT_BLK: { - struct pic_block *blk = (struct pic_block *)obj; - - if (blk->prev) { - gc_mark_object(pic, (struct pic_object *)blk->prev); - } - if (blk->in) { - gc_mark_object(pic, (struct pic_object *)blk->in); - } - if (blk->out) { - gc_mark_object(pic, (struct pic_object *)blk->out); - } - break; - } - case PIC_TT_NIL: - case PIC_TT_BOOL: - case PIC_TT_FLOAT: - case PIC_TT_INT: - case PIC_TT_SYMBOL: - case PIC_TT_CHAR: - case PIC_TT_EOF: - case PIC_TT_UNDEF: - pic_abort(pic, "logic flaw"); - } -} - -static void -gc_mark(pic_state *pic, pic_value v) -{ - struct pic_object *obj; - - if (pic_vtype(v) != PIC_VTYPE_HEAP) - return; - obj = pic_obj_ptr(v); - - gc_mark_object(pic, obj); -} - -static void -gc_mark_trie(pic_state *pic, struct pic_trie *trie) -{ - size_t i; - - for (i = 0; i < sizeof trie->table / sizeof(struct pic_trie *); ++i) { - if (trie->table[i] != NULL) { - gc_mark_trie(pic, trie->table[i]); - } - } - if (trie->proc != NULL) { - gc_mark_object(pic, (struct pic_object *)trie->proc); - } -} - -static void -gc_mark_phase(pic_state *pic) -{ - pic_value *stack; - pic_callinfo *ci; - size_t i, j; - xh_iter it; - - /* block */ - if (pic->blk) { - gc_mark_object(pic, (struct pic_object *)pic->blk); - } - - /* stack */ - for (stack = pic->stbase; stack != pic->sp; ++stack) { - gc_mark(pic, *stack); - } - - /* callinfo */ - for (ci = pic->ci; ci != pic->cibase; --ci) { - if (ci->env) { - gc_mark_object(pic, (struct pic_object *)ci->env); - } - } - - /* error object */ - if (pic->err) { - gc_mark_object(pic, (struct pic_object *)pic->err); - } - - /* arena */ - for (j = 0; j < pic->arena_idx; ++j) { - gc_mark_object(pic, pic->arena[j]); - } - - /* global variables */ - xh_begin(&it, &pic->globals); - while (xh_next(&it)) { - gc_mark(pic, xh_val(it.e, pic_value)); - } - - /* macro objects */ - xh_begin(&it, &pic->macros); - while (xh_next(&it)) { - gc_mark_object(pic, xh_val(it.e, struct pic_object *)); - } - - /* error handlers */ - for (i = 0; i < pic->try_jmp_idx; ++i) { - if (pic->try_jmps[i].handler) { - gc_mark_object(pic, (struct pic_object *)pic->try_jmps[i].handler); - } - } - - /* readers */ - gc_mark_trie(pic, pic->reader->trie); - - /* library table */ - gc_mark(pic, pic->libs); -} - -static void -gc_finalize_object(pic_state *pic, struct pic_object *obj) -{ -#if GC_DEBUG - printf("* finalizing object: %s", pic_type_repr(pic_type(pic_obj_value(obj)))); - // pic_debug(pic, pic_obj_value(obj)); - puts(""); -#endif - - switch (obj->tt) { - case PIC_TT_PAIR: { - break; - } - case PIC_TT_ENV: { - break; - } - case PIC_TT_PROC: { - break; - } - case PIC_TT_VECTOR: { - pic_free(pic, ((struct pic_vector *)obj)->data); - break; - } - case PIC_TT_BLOB: { - pic_free(pic, ((struct pic_blob *)obj)->data); - break; - } - case PIC_TT_STRING: { - XROPE_DECREF(((struct pic_string *)obj)->rope); - break; - } - case PIC_TT_PORT: { - break; - } - case PIC_TT_ERROR: { - break; - } - case PIC_TT_CONT: { - struct pic_cont *cont = (struct pic_cont *)obj; - pic_free(pic, cont->stk_ptr); - pic_free(pic, cont->st_ptr); - pic_free(pic, cont->ci_ptr); - pic_free(pic, cont->arena); - pic_free(pic, cont->try_jmps); - break; - } - case PIC_TT_SENV: { - struct pic_senv *senv = (struct pic_senv *)obj; - xh_destroy(&senv->map); - break; - } - case PIC_TT_MACRO: { - break; - } - case PIC_TT_LIB: { - struct pic_lib *lib = (struct pic_lib *)obj; - xh_destroy(&lib->exports); - break; - } - case PIC_TT_VAR: { - break; - } - case PIC_TT_IREP: { - struct pic_irep *irep = (struct pic_irep *)obj; - pic_free(pic, irep->code); - pic_free(pic, irep->irep); - pic_free(pic, irep->pool); - break; - } - case PIC_TT_DATA: { - struct pic_data *data = (struct pic_data *)obj; - data->type->dtor(pic, data->data); - xh_destroy(&data->storage); - break; - } - case PIC_TT_DICT: { - struct pic_dict *dict = (struct pic_dict *)obj; - xh_destroy(&dict->hash); - break; - } - case PIC_TT_RECORD: { - struct pic_record *rec = (struct pic_record *)obj; - xh_destroy(&rec->hash); - break; - } - case PIC_TT_BLK: { - break; - } - case PIC_TT_NIL: - case PIC_TT_BOOL: - case PIC_TT_FLOAT: - case PIC_TT_INT: - case PIC_TT_SYMBOL: - case PIC_TT_CHAR: - case PIC_TT_EOF: - case PIC_TT_UNDEF: - pic_abort(pic, "logic flaw"); - } -} - -static void -gc_sweep_page(pic_state *pic, struct heap_page *page) -{ -#if GC_DEBUG - static union header *NIL = (union header *)0xdeadbeef; -#else - static union header *NIL = NULL; -#endif - union header *bp, *p, *s = NIL, *t; - -#if GC_DEBUG - int c = 0; -#endif - - for (bp = page->basep; ; bp = bp->s.ptr) { - for (p = bp + bp->s.size; p != bp->s.ptr; p += p->s.size) { - if (p == page->endp) { - goto escape; - } - if (! gc_is_marked(p)) { - if (s == NIL) { - s = p; - } - else { - t->s.ptr = p; - } - t = p; - t->s.ptr = NIL; /* For dead objects we can safely reuse ptr field */ - } - gc_unmark(p); - } - } - escape: - - /* free! */ - while (s != NIL) { - t = s->s.ptr; - gc_finalize_object(pic, (struct pic_object *)(s + 1)); - gc_free(pic, s); - s = t; - -#if GC_DEBUG - c++; -#endif - } - -#if GC_DEBUG - printf("freed objects count: %d\n", c); -#endif -} - -static void -gc_sweep_phase(pic_state *pic) -{ - struct heap_page *page = pic->heap->pages; - - while (page) { - gc_sweep_page(pic, page); - page = page->next; - } -} - -void -pic_gc_run(pic_state *pic) -{ -#if GC_DEBUG - struct heap_page *page; -#endif - -#if DEBUG - puts("gc run!"); -#endif - - gc_mark_phase(pic); - gc_sweep_phase(pic); - -#if GC_DEBUG - for (page = pic->heap->pages; page; page = page->next) { - union header *bp, *p; - unsigned char *c; - - for (bp = page->basep; ; bp = bp->s.ptr) { - for (c = (unsigned char *)(bp+1); c != (unsigned char *)(bp + bp->s.size); ++c) { - assert(*c == 0xAA); - } - for (p = bp + bp->s.size; p != bp->s.ptr; p += p->s.size) { - if (p == page->endp) { - /* if (page->next) */ - /* assert(bp->s.ptr == page->next->basep); */ - /* else */ - /* assert(bp->s.ptr == &pic->heap->base); */ - goto escape; - } - assert(! gc_is_marked(p)); - } - } - escape: - ((void)0); - } - - puts("not error on heap found! gc successfully finished"); -#endif -} - -struct pic_object * -pic_obj_alloc_unsafe(pic_state *pic, size_t size, enum pic_tt tt) -{ - struct pic_object *obj; - -#if GC_DEBUG - printf("*allocating: %s\n", pic_type_repr(tt)); -#endif - -#if GC_STRESS - pic_gc_run(pic); -#endif - - obj = (struct pic_object *)gc_alloc(pic, size); - if (obj == NULL) { - pic_gc_run(pic); - obj = (struct pic_object *)gc_alloc(pic, size); - if (obj == NULL) { - add_heap_page(pic); - obj = (struct pic_object *)gc_alloc(pic, size); - if (obj == NULL) - pic_abort(pic, "GC memory exhausted"); - } - } - obj->tt = tt; - - return obj; -} - -struct pic_object * -pic_obj_alloc(pic_state *pic, size_t size, enum pic_tt tt) -{ - struct pic_object *obj; - - obj = pic_obj_alloc_unsafe(pic, size, tt); - - gc_protect(pic, obj); - return obj; -} diff --git a/src/init.c b/src/init.c index 7f869048..76b51d35 100644 --- a/src/init.c +++ b/src/init.c @@ -6,10 +6,6 @@ #include "picrin.h" #include "picrin/pair.h" -#include "picrin/read.h" -#include "picrin/lib.h" -#include "picrin/macro.h" -#include "picrin/error.h" static pic_value pic_features(pic_state *pic) @@ -39,87 +35,19 @@ pic_libraries(pic_state *pic) return libs; } -void pic_init_bool(pic_state *); -void pic_init_pair(pic_state *); -void pic_init_port(pic_state *); -void pic_init_number(pic_state *); -void pic_init_time(pic_state *); -void pic_init_system(pic_state *); -void pic_init_file(pic_state *); -void pic_init_proc(pic_state *); -void pic_init_symbol(pic_state *); -void pic_init_vector(pic_state *); -void pic_init_blob(pic_state *); -void pic_init_cont(pic_state *); -void pic_init_char(pic_state *); -void pic_init_error(pic_state *); -void pic_init_str(pic_state *); -void pic_init_macro(pic_state *); -void pic_init_var(pic_state *); -void pic_init_load(pic_state *); -void pic_init_write(pic_state *); -void pic_init_read(pic_state *); -void pic_init_dict(pic_state *); -void pic_init_record(pic_state *); -void pic_init_eval(pic_state *); -void pic_init_lib(pic_state *); void pic_init_contrib(pic_state *); - void pic_load_piclib(pic_state *); -#define DONE pic_gc_arena_restore(pic, ai); - void -pic_init_core(pic_state *pic) +pic_init_misc(pic_state *pic) { - size_t ai = pic_gc_arena_preserve(pic); - - pic_init_reader(pic); - - pic_deflibrary (pic, "(picrin base core)") { - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->rDEFINE); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->rSETBANG); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->rQUOTE); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->rLAMBDA); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->rIF); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->rBEGIN); - pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX); - } - pic_deflibrary (pic, "(picrin library)") { pic_defun(pic, "libraries", pic_libraries); } pic_deflibrary (pic, "(scheme base)") { pic_defun(pic, "features", pic_features); - - pic_init_bool(pic); DONE; - pic_init_pair(pic); DONE; - pic_init_port(pic); DONE; - pic_init_number(pic); DONE; - pic_init_time(pic); DONE; - pic_init_system(pic); DONE; - pic_init_file(pic); DONE; - pic_init_proc(pic); DONE; - pic_init_symbol(pic); DONE; - pic_init_vector(pic); DONE; - pic_init_blob(pic); DONE; - pic_init_cont(pic); DONE; - pic_init_char(pic); DONE; - pic_init_error(pic); DONE; - pic_init_str(pic); DONE; - pic_init_macro(pic); DONE; - pic_init_var(pic); DONE; - pic_init_load(pic); DONE; - pic_init_write(pic); DONE; - pic_init_read(pic); DONE; - pic_init_dict(pic); DONE; - pic_init_record(pic); DONE; - pic_init_eval(pic); DONE; - pic_init_lib(pic); DONE; - - pic_init_contrib(pic); DONE; - - pic_load_piclib(pic); DONE; + pic_init_contrib(pic); + pic_load_piclib(pic); } } diff --git a/src/lib.c b/src/lib.c deleted file mode 100644 index 45351083..00000000 --- a/src/lib.c +++ /dev/null @@ -1,273 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include "picrin.h" -#include "picrin/lib.h" -#include "picrin/pair.h" -#include "picrin/macro.h" -#include "picrin/error.h" -#include "picrin/dict.h" -#include "picrin/string.h" - -struct pic_lib * -pic_make_library(pic_state *pic, pic_value name) -{ - struct pic_lib *lib; - struct pic_senv *senv; - - 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); - - lib = (struct pic_lib *)pic_obj_alloc(pic, sizeof(struct pic_lib), PIC_TT_LIB); - lib->env = senv; - lib->name = name; - xh_init_int(&lib->exports, sizeof(pic_sym)); - - /* register! */ - pic->libs = pic_acons(pic, name, pic_obj_value(lib), pic->libs); - - return lib; -} - -void -pic_in_library(pic_state *pic, pic_value spec) -{ - struct pic_lib *lib; - - lib = pic_find_library(pic, spec); - if (! lib) { - pic_errorf(pic, "library not found: ~a", spec); - } - pic->lib = lib; -} - -struct pic_lib * -pic_find_library(pic_state *pic, pic_value spec) -{ - pic_value v; - - v = pic_assoc(pic, spec, pic->libs, NULL); - if (pic_false_p(v)) { - return NULL; - } - return pic_lib_ptr(pic_cdr(pic, v)); -} - -static struct pic_dict * -import_table(pic_state *pic, pic_value spec) -{ - const pic_sym sONLY = pic_intern_cstr(pic, "only"); - const pic_sym sRENAME = pic_intern_cstr(pic, "rename"); - const pic_sym sPREFIX = pic_intern_cstr(pic, "prefix"); - const pic_sym sEXCEPT = pic_intern_cstr(pic, "except"); - struct pic_lib *lib; - struct pic_dict *imports, *dict; - pic_value val, id; - xh_iter it; - - imports = pic_dict_new(pic); - - if (pic_list_p(spec)) { - if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sONLY))) { - dict = import_table(pic, pic_cadr(pic, spec)); - pic_for_each (val, pic_cddr(pic, spec)) { - pic_dict_set(pic, imports, pic_sym(val), pic_dict_ref(pic, dict, pic_sym(val))); - } - return imports; - } - if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sRENAME))) { - imports = import_table(pic, pic_cadr(pic, spec)); - pic_for_each (val, pic_cddr(pic, spec)) { - id = pic_dict_ref(pic, imports, pic_sym(pic_car(pic, val))); - pic_dict_del(pic, imports, pic_sym(pic_car(pic, val))); - pic_dict_set(pic, imports, pic_sym(pic_cadr(pic, val)), id); - } - return imports; - } - if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sPREFIX))) { - dict = import_table(pic, pic_cadr(pic, spec)); - xh_begin(&it, &dict->hash); - while (xh_next(&it)) { - pic_dict_set(pic, imports, pic_intern_cstr(pic, pic_str_cstr(pic_strcat(pic, pic_str_new_cstr(pic, pic_symbol_name(pic, pic_sym(pic_car(pic, pic_cddr(pic, spec))))), pic_str_new_cstr(pic, pic_symbol_name(pic, xh_key(it.e, pic_sym)))))), xh_val(it.e, pic_value)); - } - return imports; - } - if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sEXCEPT))) { - imports = import_table(pic, pic_cadr(pic, spec)); - pic_for_each (val, pic_cddr(pic, spec)) { - pic_dict_del(pic, imports, pic_sym(val)); - } - return imports; - } - } - lib = pic_find_library(pic, spec); - if (! lib) { - pic_errorf(pic, "library not found: ~a", spec); - } - xh_begin(&it, &lib->exports); - while (xh_next(&it)) { - pic_dict_set(pic, imports, xh_key(it.e, pic_sym), pic_sym_value(xh_val(it.e, pic_sym))); - } - return imports; -} - -static void -import(pic_state *pic, pic_value spec) -{ - struct pic_dict *imports; - xh_iter it; - - imports = import_table(pic, spec); - - xh_begin(&it, &imports->hash); - while (xh_next(&it)) { - -#if DEBUG - printf("* importing %s as %s\n", pic_symbol_name(pic, xh_key(it.e, pic_sym)), pic_symbol_name(pic, pic_sym(xh_val(it.e, pic_value)))); -#endif - - pic_put_rename(pic, pic->lib->env, xh_key(it.e, pic_sym), pic_sym(xh_val(it.e, pic_value))); - } -} - -static void -export(pic_state *pic, pic_value spec) -{ - const pic_sym sRENAME = pic_intern_cstr(pic, "rename"); - pic_value a, b; - pic_sym rename; - - if (pic_sym_p(spec)) { /* (export a) */ - a = b = spec; - } else { /* (export (rename a b)) */ - if (! pic_list_p(spec)) - goto fail; - if (! pic_length(pic, spec) == 3) - goto fail; - if (! pic_eq_p(pic_car(pic, spec), pic_sym_value(sRENAME))) - goto fail; - if (! pic_sym_p(a = pic_list_ref(pic, spec, 1))) - goto fail; - if (! pic_sym_p(b = pic_list_ref(pic, spec, 2))) - goto fail; - } - - if (! pic_find_rename(pic, pic->lib->env, pic_sym(a), &rename)) { - pic_errorf(pic, "export: symbol not defined %s", pic_symbol_name(pic, pic_sym(a))); - } - -#if DEBUG - printf("* exporting %s as %s\n", pic_symbol_name(pic, pic_sym(b)), pic_symbol_name(pic, rename)); -#endif - - xh_put_int(&pic->lib->exports, pic_sym(b), &rename); - - return; - - fail: - pic_errorf(pic, "illegal export spec: ~s", spec); -} - -void -pic_import(pic_state *pic, pic_value spec) -{ - import(pic, spec); -} - -void -pic_export(pic_state *pic, pic_sym sym) -{ - export(pic, pic_sym_value(sym)); -} - -static pic_value -pic_lib_import(pic_state *pic) -{ - size_t argc, i; - pic_value *argv; - - pic_get_args(pic, "*", &argc, &argv); - - for (i = 0; i < argc; ++i) { - import(pic, argv[i]); - } - - return pic_none_value(); -} - -static pic_value -pic_lib_export(pic_state *pic) -{ - size_t argc, i; - pic_value *argv; - - pic_get_args(pic, "*", &argc, &argv); - - for (i = 0; i < argc; ++i) { - export(pic, argv[i]); - } - - return pic_none_value(); -} - -static pic_value -pic_lib_define_library(pic_state *pic) -{ - struct pic_lib *prev = pic->lib; - size_t argc, i; - pic_value spec, *argv; - - pic_get_args(pic, "o*", &spec, &argc, &argv); - - pic_make_library(pic, spec); - - pic_try { - pic_in_library(pic, spec); - - for (i = 0; i < argc; ++i) { - pic_void(pic_eval(pic, argv[i], pic->lib)); - } - - pic_in_library(pic, prev->name); - } - pic_catch { - pic_in_library(pic, prev->name); /* restores pic->lib even if an error occurs */ - pic_throw_error(pic, pic->err); - } - - return pic_none_value(); -} - -static pic_value -pic_lib_in_library(pic_state *pic) -{ - pic_value spec; - - pic_get_args(pic, "o", &spec); - - pic_in_library(pic, spec); - - return pic_none_value(); -} - -void -pic_init_lib(pic_state *pic) -{ - void pic_defmacro(pic_state *, pic_sym, pic_sym, pic_func_t); - - pic_defmacro(pic, pic->sIMPORT, pic->rIMPORT, pic_lib_import); - pic_defmacro(pic, pic->sEXPORT, pic->rEXPORT, pic_lib_export); - pic_defmacro(pic, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY, pic_lib_define_library); - pic_defmacro(pic, pic->sIN_LIBRARY, pic->rIN_LIBRARY, pic_lib_in_library); -} diff --git a/src/macro.c b/src/macro.c index e9c9b64b..84237ebc 100644 --- a/src/macro.c +++ b/src/macro.c @@ -3,399 +3,6 @@ */ #include "picrin.h" -#include "picrin/pair.h" -#include "picrin/string.h" -#include "picrin/proc.h" -#include "picrin/macro.h" -#include "picrin/lib.h" -#include "picrin/error.h" -#include "picrin/dict.h" -#include "picrin/cont.h" - -pic_sym -pic_add_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym) -{ - pic_sym rename; - - rename = pic_gensym(pic, sym); - pic_put_rename(pic, senv, sym, rename); - return rename; -} - -void -pic_put_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym rename) -{ - UNUSED(pic); - - xh_put_int(&senv->map, sym, &rename); -} - -bool -pic_find_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym *rename) -{ - xh_entry *e; - - UNUSED(pic); - - if ((e = xh_get_int(&senv->map, sym)) == NULL) { - return false; - } - if (rename != NULL) { - *rename = xh_val(e, pic_sym); - } - return true; -} - -static void -define_macro(pic_state *pic, pic_sym rename, struct pic_proc *proc, struct pic_senv *senv) -{ - struct pic_macro *mac; - - mac = (struct pic_macro *)pic_obj_alloc(pic, sizeof(struct pic_macro), PIC_TT_MACRO); - mac->senv = senv; - mac->proc = proc; - - xh_put_int(&pic->macros, rename, &mac); -} - -static struct pic_macro * -find_macro(pic_state *pic, pic_sym rename) -{ - xh_entry *e; - - if ((e = xh_get_int(&pic->macros, rename)) == NULL) { - return NULL; - } - return xh_val(e, struct pic_macro *); -} - -static pic_sym -make_identifier(pic_state *pic, pic_sym sym, struct pic_senv *senv) -{ - pic_sym rename; - - while (true) { - if (pic_find_rename(pic, senv, sym, &rename)) { - return rename; - } - if (! senv->up) - break; - senv = senv->up; - } - if (! pic_interned_p(pic, sym)) { - return sym; - } - else { - return pic_gensym(pic, sym); - } -} - -static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *); - -static pic_value -macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv) -{ - return pic_sym_value(make_identifier(pic, sym, senv)); -} - -static pic_value -macroexpand_quote(pic_state *pic, pic_value expr) -{ - return pic_cons(pic, pic_sym_value(pic->rQUOTE), pic_cdr(pic, expr)); -} - -static pic_value -macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value x, head, tail; - - if (pic_pair_p(obj)) { - head = macroexpand(pic, pic_car(pic, obj), senv); - tail = macroexpand_list(pic, pic_cdr(pic, obj), senv); - x = pic_cons(pic, head, tail); - } else { - x = macroexpand(pic, obj, senv); - } - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, x); - return x; -} - -static pic_value -macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv) -{ - pic_value formal, body; - struct pic_senv *in; - pic_value a; - - if (pic_length(pic, expr) < 2) { - pic_error(pic, "syntax error"); - } - - in = pic_senv_new(pic, senv); - - for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) { - pic_value v = pic_car(pic, a); - - if (! pic_sym_p(v)) { - pic_error(pic, "syntax error"); - } - pic_add_rename(pic, in, pic_sym(v)); - } - if (pic_sym_p(a)) { - pic_add_rename(pic, in, pic_sym(a)); - } - else if (! pic_nil_p(a)) { - pic_error(pic, "syntax error"); - } - - formal = macroexpand_list(pic, pic_cadr(pic, expr), in); - body = macroexpand_list(pic, pic_cddr(pic, expr), in); - - return pic_cons(pic, pic_sym_value(pic->rLAMBDA), pic_cons(pic, formal, body)); -} - -static pic_value -macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv) -{ - pic_sym sym, rename; - pic_value var, val; - - if (pic_length(pic, expr) != 3) { - pic_error(pic, "syntax error"); - } - - var = pic_cadr(pic, expr); - if (! pic_sym_p(var)) { - pic_error(pic, "binding to non-symbol object"); - } - sym = pic_sym(var); - if (! pic_find_rename(pic, senv, sym, &rename)) { - rename = pic_add_rename(pic, senv, sym); - } - val = macroexpand(pic, pic_list_ref(pic, expr, 2), senv); - - return pic_list3(pic, pic_sym_value(pic->rDEFINE), pic_sym_value(rename), val); -} - -static pic_value -macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv) -{ - pic_value var, val; - pic_sym sym, rename; - - if (pic_length(pic, expr) != 3) { - pic_error(pic, "syntax error"); - } - - var = pic_cadr(pic, expr); - if (! pic_sym_p(var)) { - pic_error(pic, "binding to non-symbol object"); - } - sym = pic_sym(var); - if (! pic_find_rename(pic, senv, sym, &rename)) { - rename = pic_add_rename(pic, senv, sym); - } else { - pic_warnf(pic, "redefining syntax variable: ~s", pic_sym_value(sym)); - } - - val = pic_cadr(pic, pic_cdr(pic, expr)); - - pic_try { - val = pic_eval(pic, val, pic->lib); - } pic_catch { - pic_errorf(pic, "macroexpand error while definition: %s", pic_errmsg(pic)); - } - - if (! pic_proc_p(val)) { - pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var); - } - - define_macro(pic, rename, pic_proc_ptr(val), senv); - - return pic_none_value(); -} - -static pic_value -macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv) -{ - pic_value v, args; - -#if DEBUG - puts("before expand-1:"); - pic_debug(pic, expr); - puts(""); -#endif - - if (mac->senv == NULL) { /* legacy macro */ - args = pic_cdr(pic, expr); - } else { - args = pic_list3(pic, expr, pic_obj_value(senv), pic_obj_value(mac->senv)); - } - - pic_try { - v = pic_apply(pic, mac->proc, args); - } pic_catch { - pic_errorf(pic, "macroexpand error while application: %s", pic_errmsg(pic)); - } - -#if DEBUG - puts("after expand-1:"); - pic_debug(pic, v); - puts(""); -#endif - - return v; -} - -static pic_value -macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv) -{ - switch (pic_type(expr)) { - case PIC_TT_SYMBOL: { - return macroexpand_symbol(pic, pic_sym(expr), senv); - } - case PIC_TT_PAIR: { - pic_value car; - struct pic_macro *mac; - - if (! pic_list_p(expr)) { - pic_errorf(pic, "cannot macroexpand improper list: ~s", expr); - } - - car = macroexpand(pic, pic_car(pic, expr), senv); - if (pic_sym_p(car)) { - pic_sym tag = pic_sym(car); - - if (tag == pic->rDEFINE_SYNTAX) { - return macroexpand_defsyntax(pic, expr, senv); - } - else if (tag == pic->rLAMBDA) { - return macroexpand_lambda(pic, expr, senv); - } - else if (tag == pic->rDEFINE) { - return macroexpand_define(pic, expr, senv); - } - else if (tag == pic->rQUOTE) { - return macroexpand_quote(pic, expr); - } - - if ((mac = find_macro(pic, tag)) != NULL) { - return macroexpand_node(pic, macroexpand_macro(pic, mac, expr, senv), senv); - } - } - - return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv)); - } - default: - return expr; - } -} - -static pic_value -macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value v; - -#if DEBUG - printf("[macroexpand] expanding... "); - pic_debug(pic, expr); - puts(""); -#endif - - v = macroexpand_node(pic, expr, senv); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, v); - return v; -} - -pic_value -pic_macroexpand(pic_state *pic, pic_value expr, struct pic_lib *lib) -{ - struct pic_lib *prev; - pic_value v; - -#if DEBUG - puts("before expand:"); - pic_debug(pic, expr); - puts(""); -#endif - - /* change library for macro-expansion time processing */ - prev = pic->lib; - pic->lib = lib; - - v = macroexpand(pic, expr, lib->env); - - pic->lib = prev; - -#if DEBUG - puts("after expand:"); - pic_debug(pic, v); - puts(""); -#endif - - return v; -} - -struct pic_senv * -pic_senv_new(pic_state *pic, struct pic_senv *up) -{ - struct pic_senv *senv; - - senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV); - senv->up = up; - xh_init_int(&senv->map, sizeof(pic_sym)); - - return senv; -} - -struct pic_senv * -pic_null_syntactic_environment(pic_state *pic) -{ - struct pic_senv *senv; - - senv = pic_senv_new(pic, NULL); - - pic_define_syntactic_keyword(pic, senv, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY); - pic_define_syntactic_keyword(pic, senv, pic->sIMPORT, pic->rIMPORT); - pic_define_syntactic_keyword(pic, senv, pic->sEXPORT, pic->rEXPORT); - pic_define_syntactic_keyword(pic, senv, pic->sIN_LIBRARY, pic->rIN_LIBRARY); - - return senv; -} - -void -pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym rsym) -{ - pic_put_rename(pic, senv, sym, rsym); - - if (pic->lib && pic->lib->env == senv) { - pic_export(pic, sym); - } -} - -void -pic_defmacro(pic_state *pic, pic_sym name, pic_sym id, pic_func_t func) -{ - pic_put_rename(pic, pic->lib->env, name, id); - - /* symbol registration */ - define_macro(pic, id, pic_proc_new(pic, func, pic_symbol_name(pic, name)), NULL); - - /* auto export! */ - pic_export(pic, name); -} - -bool -pic_identifier_p(pic_state *pic, pic_value obj) -{ - return pic_sym_p(obj) && ! pic_interned_p(pic, pic_sym(obj)); -} static pic_value pic_macro_gensym(pic_state *pic) @@ -429,66 +36,12 @@ pic_macro_macroexpand(pic_state *pic) return pic_macroexpand(pic, expr, pic->lib); } -static pic_value -pic_macro_macroexpand_1(pic_state *pic) -{ - struct pic_senv *senv = pic->lib->env; - struct pic_macro *mac; - pic_value expr; - pic_sym sym; - - pic_get_args(pic, "o", &expr); - - if (pic_sym_p(expr)) { - if (pic_interned_p(pic, pic_sym(expr))) { - return pic_values2(pic, macroexpand_symbol(pic, pic_sym(expr), senv), pic_true_value()); - } - } - if (pic_pair_p(expr) && pic_sym_p(pic_car(pic, expr))) { - sym = make_identifier(pic, pic_sym(pic_car(pic, expr)), senv); - if ((mac = find_macro(pic, sym)) != NULL) { - return pic_values2(pic, macroexpand_macro(pic, mac, expr, senv), pic_true_value()); - } - } - - return pic_values2(pic, expr, pic_false_value()); /* no expansion occurred */ -} - -static pic_value -pic_macro_identifier_p(pic_state *pic) -{ - pic_value obj; - - pic_get_args(pic, "o", &obj); - - return pic_bool_value(pic_identifier_p(pic, obj)); -} - -static pic_value -pic_macro_make_identifier(pic_state *pic) -{ - pic_value obj; - pic_sym sym; - - pic_get_args(pic, "mo", &sym, &obj); - - pic_assert_type(pic, obj, senv); - - return pic_sym_value(make_identifier(pic, sym, pic_senv_ptr(obj))); -} - void -pic_init_macro(pic_state *pic) +pic_init_macro2(pic_state *pic) { - pic_deflibrary (pic, "(picrin base macro)") { - pic_defun(pic, "identifier?", pic_macro_identifier_p); - pic_defun(pic, "make-identifier", pic_macro_make_identifier); - } - pic_deflibrary (pic, "(picrin macro)") { pic_defun(pic, "gensym", pic_macro_gensym); pic_defun(pic, "ungensym", pic_macro_ungensym); pic_defun(pic, "macroexpand", pic_macro_macroexpand); - pic_defun(pic, "macroexpand-1", pic_macro_macroexpand_1); } } diff --git a/src/number.c b/src/number.c deleted file mode 100644 index ed6ce95c..00000000 --- a/src/number.c +++ /dev/null @@ -1,944 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include -#include -#include - -#include "picrin.h" -#include "picrin/string.h" -#include "picrin/cont.h" - -static int -gcd(int a, int b) -{ - if (a > b) - return gcd(b, a); - if (a < 0) - return gcd(-a, b); - if (a > 0) - return gcd(b % a, a); - return b; -} - -static double -lcm(int a, int b) -{ - return fabs((double)a * b) / gcd(a, b); -} - -/** - * Returns the length of string representing val. - * radix is between 2 and 36 (inclusive). - * No error checks are performed in this function. - */ -static int -number_string_length(int val, int radix) -{ - long long v = val; /* in case val == INT_MIN */ - int count = 0; - if (val == 0) { - return 1; - } - if (val < 0) { - v = - v; - count = 1; - } - while (v > 0) { - ++count; - v /= radix; - } - return count; -} - -/** - * Returns the string representing val. - * radix is between 2 and 36 (inclusive). - * This function overwrites buffer and stores the result. - * No error checks are performed in this function. It is caller's responsibility to avoid buffer-overrun. - */ -static void -number_string(int val, int radix, int length, char *buffer) { - const char digits[37] = "0123456789abcdefghijklmnopqrstuvwxyz"; - long long v = val; - int i; - if (val == 0) { - buffer[0] = '0'; - buffer[1] = '\0'; - return; - } - if (val < 0) { - buffer[0] = '-'; - v = -v; - } - - for(i = length - 1; v > 0; --i) { - buffer[i] = digits[v % radix]; - v /= radix; - } - buffer[length] = '\0'; - return; -} - -static pic_value -pic_number_real_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - return pic_bool_value(pic_float_p(v) || pic_int_p(v)); -} - -static pic_value -pic_number_integer_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - if (pic_int_p(v)) { - return pic_true_value(); - } - if (pic_float_p(v)) { - double f = pic_float(v); - - if (isinf(f)) { - return pic_false_value(); - } - - if (f == round(f)) { - return pic_true_value(); - } - } - return pic_false_value(); -} - -static pic_value -pic_number_exact_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - return pic_bool_value(pic_int_p(v)); -} - -static pic_value -pic_number_inexact_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - return pic_bool_value(pic_float_p(v)); -} - -static pic_value -pic_number_finite_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - if (pic_int_p(v)) - return pic_true_value(); - if (pic_float_p(v) && ! (isinf(pic_float(v)) || isnan(pic_float(v)))) - return pic_true_value(); - else - return pic_false_value(); -} - -static pic_value -pic_number_infinite_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - if (pic_float_p(v) && isinf(pic_float(v))) - return pic_true_value(); - else - return pic_false_value(); -} - -static pic_value -pic_number_nan_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - if (pic_float_p(v) && isnan(pic_float(v))) - return pic_true_value(); - else - return pic_false_value(); -} - -#define DEFINE_ARITH_CMP(op, name) \ - static pic_value \ - pic_number_##name(pic_state *pic) \ - { \ - size_t argc; \ - pic_value *argv; \ - size_t i; \ - double f,g; \ - \ - pic_get_args(pic, "ff*", &f, &g, &argc, &argv); \ - \ - if (! (f op g)) \ - return pic_false_value(); \ - \ - for (i = 0; i < argc; ++i) { \ - f = g; \ - if (pic_float_p(argv[i])) \ - g = pic_float(argv[i]); \ - else if (pic_int_p(argv[i])) \ - g = pic_int(argv[i]); \ - else \ - pic_error(pic, #op ": number required"); \ - \ - if (! (f op g)) \ - return pic_false_value(); \ - } \ - \ - return pic_true_value(); \ - } - -DEFINE_ARITH_CMP(==, eq) -DEFINE_ARITH_CMP(<, lt) -DEFINE_ARITH_CMP(>, gt) -DEFINE_ARITH_CMP(<=, le) -DEFINE_ARITH_CMP(>=, ge) - -static pic_value -pic_number_zero_p(pic_state *pic) -{ - double f; - - pic_get_args(pic, "f", &f); - - return pic_bool_value(f == 0); -} - -static pic_value -pic_number_positive_p(pic_state *pic) -{ - double f; - - pic_get_args(pic, "f", &f); - - return pic_bool_value(f > 0); -} - -static pic_value -pic_number_negative_p(pic_state *pic) -{ - double f; - - pic_get_args(pic, "f", &f); - - return pic_bool_value(f < 0); -} - -static pic_value -pic_number_odd_p(pic_state *pic) -{ - int i; - - pic_get_args(pic, "i", &i); - - return pic_bool_value(i % 2 != 0); -} - -static pic_value -pic_number_even_p(pic_state *pic) -{ - int i; - - pic_get_args(pic, "i", &i); - - return pic_bool_value(i % 2 == 0); -} - -static pic_value -pic_number_max(pic_state *pic) -{ - size_t argc; - pic_value *argv; - size_t i; - double f; - bool e = true; - - pic_get_args(pic, "*", &argc, &argv); - - f = -INFINITY; - for (i = 0; i < argc; ++i) { - if (pic_int_p(argv[i])) { - f = fmax(f, pic_int(argv[i])); - } - else if (pic_float_p(argv[i])) { - e = false; - f = fmax(f, pic_float(argv[i])); - } - else { - pic_error(pic, "max: number required"); - } - } - - return e ? pic_int_value(f) : pic_float_value(f); -} - -static pic_value -pic_number_min(pic_state *pic) -{ - size_t argc; - pic_value *argv; - size_t i; - double f; - bool e = true; - - pic_get_args(pic, "*", &argc, &argv); - - f = INFINITY; - for (i = 0; i < argc; ++i) { - if (pic_int_p(argv[i])) { - f = fmin(f, pic_int(argv[i])); - } - else if (pic_float_p(argv[i])) { - e = false; - f = fmin(f, pic_float(argv[i])); - } - else { - pic_error(pic, "min: number required"); - } - } - - return e ? pic_int_value(f) : pic_float_value(f); -} - -#define DEFINE_ARITH_OP(op, name, unit) \ - static pic_value \ - pic_number_##name(pic_state *pic) \ - { \ - size_t argc; \ - pic_value *argv; \ - size_t i; \ - double f; \ - bool e = true; \ - \ - pic_get_args(pic, "*", &argc, &argv); \ - \ - f = unit; \ - for (i = 0; i < argc; ++i) { \ - if (pic_int_p(argv[i])) { \ - f op##= pic_int(argv[i]); \ - } \ - else if (pic_float_p(argv[i])) { \ - e = false; \ - f op##= pic_float(argv[i]); \ - } \ - else { \ - pic_error(pic, #op ": number required"); \ - } \ - } \ - \ - return e ? pic_int_value((int)f) : pic_float_value(f); \ - } - -DEFINE_ARITH_OP(+, add, 0) -DEFINE_ARITH_OP(*, mul, 1) - -#define DEFINE_ARITH_INV_OP(op, name, unit, exact) \ - static pic_value \ - pic_number_##name(pic_state *pic) \ - { \ - size_t argc; \ - pic_value *argv; \ - size_t i; \ - double f; \ - bool e; \ - \ - pic_get_args(pic, "F*", &f, &e, &argc, &argv); \ - \ - e = e && exact; \ - \ - if (argc == 0) { \ - f = unit op f; \ - } \ - for (i = 0; i < argc; ++i) { \ - if (pic_int_p(argv[i])) { \ - f op##= pic_int(argv[i]); \ - } \ - else if (pic_float_p(argv[i])) { \ - e = false; \ - f op##= pic_float(argv[i]); \ - } \ - else { \ - pic_error(pic, #op ": number required"); \ - } \ - } \ - \ - return e ? pic_int_value((int)f) : pic_float_value(f); \ - } - -DEFINE_ARITH_INV_OP(-, sub, 0, true) -DEFINE_ARITH_INV_OP(/, div, 1, false) - -static pic_value -pic_number_abs(pic_state *pic) -{ - double f; - bool e; - - pic_get_args(pic, "F", &f, &e); - - if (e) { - return pic_int_value(fabs(f)); - } - else { - return pic_float_value(fabs(f)); - } -} - -static pic_value -pic_number_floor_quotient(pic_state *pic) -{ - int i,j; - bool e1, e2; - - pic_get_args(pic, "II", &i, &e1, &j, &e2); - - if (e1 && e2) { - return pic_int_value((int)floor((double)i/j)); - } - else { - return pic_float_value(floor((double)i/j)); - } -} - -static pic_value -pic_number_floor_remainder(pic_state *pic) -{ - int i,j,q; - bool e1, e2; - - pic_get_args(pic, "II", &i, &e1, &j, &e2); - - q = (int)floor((double)i/j); - if (e1 && e2) { - return pic_int_value(i - j * q); - } - else { - return pic_float_value(i - j * q); - } -} - -static pic_value -pic_number_floor2(pic_state *pic) -{ - int i, j; - bool e1, e2; - double q, r; - - pic_get_args(pic, "II", &i, &e1, &j, &e2); - - q = floor((double)i/j); - r = i - j * q; - - if (e1 && e2) { - return pic_values2(pic, pic_int_value(q), pic_int_value(r)); - } - else { - return pic_values2(pic, pic_float_value(q), pic_float_value(r)); - } -} - -static pic_value -pic_number_trunc_quotient(pic_state *pic) -{ - int i,j; - bool e1, e2; - - pic_get_args(pic, "II", &i, &e1, &j, &e2); - - if (e1 && e2) { - return pic_int_value((int)trunc((double)i/j)); - } - else { - return pic_float_value(trunc((double)i/j)); - } -} - -static pic_value -pic_number_trunc_remainder(pic_state *pic) -{ - int i,j,q; - bool e1, e2; - - pic_get_args(pic, "II", &i, &e1, &j, &e2); - - q = (int)trunc((double)i/j); - if (e1 && e2) { - return pic_int_value(i - j * q); - } - else { - return pic_float_value(i - j * q); - } -} - -static pic_value -pic_number_trunc2(pic_state *pic) -{ - int i, j; - bool e1, e2; - double q, r; - - pic_get_args(pic, "II", &i, &e1, &j, &e2); - - q = trunc((double)i/j); - r = i - j * q; - - if (e1 && e2) { - return pic_values2(pic, pic_int_value(q), pic_int_value(r)); - } - else { - return pic_values2(pic, pic_float_value(q), pic_float_value(r)); - } -} - -static pic_value -pic_number_gcd(pic_state *pic) -{ - size_t argc; - pic_value *args; - int r; - bool e = true; - - pic_get_args(pic, "*", &argc, &args); - - r = 0; - while (argc-- > 0) { - if (pic_int_p(args[argc])) { - r = gcd(r, pic_int(args[argc])); - } - else if (pic_float_p(args[argc])) { - e = false; - r = gcd(r, pic_float(args[argc])); - } - else { - pic_error(pic, "gcd: number required"); - } - } - return e ? pic_int_value(r) : pic_float_value(r); -} - -static pic_value -pic_number_lcm(pic_state *pic) -{ - size_t argc; - pic_value *args; - double r; - bool e = true; - - pic_get_args(pic, "*", &argc, &args); - - r = 1; - while (argc-- > 0) { - if (pic_int_p(args[argc])) { - r = lcm(r, pic_int(args[argc])); - } - else if (pic_float_p(args[argc])) { - e = false; - r = lcm(r, pic_float(args[argc])); - } - else { - pic_error(pic, "lcm: number required"); - } - } - return e && pic_valid_int(r) ? pic_int_value(r) : pic_float_value(r); -} - -static pic_value -pic_number_floor(pic_state *pic) -{ - double f; - bool e; - - pic_get_args(pic, "F", &f, &e); - - if (e) { - return pic_int_value((int)f); - } - else { - return pic_float_value(floor(f)); - } -} - -static pic_value -pic_number_ceil(pic_state *pic) -{ - double f; - bool e; - - pic_get_args(pic, "F", &f, &e); - - if (e) { - return pic_int_value((int)f); - } - else { - return pic_float_value(ceil(f)); - } -} - -static pic_value -pic_number_trunc(pic_state *pic) -{ - double f; - bool e; - - pic_get_args(pic, "F", &f, &e); - - if (e) { - return pic_int_value((int)f); - } - else { - return pic_float_value(trunc(f)); - } -} - -static pic_value -pic_number_round(pic_state *pic) -{ - double f; - bool e; - - pic_get_args(pic, "F", &f, &e); - - if (e) { - return pic_int_value((int)f); - } - else { - return pic_float_value(round(f)); - } -} - -static pic_value -pic_number_exp(pic_state *pic) -{ - double f; - - pic_get_args(pic, "f", &f); - return pic_float_value(exp(f)); -} - -static pic_value -pic_number_log(pic_state *pic) -{ - double f,g; - int argc; - - argc = pic_get_args(pic, "f|f", &f, &g); - if (argc == 1) { - return pic_float_value(log(f)); - } - else { - return pic_float_value(log(f) / log(g)); - } -} - -static pic_value -pic_number_sin(pic_state *pic) -{ - double f; - - pic_get_args(pic, "f", &f); - f = sin(f); - return pic_float_value(f); -} - -static pic_value -pic_number_cos(pic_state *pic) -{ - double f; - - pic_get_args(pic, "f", &f); - f = cos(f); - return pic_float_value(f); -} - -static pic_value -pic_number_tan(pic_state *pic) -{ - double f; - - pic_get_args(pic, "f", &f); - f = tan(f); - return pic_float_value(f); -} - -static pic_value -pic_number_acos(pic_state *pic) -{ - double f; - - pic_get_args(pic, "f", &f); - f = acos(f); - return pic_float_value(f); -} - -static pic_value -pic_number_asin(pic_state *pic) -{ - double f; - - pic_get_args(pic, "f", &f); - f = asin(f); - return pic_float_value(f); -} - -static pic_value -pic_number_atan(pic_state *pic) -{ - double f,g; - int argc; - - argc = pic_get_args(pic, "f|f", &f, &g); - if (argc == 1) { - f = atan(f); - return pic_float_value(f); - } - else { - return pic_float_value(atan2(f,g)); - } -} - -static pic_value -pic_number_exact_integer_sqrt(pic_state *pic) -{ - int k, n, m; - - pic_get_args(pic, "i", &k); - - n = sqrt(k); - m = k - n * n; - - return pic_values2(pic, pic_int_value(n), pic_int_value(m)); -} - -static pic_value -pic_number_square(pic_state *pic) -{ - double f; - bool e; - - pic_get_args(pic, "F", &f, &e); - - if (e) { - long long i = (long long)f; - - if (i * i <= INT_MAX) { - return pic_int_value(i * i); - } - } - return pic_float_value(f * f); -} - -static pic_value -pic_number_sqrt(pic_state *pic) -{ - double f; - - pic_get_args(pic, "f", &f); - - return pic_float_value(sqrt(f)); -} - -static pic_value -pic_number_expt(pic_state *pic) -{ - double f, g, h; - bool e1, e2; - - pic_get_args(pic, "FF", &f, &e1, &g, &e2); - - h = pow(f, g); - if (e1 && e2) { - if (h <= INT_MAX) { - return pic_int_value((int)h); - } - } - return pic_float_value(h); -} - -static pic_value -pic_number_inexact(pic_state *pic) -{ - double f; - - pic_get_args(pic, "f", &f); - - return pic_float_value(f); -} - -static pic_value -pic_number_exact(pic_state *pic) -{ - double f; - - pic_get_args(pic, "f", &f); - - return pic_int_value((int)round(f)); -} - -static pic_value -pic_number_number_to_string(pic_state *pic) -{ - double f; - bool e; - int radix = 10; - - pic_get_args(pic, "F|i", &f, &e, &radix); - - if (radix < 2 || radix > 36) { - pic_errorf(pic, "number->string: invalid radix %d (between 2 and 36, inclusive)", radix); - } - - if (e) { - int ival = (int) f; - int ilen = number_string_length(ival, radix); - char buf[ilen + 1]; - - number_string(ival, radix, ilen, buf); - - return pic_obj_value(pic_str_new(pic, buf, sizeof buf - 1)); - } - else { - char buf[snprintf(NULL, 0, "%a", f) + 1]; - - snprintf(buf, sizeof buf, "%a", f); - - return pic_obj_value(pic_str_new(pic, buf, sizeof buf - 1)); - } -} - -static pic_value -pic_number_string_to_number(pic_state *pic) -{ - const char *str; - int radix = 10; - long num; - char *eptr; - double flo; - - pic_get_args(pic, "z|i", &str, &radix); - - num = strtol(str, &eptr, radix); - if (*eptr == '\0') { - return pic_valid_int(num) - ? pic_int_value(num) - : pic_float_value(num); - } - - flo = strtod(str, &eptr); - if (*eptr == '\0') { - return pic_float_value(flo); - } - - pic_errorf(pic, "invalid string given: %s", str); -} - -void -pic_init_number(pic_state *pic) -{ - size_t ai = pic_gc_arena_preserve(pic); - - pic_defun(pic, "number?", pic_number_real_p); - pic_defun(pic, "complex?", pic_number_real_p); - pic_defun(pic, "real?", pic_number_real_p); - pic_defun(pic, "rational?", pic_number_real_p); - pic_defun(pic, "integer?", pic_number_integer_p); - pic_gc_arena_restore(pic, ai); - - pic_defun(pic, "exact?", pic_number_exact_p); - pic_defun(pic, "inexact?", pic_number_inexact_p); - pic_defun(pic, "exact-integer?", pic_number_exact_p); - pic_gc_arena_restore(pic, ai); - - pic_defun(pic, "=", pic_number_eq); - pic_defun(pic, "<", pic_number_lt); - pic_defun(pic, ">", pic_number_gt); - pic_defun(pic, "<=", pic_number_le); - pic_defun(pic, ">=", pic_number_ge); - pic_gc_arena_restore(pic, ai); - - pic_defun(pic, "zero?", pic_number_zero_p); - pic_defun(pic, "positive?", pic_number_positive_p); - pic_defun(pic, "negative?", pic_number_negative_p); - pic_defun(pic, "odd?", pic_number_odd_p); - pic_defun(pic, "even?", pic_number_even_p); - pic_gc_arena_restore(pic, ai); - - pic_defun(pic, "min", pic_number_min); - pic_defun(pic, "max", pic_number_max); - pic_gc_arena_restore(pic, ai); - - pic_defun(pic, "+", pic_number_add); - pic_defun(pic, "-", pic_number_sub); - pic_defun(pic, "*", pic_number_mul); - pic_defun(pic, "/", pic_number_div); - pic_gc_arena_restore(pic, ai); - - pic_defun(pic, "abs", pic_number_abs); - pic_defun(pic, "floor-quotient", pic_number_floor_quotient); - pic_defun(pic, "floor-remainder", pic_number_floor_remainder); - pic_defun(pic, "floor/", pic_number_floor2); - pic_defun(pic, "truncate-quotient", pic_number_trunc_quotient); - pic_defun(pic, "truncate-remainder", pic_number_trunc_remainder); - pic_defun(pic, "truncate/", pic_number_trunc2); - pic_defun(pic, "modulo", pic_number_floor_remainder); - pic_defun(pic, "quotient", pic_number_trunc_quotient); - pic_defun(pic, "remainder", pic_number_trunc_remainder); - pic_gc_arena_restore(pic, ai); - - pic_defun(pic, "gcd", pic_number_gcd); - pic_defun(pic, "lcm", pic_number_lcm); - pic_gc_arena_restore(pic, ai); - - pic_defun(pic, "floor", pic_number_floor); - pic_defun(pic, "ceiling", pic_number_ceil); - pic_defun(pic, "truncate", pic_number_trunc); - pic_defun(pic, "round", pic_number_round); - pic_gc_arena_restore(pic, ai); - - pic_defun(pic, "exact-integer-sqrt", pic_number_exact_integer_sqrt); - pic_defun(pic, "square", pic_number_square); - pic_defun(pic, "expt", pic_number_expt); - pic_gc_arena_restore(pic, ai); - - pic_defun(pic, "inexact", pic_number_inexact); - pic_defun(pic, "exact", pic_number_exact); - pic_gc_arena_restore(pic, ai); - - pic_defun(pic, "number->string", pic_number_number_to_string); - pic_defun(pic, "string->number", pic_number_string_to_number); - pic_gc_arena_restore(pic, ai); - - pic_deflibrary (pic, "(scheme inexact)") { - pic_defun(pic, "finite?", pic_number_finite_p); - pic_defun(pic, "infinite?", pic_number_infinite_p); - pic_defun(pic, "nan?", pic_number_nan_p); - - pic_defun(pic, "exp", pic_number_exp); - pic_defun(pic, "log", pic_number_log); - pic_defun(pic, "sin", pic_number_sin); - pic_defun(pic, "cos", pic_number_cos); - pic_defun(pic, "tan", pic_number_tan); - pic_defun(pic, "acos", pic_number_acos); - pic_defun(pic, "asin", pic_number_asin); - pic_defun(pic, "atan", pic_number_atan); - - pic_defun(pic, "sqrt", pic_number_sqrt); - } -} diff --git a/src/pair.c b/src/pair.c deleted file mode 100644 index 5b62ceaf..00000000 --- a/src/pair.c +++ /dev/null @@ -1,767 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include - -#include "picrin.h" -#include "picrin/pair.h" - -pic_value -pic_cons(pic_state *pic, pic_value car, pic_value cdr) -{ - struct pic_pair *pair; - - pair = (struct pic_pair *)pic_obj_alloc(pic, sizeof(struct pic_pair), PIC_TT_PAIR); - pair->car = car; - pair->cdr = cdr; - - return pic_obj_value(pair); -} - -pic_value -pic_car(pic_state *pic, pic_value obj) -{ - struct pic_pair *pair; - - if (! pic_pair_p(obj)) { - pic_errorf(pic, "pair required, but got ~s", obj); - } - pair = pic_pair_ptr(obj); - - return pair->car; -} - -pic_value -pic_cdr(pic_state *pic, pic_value obj) -{ - struct pic_pair *pair; - - if (! pic_pair_p(obj)) { - pic_errorf(pic, "pair required, but got ~s", obj); - } - pair = pic_pair_ptr(obj); - - return pair->cdr; -} - -void -pic_set_car(pic_state *pic, pic_value obj, pic_value val) -{ - struct pic_pair *pair; - - if (! pic_pair_p(obj)) { - pic_error(pic, "pair required"); - } - pair = pic_pair_ptr(obj); - - pair->car = val; -} - -void -pic_set_cdr(pic_state *pic, pic_value obj, pic_value val) -{ - struct pic_pair *pair; - - if (! pic_pair_p(obj)) { - pic_error(pic, "pair required"); - } - pair = pic_pair_ptr(obj); - - pair->cdr = val; -} - -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; - } - } -} - -pic_value -pic_list1(pic_state *pic, pic_value obj1) -{ - return pic_cons(pic, obj1, pic_nil_value()); -} - -pic_value -pic_list2(pic_state *pic, pic_value obj1, pic_value obj2) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value val; - - val = pic_cons(pic, obj1, pic_list1(pic, obj2)); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, val); - return val; -} - -pic_value -pic_list3(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value val; - - val = pic_cons(pic, obj1, pic_list2(pic, obj2, obj3)); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, val); - return val; -} - -pic_value -pic_list4(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value val; - - val = pic_cons(pic, obj1, pic_list3(pic, obj2, obj3, obj4)); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, val); - return val; -} - -pic_value -pic_list5(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value val; - - val = pic_cons(pic, obj1, pic_list4(pic, obj2, obj3, obj4, obj5)); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, val); - return val; -} - -pic_value -pic_list6(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5, pic_value obj6) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value val; - - val = pic_cons(pic, obj1, pic_list5(pic, obj2, obj3, obj4, obj5, obj6)); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, val); - return val; -} - -pic_value -pic_list7(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5, pic_value obj6, pic_value obj7) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value val; - - val = pic_cons(pic, obj1, pic_list6(pic, obj2, obj3, obj4, obj5, obj6, obj7)); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, val); - return val; -} - -pic_value -pic_list_by_array(pic_state *pic, size_t c, pic_value *vs) -{ - pic_value v; - - v = pic_nil_value(); - while (c--) { - v = pic_cons(pic, vs[c], v); - } - return v; -} - -pic_value -pic_make_list(pic_state *pic, int k, pic_value fill) -{ - pic_value list; - int i; - - list = pic_nil_value(); - for (i = 0; i < k; ++i) { - list = pic_cons(pic, fill, list); - } - - return list; -} - -int -pic_length(pic_state *pic, pic_value obj) -{ - int c = 0; - - if (! pic_list_p(obj)) { - pic_errorf(pic, "length: expected list, but got ~s", obj); - } - - while (! pic_nil_p(obj)) { - obj = pic_cdr(pic, obj); - ++c; - } - - return c; -} - -pic_value -pic_reverse(pic_state *pic, pic_value list) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value v, acc; - - acc = pic_nil_value(); - pic_for_each(v, list) { - acc = pic_cons(pic, v, acc); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, acc); - } - return acc; -} - -pic_value -pic_append(pic_state *pic, pic_value xs, pic_value ys) -{ - size_t ai = pic_gc_arena_preserve(pic); - pic_value x; - - xs = pic_reverse(pic, xs); - pic_for_each (x, xs) { - ys = pic_cons(pic, x, ys); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, xs); - pic_gc_protect(pic, ys); - } - return ys; -} - -pic_value -pic_memq(pic_state *pic, pic_value key, pic_value list) -{ - enter: - - if (pic_nil_p(list)) - return pic_false_value(); - - if (pic_eq_p(key, pic_car(pic, list))) - return list; - - list = pic_cdr(pic, list); - goto enter; -} - -pic_value -pic_memv(pic_state *pic, pic_value key, pic_value list) -{ - enter: - - if (pic_nil_p(list)) - return pic_false_value(); - - if (pic_eqv_p(key, pic_car(pic, list))) - return list; - - list = pic_cdr(pic, list); - goto enter; -} - -pic_value -pic_member(pic_state *pic, pic_value key, pic_value list, struct pic_proc *compar) -{ - enter: - - if (pic_nil_p(list)) - return pic_false_value(); - - if (compar == NULL) { - if (pic_equal_p(pic, key, pic_car(pic, list))) - return list; - } else { - if (pic_test(pic_apply2(pic, compar, key, pic_car(pic, list)))) - return list; - } - - list = pic_cdr(pic, list); - goto enter; -} - -pic_value -pic_assq(pic_state *pic, pic_value key, pic_value assoc) -{ - pic_value cell; - - enter: - - if (pic_nil_p(assoc)) - return pic_false_value(); - - cell = pic_car(pic, assoc); - if (pic_eq_p(key, pic_car(pic, cell))) - return cell; - - assoc = pic_cdr(pic, assoc); - goto enter; -} - -pic_value -pic_assv(pic_state *pic, pic_value key, pic_value assoc) -{ - pic_value cell; - - enter: - - if (pic_nil_p(assoc)) - return pic_false_value(); - - cell = pic_car(pic, assoc); - if (pic_eqv_p(key, pic_car(pic, cell))) - return cell; - - assoc = pic_cdr(pic, assoc); - goto enter; -} - -pic_value -pic_assoc(pic_state *pic, pic_value key, pic_value assoc, struct pic_proc *compar) -{ - pic_value cell; - - enter: - - if (pic_nil_p(assoc)) - return pic_false_value(); - - cell = pic_car(pic, assoc); - if (compar == NULL) { - if (pic_equal_p(pic, key, pic_car(pic, cell))) - return cell; - } else { - if (pic_test(pic_apply2(pic, compar, key, pic_car(pic, cell)))) - return cell; - } - - assoc = pic_cdr(pic, assoc); - goto enter; -} - -pic_value -pic_acons(pic_state *pic, pic_value key, pic_value val, pic_value assoc) -{ - return pic_cons(pic, pic_cons(pic, key, val), assoc); -} - -pic_value -pic_caar(pic_state *pic, pic_value v) -{ - return pic_car(pic, pic_car(pic, v)); -} - -pic_value -pic_cadr(pic_state *pic, pic_value v) -{ - return pic_car(pic, pic_cdr(pic, v)); -} - -pic_value -pic_cdar(pic_state *pic, pic_value v) -{ - return pic_cdr(pic, pic_car(pic, v)); -} - -pic_value -pic_cddr(pic_state *pic, pic_value v) -{ - return pic_cdr(pic, pic_cdr(pic, v)); -} - -pic_value -pic_list_tail(pic_state *pic, pic_value list, int i) -{ - while (i-- > 0) { - list = pic_cdr(pic, list); - } - return list; -} - -pic_value -pic_list_ref(pic_state *pic, pic_value list, int i) -{ - return pic_car(pic, pic_list_tail(pic, list, i)); -} - -void -pic_list_set(pic_state *pic, pic_value list, int i, pic_value obj) -{ - pic_pair_ptr(pic_list_tail(pic, list, i))->car = obj; -} - -pic_value -pic_list_copy(pic_state *pic, pic_value obj) -{ - if (pic_pair_p(obj)) { - return pic_cons(pic, pic_car(pic, obj), pic_list_copy(pic, pic_cdr(pic, obj))); - } - else { - return obj; - } -} - -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)); -} - -static pic_value -pic_pair_cons(pic_state *pic) -{ - pic_value v,w; - - pic_get_args(pic, "oo", &v, &w); - - return pic_cons(pic, v, w); -} - -static pic_value -pic_pair_car(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - return pic_car(pic, v); -} - -static pic_value -pic_pair_cdr(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - return pic_cdr(pic, v); -} - -static pic_value -pic_pair_caar(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - return pic_caar(pic, v); -} - -static pic_value -pic_pair_cadr(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - return pic_cadr(pic, v); -} - -static pic_value -pic_pair_cdar(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - return pic_cdar(pic, v); -} - -static pic_value -pic_pair_cddr(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - return pic_cddr(pic, v); -} - -static pic_value -pic_pair_set_car(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)->car = w; - return pic_none_value(); -} - -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_none_value(); -} - -static pic_value -pic_pair_null_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - return pic_bool_value(pic_nil_p(v)); -} - -static pic_value -pic_pair_list_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - return pic_bool_value(pic_list_p(v)); -} - -static pic_value -pic_pair_make_list(pic_state *pic) -{ - int i; - pic_value fill = pic_none_value(); - - pic_get_args(pic, "i|o", &i, &fill); - - return pic_make_list(pic, i, fill); -} - -static pic_value -pic_pair_list(pic_state *pic) -{ - size_t argc; - pic_value *argv; - - pic_get_args(pic, "*", &argc, &argv); - - return pic_list_by_array(pic, argc, argv); -} - -static pic_value -pic_pair_length(pic_state *pic) -{ - pic_value list; - - pic_get_args(pic, "o", &list); - - return pic_int_value(pic_length(pic, list)); -} - -static pic_value -pic_pair_append(pic_state *pic) -{ - size_t argc; - pic_value *args, list; - - pic_get_args(pic, "*", &argc, &args); - - if (argc == 0) { - return pic_nil_value(); - } - - list = args[--argc]; - - while (argc-- > 0) { - list = pic_append(pic, args[argc], list); - } - return list; -} - -static pic_value -pic_pair_reverse(pic_state *pic) -{ - pic_value list; - - pic_get_args(pic, "o", &list); - - return pic_reverse(pic, list); -} - -static pic_value -pic_pair_list_tail(pic_state *pic) -{ - pic_value list; - int i; - - pic_get_args(pic, "oi", &list, &i); - - return pic_list_tail(pic, list, i); -} - -static pic_value -pic_pair_list_ref(pic_state *pic) -{ - pic_value list; - int i; - - pic_get_args(pic, "oi", &list, &i); - - return pic_list_ref(pic, list, i); -} - -static pic_value -pic_pair_list_set(pic_state *pic) -{ - pic_value list, obj; - int i; - - pic_get_args(pic, "oio", &list, &i, &obj); - - pic_list_set(pic, list, i, obj); - - return pic_none_value(); -} - -static pic_value -pic_pair_list_copy(pic_state *pic) -{ - pic_value obj; - - pic_get_args(pic, "o", &obj); - - return pic_list_copy(pic, obj); -} - -static pic_value -pic_pair_memq(pic_state *pic) -{ - pic_value key, list; - - pic_get_args(pic, "oo", &key, &list); - - return pic_memq(pic, key, list); -} - -static pic_value -pic_pair_memv(pic_state *pic) -{ - pic_value key, list; - - pic_get_args(pic, "oo", &key, &list); - - return pic_memv(pic, key, list); -} - -static pic_value -pic_pair_member(pic_state *pic) -{ - struct pic_proc *proc = NULL; - pic_value key, list; - - pic_get_args(pic, "oo|l", &key, &list, &proc); - - return pic_member(pic, key, list, proc); -} - -static pic_value -pic_pair_assq(pic_state *pic) -{ - pic_value key, list; - - pic_get_args(pic, "oo", &key, &list); - - return pic_assq(pic, key, list); -} - -static pic_value -pic_pair_assv(pic_state *pic) -{ - pic_value key, list; - - pic_get_args(pic, "oo", &key, &list); - - return pic_assv(pic, key, list); -} - -static pic_value -pic_pair_assoc(pic_state *pic) -{ - struct pic_proc *proc = NULL; - pic_value key, list; - - pic_get_args(pic, "oo|l", &key, &list, &proc); - - return pic_assoc(pic, key, list, proc); -} - -void -pic_init_pair(pic_state *pic) -{ - pic_deflibrary (pic, "(picrin base list)") { - pic_defun(pic, "pair?", pic_pair_pair_p); - pic_defun(pic, "cons", pic_pair_cons); - pic_defun(pic, "car", pic_pair_car); - pic_defun(pic, "cdr", pic_pair_cdr); - pic_defun(pic, "set-car!", pic_pair_set_car); - pic_defun(pic, "set-cdr!", pic_pair_set_cdr); - pic_defun(pic, "null?", pic_pair_null_p); - } - - pic_deflibrary (pic, "(picrin list)") { - pic_defun(pic, "caar", pic_pair_caar); - pic_defun(pic, "cadr", pic_pair_cadr); - pic_defun(pic, "cdar", pic_pair_cdar); - pic_defun(pic, "cddr", pic_pair_cddr); - pic_defun(pic, "list?", pic_pair_list_p); - pic_defun(pic, "make-list", pic_pair_make_list); - pic_defun(pic, "list", pic_pair_list); - pic_defun(pic, "length", pic_pair_length); - pic_defun(pic, "append", pic_pair_append); - pic_defun(pic, "reverse", pic_pair_reverse); - pic_defun(pic, "list-tail", pic_pair_list_tail); - pic_defun(pic, "list-ref", pic_pair_list_ref); - pic_defun(pic, "list-set!", pic_pair_list_set); - pic_defun(pic, "list-copy", pic_pair_list_copy); - pic_defun(pic, "memq", pic_pair_memq); - pic_defun(pic, "memv", pic_pair_memv); - pic_defun(pic, "member", pic_pair_member); - pic_defun(pic, "assq", pic_pair_assq); - pic_defun(pic, "assv", pic_pair_assv); - pic_defun(pic, "assoc", pic_pair_assoc); - } -} diff --git a/src/port.c b/src/port.c deleted file mode 100644 index b9790d06..00000000 --- a/src/port.c +++ /dev/null @@ -1,749 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include -#include -#include - -#include "picrin.h" -#include "picrin/proc.h" -#include "picrin/port.h" -#include "picrin/string.h" -#include "picrin/blob.h" -#include "picrin/var.h" - -pic_value -pic_eof_object() -{ - pic_value v; - - pic_init_value(v, PIC_VTYPE_EOF); - - return v; -} - -struct pic_port * -pic_stdin(pic_state *pic) -{ - struct pic_proc *proc; - - proc = pic_proc_ptr(pic_ref(pic, "current-input-port")); - - return pic_port_ptr(pic_apply(pic, proc, pic_nil_value())); -} - -struct pic_port * -pic_stdout(pic_state *pic) -{ - struct pic_proc *proc; - - proc = pic_proc_ptr(pic_ref(pic, "current-output-port")); - - return pic_port_ptr(pic_apply(pic, proc, pic_nil_value())); -} - -static struct pic_port * -port_new_stdport(pic_state *pic, xFILE *file, short dir) -{ - struct pic_port *port; - - port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT); - port->file = file; - port->flags = dir | PIC_PORT_TEXT; - port->status = PIC_PORT_OPEN; - return port; -} - -struct pic_port * -pic_open_input_string(pic_state *pic, const char *str) -{ - struct pic_port *port; - - port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT); - port->file = xmopen(); - port->flags = PIC_PORT_IN | PIC_PORT_TEXT; - port->status = PIC_PORT_OPEN; - - xfputs(str, port->file); - xfflush(port->file); - xrewind(port->file); - - return port; -} - -struct pic_port * -pic_open_output_string(pic_state *pic) -{ - struct pic_port *port; - - port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT); - port->file = xmopen(); - port->flags = PIC_PORT_OUT | PIC_PORT_TEXT; - port->status = PIC_PORT_OPEN; - - return port; -} - -struct pic_string * -pic_get_output_string(pic_state *pic, struct pic_port *port) -{ - long size; - char *buf; - - /* get endpos */ - xfflush(port->file); - size = xftell(port->file); - xrewind(port->file); - - /* copy to buf */ - buf = (char *)pic_alloc(pic, size + 1); - buf[size] = 0; - xfread(buf, size, 1, port->file); - - return pic_str_new(pic, buf, size); -} - -void -pic_close_port(pic_state *pic, struct pic_port *port) -{ - if (xfclose(port->file) == EOF) { - pic_error(pic, "close-port: failure"); - } - port->status = PIC_PORT_CLOSE; -} - -static pic_value -pic_port_input_port_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_IN) != 0) { - return pic_true_value(); - } - else { - return pic_false_value(); - } -} - -static pic_value -pic_port_output_port_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_OUT) != 0) { - return pic_true_value(); - } - else { - return pic_false_value(); - } -} - -static pic_value -pic_port_textual_port_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_TEXT) != 0) { - return pic_true_value(); - } - else { - return pic_false_value(); - } -} - -static pic_value -pic_port_binary_port_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_BINARY) != 0) { - return pic_true_value(); - } - else { - return pic_false_value(); - } -} - -static pic_value -pic_port_port_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - return pic_bool_value(pic_port_p(v)); -} - -static pic_value -pic_port_input_port_open_p(pic_state *pic) -{ - pic_value v; - struct pic_port *port; - - pic_get_args(pic, "o", &v); - - if (! pic_port_p(v)) - return pic_false_value(); - port = pic_port_ptr(v); - if ((port->flags & PIC_PORT_IN) == 0) - return pic_false_value(); - - return pic_bool_value(port->status == PIC_PORT_OPEN); -} - -static pic_value -pic_port_output_port_open_p(pic_state *pic) -{ - pic_value v; - struct pic_port *port; - - pic_get_args(pic, "o", &v); - - if (! pic_port_p(v)) - return pic_false_value(); - port = pic_port_ptr(v); - if ((port->flags & PIC_PORT_OUT) == 0) - return pic_false_value(); - - return pic_bool_value(port->status == PIC_PORT_OPEN); -} - -static pic_value -pic_port_eof_object_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - if (pic_vtype(v) == PIC_VTYPE_EOF) { - return pic_true_value(); - } - else { - return pic_false_value(); - } -} - -static pic_value -pic_port_eof_object(pic_state *pic) -{ - pic_get_args(pic, ""); - - return pic_eof_object(); -} - -static pic_value -pic_port_close_port(pic_state *pic) -{ - struct pic_port *port; - - pic_get_args(pic, "p", &port); - - pic_close_port(pic, port); - - return pic_none_value(); -} - -#define assert_port_profile(port, flgs, stat, caller) do { \ - if ((port->flags & (flgs)) != (flgs)) { \ - switch (flgs) { \ - case PIC_PORT_IN: \ - pic_error(pic, caller ": expected output port"); \ - case PIC_PORT_OUT: \ - pic_error(pic, caller ": expected input port"); \ - case PIC_PORT_IN | PIC_PORT_TEXT: \ - pic_error(pic, caller ": expected input/textual port"); \ - case PIC_PORT_IN | PIC_PORT_BINARY: \ - pic_error(pic, caller ": expected input/binary port"); \ - case PIC_PORT_OUT | PIC_PORT_TEXT: \ - pic_error(pic, caller ": expected output/textual port"); \ - case PIC_PORT_OUT | PIC_PORT_BINARY: \ - pic_error(pic, caller ": expected output/binary port"); \ - } \ - } \ - if (port->status != stat) { \ - switch (stat) { \ - case PIC_PORT_OPEN: \ - pic_error(pic, caller ": expected open port"); \ - case PIC_PORT_CLOSE: \ - pic_error(pic, caller ": expected close port"); \ - } \ - } \ - } while (0) - -static pic_value -pic_port_open_input_string(pic_state *pic) -{ - struct pic_port *port; - char *str; - - pic_get_args(pic, "z", &str); - - port = pic_open_input_string(pic, str); - - return pic_obj_value(port); -} - -static pic_value -pic_port_open_output_string(pic_state *pic) -{ - struct pic_port *port; - - pic_get_args(pic, ""); - - port = pic_open_output_string(pic); - - return pic_obj_value(port); -} - -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)); -} - -static pic_value -pic_port_open_input_blob(pic_state *pic) -{ - struct pic_port *port; - struct pic_blob *blob; - - pic_get_args(pic, "b", &blob); - - port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT); - port->file = xmopen(); - port->flags = PIC_PORT_IN | PIC_PORT_BINARY; - port->status = PIC_PORT_OPEN; - - xfwrite(blob->data, 1, blob->len, port->file); - xfflush(port->file); - xrewind(port->file); - - return pic_obj_value(port); -} - -static pic_value -pic_port_open_output_bytevector(pic_state *pic) -{ - struct pic_port *port; - - pic_get_args(pic, ""); - - port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT); - port->file = xmopen(); - port->flags = PIC_PORT_OUT | PIC_PORT_BINARY; - port->status = PIC_PORT_OPEN; - - return pic_obj_value(port); -} - -static pic_value -pic_port_get_output_bytevector(pic_state *pic) -{ - struct pic_port *port = pic_stdout(pic); - pic_blob *blob; - long endpos; - - pic_get_args(pic, "|p", &port); - - assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, PIC_PORT_OPEN, "get-output-bytevector"); - - /* get endpos */ - xfflush(port->file); - endpos = xftell(port->file); - xrewind(port->file); - - /* copy to buf */ - blob = pic_blob_new(pic, endpos); - xfread(blob->data, 1, endpos, port->file); - - return pic_obj_value(blob); -} - -static pic_value -pic_port_read_char(pic_state *pic) -{ - int c; - struct pic_port *port = pic_stdin(pic); - - pic_get_args(pic, "|p", &port); - - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "read-char"); - - if ((c = xfgetc(port->file)) == EOF) { - return pic_eof_object(); - } - else { - return pic_char_value((char)c); - } -} - -static pic_value -pic_port_peek_char(pic_state *pic) -{ - int c; - struct pic_port *port = pic_stdin(pic); - - pic_get_args(pic, "|p", &port); - - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "peek-char"); - - if ((c = xfgetc(port->file)) == EOF) { - return pic_eof_object(); - } - else { - xungetc(c, port->file); - return pic_char_value((char)c); - } -} - -static pic_value -pic_port_read_line(pic_state *pic) -{ - int c; - struct pic_port *port = pic_stdin(pic), *buf; - struct pic_string *str; - - pic_get_args(pic, "|p", &port); - - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "read-line"); - - buf = pic_open_output_string(pic); - while ((c = xfgetc(port->file)) != EOF && c != '\n') { - 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); - } -} - -static pic_value -pic_port_char_ready_p(pic_state *pic) -{ - struct pic_port *port = pic_stdin(pic); - - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "char-ready?"); - - pic_get_args(pic, "|p", &port); - - return pic_true_value(); /* FIXME: always returns #t */ -} - -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); - } - -} - -static pic_value -pic_port_read_byte(pic_state *pic){ - struct pic_port *port = pic_stdin(pic); - int c; - pic_get_args(pic, "|p", &port); - - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-u8"); - if ((c = xfgetc(port->file)) == EOF) { - return pic_eof_object(); - } - - return pic_int_value(c); -} - -static pic_value -pic_port_peek_byte(pic_state *pic) -{ - int c; - struct pic_port *port = pic_stdin(pic); - - pic_get_args(pic, "|p", &port); - - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "peek-u8"); - - c = xfgetc(port->file); - if (c == EOF) { - return pic_eof_object(); - } - else { - xungetc(c, port->file); - return pic_int_value(c); - } -} - -static pic_value -pic_port_byte_ready_p(pic_state *pic) -{ - struct pic_port *port = pic_stdin(pic); - - pic_get_args(pic, "|p", &port); - - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "u8-ready?"); - - return pic_true_value(); /* FIXME: always returns #t */ -} - - -static pic_value -pic_port_read_blob(pic_state *pic) -{ - struct pic_port *port = pic_stdin(pic); - pic_blob *blob; - int k, i; - - pic_get_args(pic, "i|p", &k, &port); - - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-bytevector"); - - blob = pic_blob_new(pic, k); - - i = xfread(blob->data, sizeof(char), k, port->file); - if ( i == 0 ) { - return pic_eof_object(); - } - else { - pic_realloc(pic, blob->data, i); - blob->len = i; - return pic_obj_value(blob); - } -} - -static pic_value -pic_port_read_blob_ip(pic_state *pic) -{ - struct pic_port *port; - struct pic_blob *bv; - int i, n, start, end, len; - char *buf; - - n = pic_get_args(pic, "b|pii", &bv, &port, &start, &end); - switch (n) { - case 1: - port = pic_stdin(pic); - case 2: - start = 0; - case 3: - end = bv->len; - } - - assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-bytevector!"); - len = end - start; - - buf = pic_calloc(pic, len, sizeof(char)); - i = xfread(buf, sizeof(char), len, port->file); - memcpy(bv->data + start, buf, i); - pic_free(pic, buf); - - if ( i == 0) { - return pic_eof_object(); - } - else { - return pic_int_value(i); - } -} - -static pic_value -pic_port_newline(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, "newline"); - - xfputs("\n", port->file); - return pic_none_value(); -} - -static pic_value -pic_port_write_char(pic_state *pic) -{ - char c; - struct pic_port *port = pic_stdout(pic); - - pic_get_args(pic, "c|p", &c, &port); - - assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "write-char"); - - xfputc(c, port->file); - return pic_none_value(); -} - -static pic_value -pic_port_write_string(pic_state *pic) -{ - char *str; - struct pic_port *port; - int start, end, n, i; - - n = pic_get_args(pic, "z|pii", &str, &port, &start, &end); - switch (n) { - case 1: - port = pic_stdout(pic); - case 2: - start = 0; - case 3: - end = INT_MAX; - } - - assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "write-string"); - - for (i = start; i < end && str[i] != '\0'; ++i) { - xfputc(str[i], port->file); - } - return pic_none_value(); -} - -static pic_value -pic_port_write_byte(pic_state *pic) -{ - int i; - struct pic_port *port = pic_stdout(pic); - - pic_get_args(pic, "i|p", &i, &port); - - assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, PIC_PORT_OPEN, "write-u8"); - - xfputc(i, port->file); - return pic_none_value(); -} - -static pic_value -pic_port_write_blob(pic_state *pic) -{ - struct pic_blob *blob; - struct pic_port *port; - int start, end, n, i; - - n = pic_get_args(pic, "b|pii", &blob, &port, &start, &end); - switch (n) { - case 1: - port = pic_stdout(pic); - case 2: - start = 0; - case 3: - end = blob->len; - } - - assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, PIC_PORT_OPEN, "write-bytevector"); - - for (i = start; i < end; ++i) { - xfputc(blob->data[i], port->file); - } - return pic_none_value(); -} - -static pic_value -pic_port_flush(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_OPEN, "flush-output-port"); - - xfflush(port->file); - return pic_none_value(); -} - -void -pic_init_port(pic_state *pic) -{ - struct pic_port *STDIN, *STDOUT, *STDERR; - - STDIN = port_new_stdport(pic, xstdin, PIC_PORT_IN); - STDOUT = port_new_stdport(pic, xstdout, PIC_PORT_OUT); - STDERR = port_new_stdport(pic, xstderr, PIC_PORT_OUT); - - pic_deflibrary (pic, "(picrin port)") { - pic_define(pic, "standard-input-port", pic_obj_value(STDIN)); - pic_define(pic, "standard-output-port", pic_obj_value(STDOUT)); - pic_define(pic, "standard-error-port", pic_obj_value(STDERR)); - } - - pic_define(pic, "current-input-port", pic_obj_value(pic_var_new(pic, pic_obj_value(STDIN), NULL))); - pic_define(pic, "current-output-port", pic_obj_value(pic_var_new(pic, pic_obj_value(STDOUT), NULL))); - pic_define(pic, "current-error-port", pic_obj_value(pic_var_new(pic, pic_obj_value(STDERR), NULL))); - - 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, "input-port-open?", pic_port_input_port_open_p); - pic_defun(pic, "output-port-open?", pic_port_output_port_open_p); - pic_defun(pic, "close-port", pic_port_close_port); - pic_defun(pic, "close-input-port", pic_port_close_port); - pic_defun(pic, "close-output-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); -} diff --git a/src/proc.c b/src/proc.c deleted file mode 100644 index 889a621d..00000000 --- a/src/proc.c +++ /dev/null @@ -1,183 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include "picrin.h" -#include "picrin/pair.h" -#include "picrin/proc.h" -#include "picrin/irep.h" -#include "picrin/dict.h" - -struct pic_proc * -pic_proc_new(pic_state *pic, pic_func_t func, const char *name) -{ - struct pic_proc *proc; - - assert(name != NULL); - - proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc), PIC_TT_PROC); - proc->kind = PIC_PROC_KIND_FUNC; - proc->u.func.f = func; - proc->u.func.name = pic_intern_cstr(pic, name); - proc->env = NULL; - proc->attr = NULL; - return proc; -} - -struct pic_proc * -pic_proc_new_irep(pic_state *pic, struct pic_irep *irep, struct pic_env *env) -{ - struct pic_proc *proc; - - proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc), PIC_TT_PROC); - proc->kind = PIC_PROC_KIND_IREP; - proc->u.irep = irep; - proc->env = env; - proc->attr = NULL; - return proc; -} - -pic_sym -pic_proc_name(struct pic_proc *proc) -{ - switch (proc->kind) { - case PIC_PROC_KIND_FUNC: - return proc->u.func.name; - case PIC_PROC_KIND_IREP: - return proc->u.irep->name; - } - UNREACHABLE(); -} - -struct pic_dict * -pic_attr(pic_state *pic, struct pic_proc *proc) -{ - if (proc->attr == NULL) { - proc->attr = pic_dict_new(pic); - } - return proc->attr; -} - -pic_value -pic_attr_ref(pic_state *pic, struct pic_proc *proc, const char *key) -{ - return pic_dict_ref(pic, pic_attr(pic, proc), pic_intern_cstr(pic, key)); -} - -void -pic_attr_set(pic_state *pic, struct pic_proc *proc, const char *key, pic_value v) -{ - pic_dict_set(pic, pic_attr(pic, proc), pic_intern_cstr(pic, key), v); -} - -static pic_value -pic_proc_proc_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - return pic_bool_value(pic_proc_p(v)); -} - -static pic_value -pic_proc_apply(pic_state *pic) -{ - struct pic_proc *proc; - pic_value *args; - size_t argc; - pic_value arg_list; - - pic_get_args(pic, "l*", &proc, &argc, &args); - - if (argc == 0) { - pic_error(pic, "apply: wrong number of arguments"); - } - - arg_list = args[--argc]; - while (argc--) { - arg_list = pic_cons(pic, args[argc], arg_list); - } - - return pic_apply_trampoline(pic, proc, arg_list); -} - -static pic_value -pic_proc_map(pic_state *pic) -{ - struct pic_proc *proc; - size_t argc; - pic_value *args; - int i; - pic_value cars, ret; - - pic_get_args(pic, "l*", &proc, &argc, &args); - - ret = pic_nil_value(); - 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; - ret = pic_cons(pic, pic_apply(pic, proc, cars), ret); - } while (1); - - return pic_reverse(pic, ret); -} - -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(); -} - -static pic_value -pic_proc_attribute(pic_state *pic) -{ - struct pic_proc *proc; - - pic_get_args(pic, "l", &proc); - - return pic_obj_value(pic_attr(pic, proc)); -} - -void -pic_init_proc(pic_state *pic) -{ - pic_defun(pic, "procedure?", pic_proc_proc_p); - pic_defun(pic, "apply", pic_proc_apply); - pic_defun(pic, "map", pic_proc_map); - pic_defun(pic, "for-each", pic_proc_for_each); - - pic_deflibrary (pic, "(picrin attribute)") { - pic_defun(pic, "attribute", pic_proc_attribute); - } -} diff --git a/src/read.c b/src/read.c deleted file mode 100644 index 2eb12829..00000000 --- a/src/read.c +++ /dev/null @@ -1,976 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include -#include -#include -#include "picrin.h" -#include "picrin/read.h" -#include "picrin/error.h" -#include "picrin/pair.h" -#include "picrin/string.h" -#include "picrin/vector.h" -#include "picrin/blob.h" -#include "picrin/port.h" -#include "picrin/proc.h" - -static pic_value read(pic_state *pic, struct pic_port *port, int c); -static pic_value read_nullable(pic_state *pic, struct pic_port *port, int c); - -static noreturn void -read_error(pic_state *pic, const char *msg) -{ - pic_throw(pic, PIC_ERROR_READ, msg, pic_nil_value()); -} - -static int -skip(struct pic_port *port, int c) -{ - while (isspace(c)) { - c = xfgetc(port->file); - } - return c; -} - -static int -next(struct pic_port *port) -{ - return xfgetc(port->file); -} - -static int -peek(struct pic_port *port) -{ - int c; - - xungetc((c = xfgetc(port->file)), port->file); - - return c; -} - -static bool -expect(struct pic_port *port, const char *str) -{ - int c; - - while ((c = (int)*str++) != 0) { - if (c != peek(port)) - return false; - next(port); - } - - return true; -} - -static bool -isdelim(int c) -{ - return c == EOF || strchr("();,|\" \t\n\r", c) != NULL; /* ignores "#", "'" */ -} - -static bool -strcaseeq(const char *s1, const char *s2) -{ - char a, b; - - while ((a = *s1++) * (b = *s2++)) { - if (tolower(a) != tolower(b)) - return false; - } - return a == b; -} - -static pic_value -read_comment(pic_state *pic, struct pic_port *port, const char *str) -{ - int c; - - UNUSED(pic); - UNUSED(str); - - do { - c = next(port); - } while (! (c == EOF || c == '\n')); - - return pic_undef_value(); -} - -static pic_value -read_block_comment(pic_state *pic, struct pic_port *port, const char *str) -{ - int x, y; - int i = 1; - - UNUSED(pic); - UNUSED(str); - - y = next(port); - - while (y != EOF && i > 0) { - x = y; - y = next(port); - if (x == '|' && y == '#') { - i--; - } - if (x == '#' && y == '|') { - i++; - } - } - - return pic_undef_value(); -} - -static pic_value -read_datum_comment(pic_state *pic, struct pic_port *port, const char *str) -{ - UNUSED(str); - - read(pic, port, next(port)); - - return pic_undef_value(); -} - -static pic_value -read_directive(pic_state *pic, struct pic_port *port, const char *str) -{ - switch (peek(port)) { - case 'n': - if (expect(port, "no-fold-case")) { - pic->reader->typecase = PIC_CASE_DEFAULT; - return pic_undef_value(); - } - break; - case 'f': - if (expect(port, "fold-case")) { - pic->reader->typecase = PIC_CASE_FOLD; - return pic_undef_value(); - } - break; - } - - return read_comment(pic, port, str); -} - -static pic_value -read_eval(pic_state *pic, struct pic_port *port, const char *str) -{ - pic_value form; - - UNUSED(str); - - form = read(pic, port, next(port)); - - return pic_eval(pic, form, pic->lib); -} - -static pic_value -read_quote(pic_state *pic, struct pic_port *port, const char *str) -{ - UNUSED(str); - - return pic_list2(pic, pic_sym_value(pic->sQUOTE), read(pic, port, next(port))); -} - -static pic_value -read_quasiquote(pic_state *pic, struct pic_port *port, const char *str) -{ - UNUSED(str); - - return pic_list2(pic, pic_sym_value(pic->sQUASIQUOTE), read(pic, port, next(port))); -} - -static pic_value -read_unquote(pic_state *pic, struct pic_port *port, const char *str) -{ - UNUSED(str); - - return pic_list2(pic, pic_sym_value(pic->sUNQUOTE), read(pic, port, next(port))); -} - -static pic_value -read_unquote_splicing(pic_state *pic, struct pic_port *port, const char *str) -{ - UNUSED(str); - - return pic_list2(pic, pic_sym_value(pic->sUNQUOTE_SPLICING), read(pic, port, next(port))); -} - -static pic_value -read_symbol(pic_state *pic, struct pic_port *port, const char *str) -{ - size_t len, i; - char *buf; - pic_sym sym; - int c; - - len = strlen(str); - buf = pic_calloc(pic, 1, len + 1); - - for (i = 0; i < len; ++i) { - if (pic->reader->typecase == PIC_CASE_FOLD) { - buf[i] = tolower(str[i]); - } else { - buf[i] = str[i]; - } - } - - while (! isdelim(peek(port))) { - c = next(port); - if (pic->reader->typecase == PIC_CASE_FOLD) { - c = tolower(c); - } - len += 1; - buf = pic_realloc(pic, buf, len + 1); - buf[len - 1] = c; - } - - sym = pic_intern(pic, buf, len); - pic_free(pic, buf); - - return pic_sym_value(sym); -} - -static size_t -read_uinteger(pic_state *pic, struct pic_port *port, int c, char buf[]) -{ - size_t i = 0; - - if (! isdigit(c)) { - read_error(pic, "expected one or more digits"); - } - - buf[i++] = c; - while (isdigit(c = peek(port))) { - buf[i++] = next(port); - } - - buf[i] = '\0'; - - return i; -} - -static size_t -read_suffix(pic_state *pic, struct pic_port *port, char buf[]) -{ - size_t i = 0; - int c; - - c = peek(port); - - if (c != 'e' && c != 'E') { - return i; - } - - buf[i++] = next(port); - - switch ((c = next(port))) { - case '-': - case '+': - buf[i++] = c; - c = next(port); - default: - return i + read_uinteger(pic, port, c, buf + i); - } -} - -static pic_value -read_unsigned(pic_state *pic, struct pic_port *port, int c) -{ - char buf[256]; - size_t i; - - i = read_uinteger(pic, port, c, buf); - - switch (peek(port)) { - case '.': - buf[i++] = next(port); - i += read_uinteger(pic, port, next(port), buf + i); - read_suffix(pic, port, buf + i); - return pic_float_value(atof(buf)); - - default: - read_suffix(pic, port, buf + i); - return pic_int_value((int)atof(buf)); - } -} - -static pic_value -read_number(pic_state *pic, struct pic_port *port, const char *str) -{ - return read_unsigned(pic, port, str[0]); -} - -static pic_value -negate(pic_value n) -{ - if (pic_int_p(n)) { - return pic_int_value(-pic_int(n)); - } else { - return pic_float_value(-pic_float(n)); - } -} - -static pic_value -read_minus(pic_state *pic, struct pic_port *port, const char *str) -{ - pic_value sym; - - if (isdigit(peek(port))) { - return negate(read_unsigned(pic, port, next(port))); - } - else { - sym = read_symbol(pic, port, str); - if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "-inf.0")) { - return pic_float_value(-INFINITY); - } - if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "-nan.0")) { - return pic_float_value(-NAN); - } - return sym; - } -} - -static pic_value -read_plus(pic_state *pic, struct pic_port *port, const char *str) -{ - pic_value sym; - - if (isdigit(peek(port))) { - return read_unsigned(pic, port, next(port)); - } - else { - sym = read_symbol(pic, port, str); - if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "+inf.0")) { - return pic_float_value(INFINITY); - } - if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "+nan.0")) { - return pic_float_value(NAN); - } - return sym; - } -} - -static pic_value -read_true(pic_state *pic, struct pic_port *port, const char *str) -{ - UNUSED(pic); - UNUSED(port); - UNUSED(str); - - return pic_true_value(); -} - -static pic_value -read_false(pic_state *pic, struct pic_port *port, const char *str) -{ - UNUSED(pic); - UNUSED(port); - UNUSED(str); - - return pic_false_value(); -} - -static pic_value -read_char(pic_state *pic, struct pic_port *port, const char *str) -{ - int c; - - UNUSED(str); - - c = next(port); - - if (! isdelim(peek(port))) { - switch (c) { - default: read_error(pic, "unexpected character after char literal"); - case 'a': c = '\a'; if (! expect(port, "lerm")) goto fail; break; - case 'b': c = '\b'; if (! expect(port, "ackspace")) goto fail; break; - case 'd': c = 0x7F; if (! expect(port, "elete")) goto fail; break; - case 'e': c = 0x1B; if (! expect(port, "scape")) goto fail; break; - case 'n': - if ((c = peek(port)) == 'e') { - c = '\n'; - if (! expect(port, "ewline")) - goto fail; - } else { - c = '\0'; - if (! expect(port, "ull")) - goto fail; - } - break; - case 'r': c = '\r'; if (! expect(port, "eturn")) goto fail; break; - case 's': c = ' '; if (! expect(port, "pace")) goto fail; break; - case 't': c = '\t'; if (! expect(port, "ab")) goto fail; break; - } - } - - return pic_char_value(c); - - fail: - read_error(pic, "unexpected character while reading character literal"); -} - -static pic_value -read_string(pic_state *pic, struct pic_port *port, const char *name) -{ - int c; - char *buf; - size_t size, cnt; - pic_str *str; - - UNUSED(name); - - size = 256; - buf = pic_alloc(pic, size); - cnt = 0; - - /* TODO: intraline whitespaces */ - - while ((c = next(port)) != '"') { - if (c == '\\') { - switch (c = next(port)) { - case 'a': c = '\a'; break; - case 'b': c = '\b'; break; - case 't': c = '\t'; break; - case 'n': c = '\n'; break; - case 'r': c = '\r'; break; - } - } - buf[cnt++] = c; - if (cnt >= size) { - buf = pic_realloc(pic, buf, size *= 2); - } - } - buf[cnt] = '\0'; - - str = pic_str_new(pic, buf, cnt); - pic_free(pic, buf); - return pic_obj_value(str); -} - -static pic_value -read_pipe(pic_state *pic, struct pic_port *port, const char *str) -{ - char *buf; - size_t size, cnt; - pic_sym sym; - /* Currently supports only ascii chars */ - char HEX_BUF[3]; - size_t i = 0; - int c; - - UNUSED(str); - - size = 256; - buf = pic_alloc(pic, size); - cnt = 0; - while ((c = next(port)) != '|') { - if (c == '\\') { - switch ((c = next(port))) { - case 'a': c = '\a'; break; - case 'b': c = '\b'; break; - case 't': c = '\t'; break; - case 'n': c = '\n'; break; - case 'r': c = '\r'; break; - case 'x': - i = 0; - while ((HEX_BUF[i++] = next(port)) != ';') { - if (i >= sizeof HEX_BUF) - read_error(pic, "expected ';'"); - } - c = strtol(HEX_BUF, NULL, 16); - break; - } - } - buf[cnt++] = c; - if (cnt >= size) { - buf = pic_realloc(pic, buf, size *= 2); - } - } - buf[cnt] = '\0'; - - sym = pic_intern_cstr(pic, buf); - pic_free(pic, buf); - - return pic_sym_value(sym); -} - -static pic_value -read_blob(pic_state *pic, struct pic_port *port, const char *str) -{ - int nbits, n, c; - size_t len, i; - char *dat, buf[256]; - pic_blob *blob; - - UNUSED(str); - - nbits = 0; - - while (isdigit(c = next(port))) { - nbits = 10 * nbits + c - '0'; - } - - if (nbits != 8) { - read_error(pic, "unsupported bytevector bit width"); - } - - if (c != '(') { - read_error(pic, "expected '(' character"); - } - - len = 0; - dat = NULL; - c = next(port); - while ((c = skip(port, c)) != ')') { - read_uinteger(pic, port, c, buf); - n = atoi(buf); - if (n < 0 || (1 << nbits) <= n) { - read_error(pic, "invalid element in bytevector literal"); - } - len += 1; - dat = pic_realloc(pic, dat, len); - dat[len - 1] = n; - c = next(port); - } - - blob = pic_blob_new(pic, len); - for (i = 0; i < len; ++i) { - blob->data[i] = dat[i]; - } - - pic_free(pic, dat); - return pic_obj_value(blob); -} - -static pic_value -read_pair(pic_state *pic, struct pic_port *port, const char *str) -{ - const int tCLOSE = (str[0] == '(') ? ')' : ']'; - pic_value car, cdr; - int c; - - retry: - - c = skip(port, ' '); - - if (c == tCLOSE) { - return pic_nil_value(); - } - if (c == '.' && isdelim(peek(port))) { - cdr = read(pic, port, next(port)); - - closing: - if ((c = skip(port, ' ')) != tCLOSE) { - if (pic_undef_p(read_nullable(pic, port, c))) { - goto closing; - } - read_error(pic, "unmatched parenthesis"); - } - return cdr; - } - else { - car = read_nullable(pic, port, c); - - if (pic_undef_p(car)) { - goto retry; - } - - cdr = read_pair(pic, port, str); - return pic_cons(pic, car, cdr); - } -} - -static pic_value -read_vector(pic_state *pic, struct pic_port *port, const char *str) -{ - pic_value list; - - list = read(pic, port, str[1]); - - return pic_obj_value(pic_vec_new_from_list(pic, list)); -} - -static pic_value -read_label_set(pic_state *pic, struct pic_port *port, int i) -{ - pic_value val; - int c; - - switch ((c = skip(port, ' '))) { - case '(': case '[': - { - pic_value tmp; - - val = pic_cons(pic, pic_none_value(), pic_none_value()); - - xh_put_int(&pic->reader->labels, i, &val); - - tmp = read(pic, port, c); - pic_pair_ptr(val)->car = pic_car(pic, tmp); - pic_pair_ptr(val)->cdr = pic_cdr(pic, tmp); - - return val; - } - case '#': - { - bool vect; - - if (peek(port) == '(') { - vect = true; - } else { - vect = false; - } - - if (vect) { - pic_vec *tmp; - - val = pic_obj_value(pic_vec_new(pic, 0)); - - xh_put_int(&pic->reader->labels, i, &val); - - tmp = pic_vec_ptr(read(pic, port, c)); - SWAP(pic_value *, tmp->data, pic_vec_ptr(val)->data); - SWAP(size_t, tmp->len, pic_vec_ptr(val)->len); - - return val; - } - - FALLTHROUGH; - } - default: - { - val = read(pic, port, c); - - xh_put_int(&pic->reader->labels, i, &val); - - return val; - } - } -} - -static pic_value -read_label_ref(pic_state *pic, struct pic_port *port, int i) -{ - xh_entry *e; - - UNUSED(port); - - e = xh_get_int(&pic->reader->labels, i); - if (! e) { - read_error(pic, "label of given index not defined"); - } - return xh_val(e, pic_value); -} - -static pic_value -read_label(pic_state *pic, struct pic_port *port, const char *str) -{ - int i, c; - - i = 0; - c = str[1]; /* initial index letter */ - do { - i = i * 10 + c; - } while (isdigit(c = next(port))); - - if (c == '=') { - return read_label_set(pic, port, i); - } - if (c == '#') { - return read_label_ref(pic, port, i); - } - read_error(pic, "broken label expression"); -} - -static pic_value -read_unmatch(pic_state *pic, struct pic_port *port, const char *str) -{ - UNUSED(port); - UNUSED(str); - - read_error(pic, "unmatched parenthesis"); -} - -static pic_value -read_nullable(pic_state *pic, struct pic_port *port, int c) -{ - struct pic_trie *trie = pic->reader->trie; - char buf[128]; - size_t i = 0; - pic_str *str; - - c = skip(port, c); - - if (c == EOF) { - read_error(pic, "unexpected EOF"); - } - - if (trie->table[c] == NULL) { - read_error(pic, "invalid character at the seeker head"); - } - - buf[i++] = c; - - while (i < sizeof buf) { - trie = trie->table[c]; - - if ((c = peek(port)) == EOF) { - break; - } - if (trie->table[c] == NULL) { - break; - } - buf[i++] = next(port); - } - if (i == sizeof buf) { - read_error(pic, "too long dispatch string"); - } - - if (trie->proc == NULL) { - read_error(pic, "no reader registered for current string"); - } - str = pic_str_new(pic, buf, i); - return pic_apply2(pic, trie->proc, pic_obj_value(port), pic_obj_value(str)); -} - -static pic_value -read(pic_state *pic, struct pic_port *port, int c) -{ - pic_value val; - - retry: - val = read_nullable(pic, port, c); - - if (pic_undef_p(val)) { - c = next(port); - goto retry; - } - - return val; -} - -struct pic_trie * -pic_trie_new(pic_state *pic) -{ - struct pic_trie *trie; - - trie = pic_alloc(pic, sizeof(struct pic_trie)); - trie->proc = NULL; - memset(trie->table, 0, sizeof trie->table); - - return trie; -} - -void -pic_trie_delete(pic_state *pic, struct pic_trie *trie) -{ - size_t i; - - for (i = 0; i < sizeof trie->table / sizeof(struct pic_trie *); ++i) { - if (trie->table[i] != NULL) { - pic_trie_delete(pic, trie->table[i]); - } - } - - pic_free(pic, trie); -} - -void -pic_define_reader(pic_state *pic, const char *str, pic_func_t reader) -{ - struct pic_trie *trie = pic->reader->trie; - int c; - - while ((c = *str++)) { - if (trie->table[c] == NULL) { - trie->table[c] = pic_trie_new(pic); - } - trie = trie->table[c]; - } - trie->proc = pic_proc_new(pic, reader, "reader"); -} - -#define DEFINE_READER(name) \ - static pic_value \ - pic_##name(pic_state *pic) \ - { \ - struct pic_port *port; \ - const char *str; \ - \ - pic_get_args(pic, "pz", &port, &str); \ - \ - return name(pic, port, str); \ - } - -DEFINE_READER(read_unmatch) -DEFINE_READER(read_comment) -DEFINE_READER(read_quote) -DEFINE_READER(read_quasiquote) -DEFINE_READER(read_unquote) -DEFINE_READER(read_unquote_splicing) -DEFINE_READER(read_string) -DEFINE_READER(read_pipe) -DEFINE_READER(read_plus) -DEFINE_READER(read_minus) -DEFINE_READER(read_pair) -DEFINE_READER(read_directive) -DEFINE_READER(read_block_comment) -DEFINE_READER(read_datum_comment) -DEFINE_READER(read_true) -DEFINE_READER(read_false) -DEFINE_READER(read_char) -DEFINE_READER(read_vector) -DEFINE_READER(read_blob) -DEFINE_READER(read_eval) -DEFINE_READER(read_symbol) -DEFINE_READER(read_number) -DEFINE_READER(read_label) - -void -pic_init_reader(pic_state *pic) -{ - static const char INIT[] = "!$%&*./:<=>?@^_~"; - char buf[3] = { 0 }; - size_t i; - - pic_define_reader(pic, ")", pic_read_unmatch); - pic_define_reader(pic, ";", pic_read_comment); - pic_define_reader(pic, "'", pic_read_quote); - pic_define_reader(pic, "`", pic_read_quasiquote); - pic_define_reader(pic, ",", pic_read_unquote); - pic_define_reader(pic, ",@", pic_read_unquote_splicing); - pic_define_reader(pic, "\"", pic_read_string); - pic_define_reader(pic, "|", pic_read_pipe); - pic_define_reader(pic, "+", pic_read_plus); - pic_define_reader(pic, "-", pic_read_minus); - pic_define_reader(pic, "(", pic_read_pair); - pic_define_reader(pic, "[", pic_read_pair); - - pic_define_reader(pic, "#!", pic_read_directive); - pic_define_reader(pic, "#|", pic_read_block_comment); - pic_define_reader(pic, "#;", pic_read_datum_comment); - pic_define_reader(pic, "#t", pic_read_true); - pic_define_reader(pic, "#true", pic_read_true); - pic_define_reader(pic, "#f", pic_read_false); - pic_define_reader(pic, "#false", pic_read_false); - pic_define_reader(pic, "#\\", pic_read_char); - pic_define_reader(pic, "#(", pic_read_vector); - pic_define_reader(pic, "#u", pic_read_blob); - pic_define_reader(pic, "#.", pic_read_eval); - - /* read number */ - for (buf[0] = '0'; buf[0] <= '9'; ++buf[0]) { - pic_define_reader(pic, buf, pic_read_number); - } - - /* read symbol */ - for (buf[0] = 'a'; buf[0] <= 'z'; ++buf[0]) { - pic_define_reader(pic, buf, pic_read_symbol); - } - for (buf[0] = 'A'; buf[0] <= 'Z'; ++buf[0]) { - pic_define_reader(pic, buf, pic_read_symbol); - } - for (i = 0; i < sizeof INIT; ++i) { - buf[0] = INIT[i]; - pic_define_reader(pic, buf, pic_read_symbol); - } - - /* read label */ - buf[0] = '#'; - for (buf[1] = '0'; buf[1] <= '9'; ++buf[1]) { - pic_define_reader(pic, buf, pic_read_label); - } -} - -pic_value -pic_read(pic_state *pic, struct pic_port *port) -{ - pic_value val; - int c = next(port); - - retry: - c = skip(port, c); - - if (c == EOF) { - return pic_eof_object(); - } - - val = read_nullable(pic, port, c); - - if (pic_undef_p(val)) { - c = next(port); - goto retry; - } - - return val; -} - -pic_value -pic_read_cstr(pic_state *pic, const char *str) -{ - struct pic_port *port; - - port = pic_open_input_string(pic, str); - - return pic_read(pic, port); -} - -static pic_value -pic_parse(pic_state *pic, struct pic_port *port) -{ - pic_value val, acc; - - pic_try { - acc = pic_nil_value(); - while (! pic_eof_p(val = pic_read(pic, port))) { - pic_push(pic, val, acc); - } - } - pic_catch { - return pic_undef_value(); - } - - return pic_reverse(pic, acc); -} - -pic_list -pic_parse_file(pic_state *pic, FILE *file) -{ - struct pic_port *port; - - port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT); - port->file = xfpopen(file); - port->flags = PIC_PORT_OUT | PIC_PORT_TEXT; - port->status = PIC_PORT_OPEN; - - return pic_parse(pic, port); -} - -pic_list -pic_parse_cstr(pic_state *pic, const char *str) -{ - struct pic_port *port; - - port = pic_open_input_string(pic, str); - - return pic_parse(pic, port); -} - -static pic_value -pic_read_read(pic_state *pic) -{ - struct pic_port *port = pic_stdin(pic); - - pic_get_args(pic, "|p", &port); - - return pic_read(pic, port); -} - -void -pic_init_read(pic_state *pic) -{ - pic_deflibrary (pic, "(scheme read)") { - pic_defun(pic, "read", pic_read_read); - } -} diff --git a/src/record.c b/src/record.c deleted file mode 100644 index d62776ca..00000000 --- a/src/record.c +++ /dev/null @@ -1,115 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include "picrin.h" -#include "picrin/record.h" - -struct pic_record * -pic_record_new(pic_state *pic, pic_value rectype) -{ - struct pic_record *rec; - - rec = (struct pic_record *)pic_obj_alloc(pic, sizeof(struct pic_record), PIC_TT_RECORD); - xh_init_int(&rec->hash, sizeof(pic_value)); - - pic_record_set(pic, rec, pic_intern_cstr(pic, "@@type"), rectype); - - return rec; -} - -pic_value -pic_record_type(pic_state *pic, struct pic_record *rec) -{ - return pic_record_ref(pic, rec, pic_intern_cstr(pic, "@@type")); -} - -pic_value -pic_record_ref(pic_state *pic, struct pic_record *rec, pic_sym slot) -{ - xh_entry *e; - - e = xh_get_int(&rec->hash, slot); - if (! e) { - pic_errorf(pic, "slot named ~s is not found for record: ~s", pic_sym_value(slot), rec); - } - return xh_val(e, pic_value); -} - -void -pic_record_set(pic_state *pic, struct pic_record *rec, pic_sym slot, pic_value val) -{ - UNUSED(pic); - - xh_put_int(&rec->hash, slot, &val); -} - -static pic_value -pic_record_make_record(pic_state *pic) -{ - struct pic_record * rec; - pic_value rectype; - - pic_get_args(pic, "o", &rectype); - - rec = pic_record_new(pic, rectype); - - return pic_obj_value(rec); -} - -static pic_value -pic_record_record_p(pic_state *pic) -{ - pic_value rec; - - pic_get_args(pic, "o", &rec); - - return pic_bool_value(pic_record_p(rec)); -} - -static pic_value -pic_record_record_type(pic_state *pic) -{ - struct pic_record *rec; - - pic_get_args(pic, "r", &rec); - - return pic_record_type(pic, rec); -} - -static pic_value -pic_record_record_ref(pic_state *pic) -{ - struct pic_record *rec; - pic_sym slot; - - pic_get_args(pic, "rm", &rec, &slot); - - return pic_record_ref(pic, rec, slot); -} - -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_none_value(); -} - -void -pic_init_record(pic_state *pic) -{ - pic_deflibrary (pic, "(picrin record)") { - pic_defun(pic, "make-record", pic_record_make_record); - pic_defun(pic, "record?", pic_record_record_p); - pic_defun(pic, "record-type", pic_record_record_type); - pic_defun(pic, "record-ref", pic_record_record_ref); - pic_defun(pic, "record-set!", pic_record_record_set); - } -} diff --git a/src/state.c b/src/state.c deleted file mode 100644 index d9427f3d..00000000 --- a/src/state.c +++ /dev/null @@ -1,205 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include - -#include "picrin.h" -#include "picrin/gc.h" -#include "picrin/read.h" -#include "picrin/proc.h" -#include "picrin/macro.h" -#include "picrin/cont.h" -#include "picrin/error.h" - -void pic_init_core(pic_state *); - -pic_state * -pic_open(int argc, char *argv[], char **envp) -{ - char t; - - pic_state *pic; - size_t ai; - - pic = malloc(sizeof(pic_state)); - - /* root block */ - pic->blk = 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; - - /* memory heap */ - pic->heap = pic_heap_open(); - - /* symbol table */ - xh_init_str(&pic->syms, sizeof(pic_sym)); - xh_init_int(&pic->sym_names, sizeof(const char *)); - pic->sym_cnt = 0; - pic->uniq_sym_cnt = 0; - - /* global variables */ - xh_init_int(&pic->globals, sizeof(pic_value)); - - /* macros */ - xh_init_int(&pic->macros, sizeof(struct pic_macro *)); - - /* libraries */ - pic->libs = pic_nil_value(); - pic->lib = NULL; - - /* reader */ - pic->reader = malloc(sizeof(struct pic_reader)); - pic->reader->typecase = PIC_CASE_DEFAULT; - pic->reader->trie = pic_trie_new(pic); - xh_init_int(&pic->reader->labels, sizeof(pic_value)); - - /* error handling */ - pic->jmp = NULL; - pic->err = NULL; - pic->try_jmps = calloc(PIC_RESCUE_SIZE, sizeof(struct pic_jmpbuf)); - pic->try_jmp_idx = 0; - pic->try_jmp_size = PIC_RESCUE_SIZE; - - /* GC arena */ - pic->arena = calloc(PIC_ARENA_SIZE, sizeof(struct pic_object **)); - pic->arena_size = PIC_ARENA_SIZE; - pic->arena_idx = 0; - - /* native stack marker */ - pic->native_stack_start = &t; - -#define register_core_symbol(pic,slot,name) do { \ - pic->slot = pic_intern_cstr(pic, name); \ - } while (0) - - ai = pic_gc_arena_preserve(pic); - register_core_symbol(pic, sDEFINE, "define"); - register_core_symbol(pic, sLAMBDA, "lambda"); - register_core_symbol(pic, sIF, "if"); - register_core_symbol(pic, sBEGIN, "begin"); - register_core_symbol(pic, sSETBANG, "set!"); - register_core_symbol(pic, sQUOTE, "quote"); - register_core_symbol(pic, sQUASIQUOTE, "quasiquote"); - register_core_symbol(pic, sUNQUOTE, "unquote"); - register_core_symbol(pic, sUNQUOTE_SPLICING, "unquote-splicing"); - register_core_symbol(pic, sDEFINE_SYNTAX, "define-syntax"); - register_core_symbol(pic, sIMPORT, "import"); - register_core_symbol(pic, sEXPORT, "export"); - register_core_symbol(pic, sDEFINE_LIBRARY, "define-library"); - register_core_symbol(pic, sIN_LIBRARY, "in-library"); - register_core_symbol(pic, sCONS, "cons"); - register_core_symbol(pic, sCAR, "car"); - register_core_symbol(pic, sCDR, "cdr"); - register_core_symbol(pic, sNILP, "null?"); - register_core_symbol(pic, sADD, "+"); - register_core_symbol(pic, sSUB, "-"); - register_core_symbol(pic, sMUL, "*"); - register_core_symbol(pic, sDIV, "/"); - register_core_symbol(pic, sMINUS, "minus"); - register_core_symbol(pic, sEQ, "="); - register_core_symbol(pic, sLT, "<"); - register_core_symbol(pic, sLE, "<="); - register_core_symbol(pic, sGT, ">"); - register_core_symbol(pic, sGE, ">="); - register_core_symbol(pic, sNOT, "not"); - pic_gc_arena_restore(pic, ai); - -#define register_renamed_symbol(pic,slot,name) do { \ - pic->slot = pic_gensym(pic, pic_intern_cstr(pic, name)); \ - } while (0) - - ai = pic_gc_arena_preserve(pic); - register_renamed_symbol(pic, rDEFINE, "define"); - register_renamed_symbol(pic, rLAMBDA, "lambda"); - register_renamed_symbol(pic, rIF, "if"); - register_renamed_symbol(pic, rBEGIN, "begin"); - register_renamed_symbol(pic, rSETBANG, "set!"); - register_renamed_symbol(pic, rQUOTE, "quote"); - register_renamed_symbol(pic, rDEFINE_SYNTAX, "define-syntax"); - register_renamed_symbol(pic, rIMPORT, "import"); - register_renamed_symbol(pic, rEXPORT, "export"); - register_renamed_symbol(pic, rDEFINE_LIBRARY, "define-library"); - register_renamed_symbol(pic, rIN_LIBRARY, "in-library"); - pic_gc_arena_restore(pic, ai); - - /* root block */ - pic->blk = (struct pic_block *)pic_obj_alloc(pic, sizeof(struct pic_block), PIC_TT_BLK); - pic->blk->prev = NULL; - pic->blk->depth = 0; - pic->blk->in = pic->blk->out = NULL; - - pic_init_core(pic); - - /* set library */ - pic_make_library(pic, pic_read_cstr(pic, "(picrin user)")); - pic_in_library(pic, pic_read_cstr(pic, "(picrin user)")); - - return pic; -} - -void -pic_close(pic_state *pic) -{ - xh_iter it; - - /* invoke exit handlers */ - while (pic->blk) { - if (pic->blk->out) { - pic_apply0(pic, pic->blk->out); - } - pic->blk = pic->blk->prev; - } - - /* clear out root objects */ - pic->sp = pic->stbase; - pic->ci = pic->cibase; - pic->arena_idx = 0; - pic->err = NULL; - xh_clear(&pic->macros); - 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 reader struct */ - xh_destroy(&pic->reader->labels); - pic_trie_delete(pic, pic->reader->trie); - free(pic->reader); - - /* free global stacks */ - free(pic->try_jmps); - xh_destroy(&pic->syms); - xh_destroy(&pic->globals); - xh_destroy(&pic->macros); - - /* free GC arena */ - free(pic->arena); - - /* free symbol names */ - xh_begin(&it, &pic->sym_names); - while (xh_next(&it)) { - free(xh_val(it.e, char *)); - } - xh_destroy(&pic->sym_names); - - free(pic); -} diff --git a/src/string.c b/src/string.c deleted file mode 100644 index ab679f50..00000000 --- a/src/string.c +++ /dev/null @@ -1,424 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include - -#include "picrin.h" -#include "picrin/string.h" -#include "picrin/pair.h" -#include "picrin/port.h" - -static pic_str * -str_new_rope(pic_state *pic, xrope *rope) -{ - pic_str *str; - - str = (pic_str *)pic_obj_alloc(pic, sizeof(pic_str), PIC_TT_STRING); - str->rope = rope; /* delegate ownership */ - return str; -} - -pic_str * -pic_str_new(pic_state *pic, const char *imbed, size_t len) -{ - if (imbed == NULL && len > 0) { - pic_errorf(pic, "zero length specified against NULL ptr"); - } - return str_new_rope(pic, xr_new_copy(imbed, len)); -} - -pic_str * -pic_str_new_cstr(pic_state *pic, const char *cstr) -{ - return pic_str_new(pic, cstr, strlen(cstr)); -} - -pic_str * -pic_str_new_fill(pic_state *pic, size_t len, char fill) -{ - size_t i; - char *cstr; - pic_str *str; - - cstr = (char *)pic_alloc(pic, len + 1); - cstr[len] = '\0'; - for (i = 0; i < len; ++i) { - cstr[i] = fill; - } - - str = pic_str_new(pic, cstr, len); - - pic_free(pic, cstr); - return str; -} - -size_t -pic_strlen(pic_str *str) -{ - return xr_len(str->rope); -} - -char -pic_str_ref(pic_state *pic, pic_str *str, size_t i) -{ - int c; - - c = xr_at(str->rope, i); - if (c == -1) { - pic_errorf(pic, "index out of range %d", i); - } - return (char)c; -} - -static xrope * -xr_put(xrope *rope, size_t i, char c) -{ - xrope *x, *y, *z; - char buf[2]; - - if (xr_len(rope) <= i) { - return NULL; - } - - buf[0] = c; - buf[1] = '\0'; - - x = xr_sub(rope, 0, i); - y = xr_new_copy(buf, 1); - z = xr_cat(x, y); - XROPE_DECREF(x); - XROPE_DECREF(y); - - x = z; - y = xr_sub(rope, i + 1, xr_len(rope)); - z = xr_cat(z, y); - XROPE_DECREF(x); - XROPE_DECREF(y); - - return z; -} - -void -pic_str_set(pic_state *pic, pic_str *str, size_t i, char c) -{ - xrope *x; - - x = xr_put(str->rope, i, c); - if (x == NULL) { - pic_errorf(pic, "index out of range %d", i); - } - XROPE_DECREF(str->rope); - str->rope = x; -} - -pic_str * -pic_strcat(pic_state *pic, pic_str *a, pic_str *b) -{ - return str_new_rope(pic, xr_cat(a->rope, b->rope)); -} - -pic_str * -pic_substr(pic_state *pic, pic_str *str, size_t s, size_t e) -{ - return str_new_rope(pic, xr_sub(str->rope, s, e)); -} - -int -pic_strcmp(pic_str *str1, pic_str *str2) -{ - return strcmp(xr_cstr(str1->rope), xr_cstr(str2->rope)); -} - -const char * -pic_str_cstr(pic_str *str) -{ - return xr_cstr(str->rope); -} - -pic_value -pic_vfformat(pic_state *pic, xFILE *file, const char *fmt, va_list ap) -{ - char c; - pic_value irrs = pic_nil_value(); - - while ((c = *fmt++)) { - switch (c) { - default: - xfputc(c, file); - break; - case '%': - c = *fmt++; - if (! c) - goto exit; - switch (c) { - default: - xfputc(c, file); - break; - case '%': - xfputc('%', file); - break; - case 'c': - xfprintf(file, "%c", va_arg(ap, int)); - break; - case 's': - xfprintf(file, "%s", va_arg(ap, const char *)); - break; - case 'd': - xfprintf(file, "%d", va_arg(ap, int)); - break; - case 'p': - xfprintf(file, "%p", va_arg(ap, void *)); - break; - case 'f': - xfprintf(file, "%f", va_arg(ap, double)); - break; - } - break; - case '~': - c = *fmt++; - if (! c) - goto exit; - switch (c) { - default: - xfputc(c, file); - break; - case '~': - xfputc('~', file); - break; - case '%': - xfputc('\n', file); - break; - case 'a': - irrs = pic_cons(pic, pic_fdisplay(pic, va_arg(ap, pic_value), file), irrs); - break; - case 's': - irrs = pic_cons(pic, pic_fwrite(pic, va_arg(ap, pic_value), file), irrs); - break; - } - break; - } - } - exit: - - return pic_reverse(pic, irrs); -} - -pic_value -pic_vformat(pic_state *pic, const char *fmt, va_list ap) -{ - struct pic_port *port; - pic_value irrs; - - port = pic_open_output_string(pic); - - irrs = pic_vfformat(pic, port->file, fmt, ap); - irrs = pic_cons(pic, pic_obj_value(pic_get_output_string(pic, port)), irrs); - - pic_close_port(pic, port); - return irrs; -} - -pic_value -pic_format(pic_state *pic, const char *fmt, ...) -{ - va_list ap; - pic_value objs; - - va_start(ap, fmt); - objs = pic_vformat(pic, fmt, ap); - va_end(ap); - - return objs; -} - -static pic_value -pic_str_string_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - return pic_bool_value(pic_str_p(v)); -} - -static pic_value -pic_str_make_string(pic_state *pic) -{ - int len; - char c = ' '; - - pic_get_args(pic, "i|c", &len, &c); - - return pic_obj_value(pic_str_new_fill(pic, len, c)); -} - -static pic_value -pic_str_string_length(pic_state *pic) -{ - pic_str *str; - - pic_get_args(pic, "s", &str); - - return pic_int_value(pic_strlen(str)); -} - -static pic_value -pic_str_string_ref(pic_state *pic) -{ - pic_str *str; - int k; - - pic_get_args(pic, "si", &str, &k); - - return pic_char_value(pic_str_ref(pic, str, k)); -} - -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_none_value(); -} - -#define DEFINE_STRING_CMP(name, op) \ - static pic_value \ - pic_str_string_##name(pic_state *pic) \ - { \ - size_t argc; \ - pic_value *argv; \ - size_t i; \ - \ - pic_get_args(pic, "*", &argc, &argv); \ - \ - if (argc < 1 || ! pic_str_p(argv[0])) { \ - return pic_false_value(); \ - } \ - \ - for (i = 1; i < argc; ++i) { \ - if (! pic_str_p(argv[i])) { \ - return pic_false_value(); \ - } \ - if (! (pic_strcmp(pic_str_ptr(argv[i-1]), pic_str_ptr(argv[i])) op 0)) { \ - return pic_false_value(); \ - } \ - } \ - return pic_true_value(); \ - } - -DEFINE_STRING_CMP(eq, ==) -DEFINE_STRING_CMP(lt, <) -DEFINE_STRING_CMP(gt, >) -DEFINE_STRING_CMP(le, <=) -DEFINE_STRING_CMP(ge, >=) - -static pic_value -pic_str_string_copy(pic_state *pic) -{ - pic_str *str; - int n, start, end; - - n = pic_get_args(pic, "s|ii", &str, &start, &end); - - switch (n) { - case 1: - start = 0; - case 2: - end = pic_strlen(str); - } - - return pic_obj_value(pic_substr(pic, str, start, end)); -} - -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_strlen(from); - } - if (to == from) { - from = pic_substr(pic, from, 0, end); - } - - while (start < end) { - pic_str_set(pic, to, at++, pic_str_ref(pic, from, start++)); - } - return pic_none_value(); -} - -static pic_value -pic_str_string_append(pic_state *pic) -{ - size_t argc, i; - pic_value *argv; - pic_str *str; - - pic_get_args(pic, "*", &argc, &argv); - - str = pic_str_new(pic, NULL, 0); - for (i = 0; i < argc; ++i) { - if (! pic_str_p(argv[i])) { - pic_error(pic, "type error"); - } - str = pic_strcat(pic, str, pic_str_ptr(argv[i])); - } - return pic_obj_value(str); -} - -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_strlen(str); - } - - while (start < end) { - pic_str_set(pic, str, start++, c); - } - return pic_none_value(); -} - -void -pic_init_str(pic_state *pic) -{ - pic_defun(pic, "string?", pic_str_string_p); - pic_defun(pic, "make-string", pic_str_make_string); - pic_defun(pic, "string-length", pic_str_string_length); - pic_defun(pic, "string-ref", pic_str_string_ref); - pic_defun(pic, "string-set!", pic_str_string_set); - - pic_defun(pic, "string=?", pic_str_string_eq); - pic_defun(pic, "string?", pic_str_string_gt); - pic_defun(pic, "string<=?", pic_str_string_le); - pic_defun(pic, "string>=?", pic_str_string_ge); - - pic_defun(pic, "string-copy", pic_str_string_copy); - pic_defun(pic, "string-copy!", pic_str_string_copy_ip); - pic_defun(pic, "string-append", pic_str_string_append); - pic_defun(pic, "string-fill!", pic_str_string_fill_ip); - pic_defun(pic, "substring", pic_str_string_copy); -} diff --git a/src/symbol.c b/src/symbol.c deleted file mode 100644 index 2add0769..00000000 --- a/src/symbol.c +++ /dev/null @@ -1,161 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include -#include -#include - -#include "picrin.h" -#include "picrin/string.h" - -pic_sym -pic_intern(pic_state *pic, const char *str, size_t len) -{ - char *cstr; - xh_entry *e; - pic_sym id; - - cstr = (char *)pic_malloc(pic, len + 1); - cstr[len] = '\0'; - memcpy(cstr, str, len); - - e = xh_get_str(&pic->syms, cstr); - if (e) { - return xh_val(e, pic_sym); - } - - id = pic->sym_cnt++; - xh_put_str(&pic->syms, cstr, &id); - xh_put_int(&pic->sym_names, id, &cstr); - return id; -} - -pic_sym -pic_intern_cstr(pic_state *pic, const char *str) -{ - return pic_intern(pic, str, strlen(str)); -} - -pic_sym -pic_gensym(pic_state *pic, pic_sym base) -{ - int uid = pic->uniq_sym_cnt++, len; - char *str, mark; - pic_sym uniq; - - if (pic_interned_p(pic, base)) { - mark = '@'; - } else { - mark = '.'; - } - - len = snprintf(NULL, 0, "%s%c%d", pic_symbol_name(pic, base), mark, uid); - str = pic_alloc(pic, len + 1); - sprintf(str, "%s%c%d", pic_symbol_name(pic, base), mark, uid); - - /* don't put the symbol to pic->syms to keep it uninterned */ - uniq = pic->sym_cnt++; - xh_put_int(&pic->sym_names, uniq, &str); - - return uniq; -} - -pic_sym -pic_ungensym(pic_state *pic, pic_sym base) -{ - const char *name, *occr; - - if (pic_interned_p(pic, base)) { - return base; - } - - name = pic_symbol_name(pic, base); - if ((occr = strrchr(name, '@')) == NULL) { - pic_abort(pic, "logic flaw"); - } - return pic_intern(pic, name, occr - name); -} - -bool -pic_interned_p(pic_state *pic, pic_sym sym) -{ - return sym == pic_intern_cstr(pic, pic_symbol_name(pic, sym)); -} - -const char * -pic_symbol_name(pic_state *pic, pic_sym sym) -{ - return xh_val(xh_get_int(&pic->sym_names, sym), const char *); -} - -static pic_value -pic_symbol_symbol_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - return pic_bool_value(pic_sym_p(v)); -} - -static pic_value -pic_symbol_symbol_eq_p(pic_state *pic) -{ - size_t argc, i; - pic_value *argv; - - pic_get_args(pic, "*", &argc, &argv); - - for (i = 0; i < argc; ++i) { - if (! pic_sym_p(argv[i])) { - return pic_false_value(); - } - if (! pic_eq_p(argv[i], argv[0])) { - return pic_false_value(); - } - } - return pic_true_value(); -} - -static pic_value -pic_symbol_symbol_to_string(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - if (! pic_sym_p(v)) { - pic_error(pic, "symbol->string: expected symbol"); - } - - return pic_obj_value(pic_str_new_cstr(pic, pic_symbol_name(pic, pic_sym(v)))); -} - -static pic_value -pic_symbol_string_to_symbol(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - if (! pic_str_p(v)) { - pic_error(pic, "string->symbol: expected string"); - } - - return pic_symbol_value(pic_intern_cstr(pic, pic_str_cstr(pic_str_ptr(v)))); -} - -void -pic_init_symbol(pic_state *pic) -{ - pic_deflibrary (pic, "(picrin base symbol)") { - pic_defun(pic, "symbol?", pic_symbol_symbol_p); - pic_defun(pic, "symbol->string", pic_symbol_symbol_to_string); - pic_defun(pic, "string->symbol", pic_symbol_string_to_symbol); - } - - pic_deflibrary (pic, "(picrin symbol)") { - pic_defun(pic, "symbol=?", pic_symbol_symbol_eq_p); - } -} diff --git a/src/var.c b/src/var.c deleted file mode 100644 index a5836797..00000000 --- a/src/var.c +++ /dev/null @@ -1,134 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include "picrin.h" -#include "picrin/var.h" -#include "picrin/pair.h" - -struct pic_var * -pic_var_new(pic_state *pic, pic_value init, struct pic_proc *conv) -{ - struct pic_var *var; - - var = (struct pic_var *)pic_obj_alloc(pic, sizeof(struct pic_var), PIC_TT_VAR); - var->stack = pic_nil_value(); - var->conv = conv; - - pic_var_push(pic, var, init); - - return var; -} - -pic_value -pic_var_ref(pic_state *pic, struct pic_var *var) -{ - return pic_car(pic, var->stack); -} - -void -pic_var_set(pic_state *pic, struct pic_var *var, pic_value value) -{ - if (var->conv != NULL) { - value = pic_apply1(pic, var->conv, value); - } - pic_set_car(pic, var->stack, value); -} - -void -pic_var_push(pic_state *pic, struct pic_var *var, pic_value value) -{ - if (var->conv != NULL) { - value = pic_apply1(pic, var->conv, value); - } - var->stack = pic_cons(pic, value, var->stack); -} - -void -pic_var_pop(pic_state *pic, struct pic_var *var) -{ - var->stack = pic_cdr(pic, var->stack); -} - -static pic_value -pic_var_make_parameter(pic_state *pic) -{ - struct pic_proc *conv = NULL; - pic_value init; - - pic_get_args(pic, "o|l", &init, &conv); - - return pic_obj_value(pic_var_new(pic, init, conv)); -} - -static pic_value -pic_var_parameter_ref(pic_state *pic) -{ - struct pic_var *var; - pic_value v; - - pic_get_args(pic, "o", &v); - - pic_assert_type(pic, v, var); - - var = pic_var_ptr(v); - - return pic_var_ref(pic, var); -} - -static pic_value -pic_var_parameter_set(pic_state *pic) -{ - struct pic_var *var; - pic_value v, val; - - pic_get_args(pic, "oo", &v, &val); - - pic_assert_type(pic, v, var); - - var = pic_var_ptr(v); - pic_var_set(pic, var, val); - return pic_none_value(); -} - -static pic_value -pic_var_parameter_push(pic_state *pic) -{ - struct pic_var *var; - pic_value v, val; - - pic_get_args(pic, "oo", &v, &val); - - pic_assert_type(pic, v, var); - - var = pic_var_ptr(v); - pic_var_push(pic, var, val); - return pic_none_value(); -} - -static pic_value -pic_var_parameter_pop(pic_state *pic) -{ - struct pic_var *var; - pic_value v; - - pic_get_args(pic, "o", &v); - - pic_assert_type(pic, v, var); - - var = pic_var_ptr(v); - pic_var_pop(pic, var); - return pic_none_value(); -} - -void -pic_init_var(pic_state *pic) -{ - pic_deflibrary (pic, "(picrin parameter)") { - pic_defun(pic, "make-parameter", pic_var_make_parameter); - pic_defun(pic, "parameter-ref", pic_var_parameter_ref); - pic_defun(pic, "parameter-set!", pic_var_parameter_set); - pic_defun(pic, "parameter-push!", pic_var_parameter_push); - pic_defun(pic, "parameter-pop!", pic_var_parameter_pop); - } -} diff --git a/src/vector.c b/src/vector.c deleted file mode 100644 index d57214e7..00000000 --- a/src/vector.c +++ /dev/null @@ -1,283 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include "picrin.h" -#include "picrin/vector.h" -#include "picrin/pair.h" - -struct pic_vector * -pic_vec_new(pic_state *pic, size_t len) -{ - struct pic_vector *vec; - size_t i; - - vec = (struct pic_vector *)pic_obj_alloc(pic, sizeof(struct pic_vector), PIC_TT_VECTOR); - vec->len = len; - vec->data = (pic_value *)pic_alloc(pic, sizeof(pic_value) * len); - for (i = 0; i < len; ++i) { - vec->data[i] = pic_none_value(); - } - return vec; -} - -struct pic_vector * -pic_vec_new_from_list(pic_state *pic, pic_value data) -{ - struct pic_vector *vec; - size_t i, len; - - len = pic_length(pic, data); - - vec = pic_vec_new(pic, len); - for (i = 0; i < len; ++i) { - vec->data[i] = pic_car(pic, data); - data = pic_cdr(pic, data); - } - return vec; -} - -void -pic_vec_extend_ip(pic_state *pic, struct pic_vector *vec, size_t size) -{ - size_t len, i; - - len = vec->len; - vec->len = size; - vec->data = (pic_value *)pic_realloc(pic, vec->data, sizeof(pic_value) * size); - for (i = len; i < size; ++i) { - vec->data[i] = pic_none_value(); - } -} - -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)); -} - -static pic_value -pic_vec_make_vector(pic_state *pic) -{ - pic_value v; - int n, k; - size_t i; - struct pic_vector *vec; - - n = pic_get_args(pic, "i|o", &k, &v); - - vec = pic_vec_new(pic, k); - if (n == 2) { - for (i = 0; i < (size_t)k; ++i) { - vec->data[i] = v; - } - } - return pic_obj_value(vec); -} - -static pic_value -pic_vec_vector_length(pic_state *pic) -{ - struct pic_vector *v; - - pic_get_args(pic, "v", &v); - - return pic_int_value(v->len); -} - -static pic_value -pic_vec_vector_ref(pic_state *pic) -{ - struct pic_vector *v; - int k; - - pic_get_args(pic, "vi", &v, &k); - - if (k < 0 || v->len <= (size_t)k) { - pic_error(pic, "vector-ref: index out of range"); - } - return v->data[k]; -} - -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 (k < 0 || v->len <= (size_t)k) { - pic_error(pic, "vector-set!: index out of range"); - } - v->data[k] = o; - return pic_none_value(); -} - -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_none_value(); - } - - while (start < end) { - to->data[at++] = from->data[start++]; - } - - return pic_none_value(); -} - -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; - } - - to = pic_vec_new(pic, end - start); - while (start < end) { - to->data[i++] = vec->data[start++]; - } - - return pic_obj_value(to); -} - -static pic_value -pic_vec_vector_append(pic_state *pic) -{ - size_t argc, i, j, len; - pic_value *argv; - 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_vec_new(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_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_none_value(); -} - -static pic_value -pic_vec_list_to_vector(pic_state *pic) -{ - struct pic_vector *vec; - pic_value list, e, *data; - - pic_get_args(pic, "o", &list); - - vec = pic_vec_new(pic, pic_length(pic, list)); - - data = vec->data; - - pic_for_each (e, list) { - *data++ = e; - } - return pic_obj_value(vec); -} - -static pic_value -pic_vec_vector_to_list(pic_state *pic) -{ - struct pic_vector *vec; - pic_value list; - int n, start, end, i; - - n = pic_get_args(pic, "v|ii", &vec, &start, &end); - - switch (n) { - case 1: - start = 0; - case 2: - end = vec->len; - } - - list = pic_nil_value(); - - for (i = start; i < end; ++i) { - pic_push(pic, vec->data[i], list); - } - return pic_reverse(pic, list); -} - -void -pic_init_vector(pic_state *pic) -{ - pic_defun(pic, "vector?", pic_vec_vector_p); - pic_defun(pic, "make-vector", pic_vec_make_vector); - pic_defun(pic, "vector-length", pic_vec_vector_length); - pic_defun(pic, "vector-ref", pic_vec_vector_ref); - pic_defun(pic, "vector-set!", pic_vec_vector_set); - pic_defun(pic, "vector-copy!", pic_vec_vector_copy_i); - pic_defun(pic, "vector-copy", pic_vec_vector_copy); - pic_defun(pic, "vector-append", pic_vec_vector_append); - pic_defun(pic, "vector-fill!", pic_vec_vector_fill_i); - pic_defun(pic, "list->vector", pic_vec_list_to_vector); - pic_defun(pic, "vector->list", pic_vec_vector_to_list); -} diff --git a/src/vm.c b/src/vm.c deleted file mode 100644 index 2fcd74fc..00000000 --- a/src/vm.c +++ /dev/null @@ -1,1069 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include -#include -#include -#include - -#include "picrin.h" -#include "picrin/pair.h" -#include "picrin/string.h" -#include "picrin/vector.h" -#include "picrin/proc.h" -#include "picrin/port.h" -#include "picrin/irep.h" -#include "picrin/blob.h" -#include "picrin/var.h" -#include "picrin/lib.h" -#include "picrin/macro.h" -#include "picrin/error.h" -#include "picrin/dict.h" -#include "picrin/record.h" - -#define GET_OPERAND(pic,n) ((pic)->ci->fp[(n)]) - -struct pic_proc * -pic_get_proc(pic_state *pic) -{ - pic_value v = GET_OPERAND(pic,0); - - if (! pic_proc_p(v)) { - pic_error(pic, "fatal error"); - } - return pic_proc_ptr(v); -} - -/** - * char type - * ---- ---- - * o object - * i int - * I int with exactness - * f float - * F float with exactness - * s string object - * z c string - * m symbol - * v vector object - * b bytevector object - * c char - * l lambda object - * p port object - * d dictionary object - * e error object - * - * | optional operator - * * variable length operator - */ - -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_errorf(pic, "pic_get_args: expected float or int, but got ~s", v); - } - 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_errorf(pic, "pic_get_args: expected float or int, but got ~s", v); - } - 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_errorf(pic, "pic_get_args: expected float or int, but got ~s", v); - } - 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_errorf(pic, "pic_get_args: expected int, but got ~s", v); - } - 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_errorf(pic, "pic_get_args: expected string, but got ~s", v); - } - i++; - } - break; - } - case 'z': { - const char **cstr; - pic_value v; - - cstr = va_arg(ap, const char **); - if (i < argc) { - v = GET_OPERAND(pic,i); - if (! pic_str_p(v)) { - pic_errorf(pic, "pic_get_args: expected string, but got ~s", v); - } - *cstr = pic_str_cstr(pic_str_ptr(v)); - 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_errorf(pic, "pic_get_args: expected symbol, but got ~s", v); - } - 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_errorf(pic, "pic_get_args: expected vector, but got ~s", v); - } - 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_errorf(pic, "pic_get_args: expected bytevector, but got ~s", v); - } - 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_errorf(pic, "pic_get_args: expected char, but got ~s", v); - } - 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_errorf(pic, "pic_get_args, expected procedure, but got ~s", v); - } - 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_errorf(pic, "pic_get_args, expected port, but got ~s", v); - } - i++; - } - break; - } - case 'd': { - struct pic_dict **d; - pic_value v; - - d = va_arg(ap, struct pic_dict **); - if (i < argc) { - v = GET_OPERAND(pic,i); - if (pic_dict_p(v)) { - *d = pic_dict_ptr(v); - } - else { - pic_errorf(pic, "pic_get_args, expected dictionary, but got ~s", v); - } - i++; - } - break; - } - case 'r': { - struct pic_record **r; - pic_value v; - - r = va_arg(ap, struct pic_record **); - if (i < argc) { - v = GET_OPERAND(pic,i); - if (pic_record_p(v)) { - *r = pic_record_ptr(v); - } - else { - pic_errorf(pic, "pic_get_args: expected record, but got ~s", v); - } - i++; - } - break; - } - case 'e': { - struct pic_error **e; - pic_value v; - - e = va_arg(ap, struct pic_error **); - if (i < argc) { - v = GET_OPERAND(pic,i); - if (pic_error_p(v)) { - *e = pic_error_ptr(v); - } - else { - pic_error(pic, "pic_get_args, expected error"); - } - i++; - } - break; - } - default: - pic_errorf(pic, "pic_get_args: invalid argument specifier '%c' given", c); - } - } - 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; - } - } - else if (argc > i) { - pic_error(pic, "wrong number of arguments"); - } - va_end(ap); - return i - 1; -} - -void -pic_define(pic_state *pic, const char *name, pic_value val) -{ - pic_sym sym, rename; - - sym = pic_intern_cstr(pic, name); - - if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) { - rename = pic_add_rename(pic, pic->lib->env, sym); - } else { - pic_warn(pic, "redefining global"); - } - - /* push to the global arena */ - xh_put_int(&pic->globals, rename, &val); - - /* export! */ - pic_export(pic, sym); -} - -pic_value -pic_ref(pic_state *pic, const char *name) -{ - pic_sym sym, rename; - - sym = pic_intern_cstr(pic, name); - - if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) { - pic_errorf(pic, "symbol \"%s\" not defined", name); - } - - return xh_val(xh_get_int(&pic->globals, rename), pic_value); -} - -pic_value -pic_funcall(pic_state *pic, const char *name, pic_list args) -{ - pic_value proc; - - proc = pic_ref(pic, name); - - pic_assert_type(pic, proc, proc); - - return pic_apply(pic, pic_proc_ptr(proc), args); -} - -void -pic_defun(pic_state *pic, const char *name, pic_func_t cfunc) -{ - struct pic_proc *proc; - - proc = pic_proc_new(pic, cfunc, name); - pic_define(pic, name, pic_obj_value(proc)); -} - -static void -vm_push_env(pic_state *pic) -{ - pic_callinfo *ci = pic->ci; - - ci->env = (struct pic_env *)pic_obj_alloc(pic, offsetof(struct pic_env, storage) + sizeof(pic_value) * ci->regc, PIC_TT_ENV); - ci->env->up = ci->up; - ci->env->regc = ci->regc; - ci->env->regs = ci->regs; -} - -static void -vm_tear_off(pic_callinfo *ci) -{ - struct pic_env *env; - int i; - - assert(ci->env != NULL); - - env = ci->env; - - if (env->regs == env->storage) { - return; /* is torn off */ - } - for (i = 0; i < env->regc; ++i) { - env->storage[i] = env->regs[i]; - } - env->regs = env->storage; -} - -void -pic_vm_tear_off(pic_state *pic) -{ - pic_callinfo *ci; - - for (ci = pic->ci; ci > pic->cibase; ci--) { - if (ci->env != NULL) { - vm_tear_off(ci); - } - } -} - -pic_value -pic_apply0(pic_state *pic, struct pic_proc *proc) -{ - return pic_apply(pic, proc, pic_nil_value()); -} - -pic_value -pic_apply1(pic_state *pic, struct pic_proc *proc, pic_value arg1) -{ - return pic_apply(pic, proc, pic_list1(pic, arg1)); -} - -pic_value -pic_apply2(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2) -{ - return pic_apply(pic, proc, pic_list2(pic, arg1, arg2)); -} - -pic_value -pic_apply3(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2, pic_value arg3) -{ - return pic_apply(pic, proc, pic_list3(pic, arg1, arg2, arg3)); -} - -pic_value -pic_apply4(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4) -{ - return pic_apply(pic, proc, pic_list4(pic, arg1, arg2, arg3, arg4)); -} - -pic_value -pic_apply5(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4, pic_value arg5) -{ - return pic_apply(pic, proc, pic_list5(pic, arg1, arg2, arg3, arg4, arg5)); -} - -#if VM_DEBUG -# define OPCODE_EXEC_HOOK pic_dump_code(c) -#else -# define OPCODE_EXEC_HOOK ((void)0) -#endif - -#if PIC_DIRECT_THREADED_VM -# define VM_LOOP JUMP; -# define CASE(x) L_##x: OPCODE_EXEC_HOOK; -# define NEXT pic->ip++; JUMP; -# define JUMP c = *pic->ip; goto *oplabels[c.insn]; -# define VM_LOOP_END -#else -# define VM_LOOP for (;;) { c = *pic->ip; switch (c.insn) { -# define CASE(x) case x: -# define NEXT pic->ip++; break -# define JUMP break -# define VM_LOOP_END } } -#endif - -#define PUSH(v) ((pic->sp >= pic->stend) ? abort() : (*pic->sp++ = (v))) -#define POP() (*--pic->sp) - -#define PUSHCI() (++pic->ci) -#define POPCI() (pic->ci--) - -pic_value -pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) -{ - pic_code c; - size_t ai = pic_gc_arena_preserve(pic); - size_t argc, i; - pic_code boot[2]; - -#if PIC_DIRECT_THREADED_VM - static void *oplabels[] = { - &&L_OP_NOP, &&L_OP_POP, &&L_OP_PUSHNIL, &&L_OP_PUSHTRUE, &&L_OP_PUSHFALSE, - &&L_OP_PUSHINT, &&L_OP_PUSHCHAR, &&L_OP_PUSHCONST, - &&L_OP_GREF, &&L_OP_GSET, &&L_OP_LREF, &&L_OP_LSET, &&L_OP_CREF, &&L_OP_CSET, - &&L_OP_JMP, &&L_OP_JMPIF, &&L_OP_NOT, &&L_OP_CALL, &&L_OP_TAILCALL, &&L_OP_RET, - &&L_OP_LAMBDA, &&L_OP_CONS, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_NILP, - &&L_OP_ADD, &&L_OP_SUB, &&L_OP_MUL, &&L_OP_DIV, &&L_OP_MINUS, - &&L_OP_EQ, &&L_OP_LT, &&L_OP_LE, &&L_OP_STOP - }; -#endif - - if (! pic_list_p(argv)) { - pic_error(pic, "argv must be a proper list"); - } - - argc = pic_length(pic, argv) + 1; - -#if VM_DEBUG - puts("### booting VM... ###"); - pic_value *stbase = pic->sp; - pic_callinfo *cibase = pic->ci; -#endif - - PUSH(pic_obj_value(proc)); - for (i = 1; i < argc; ++i) { - PUSH(pic_car(pic, argv)); - argv = pic_cdr(pic, argv); - } - - /* boot! */ - boot[0].insn = OP_CALL; - boot[0].u.i = argc; - boot[1].insn = OP_STOP; - pic->ip = boot; - - VM_LOOP { - CASE(OP_NOP) { - NEXT; - } - CASE(OP_POP) { - POP(); - NEXT; - } - CASE(OP_PUSHNIL) { - PUSH(pic_nil_value()); - NEXT; - } - CASE(OP_PUSHTRUE) { - PUSH(pic_true_value()); - NEXT; - } - CASE(OP_PUSHFALSE) { - PUSH(pic_false_value()); - NEXT; - } - CASE(OP_PUSHINT) { - PUSH(pic_int_value(c.u.i)); - NEXT; - } - CASE(OP_PUSHCHAR) { - PUSH(pic_char_value(c.u.c)); - NEXT; - } - CASE(OP_PUSHCONST) { - pic_value self; - struct pic_irep *irep; - - self = pic->ci->fp[0]; - if (! pic_proc_p(self)) { - pic_error(pic, "logic flaw"); - } - irep = pic_proc_ptr(self)->u.irep; - if (! pic_proc_irep_p(pic_proc_ptr(self))) { - pic_error(pic, "logic flaw"); - } - PUSH(irep->pool[c.u.i]); - NEXT; - } - CASE(OP_GREF) { - xh_entry *e; - - if ((e = xh_get_int(&pic->globals, c.u.i)) == NULL) { - pic_errorf(pic, "logic flaw; reference to uninitialized global variable: ~s", pic_symbol_name(pic, c.u.i)); - } - PUSH(xh_val(e, pic_value)); - NEXT; - } - CASE(OP_GSET) { - pic_value val; - - val = POP(); - xh_put_int(&pic->globals, c.u.i, &val); - NEXT; - } - CASE(OP_LREF) { - pic_callinfo *ci = pic->ci; - - if (ci->env != NULL && ci->env->regs == ci->env->storage) { - PUSH(ci->env->regs[c.u.i - (ci->regs - ci->fp)]); - NEXT; - } - PUSH(pic->ci->fp[c.u.i]); - NEXT; - } - CASE(OP_LSET) { - pic_callinfo *ci = pic->ci; - - if (ci->env != NULL && ci->env->regs == ci->env->storage) { - ci->env->regs[c.u.i - (ci->regs - ci->fp)] = POP(); - NEXT; - } - pic->ci->fp[c.u.i] = POP(); - NEXT; - } - CASE(OP_CREF) { - int depth = c.u.r.depth; - struct pic_env *env; - - env = pic->ci->up; - while (--depth) { - env = env->up; - } - PUSH(env->regs[c.u.r.idx]); - NEXT; - } - CASE(OP_CSET) { - int depth = c.u.r.depth; - struct pic_env *env; - - env = pic->ci->up; - while (--depth) { - env = env->up; - } - env->regs[c.u.r.idx] = POP(); - NEXT; - } - CASE(OP_JMP) { - pic->ip += c.u.i; - JUMP; - } - CASE(OP_JMPIF) { - pic_value v; - - v = POP(); - if (! pic_false_p(v)) { - pic->ip += c.u.i; - JUMP; - } - NEXT; - } - CASE(OP_NOT) { - pic_value v; - - v = pic_false_p(POP()) ? pic_true_value() : pic_false_value(); - PUSH(v); - NEXT; - } - CASE(OP_CALL) { - pic_value x, v; - pic_callinfo *ci; - struct pic_proc *proc; - - if (c.u.i == -1) { - pic->sp += pic->ci[1].retc - 1; - c.u.i = pic->ci[1].retc + 1; - } - - L_CALL: - x = pic->sp[-c.u.i]; - if (! pic_proc_p(x)) { - - if (pic_var_p(x)) { - if (c.u.i != 1) { - pic_errorf(pic, "invalid call-sequence for var object"); - } - POP(); - PUSH(pic_var_ref(pic, pic_var_ptr(x))); - NEXT; - } - pic_errorf(pic, "invalid application: ~s", x); - } - proc = pic_proc_ptr(x); - -#if VM_DEBUG - puts("\n== calling proc..."); - printf(" proc = "); - pic_debug(pic, pic_obj_value(proc)); - puts(""); - printf(" argv = ("); - for (short i = 1; i < c.u.i; ++i) { - if (i > 1) - printf(" "); - pic_debug(pic, pic->sp[-c.u.i + i]); - } - puts(")"); - if (! pic_proc_func_p(proc)) { - printf(" irep = %p\n", proc->u.irep); - printf(" name = %s\n", pic_symbol_name(pic, pic_proc_name(proc))); - pic_dump_irep(proc->u.irep); - } - else { - printf(" cfunc = %p\n", (void *)proc->u.func.f); - printf(" name = %s\n", pic_symbol_name(pic, pic_proc_name(proc))); - } - puts("== end\n"); -#endif - - ci = PUSHCI(); - ci->argc = c.u.i; - ci->retc = 1; - ci->ip = pic->ip; - ci->fp = pic->sp - c.u.i; - ci->env = NULL; - if (pic_proc_func_p(pic_proc_ptr(x))) { - - /* invoke! */ - v = proc->u.func.f(pic); - pic->sp[0] = v; - pic->sp += pic->ci->retc; - - pic_gc_arena_restore(pic, ai); - goto L_RET; - } - else { - struct pic_irep *irep = proc->u.irep; - int i; - pic_value rest; - - if (ci->argc != irep->argc) { - if (! (irep->varg && ci->argc >= irep->argc)) { - pic_errorf(pic, "wrong number of arguments (%d for %d%s)", ci->argc - 1, irep->argc - 1, (irep->varg ? "+" : "")); - } - } - /* prepare rest args */ - if (irep->varg) { - rest = pic_nil_value(); - for (i = 0; i < ci->argc - irep->argc; ++i) { - pic_gc_protect(pic, v = POP()); - rest = pic_cons(pic, v, rest); - } - PUSH(rest); - } - /* prepare local variable area */ - if (irep->localc > 0) { - int l = irep->localc; - if (irep->varg) { - --l; - } - for (i = 0; i < l; ++i) { - PUSH(pic_undef_value()); - } - } - - /* prepare env */ - ci->up = proc->env; - ci->regc = irep->capturec; - ci->regs = ci->fp + irep->argc + irep->localc; - - pic->ip = irep->code; - pic_gc_arena_restore(pic, ai); - JUMP; - } - } - CASE(OP_TAILCALL) { - int i, argc; - pic_value *argv; - pic_callinfo *ci; - - if (pic->ci->env != NULL) { - vm_tear_off(pic->ci); - } - - if (c.u.i == -1) { - pic->sp += pic->ci[1].retc - 1; - c.u.i = pic->ci[1].retc + 1; - } - - argc = c.u.i; - argv = pic->sp - argc; - for (i = 0; i < argc; ++i) { - pic->ci->fp[i] = argv[i]; - } - ci = POPCI(); - pic->sp = ci->fp + argc; - pic->ip = ci->ip; - - /* c is not changed */ - goto L_CALL; - } - CASE(OP_RET) { - int i, retc; - pic_value *retv; - pic_callinfo *ci; - - if (pic->ci->env != NULL) { - vm_tear_off(pic->ci); - } - - pic->ci->retc = c.u.i; - - L_RET: - retc = pic->ci->retc; - retv = pic->sp - retc; - if (retc == 0) { - pic->ci->fp[0] = retv[0]; /* copy at least once */ - } - for (i = 0; i < retc; ++i) { - pic->ci->fp[i] = retv[i]; - } - ci = POPCI(); - pic->sp = ci->fp + 1; /* advance only one! */ - pic->ip = ci->ip; - - NEXT; - } - CASE(OP_LAMBDA) { - pic_value self; - struct pic_irep *irep; - struct pic_proc *proc; - - self = pic->ci->fp[0]; - if (! pic_proc_p(self)) { - pic_error(pic, "logic flaw"); - } - irep = pic_proc_ptr(self)->u.irep; - if (! pic_proc_irep_p(pic_proc_ptr(self))) { - pic_error(pic, "logic flaw"); - } - - if (pic->ci->env == NULL) { - vm_push_env(pic); - } - - proc = pic_proc_new_irep(pic, irep->irep[c.u.i], pic->ci->env); - PUSH(pic_obj_value(proc)); - pic_gc_arena_restore(pic, ai); - NEXT; - } - CASE(OP_CONS) { - pic_value a, b; - pic_gc_protect(pic, b = POP()); - pic_gc_protect(pic, a = POP()); - PUSH(pic_cons(pic, a, b)); - pic_gc_arena_restore(pic, ai); - NEXT; - } - CASE(OP_CAR) { - pic_value p; - p = POP(); - PUSH(pic_car(pic, p)); - NEXT; - } - CASE(OP_CDR) { - pic_value p; - p = POP(); - PUSH(pic_cdr(pic, p)); - NEXT; - } - CASE(OP_NILP) { - pic_value p; - p = POP(); - PUSH(pic_bool_value(pic_nil_p(p))); - NEXT; - } - -#define DEFINE_ARITH_OP(opcode, op, guard) \ - CASE(opcode) { \ - pic_value a, b; \ - b = POP(); \ - a = POP(); \ - if (pic_int_p(a) && pic_int_p(b)) { \ - double f = (double)pic_int(a) op (double)pic_int(b); \ - if (INT_MIN <= f && f <= INT_MAX && (guard)) { \ - PUSH(pic_int_value((int)f)); \ - } \ - else { \ - PUSH(pic_float_value(f)); \ - } \ - } \ - else if (pic_float_p(a) && pic_float_p(b)) { \ - PUSH(pic_float_value(pic_float(a) op pic_float(b))); \ - } \ - else if (pic_int_p(a) && pic_float_p(b)) { \ - PUSH(pic_float_value(pic_int(a) op pic_float(b))); \ - } \ - else if (pic_float_p(a) && pic_int_p(b)) { \ - PUSH(pic_float_value(pic_float(a) op pic_int(b))); \ - } \ - else { \ - pic_error(pic, #op " got non-number operands"); \ - } \ - NEXT; \ - } - - DEFINE_ARITH_OP(OP_ADD, +, true); - DEFINE_ARITH_OP(OP_SUB, -, true); - DEFINE_ARITH_OP(OP_MUL, *, true); - DEFINE_ARITH_OP(OP_DIV, /, f == round(f)); - - CASE(OP_MINUS) { - pic_value n; - n = POP(); - if (pic_int_p(n)) { - PUSH(pic_int_value(-pic_int(n))); - } - else if (pic_float_p(n)) { - PUSH(pic_float_value(-pic_float(n))); - } - else { - pic_error(pic, "unary - got a non-number operand"); - } - NEXT; - } - -#define DEFINE_COMP_OP(opcode, op) \ - CASE(opcode) { \ - pic_value a, b; \ - b = POP(); \ - a = POP(); \ - if (pic_int_p(a) && pic_int_p(b)) { \ - PUSH(pic_bool_value(pic_int(a) op pic_int(b))); \ - } \ - else if (pic_float_p(a) && pic_float_p(b)) { \ - PUSH(pic_bool_value(pic_float(a) op pic_float(b))); \ - } \ - else if (pic_int_p(a) && pic_float_p(b)) { \ - PUSH(pic_bool_value(pic_int(a) op pic_float(b))); \ - } \ - else if (pic_float_p(a) && pic_int_p(b)) { \ - PUSH(pic_bool_value(pic_float(a) op pic_int(b))); \ - } \ - else { \ - pic_error(pic, #op " got non-number operands"); \ - } \ - NEXT; \ - } - - DEFINE_COMP_OP(OP_EQ, ==); - DEFINE_COMP_OP(OP_LT, <); - DEFINE_COMP_OP(OP_LE, <=); - - CASE(OP_STOP) { - -#if VM_DEBUG - puts("**VM END STATE**"); - printf("stbase\t= %p\nsp\t= %p\n", (void *)stbase, (void *)pic->sp); - printf("cibase\t= %p\nci\t= %p\n", (void *)cibase, (void *)pic->ci); - if (stbase < pic->sp - 1) { - pic_value *sp; - printf("* stack trace:"); - for (sp = stbase; pic->sp != sp; ++sp) { - pic_debug(pic, *sp); - puts(""); - } - } - if (stbase > pic->sp - 1) { - puts("*** stack underflow!"); - } -#endif - - return pic_gc_protect(pic, POP()); - } - } VM_LOOP_END; -} - -pic_value -pic_apply_trampoline(pic_state *pic, struct pic_proc *proc, pic_value args) -{ - static const pic_code iseq[2] = { - { OP_NOP, {} }, - { OP_TAILCALL, { .i = -1 } } - }; - - pic_value v, *sp; - pic_callinfo *ci; - - *pic->sp++ = pic_obj_value(proc); - - sp = pic->sp; - pic_for_each (v, args) { - *sp++ = v; - } - - ci = PUSHCI(); - ci->ip = (pic_code *)iseq; - ci->fp = pic->sp; - ci->retc = pic_length(pic, args); - - if (ci->retc == 0) { - return pic_none_value(); - } else { - return pic_car(pic, args); - } -} diff --git a/src/write.c b/src/write.c deleted file mode 100644 index 70a547b9..00000000 --- a/src/write.c +++ /dev/null @@ -1,506 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include - -#include "picrin.h" -#include "picrin/port.h" -#include "picrin/pair.h" -#include "picrin/string.h" -#include "picrin/vector.h" -#include "picrin/blob.h" -#include "picrin/dict.h" -#include "picrin/record.h" -#include "picrin/proc.h" - -static bool -is_tagged(pic_state *pic, pic_sym tag, pic_value pair) -{ - return pic_pair_p(pic_cdr(pic, pair)) - && pic_nil_p(pic_cddr(pic, pair)) - && pic_eq_p(pic_car(pic, pair), pic_symbol_value(tag)); -} - -static bool -is_quote(pic_state *pic, pic_value pair) -{ - return is_tagged(pic, pic->sQUOTE, pair); -} - -static bool -is_unquote(pic_state *pic, pic_value pair) -{ - return is_tagged(pic, pic->sUNQUOTE, pair); -} - -static bool -is_unquote_splicing(pic_state *pic, pic_value pair) -{ - return is_tagged(pic, pic->sUNQUOTE_SPLICING, pair); -} - -static bool -is_quasiquote(pic_state *pic, pic_value pair) -{ - return is_tagged(pic, pic->sQUASIQUOTE, pair); -} - -struct writer_control { - pic_state *pic; - xFILE *file; - int mode; - xhash labels; /* object -> int */ - xhash visited; /* object -> int */ - int cnt; -}; - -#define WRITE_MODE 1 -#define DISPLAY_MODE 2 - -static void -writer_control_init(struct writer_control *p, pic_state *pic, xFILE *file, int mode) -{ - p->pic = pic; - p->file = file; - p->mode = mode; - p->cnt = 0; - xh_init_ptr(&p->labels, sizeof(int)); - xh_init_ptr(&p->visited, sizeof(int)); -} - -static void -writer_control_destroy(struct writer_control *p) -{ - xh_destroy(&p->labels); - xh_destroy(&p->visited); -} - -static void -traverse_shared(struct writer_control *p, pic_value obj) -{ - xh_entry *e; - size_t i; - int c; - - switch (pic_type(obj)) { - case PIC_TT_PAIR: - case PIC_TT_VECTOR: - e = xh_get_ptr(&p->labels, pic_obj_ptr(obj)); - if (e == NULL) { - c = -1; - xh_put_ptr(&p->labels, pic_obj_ptr(obj), &c); - } - else if (xh_val(e, int) == -1) { - c = p->cnt++; - xh_put_ptr(&p->labels, pic_obj_ptr(obj), &c); - break; - } - else { - break; - } - - if (pic_pair_p(obj)) { - traverse_shared(p, pic_car(p->pic, obj)); - traverse_shared(p, pic_cdr(p->pic, obj)); - } - else { - for (i = 0; i < pic_vec_ptr(obj)->len; ++i) { - traverse_shared(p, pic_vec_ptr(obj)->data[i]); - } - } - break; - default: - /* pass */ - break; - } -} - -static void write_core(struct writer_control *p, pic_value); - -static void -write_pair(struct writer_control *p, struct pic_pair *pair) -{ - xh_entry *e; - int c; - - write_core(p, pair->car); - - if (pic_nil_p(pair->cdr)) { - return; - } - else if (pic_pair_p(pair->cdr)) { - - /* shared objects */ - if ((e = xh_get_ptr(&p->labels, pic_obj_ptr(pair->cdr))) && xh_val(e, int) != -1) { - xfprintf(p->file, " . "); - - if ((xh_get_ptr(&p->visited, pic_obj_ptr(pair->cdr)))) { - xfprintf(p->file, "#%d#", xh_val(e, int)); - return; - } - else { - xfprintf(p->file, "#%d=", xh_val(e, int)); - c = 1; - xh_put_ptr(&p->visited, pic_obj_ptr(pair->cdr), &c); - } - } - else { - xfprintf(p->file, " "); - } - - write_pair(p, pic_pair_ptr(pair->cdr)); - return; - } - else { - xfprintf(p->file, " . "); - write_core(p, pair->cdr); - } -} - -static void -write_str(pic_state *pic, struct pic_string *str, xFILE *file) -{ - size_t i; - const char *cstr = pic_str_cstr(str); - - UNUSED(pic); - - for (i = 0; i < pic_strlen(str); ++i) { - if (cstr[i] == '"' || cstr[i] == '\\') { - xfputc('\\', file); - } - xfputc(cstr[i], file); - } -} - -static void -write_record(pic_state *pic, struct pic_record *rec, xFILE *file) -{ - const pic_sym sWRITER = pic_intern_cstr(pic, "writer"); - pic_value type, writer, str; - -#if DEBUG - - xfprintf(file, "#", rec); - -#else - - type = pic_record_type(pic, rec); - if (! pic_record_p(type)) { - pic_errorf(pic, "\"@@type\" property of record object is not of record type"); - } - writer = pic_record_ref(pic, pic_record_ptr(type), sWRITER); - if (! pic_proc_p(writer)) { - pic_errorf(pic, "\"writer\" property of record type object is not a procedure"); - } - str = pic_apply1(pic, pic_proc_ptr(writer), pic_obj_value(rec)); - if (! pic_str_p(str)) { - pic_errorf(pic, "return value from writer procedure is not of string type"); - } - xfprintf(file, "%s", pic_str_cstr(pic_str_ptr(str))); - -#endif -} - -static void -write_core(struct writer_control *p, pic_value obj) -{ - pic_state *pic = p->pic; - xFILE *file = p->file; - size_t i; - xh_entry *e; - xh_iter it; - int c; - float f; - - /* shared objects */ - if (pic_vtype(obj) == PIC_VTYPE_HEAP - && (e = xh_get_ptr(&p->labels, pic_obj_ptr(obj))) - && xh_val(e, int) != -1) { - if ((xh_get_ptr(&p->visited, pic_obj_ptr(obj)))) { - xfprintf(file, "#%d#", xh_val(e, int)); - return; - } - else { - xfprintf(file, "#%d=", xh_val(e, int)); - c = 1; - xh_put_ptr(&p->visited, pic_obj_ptr(obj), &c); - } - } - - switch (pic_type(obj)) { - case PIC_TT_UNDEF: - xfprintf(file, "#"); - break; - case PIC_TT_NIL: - xfprintf(file, "()"); - break; - case PIC_TT_BOOL: - if (pic_true_p(obj)) - xfprintf(file, "#t"); - else - xfprintf(file, "#f"); - break; - case PIC_TT_PAIR: - if (is_quote(pic, obj)) { - xfprintf(file, "'"); - write_core(p, pic_list_ref(pic, obj, 1)); - break; - } - else if (is_unquote(pic, obj)) { - xfprintf(file, ","); - write_core(p, pic_list_ref(pic, obj, 1)); - break; - } - else if (is_unquote_splicing(pic, obj)) { - xfprintf(file, ",@"); - write_core(p, pic_list_ref(pic, obj, 1)); - break; - } - else if (is_quasiquote(pic, obj)) { - xfprintf(file, "`"); - write_core(p, pic_list_ref(pic, obj, 1)); - break; - } - xfprintf(file, "("); - write_pair(p, pic_pair_ptr(obj)); - xfprintf(file, ")"); - break; - case PIC_TT_SYMBOL: - xfprintf(file, "%s", pic_symbol_name(pic, pic_sym(obj))); - break; - case PIC_TT_CHAR: - if (p->mode == DISPLAY_MODE) { - xfputc(pic_char(obj), file); - break; - } - switch (pic_char(obj)) { - default: xfprintf(file, "#\\%c", pic_char(obj)); break; - case '\a': xfprintf(file, "#\\alarm"); break; - case '\b': xfprintf(file, "#\\backspace"); break; - case 0x7f: xfprintf(file, "#\\delete"); break; - case 0x1b: xfprintf(file, "#\\escape"); break; - case '\n': xfprintf(file, "#\\newline"); break; - case '\r': xfprintf(file, "#\\return"); break; - case ' ': xfprintf(file, "#\\space"); break; - case '\t': xfprintf(file, "#\\tab"); break; - } - break; - case PIC_TT_FLOAT: - f = pic_float(obj); - if (isnan(f)) { - xfprintf(file, signbit(f) ? "-nan.0" : "+nan.0"); - } else if (isinf(f)) { - xfprintf(file, signbit(f) ? "-inf.0" : "+inf.0"); - } else { - xfprintf(file, "%f", pic_float(obj)); - } - break; - case PIC_TT_INT: - xfprintf(file, "%d", pic_int(obj)); - break; - case PIC_TT_EOF: - xfprintf(file, "#.(eof-object)"); - break; - case PIC_TT_STRING: - if (p->mode == DISPLAY_MODE) { - xfprintf(file, "%s", pic_str_cstr(pic_str_ptr(obj))); - break; - } - xfprintf(file, "\""); - write_str(pic, pic_str_ptr(obj), file); - xfprintf(file, "\""); - break; - case PIC_TT_VECTOR: - xfprintf(file, "#("); - for (i = 0; i < pic_vec_ptr(obj)->len; ++i) { - write_core(p, pic_vec_ptr(obj)->data[i]); - if (i + 1 < pic_vec_ptr(obj)->len) { - xfprintf(file, " "); - } - } - xfprintf(file, ")"); - break; - case PIC_TT_BLOB: - xfprintf(file, "#u8("); - for (i = 0; i < pic_blob_ptr(obj)->len; ++i) { - xfprintf(file, "%d", pic_blob_ptr(obj)->data[i]); - if (i + 1 < pic_blob_ptr(obj)->len) { - xfprintf(file, " "); - } - } - xfprintf(file, ")"); - break; - case PIC_TT_DICT: - xfprintf(file, "#.(dictionary"); - xh_begin(&it, &pic_dict_ptr(obj)->hash); - while (xh_next(&it)) { - xfprintf(file, " '%s ", pic_symbol_name(pic, xh_key(it.e, pic_sym))); - write_core(p, xh_val(it.e, pic_value)); - } - xfprintf(file, ")"); - break; - case PIC_TT_RECORD: - write_record(pic, pic_record_ptr(obj), file); - break; - default: - xfprintf(file, "#<%s %p>", pic_type_repr(pic_type(obj)), pic_ptr(obj)); - break; - } -} - -static void -write(pic_state *pic, pic_value obj, xFILE *file) -{ - struct writer_control p; - - writer_control_init(&p, pic, file, WRITE_MODE); - - traverse_shared(&p, obj); /* FIXME */ - - write_core(&p, obj); - - writer_control_destroy(&p); -} - -static void -write_simple(pic_state *pic, pic_value obj, xFILE *file) -{ - struct writer_control p; - - writer_control_init(&p, pic, file, WRITE_MODE); - - /* no traverse here! */ - - write_core(&p, obj); - - writer_control_destroy(&p); -} - -static void -write_shared(pic_state *pic, pic_value obj, xFILE *file) -{ - struct writer_control p; - - writer_control_init(&p, pic, file, WRITE_MODE); - - traverse_shared(&p, obj); - - write_core(&p, obj); - - writer_control_destroy(&p); -} - -static void -display(pic_state *pic, pic_value obj, xFILE *file) -{ - struct writer_control p; - - writer_control_init(&p, pic, file, DISPLAY_MODE); - - traverse_shared(&p, obj); /* FIXME */ - - write_core(&p, obj); - - writer_control_destroy(&p); -} - -pic_value -pic_write(pic_state *pic, pic_value obj) -{ - return pic_fwrite(pic, obj, xstdout); -} - -pic_value -pic_fwrite(pic_state *pic, pic_value obj, xFILE *file) -{ - write(pic, obj, file); - xfflush(file); - return obj; -} - -pic_value -pic_display(pic_state *pic, pic_value obj) -{ - return pic_fdisplay(pic, obj, xstdout); -} - -pic_value -pic_fdisplay(pic_state *pic, pic_value obj, xFILE *file) -{ - display(pic, obj, file); - xfflush(file); - return obj; -} - -void -pic_printf(pic_state *pic, const char *fmt, ...) -{ - va_list ap; - pic_str *str; - - va_start(ap, fmt); - - str = pic_str_ptr(pic_car(pic, pic_vformat(pic, fmt, ap))); - - va_end(ap); - - xprintf("%s", pic_str_cstr(str)); - xfflush(xstdout); -} - -static pic_value -pic_write_write(pic_state *pic) -{ - pic_value v; - struct pic_port *port = pic_stdout(pic); - - pic_get_args(pic, "o|p", &v, &port); - write(pic, v, port->file); - return pic_none_value(); -} - -static pic_value -pic_write_write_simple(pic_state *pic) -{ - pic_value v; - struct pic_port *port = pic_stdout(pic); - - pic_get_args(pic, "o|p", &v, &port); - write_simple(pic, v, port->file); - return pic_none_value(); -} - -static pic_value -pic_write_write_shared(pic_state *pic) -{ - pic_value v; - struct pic_port *port = pic_stdout(pic); - - pic_get_args(pic, "o|p", &v, &port); - write_shared(pic, v, port->file); - return pic_none_value(); -} - -static pic_value -pic_write_display(pic_state *pic) -{ - pic_value v; - struct pic_port *port = pic_stdout(pic); - - pic_get_args(pic, "o|p", &v, &port); - display(pic, v, port->file); - return pic_none_value(); -} - -void -pic_init_write(pic_state *pic) -{ - pic_deflibrary (pic, "(scheme write)") { - pic_defun(pic, "write", pic_write_write); - pic_defun(pic, "write-simple", pic_write_write_simple); - pic_defun(pic, "write-shared", pic_write_write_shared); - pic_defun(pic, "display", pic_write_display); - } -}