conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

add renamer APIs

This commit is contained in:
Yuichi Nishiwaki 2014-03-25 14:12:53 +09:00
parent 816343bd31
commit b757368748
4 changed files with 70 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
include/picrin/macro.h
View File

@ -41,6 +41,10 @@ struct pic_senv *pic_null_syntactic_env(pic_state *);
struct pic_senv *pic_minimal_syntactic_env(pic_state *); struct pic_senv *pic_minimal_syntactic_env(pic_state *);
struct pic_senv *pic_core_syntactic_env(pic_state *); struct pic_senv *pic_core_syntactic_env(pic_state *);
pic_sym pic_add_rename(pic_state *, struct pic_senv *, pic_sym);
pic_sym pic_find_rename(pic_state *, struct pic_senv *, pic_sym); /* may return 0! */
void pic_put_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym);
#if defined(__cplusplus) #if defined(__cplusplus)
} }
#endif #endif

8
src/codegen.c
View File

@ -49,10 +49,12 @@ static void pop_scope(analyze_state *);
} while (0) } while (0)
#define register_renamed_symbol(pic, state, slot, lib, id) do { \ #define register_renamed_symbol(pic, state, slot, lib, id) do { \
xh_entry *e; \ pic_sym sym, gsym; \
if (! (e = xh_get_int(lib->senv->name, pic_intern_cstr(pic, id)))) \ sym = pic_intern_cstr(pic, id); \
if ((gsym = pic_find_rename(pic, lib->senv, sym)) == 0) { \
pic_error(pic, "internal error! native VM procedure not found"); \ pic_error(pic, "internal error! native VM procedure not found"); \
state->slot = e->val; \ } \
state->slot = gsym; \
} while (0) } while (0)
static analyze_state * static analyze_state *

86
src/macro.c
View File

@ -10,6 +10,37 @@
#include "picrin/lib.h" #include "picrin/lib.h"
#include "picrin/error.h" #include "picrin/error.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->name, sym, rename);
}
pic_sym
pic_find_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym)
{
xh_entry *e;
UNUSED(pic);
if ((e = xh_get_int(senv->name, sym)) == NULL) {
return 0;
}
return e->val;
}
static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *); static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *);
static pic_value macroexpand_list(pic_state *, pic_value, struct pic_senv *); static pic_value macroexpand_list(pic_state *, pic_value, struct pic_senv *);
@ -30,7 +61,6 @@ senv_new_local(pic_state *pic, pic_value formals, struct pic_senv *up)
{ {
struct pic_senv *senv; struct pic_senv *senv;
pic_value a; pic_value a;
pic_sym sym;
senv = senv_new(pic, up); senv = senv_new(pic, up);
@ -43,15 +73,13 @@ senv_new_local(pic_state *pic, pic_value formals, struct pic_senv *up)
if (! pic_sym_p(v)) { if (! pic_sym_p(v)) {
pic_error(pic, "syntax error"); pic_error(pic, "syntax error");
} }
sym = pic_sym(v); pic_add_rename(pic, senv, pic_sym(v));
xh_put_int(senv->name, sym, pic_gensym(pic, sym));
} }
if (! pic_sym_p(a)) { if (! pic_sym_p(a)) {
a = macroexpand(pic, a, up); a = macroexpand(pic, a, up);
} }
if (pic_sym_p(a)) { if (pic_sym_p(a)) {
sym = pic_sym(a); pic_add_rename(pic, senv, pic_sym(a));
xh_put_int(senv->name, sym, pic_gensym(pic, sym));
} }
else if (! pic_nil_p(a)) { else if (! pic_nil_p(a)) {
pic_error(pic, "syntax error"); pic_error(pic, "syntax error");
@ -125,36 +153,35 @@ pic_import(pic_state *pic, pic_value spec)
pic_symbol_name(pic, it.e->val)); pic_symbol_name(pic, it.e->val));
#endif #endif
xh_put_int(pic->lib->senv->name, (long)it.e->key, it.e->val); pic_put_rename(pic, pic->lib->senv, (long)it.e->key, it.e->val);
} }
} }
void void
pic_export(pic_state *pic, pic_sym sym) pic_export(pic_state *pic, pic_sym sym)
{ {
xh_entry *e; pic_sym rename;
e = xh_get_int(pic->lib->senv->name, sym); rename = pic_find_rename(pic, pic->lib->senv, sym);
if (! e) { if (rename == 0) {
pic_errorf(pic, "export: symbol not defined %s", pic_symbol_name(pic, sym)); pic_errorf(pic, "export: symbol not defined %s", pic_symbol_name(pic, sym));
} }
xh_put_int(pic->lib->exports, (long)e->key, e->val); xh_put_int(pic->lib->exports, sym, rename);
} }
void void
pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro) pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro)
{ {
struct pic_macro *mac; struct pic_macro *mac;
pic_sym sym, uniq; pic_sym sym, rename;
/* new macro */ /* new macro */
mac = macro_new(pic, macro, NULL); mac = macro_new(pic, macro, NULL);
/* symbol registration */ /* symbol registration */
sym = pic_intern_cstr(pic, name); sym = pic_intern_cstr(pic, name);
uniq = pic_gensym(pic, sym); rename = pic_add_rename(pic, pic->lib->senv, sym);
xh_put_int(pic->lib->senv->name, sym, uniq); xh_put_int(pic->macros, rename, (long)mac);
xh_put_int(pic->macros, uniq, (long)mac);
/* auto export! */ /* auto export! */
pic_export(pic, sym); pic_export(pic, sym);
@ -163,14 +190,14 @@ pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro)
static pic_sym static pic_sym
symbol_rename(pic_state *pic, pic_sym sym, struct pic_senv *senv) symbol_rename(pic_state *pic, pic_sym sym, struct pic_senv *senv)
{ {
xh_entry *e; pic_sym rename;
if (! pic_interned_p(pic, sym)) { if (! pic_interned_p(pic, sym)) {
return sym; return sym;
} }
while (true) { while (true) {
if ((e = xh_get_int(senv->name, sym)) != NULL) { if ((rename = pic_find_rename(pic, senv, sym)) != 0) {
return (pic_sym)e->val; return rename;
} }
if (! senv->up) if (! senv->up)
break; break;
@ -260,7 +287,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
else if (tag == pic->sDEFINE_SYNTAX) { else if (tag == pic->sDEFINE_SYNTAX) {
pic_value var, val; pic_value var, val;
pic_sym uniq; pic_sym rename;
struct pic_macro *mac; struct pic_macro *mac;
if (pic_length(pic, expr) != 3) { if (pic_length(pic, expr) != 3) {
@ -274,8 +301,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
if (! pic_sym_p(var)) { if (! pic_sym_p(var)) {
pic_error(pic, "binding to non-symbol object"); pic_error(pic, "binding to non-symbol object");
} }
uniq = pic_gensym(pic, pic_sym(var)); rename = pic_add_rename(pic, senv, pic_sym(var));
xh_put_int(senv->name, pic_sym(var), uniq);
val = pic_cadr(pic, pic_cdr(pic, expr)); val = pic_cadr(pic, pic_cdr(pic, expr));
@ -290,7 +316,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
} }
mac = macro_new(pic, pic_proc_ptr(v), senv); mac = macro_new(pic, pic_proc_ptr(v), senv);
xh_put_int(pic->macros, uniq, (long)mac); xh_put_int(pic->macros, rename, (long)mac);
pic_gc_arena_restore(pic, ai); pic_gc_arena_restore(pic, ai);
return pic_none_value(); return pic_none_value();
@ -298,7 +324,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
else if (tag == pic->sDEFINE_MACRO) { else if (tag == pic->sDEFINE_MACRO) {
pic_value var, val; pic_value var, val;
pic_sym uniq; pic_sym rename;
struct pic_macro *mac; struct pic_macro *mac;
if (pic_length(pic, expr) < 2) { if (pic_length(pic, expr) < 2) {
@ -322,8 +348,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
if (! pic_sym_p(var)) { if (! pic_sym_p(var)) {
pic_error(pic, "syntax error"); pic_error(pic, "syntax error");
} }
uniq = pic_gensym(pic, pic_sym(var)); rename = pic_add_rename(pic, senv, pic_sym(var));
xh_put_int(senv->name, pic_sym(var), uniq);
pic_try { pic_try {
v = pic_eval(pic, val); v = pic_eval(pic, val);
@ -336,7 +361,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
} }
mac = macro_new(pic, pic_proc_ptr(v), NULL); mac = macro_new(pic, pic_proc_ptr(v), NULL);
xh_put_int(pic->macros, uniq, (long)mac); xh_put_int(pic->macros, rename, (long)mac);
pic_gc_arena_restore(pic, ai); pic_gc_arena_restore(pic, ai);
return pic_none_value(); return pic_none_value();
@ -376,8 +401,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
if (! pic_sym_p(a)) { if (! pic_sym_p(a)) {
pic_error(pic, "binding to non-symbol object"); pic_error(pic, "binding to non-symbol object");
} }
var = pic_sym(a); pic_add_rename(pic, senv, pic_sym(a));
xh_put_int(senv->name, var, pic_gensym(pic, var));
/* binding value */ /* binding value */
v = pic_cons(pic, car, v = pic_cons(pic, car,
@ -398,8 +422,8 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
} }
var = pic_sym(formals); var = pic_sym(formals);
/* do not make duplicate variable slot */ /* do not make duplicate variable slot */
if (xh_get_int(senv->name, var) == NULL) { if (pic_find_rename(pic, senv, var) == 0) {
xh_put_int(senv->name, var, pic_gensym(pic, var)); pic_add_rename(pic, senv, var);
} }
v = pic_cons(pic, pic_symbol_value(tag), v = pic_cons(pic, pic_symbol_value(tag),
@ -558,7 +582,7 @@ pic_null_syntactic_env(pic_state *pic)
#define register_core_syntax(pic,senv,id) do { \ #define register_core_syntax(pic,senv,id) do { \
pic_sym sym = pic_intern_cstr(pic, id); \ pic_sym sym = pic_intern_cstr(pic, id); \
xh_put_int(senv->name, sym, sym); \ pic_put_rename(pic, senv, sym, sym); \
} while (0) } while (0)
struct pic_senv * struct pic_senv *
@ -902,7 +926,7 @@ pic_init_macro(pic_state *pic)
pic_deflibrary ("(picrin macro)") { pic_deflibrary ("(picrin macro)") {
/* export define-macro syntax */ /* export define-macro syntax */
xh_put_int(pic->lib->senv->name, pic->sDEFINE_MACRO, pic->sDEFINE_MACRO); pic_put_rename(pic, pic->lib->senv, pic->sDEFINE_MACRO, pic->sDEFINE_MACRO);
pic_export(pic, pic->sDEFINE_MACRO); pic_export(pic, pic->sDEFINE_MACRO);
pic_defun(pic, "gensym", pic_macro_gensym); pic_defun(pic, "gensym", pic_macro_gensym);

15
src/vm.c
View File

@ -333,14 +333,13 @@ static size_t
global_ref(pic_state *pic, const char *name) global_ref(pic_state *pic, const char *name)
{ {
xh_entry *e; xh_entry *e;
pic_sym sym; pic_sym sym, rename;
sym = pic_intern_cstr(pic, name); sym = pic_intern_cstr(pic, name);
if (! (e = xh_get_int(pic->lib->senv->name, sym))) { if ((rename = pic_find_rename(pic, pic->lib->senv, sym)) == 0) {
return SIZE_MAX; return SIZE_MAX;
} }
assert(e->val >= 0); if (! (e = xh_get_int(pic->global_tbl, rename))) {
if (! (e = xh_get_int(pic->global_tbl, e->val))) {
return SIZE_MAX; return SIZE_MAX;
} }
return e->val; return e->val;
@ -349,7 +348,7 @@ global_ref(pic_state *pic, const char *name)
static size_t static size_t
global_def(pic_state *pic, const char *name) global_def(pic_state *pic, const char *name)
{ {
pic_sym sym, gsym; pic_sym sym, rename;
size_t gidx; size_t gidx;
sym = pic_intern_cstr(pic, name); sym = pic_intern_cstr(pic, name);
@ -358,17 +357,15 @@ global_def(pic_state *pic, const char *name)
return gidx; return gidx;
} }
gsym = pic_gensym(pic, sym);
/* register to the senv */ /* register to the senv */
xh_put_int(pic->lib->senv->name, sym, gsym); rename = pic_add_rename(pic, pic->lib->senv, sym);
/* register to the global table */ /* register to the global table */
gidx = pic->glen++; gidx = pic->glen++;
if (pic->glen >= pic->gcapa) { if (pic->glen >= pic->gcapa) {
pic_error(pic, "global table overflow"); pic_error(pic, "global table overflow");
} }
xh_put_int(pic->global_tbl, gsym, gidx); xh_put_int(pic->global_tbl, rename, gidx);
return gidx; return gidx;
} }