diff --git a/extlib/benz/bool.c b/extlib/benz/bool.c index b5edfe98..33b6d0bf 100644 --- a/extlib/benz/bool.c +++ b/extlib/benz/bool.c @@ -189,11 +189,14 @@ pic_bool_boolean_eq_p(pic_state *pic) void pic_init_bool(pic_state *pic) { + void pic_defun_vm(pic_state *, const char *, pic_sym *, pic_func_t); + 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_vm(pic, "not", pic->rNOT, pic_bool_not); + pic_defun(pic, "boolean?", pic_bool_boolean_p); pic_defun(pic, "boolean=?", pic_bool_boolean_eq_p); } diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index d998eda9..ff53f12b 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -33,29 +33,11 @@ typedef struct analyze_scope { typedef struct analyze_state { pic_state *pic; analyze_scope *scope; - pic_sym *rCONS, *rCAR, *rCDR, *rNILP; - pic_sym *rSYMBOLP, *rPAIRP; - pic_sym *rADD, *rSUB, *rMUL, *rDIV; - pic_sym *rEQ, *rLT, *rLE, *rGT, *rGE, *rNOT; - pic_sym *rVALUES, *rCALL_WITH_VALUES; } 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_errorf(pic, "internal error! native VM procedure not found: %s", id); \ - } \ - state->slot = gsym; \ - } while (0) - static analyze_state * new_analyze_state(pic_state *pic) { @@ -67,26 +49,6 @@ new_analyze_state(pic_state *pic) state->pic = pic; state->scope = NULL; - /* native VM procedures */ - register_renamed_symbol(pic, state, rCONS, pic->PICRIN_BASE, "cons"); - register_renamed_symbol(pic, state, rCAR, pic->PICRIN_BASE, "car"); - register_renamed_symbol(pic, state, rCDR, pic->PICRIN_BASE, "cdr"); - register_renamed_symbol(pic, state, rNILP, pic->PICRIN_BASE, "null?"); - register_renamed_symbol(pic, state, rSYMBOLP, pic->PICRIN_BASE, "symbol?"); - register_renamed_symbol(pic, state, rPAIRP, pic->PICRIN_BASE, "pair?"); - register_renamed_symbol(pic, state, rADD, pic->PICRIN_BASE, "+"); - register_renamed_symbol(pic, state, rSUB, pic->PICRIN_BASE, "-"); - register_renamed_symbol(pic, state, rMUL, pic->PICRIN_BASE, "*"); - register_renamed_symbol(pic, state, rDIV, pic->PICRIN_BASE, "/"); - register_renamed_symbol(pic, state, rEQ, pic->PICRIN_BASE, "="); - register_renamed_symbol(pic, state, rLT, pic->PICRIN_BASE, "<"); - register_renamed_symbol(pic, state, rLE, pic->PICRIN_BASE, "<="); - register_renamed_symbol(pic, state, rGT, pic->PICRIN_BASE, ">"); - register_renamed_symbol(pic, state, rGE, pic->PICRIN_BASE, ">="); - register_renamed_symbol(pic, state, rNOT, pic->PICRIN_BASE, "not"); - register_renamed_symbol(pic, state, rVALUES, pic->PICRIN_BASE, "values"); - register_renamed_symbol(pic, state, rCALL_WITH_VALUES, pic->PICRIN_BASE, "call-with-values"); - /* push initial scope */ push_scope(state, pic_nil_value()); @@ -760,70 +722,70 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos) else if (sym == pic->rQUOTE) { return analyze_quote(state, obj); } - else if (sym == state->rCONS) { + else if (sym == pic->rCONS) { ARGC_ASSERT(2, "cons"); return CONSTRUCT_OP2(pic->sCONS); } - else if (sym == state->rCAR) { + else if (sym == pic->rCAR) { ARGC_ASSERT(1, "car"); return CONSTRUCT_OP1(pic->sCAR); } - else if (sym == state->rCDR) { + else if (sym == pic->rCDR) { ARGC_ASSERT(1, "cdr"); return CONSTRUCT_OP1(pic->sCDR); } - else if (sym == state->rNILP) { + else if (sym == pic->rNILP) { ARGC_ASSERT(1, "nil?"); return CONSTRUCT_OP1(pic->sNILP); } - else if (sym == state->rSYMBOLP) { + else if (sym == pic->rSYMBOLP) { ARGC_ASSERT(1, "symbol?"); return CONSTRUCT_OP1(pic->sSYMBOLP); } - else if (sym == state->rPAIRP) { + else if (sym == pic->rPAIRP) { ARGC_ASSERT(1, "pair?"); return CONSTRUCT_OP1(pic->sPAIRP); } - else if (sym == state->rADD) { + else if (sym == pic->rADD) { return analyze_add(state, obj, tailpos); } - else if (sym == state->rSUB) { + else if (sym == pic->rSUB) { return analyze_sub(state, obj); } - else if (sym == state->rMUL) { + else if (sym == pic->rMUL) { return analyze_mul(state, obj, tailpos); } - else if (sym == state->rDIV) { + else if (sym == pic->rDIV) { return analyze_div(state, obj); } - else if (sym == state->rEQ) { + else if (sym == pic->rEQ) { ARGC_ASSERT_WITH_FALLBACK(2); return CONSTRUCT_OP2(pic->sEQ); } - else if (sym == state->rLT) { + else if (sym == pic->rLT) { ARGC_ASSERT_WITH_FALLBACK(2); return CONSTRUCT_OP2(pic->sLT); } - else if (sym == state->rLE) { + else if (sym == pic->rLE) { ARGC_ASSERT_WITH_FALLBACK(2); return CONSTRUCT_OP2(pic->sLE); } - else if (sym == state->rGT) { + else if (sym == pic->rGT) { ARGC_ASSERT_WITH_FALLBACK(2); return CONSTRUCT_OP2(pic->sGT); } - else if (sym == state->rGE) { + else if (sym == pic->rGE) { ARGC_ASSERT_WITH_FALLBACK(2); return CONSTRUCT_OP2(pic->sGE); } - else if (sym == state->rNOT) { + else if (sym == pic->rNOT) { ARGC_ASSERT(1, "not"); return CONSTRUCT_OP1(pic->sNOT); } - else if (sym == state->rVALUES) { + else if (sym == pic->rVALUES) { return analyze_values(state, obj, tailpos); } - else if (sym == state->rCALL_WITH_VALUES) { + else if (sym == pic->rCALL_WITH_VALUES) { return analyze_call_with_values(state, obj, tailpos); } } diff --git a/extlib/benz/cont.c b/extlib/benz/cont.c index b331d0c6..dd021989 100644 --- a/extlib/benz/cont.c +++ b/extlib/benz/cont.c @@ -280,9 +280,12 @@ pic_cont_call_with_values(pic_state *pic) void pic_init_cont(pic_state *pic) { + void pic_defun_vm(pic_state *, const char *, pic_sym *, pic_func_t); + 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); + + pic_defun_vm(pic, "values", pic->rVALUES, pic_cont_values); + pic_defun_vm(pic, "call-with-values", pic->rCALL_WITH_VALUES, pic_cont_call_with_values); } diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index aedd9836..426a9256 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -521,6 +521,11 @@ gc_mark_global_symbols(pic_state *pic) M(rDEFINE_SYNTAX); M(rIMPORT); M(rEXPORT); M(rDEFINE_LIBRARY); M(rIN_LIBRARY); M(rCOND_EXPAND); + M(rCONS); M(rCAR); M(rCDR); M(rNILP); + M(rSYMBOLP); M(rPAIRP); + M(rADD); M(rSUB); M(rMUL); M(rDIV); + M(rEQ); M(rLT); M(rLE); M(rGT); M(rGE); M(rNOT); + M(rVALUES); M(rCALL_WITH_VALUES); } static void diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index faf3b29f..1d333a98 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -113,6 +113,11 @@ typedef struct { pic_sym *rDEFINE_SYNTAX, *rIMPORT, *rEXPORT; pic_sym *rDEFINE_LIBRARY, *rIN_LIBRARY; pic_sym *rCOND_EXPAND; + pic_sym *rCONS, *rCAR, *rCDR, *rNILP; + pic_sym *rSYMBOLP, *rPAIRP; + pic_sym *rADD, *rSUB, *rMUL, *rDIV; + pic_sym *rEQ, *rLT, *rLE, *rGT, *rGE, *rNOT; + pic_sym *rVALUES, *rCALL_WITH_VALUES; struct pic_lib *PICRIN_BASE; struct pic_lib *PICRIN_USER; diff --git a/extlib/benz/number.c b/extlib/benz/number.c index 1f02ca0c..80c7fab9 100644 --- a/extlib/benz/number.c +++ b/extlib/benz/number.c @@ -801,6 +801,8 @@ pic_number_sqrt(pic_state *pic) void pic_init_number(pic_state *pic) { + void pic_defun_vm(pic_state *, const char *, pic_sym *, pic_func_t); + size_t ai = pic_gc_arena_preserve(pic); pic_defun(pic, "number?", pic_number_real_p); @@ -814,17 +816,17 @@ pic_init_number(pic_state *pic) pic_defun(pic, "inexact?", pic_number_inexact_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_defun_vm(pic, "=", pic->rEQ, pic_number_eq); + pic_defun_vm(pic, "<", pic->rLT, pic_number_lt); + pic_defun_vm(pic, ">", pic->rGT, pic_number_gt); + pic_defun_vm(pic, "<=", pic->rLE, pic_number_le); + pic_defun_vm(pic, ">=", pic->rGE, pic_number_ge); 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_defun_vm(pic, "+", pic->rADD, pic_number_add); + pic_defun_vm(pic, "-", pic->rSUB, pic_number_sub); + pic_defun_vm(pic, "*", pic->rMUL, pic_number_mul); + pic_defun_vm(pic, "/", pic->rDIV, pic_number_div); pic_gc_arena_restore(pic, ai); pic_defun(pic, "abs", pic_number_abs); diff --git a/extlib/benz/pair.c b/extlib/benz/pair.c index 17da2394..c0b031af 100644 --- a/extlib/benz/pair.c +++ b/extlib/benz/pair.c @@ -760,13 +760,16 @@ pic_pair_assoc(pic_state *pic) void pic_init_pair(pic_state *pic) { - 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); + void pic_defun_vm(pic_state *, const char *, pic_sym *, pic_func_t); + + pic_defun_vm(pic, "pair?", pic->rPAIRP, pic_pair_pair_p); + pic_defun_vm(pic, "cons", pic->rCONS, pic_pair_cons); + pic_defun_vm(pic, "car", pic->rCAR, pic_pair_car); + pic_defun_vm(pic, "cdr", pic->rCDR, pic_pair_cdr); + pic_defun_vm(pic, "null?", pic->rNILP, pic_pair_null_p); + 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_defun(pic, "caar", pic_pair_caar); pic_defun(pic, "cadr", pic_pair_cadr); diff --git a/extlib/benz/state.c b/extlib/benz/state.c index 13a17e09..2dd19c2c 100644 --- a/extlib/benz/state.c +++ b/extlib/benz/state.c @@ -304,6 +304,24 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf) R(rDEFINE_LIBRARY, "define-library"); R(rIN_LIBRARY, "in-library"); R(rCOND_EXPAND, "cond-expand"); + R(rCONS, "cons"); + R(rCAR, "car"); + R(rCDR, "cdr"); + R(rNILP, "null?"); + R(rSYMBOLP, "symbol?"); + R(rPAIRP, "pair?"); + R(rADD, "+"); + R(rSUB, "-"); + R(rMUL, "*"); + R(rDIV, "/"); + R(rEQ, "="); + R(rLT, "<"); + R(rLE, "<="); + R(rGT, ">"); + R(rGE, ">="); + R(rNOT, "not"); + R(rVALUES, "values"); + R(rCALL_WITH_VALUES, "call-with-values"); pic_gc_arena_restore(pic, ai); /* root tables */ diff --git a/extlib/benz/symbol.c b/extlib/benz/symbol.c index 008c52b2..8298465d 100644 --- a/extlib/benz/symbol.c +++ b/extlib/benz/symbol.c @@ -119,7 +119,10 @@ pic_symbol_string_to_symbol(pic_state *pic) void pic_init_symbol(pic_state *pic) { - pic_defun(pic, "symbol?", pic_symbol_symbol_p); + void pic_defun_vm(pic_state *, const char *, pic_sym *, pic_func_t); + + pic_defun_vm(pic, "symbol?", pic->rSYMBOLP, pic_symbol_symbol_p); + pic_defun(pic, "symbol->string", pic_symbol_symbol_to_string); pic_defun(pic, "string->symbol", pic_symbol_string_to_symbol); diff --git a/extlib/benz/vm.c b/extlib/benz/vm.c index 91cedab6..17bf655f 100644 --- a/extlib/benz/vm.c +++ b/extlib/benz/vm.c @@ -466,6 +466,23 @@ pic_defun(pic_state *pic, const char *name, pic_func_t cfunc) pic_define(pic, name, pic_obj_value(proc)); } +void +pic_defun_vm(pic_state *pic, const char *name, pic_sym *rename, pic_func_t func) +{ + struct pic_proc *proc; + pic_sym *sym; + + proc = pic_make_proc(pic, func, name); + + sym = pic_intern_cstr(pic, name); + + pic_put_rename(pic, pic->lib->env, sym, rename); + + pic_dict_set(pic, pic->globals, rename, pic_obj_value(proc)); + + pic_export(pic, sym); +} + void pic_defvar(pic_state *pic, const char *name, pic_value init, struct pic_proc *conv) {