From 5faa7cd46d5a9320c4cda221acdadc1088d191e4 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 14 Jul 2014 10:08:11 +0900 Subject: [PATCH] leave core syntax keywords renamed --- include/picrin.h | 5 +++++ include/picrin/macro.h | 2 +- src/codegen.c | 16 ++++++++-------- src/init.c | 18 +++++++++--------- src/macro.c | 38 +++++++++++++++++++------------------- src/state.c | 20 ++++++++++++++++++++ 6 files changed, 62 insertions(+), 37 deletions(-) diff --git a/include/picrin.h b/include/picrin.h index 6b6629a5..2406e48f 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -87,6 +87,11 @@ typedef struct { pic_sym sADD, sSUB, sMUL, sDIV, sMINUS; pic_sym sEQ, sLT, sLE, sGT, sGE, sNOT; + pic_sym rDEFINE, rLAMBDA, rIF, rBEGIN, rQUOTE, rSETBANG; + pic_sym rDEFINE_SYNTAX, rDEFINE_MACRO; + pic_sym rLET_SYNTAX, rLETREC_SYNTAX; + pic_sym rDEFINE_LIBRARY, rIMPORT, rEXPORT; + xhash syms; /* name to symbol */ xhash sym_names; /* symbol to name */ int sym_cnt; diff --git a/include/picrin/macro.h b/include/picrin/macro.h index 151eb144..b733a5fe 100644 --- a/include/picrin/macro.h +++ b/include/picrin/macro.h @@ -42,7 +42,7 @@ pic_sym pic_add_rename(pic_state *, struct pic_senv *, pic_sym); bool pic_find_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym * /* = NULL */); void pic_put_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym); -void pic_define_syntactic_keyword(pic_state *, struct pic_senv *, pic_sym); +void pic_define_syntactic_keyword(pic_state *, struct pic_senv *, pic_sym, pic_sym); #if defined(__cplusplus) } diff --git a/src/codegen.c b/src/codegen.c index 8dd84b7a..a4d7e25b 100644 --- a/src/codegen.c +++ b/src/codegen.c @@ -366,7 +366,7 @@ analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_v : 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->sBEGIN), body_exprs), true); + 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) { @@ -535,7 +535,7 @@ analyze_quote(analyze_state *state, pic_value obj) if (pic_length(pic, obj) != 2) { pic_error(pic, "syntax error"); } - return obj; + return pic_list2(pic, pic_sym_value(pic->sQUOTE), pic_list_ref(pic, obj, 1)); } #define ARGC_ASSERT_GE(n) do { \ @@ -727,22 +727,22 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos) if (pic_sym_p(proc)) { pic_sym sym = pic_sym(proc); - if (sym == pic->sDEFINE) { + if (sym == pic->rDEFINE) { return analyze_define(state, obj); } - else if (sym == pic->sLAMBDA) { + else if (sym == pic->rLAMBDA) { return analyze_lambda(state, obj); } - else if (sym == pic->sIF) { + else if (sym == pic->rIF) { return analyze_if(state, obj, tailpos); } - else if (sym == pic->sBEGIN) { + else if (sym == pic->rBEGIN) { return analyze_begin(state, obj, tailpos); } - else if (sym == pic->sSETBANG) { + else if (sym == pic->rSETBANG) { return analyze_set(state, obj); } - else if (sym == pic->sQUOTE) { + else if (sym == pic->rQUOTE) { return analyze_quote(state, obj); } else if (sym == state->rCONS) { diff --git a/src/init.c b/src/init.c index b6051a3f..4fdba1e0 100644 --- a/src/init.c +++ b/src/init.c @@ -68,15 +68,15 @@ pic_init_core(pic_state *pic) /* load core syntaces */ pic->lib->senv = pic_null_syntactic_environment(pic); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sSETBANG); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sQUOTE); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLAMBDA); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sIF); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sBEGIN); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_SYNTAX); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLET_SYNTAX); - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLETREC_SYNTAX); + pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE, pic->rDEFINE); + pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sSETBANG, pic->rSETBANG); + pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sQUOTE, pic->rQUOTE); + pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLAMBDA, pic->rLAMBDA); + pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sIF, pic->rIF); + pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sBEGIN, pic->rBEGIN); + pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX); + pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLET_SYNTAX, pic->rLET_SYNTAX); + pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sLETREC_SYNTAX, pic->rLETREC_SYNTAX); pic_init_bool(pic); DONE; pic_init_pair(pic); DONE; diff --git a/src/macro.c b/src/macro.c index c9da6aee..5ac2e4dc 100644 --- a/src/macro.c +++ b/src/macro.c @@ -104,7 +104,7 @@ macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pi static pic_value macroexpand_quote(pic_state *pic, pic_value expr) { - return pic_cons(pic, pic_sym_value(pic->sQUOTE), pic_cdr(pic, expr)); + return pic_cons(pic, pic_sym_value(pic->rQUOTE), pic_cdr(pic, expr)); } static pic_value @@ -242,7 +242,7 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv, struct formal = macroexpand_list(pic, pic_cadr(pic, expr), in, cxt); body = macroexpand_list(pic, pic_cddr(pic, expr), in, cxt); - return pic_cons(pic, pic_sym_value(pic->sLAMBDA), pic_cons(pic, formal, body)); + return pic_cons(pic, pic_sym_value(pic->rLAMBDA), pic_cons(pic, formal, body)); } static pic_value @@ -280,7 +280,7 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv, struct } else { val = macroexpand(pic, pic_car(pic, body), senv, cxt); } - return pic_list3(pic, pic_sym_value(pic->sDEFINE), macroexpand_symbol(pic, sym, senv, cxt), val); + return pic_list3(pic, pic_sym_value(pic->rDEFINE), macroexpand_symbol(pic, sym, senv, cxt), val); } static pic_value @@ -406,7 +406,7 @@ macroexpand_let_syntax(pic_state *pic, pic_value expr, struct pic_senv *senv, st } define_macro(pic, rename, pic_proc_ptr(val), senv); } - return pic_cons(pic, pic_sym_value(pic->sBEGIN), macroexpand_list(pic, pic_cddr(pic, expr), in, cxt)); + return pic_cons(pic, pic_sym_value(pic->rBEGIN), macroexpand_list(pic, pic_cddr(pic, expr), in, cxt)); } static pic_value @@ -470,34 +470,34 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv, struct p if (pic_sym_p(car)) { pic_sym tag = pic_sym(car); - if (tag == pic->sDEFINE_LIBRARY) { + if (tag == pic->rDEFINE_LIBRARY) { return macroexpand_deflibrary(pic, expr); } - else if (tag == pic->sIMPORT) { + else if (tag == pic->rIMPORT) { return macroexpand_import(pic, expr); } - else if (tag == pic->sEXPORT) { + else if (tag == pic->rEXPORT) { return macroexpand_export(pic, expr); } - else if (tag == pic->sDEFINE_SYNTAX) { + else if (tag == pic->rDEFINE_SYNTAX) { return macroexpand_defsyntax(pic, expr, senv, cxt); } - else if (tag == pic->sDEFINE_MACRO) { + else if (tag == pic->rDEFINE_MACRO) { return macroexpand_defmacro(pic, expr, senv); } - else if (tag == pic->sLET_SYNTAX) { + else if (tag == pic->rLET_SYNTAX) { return macroexpand_let_syntax(pic, expr, senv, cxt); } /* else if (tag == pic->sLETREC_SYNTAX) { */ /* return macroexpand_letrec_syntax(pic, expr, senv, cxt); */ /* } */ - else if (tag == pic->sLAMBDA) { + else if (tag == pic->rLAMBDA) { return macroexpand_lambda(pic, expr, senv, cxt); } - else if (tag == pic->sDEFINE) { + else if (tag == pic->rDEFINE) { return macroexpand_define(pic, expr, senv, cxt); } - else if (tag == pic->sQUOTE) { + else if (tag == pic->rQUOTE) { return macroexpand_quote(pic, expr); } @@ -582,17 +582,17 @@ pic_null_syntactic_environment(pic_state *pic) senv->up = NULL; xh_init_int(&senv->renames, sizeof(pic_sym)); - pic_define_syntactic_keyword(pic, senv, pic->sDEFINE_LIBRARY); - pic_define_syntactic_keyword(pic, senv, pic->sIMPORT); - pic_define_syntactic_keyword(pic, senv, pic->sEXPORT); + 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); return senv; } void -pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym) +pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym rsym) { - pic_put_rename(pic, senv, sym, sym); + pic_put_rename(pic, senv, sym, rsym); if (pic->lib && pic->lib->senv == senv) { pic_export(pic, sym); @@ -944,7 +944,7 @@ pic_init_macro(pic_state *pic) pic_deflibrary ("(picrin macro)") { /* export define-macro syntax */ - pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_MACRO); + pic_define_syntactic_keyword(pic, pic->lib->senv, pic->sDEFINE_MACRO, pic->rDEFINE_MACRO); pic_defun(pic, "gensym", pic_macro_gensym); pic_defun(pic, "macroexpand", pic_macro_macroexpand); diff --git a/src/state.c b/src/state.c index 9db4986b..cb01c754 100644 --- a/src/state.c +++ b/src/state.c @@ -118,6 +118,26 @@ pic_open(int argc, char *argv[], char **envp) 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, rDEFINE_MACRO, "define-macro"); + register_renamed_symbol(pic, rLET_SYNTAX, "let-syntax"); + register_renamed_symbol(pic, rLETREC_SYNTAX, "letrec-syntax"); + register_renamed_symbol(pic, rDEFINE_LIBRARY, "define-library"); + register_renamed_symbol(pic, rIMPORT, "import"); + register_renamed_symbol(pic, rEXPORT, "export"); + pic_gc_arena_restore(pic, ai); + pic_init_core(pic); /* set library */