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_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)
}
#endif

8
src/codegen.c
View File

@ -49,10 +49,12 @@ static void pop_scope(analyze_state *);
} while (0)
#define register_renamed_symbol(pic, state, slot, lib, id) do { \
xh_entry *e; \
if (! (e = xh_get_int(lib->senv->name, pic_intern_cstr(pic, id)))) \
pic_sym sym, gsym; \
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"); \
state->slot = e->val; \
} \
state->slot = gsym; \
} while (0)
static analyze_state *

86
src/macro.c
View File

@ -10,6 +10,37 @@
#include "picrin/lib.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_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;
pic_value a;
pic_sym sym;
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)) {
pic_error(pic, "syntax error");
}
sym = pic_sym(v);
xh_put_int(senv->name, sym, pic_gensym(pic, sym));
pic_add_rename(pic, senv, pic_sym(v));
}
if (! pic_sym_p(a)) {
a = macroexpand(pic, a, up);
}
if (pic_sym_p(a)) {
sym = pic_sym(a);
xh_put_int(senv->name, sym, pic_gensym(pic, sym));
pic_add_rename(pic, senv, pic_sym(a));
}
else if (! pic_nil_p(a)) {
pic_error(pic, "syntax error");
@ -125,36 +153,35 @@ pic_import(pic_state *pic, pic_value spec)
pic_symbol_name(pic, it.e->val));
#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
pic_export(pic_state *pic, pic_sym sym)
{
xh_entry *e;
pic_sym rename;
e = xh_get_int(pic->lib->senv->name, sym);
if (! e) {
rename = pic_find_rename(pic, pic->lib->senv, sym);
if (rename == 0) {
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
pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro)
{
struct pic_macro *mac;
pic_sym sym, uniq;
pic_sym sym, rename;
/* new macro */
mac = macro_new(pic, macro, NULL);
/* symbol registration */
sym = pic_intern_cstr(pic, name);
uniq = pic_gensym(pic, sym);
xh_put_int(pic->lib->senv->name, sym, uniq);
xh_put_int(pic->macros, uniq, (long)mac);
rename = pic_add_rename(pic, pic->lib->senv, sym);
xh_put_int(pic->macros, rename, (long)mac);
/* auto export! */
pic_export(pic, sym);
@ -163,14 +190,14 @@ pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro)
static pic_sym
symbol_rename(pic_state *pic, pic_sym sym, struct pic_senv *senv)
{
xh_entry *e;
pic_sym rename;
if (! pic_interned_p(pic, sym)) {
return sym;
}
while (true) {
if ((e = xh_get_int(senv->name, sym)) != NULL) {
return (pic_sym)e->val;
if ((rename = pic_find_rename(pic, senv, sym)) != 0) {
return rename;
}
if (! senv->up)
break;
@ -260,7 +287,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
else if (tag == pic->sDEFINE_SYNTAX) {
pic_value var, val;
pic_sym uniq;
pic_sym rename;
struct pic_macro *mac;
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)) {
pic_error(pic, "binding to non-symbol object");
}
uniq = pic_gensym(pic, pic_sym(var));
xh_put_int(senv->name, pic_sym(var), uniq);
rename = pic_add_rename(pic, senv, pic_sym(var));
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);
xh_put_int(pic->macros, uniq, (long)mac);
xh_put_int(pic->macros, rename, (long)mac);
pic_gc_arena_restore(pic, ai);
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) {
pic_value var, val;
pic_sym uniq;
pic_sym rename;
struct pic_macro *mac;
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)) {
pic_error(pic, "syntax error");
}
uniq = pic_gensym(pic, pic_sym(var));
xh_put_int(senv->name, pic_sym(var), uniq);
rename = pic_add_rename(pic, senv, pic_sym(var));
pic_try {
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);
xh_put_int(pic->macros, uniq, (long)mac);
xh_put_int(pic->macros, rename, (long)mac);
pic_gc_arena_restore(pic, ai);
return pic_none_value();
@ -376,8 +401,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
if (! pic_sym_p(a)) {
pic_error(pic, "binding to non-symbol object");
}
var = pic_sym(a);
xh_put_int(senv->name, var, pic_gensym(pic, var));
pic_add_rename(pic, senv, pic_sym(a));
/* binding value */
v = pic_cons(pic, car,
@ -398,8 +422,8 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
}
var = pic_sym(formals);
/* do not make duplicate variable slot */
if (xh_get_int(senv->name, var) == NULL) {
xh_put_int(senv->name, var, pic_gensym(pic, var));
if (pic_find_rename(pic, senv, var) == 0) {
pic_add_rename(pic, senv, var);
}
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 { \
pic_sym sym = pic_intern_cstr(pic, id); \
xh_put_int(senv->name, sym, sym); \
pic_put_rename(pic, senv, sym, sym); \
} while (0)
struct pic_senv *
@ -902,7 +926,7 @@ pic_init_macro(pic_state *pic)
pic_deflibrary ("(picrin macro)") {
/* 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_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)
{
xh_entry *e;
pic_sym sym;
pic_sym sym, rename;
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;
}
assert(e->val >= 0);
if (! (e = xh_get_int(pic->global_tbl, e->val))) {
if (! (e = xh_get_int(pic->global_tbl, rename))) {
return SIZE_MAX;
}
return e->val;
@ -349,7 +348,7 @@ global_ref(pic_state *pic, const char *name)
static size_t
global_def(pic_state *pic, const char *name)
{
pic_sym sym, gsym;
pic_sym sym, rename;
size_t gidx;
sym = pic_intern_cstr(pic, name);
@ -358,17 +357,15 @@ global_def(pic_state *pic, const char *name)
return gidx;
}
gsym = pic_gensym(pic, sym);
/* 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 */
gidx = pic->glen++;
if (pic->glen >= pic->gcapa) {
pic_error(pic, "global table overflow");
}
xh_put_int(pic->global_tbl, gsym, gidx);
xh_put_int(pic->global_tbl, rename, gidx);
return gidx;
}