Merge branch 'improve-hygiene'
This commit is contained in:
commit
5f2424b69e
|
@ -23,7 +23,6 @@
|
|||
#define PIC_STACK_SIZE 1024
|
||||
#define PIC_RESCUE_SIZE 30
|
||||
#define PIC_GLOBALS_SIZE 1024
|
||||
#define PIC_MACROS_SIZE 1024
|
||||
#define PIC_SYM_POOL_SIZE 128
|
||||
#define PIC_IREP_SIZE 8
|
||||
#define PIC_POOL_SIZE 8
|
||||
|
|
|
@ -107,6 +107,8 @@ typedef struct {
|
|||
pic_value *globals;
|
||||
size_t glen, gcapa;
|
||||
|
||||
xhash *macros;
|
||||
|
||||
pic_value lib_tbl;
|
||||
struct pic_lib *lib;
|
||||
|
||||
|
|
|
@ -11,31 +11,13 @@ extern "C" {
|
|||
|
||||
struct pic_senv {
|
||||
PIC_OBJECT_HEADER
|
||||
xhash *name;
|
||||
struct pic_senv *up;
|
||||
/* positive for variables, negative for macros (bitwise-not) */
|
||||
xhash *tbl;
|
||||
struct pic_syntax **stx;
|
||||
size_t xlen, xcapa;
|
||||
};
|
||||
|
||||
struct pic_syntax {
|
||||
struct pic_macro {
|
||||
PIC_OBJECT_HEADER
|
||||
enum {
|
||||
PIC_STX_DEFINE,
|
||||
PIC_STX_SET,
|
||||
PIC_STX_QUOTE,
|
||||
PIC_STX_LAMBDA,
|
||||
PIC_STX_IF,
|
||||
PIC_STX_BEGIN,
|
||||
PIC_STX_MACRO,
|
||||
PIC_STX_DEFMACRO,
|
||||
PIC_STX_DEFSYNTAX,
|
||||
PIC_STX_DEFLIBRARY,
|
||||
PIC_STX_IMPORT,
|
||||
PIC_STX_EXPORT
|
||||
} kind;
|
||||
pic_sym sym;
|
||||
struct pic_proc *macro;
|
||||
struct pic_proc *proc;
|
||||
struct pic_senv *senv;
|
||||
};
|
||||
|
||||
|
@ -48,19 +30,16 @@ struct pic_sc {
|
|||
#define pic_sc(v) ((struct pic_sc *)pic_ptr(v))
|
||||
#define pic_sc_p(v) (pic_type(v) == PIC_TT_SC)
|
||||
|
||||
#define pic_syntax(v) ((struct pic_syntax *)pic_ptr(v))
|
||||
#define pic_syntax_p(v) (pic_type(v) == PIC_TT_SYNTAX)
|
||||
#define pic_macro(v) ((struct pic_macro *)pic_ptr(v))
|
||||
#define pic_macro_p(v) (pic_type(v) == PIC_TT_MACRO)
|
||||
|
||||
#define pic_senv(v) ((struct pic_senv *)pic_ptr(v))
|
||||
#define pic_senv_p(v) (pic_type(v) == PIC_TT_SENV)
|
||||
#define pic_senv_ptr(v) ((struct pic_senv *)pic_ptr(v))
|
||||
|
||||
struct pic_senv *pic_null_syntactic_env(pic_state *pic);
|
||||
struct pic_senv *pic_minimal_syntactic_env(pic_state *pic);
|
||||
struct pic_senv *pic_core_syntactic_env(pic_state *pic);
|
||||
|
||||
struct pic_syntax *pic_syntax_new(pic_state *, int kind, pic_sym sym);
|
||||
struct pic_syntax *pic_syntax_new_macro(pic_state *, pic_sym, struct pic_proc *, struct pic_senv *senv);
|
||||
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 *);
|
||||
|
||||
#if defined(__cplusplus)
|
||||
}
|
||||
|
|
|
@ -43,6 +43,8 @@ int pic_proc_cv_size(pic_state *, struct pic_proc *);
|
|||
pic_value pic_proc_cv_ref(pic_state *, struct pic_proc *, size_t);
|
||||
void pic_proc_cv_set(pic_state *, struct pic_proc *, size_t, pic_value);
|
||||
|
||||
struct pic_proc *pic_papply(pic_state *, struct pic_proc *, pic_value);
|
||||
|
||||
#if defined(__cplusplus)
|
||||
}
|
||||
#endif
|
||||
|
|
|
@ -99,7 +99,7 @@ enum pic_tt {
|
|||
PIC_TT_ENV,
|
||||
PIC_TT_CONT,
|
||||
PIC_TT_SENV,
|
||||
PIC_TT_SYNTAX,
|
||||
PIC_TT_MACRO,
|
||||
PIC_TT_SC,
|
||||
PIC_TT_LIB,
|
||||
PIC_TT_VAR,
|
||||
|
@ -248,8 +248,8 @@ pic_type_repr(enum pic_tt tt)
|
|||
return "sc";
|
||||
case PIC_TT_SENV:
|
||||
return "senv";
|
||||
case PIC_TT_SYNTAX:
|
||||
return "syntax";
|
||||
case PIC_TT_MACRO:
|
||||
return "macro";
|
||||
case PIC_TT_LIB:
|
||||
return "lib";
|
||||
case PIC_TT_VAR:
|
||||
|
|
|
@ -98,9 +98,9 @@ static void pop_scope(analyze_state *);
|
|||
state->slot = pic_intern_cstr(pic, name); \
|
||||
} while (0)
|
||||
|
||||
#define register_renamed_symbol(pic, state, slot, lib, name) do { \
|
||||
xh_entry *e; \
|
||||
if (! (e = xh_get_int(lib->senv->tbl, pic_intern_cstr(pic, name)))) \
|
||||
#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_error(pic, "internal error! native VM procedure not found"); \
|
||||
state->slot = e->val; \
|
||||
} while (0)
|
||||
|
@ -561,7 +561,7 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos)
|
|||
case PIC_TT_PORT:
|
||||
case PIC_TT_ERROR:
|
||||
case PIC_TT_SENV:
|
||||
case PIC_TT_SYNTAX:
|
||||
case PIC_TT_MACRO:
|
||||
case PIC_TT_SC:
|
||||
case PIC_TT_LIB:
|
||||
case PIC_TT_VAR:
|
||||
|
@ -1445,7 +1445,7 @@ global_ref(pic_state *pic, const char *name)
|
|||
pic_sym sym;
|
||||
|
||||
sym = pic_intern_cstr(pic, name);
|
||||
if (! (e = xh_get_int(pic->lib->senv->tbl, sym))) {
|
||||
if (! (e = xh_get_int(pic->lib->senv->name, sym))) {
|
||||
return -1;
|
||||
}
|
||||
assert(e->val >= 0);
|
||||
|
@ -1470,7 +1470,7 @@ global_def(pic_state *pic, const char *name)
|
|||
gsym = pic_gensym(pic, sym);
|
||||
|
||||
/* register to the senv */
|
||||
xh_put_int(pic->lib->senv->tbl, sym, gsym);
|
||||
xh_put_int(pic->lib->senv->name, sym, gsym);
|
||||
|
||||
/* register to the global table */
|
||||
gidx = pic->glen++;
|
||||
|
|
31
src/gc.c
31
src/gc.c
|
@ -387,14 +387,14 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
|
|||
gc_mark(pic, cont->results);
|
||||
break;
|
||||
}
|
||||
case PIC_TT_SYNTAX: {
|
||||
struct pic_syntax *stx = (struct pic_syntax *)obj;
|
||||
case PIC_TT_MACRO: {
|
||||
struct pic_macro *mac = (struct pic_macro *)obj;
|
||||
|
||||
if (stx->macro) {
|
||||
gc_mark_object(pic, (struct pic_object *)stx->macro);
|
||||
if (mac->proc) {
|
||||
gc_mark_object(pic, (struct pic_object *)mac->proc);
|
||||
}
|
||||
if (stx->senv) {
|
||||
gc_mark_object(pic, (struct pic_object *)stx->senv);
|
||||
if (mac->senv) {
|
||||
gc_mark_object(pic, (struct pic_object *)mac->senv);
|
||||
}
|
||||
break;
|
||||
}
|
||||
|
@ -404,13 +404,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
|
|||
if (senv->up) {
|
||||
gc_mark_object(pic, (struct pic_object *)senv->up);
|
||||
}
|
||||
if (senv->stx) {
|
||||
size_t i;
|
||||
|
||||
for (i = 0; i < senv->xlen; ++i) {
|
||||
gc_mark_object(pic, (struct pic_object *)senv->stx[i]);
|
||||
}
|
||||
}
|
||||
break;
|
||||
}
|
||||
case PIC_TT_SC: {
|
||||
|
@ -476,6 +469,7 @@ gc_mark_phase(pic_state *pic)
|
|||
pic_callinfo *ci;
|
||||
size_t i;
|
||||
int j;
|
||||
xh_iter it;
|
||||
|
||||
/* block */
|
||||
gc_mark_block(pic, pic->blk);
|
||||
|
@ -512,6 +506,11 @@ gc_mark_phase(pic_state *pic)
|
|||
gc_mark(pic, pic->globals[i]);
|
||||
}
|
||||
|
||||
/* macro objects */
|
||||
for (xh_begin(pic->macros, &it); ! xh_isend(&it); xh_next(&it)) {
|
||||
gc_mark_object(pic, (struct pic_object *)it.e->val);
|
||||
}
|
||||
|
||||
/* library table */
|
||||
gc_mark(pic, pic->lib_tbl);
|
||||
}
|
||||
|
@ -565,12 +564,10 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
|
|||
}
|
||||
case PIC_TT_SENV: {
|
||||
struct pic_senv *senv = (struct pic_senv *)obj;
|
||||
xh_destroy(senv->tbl);
|
||||
if (senv->stx)
|
||||
pic_free(pic, senv->stx);
|
||||
xh_destroy(senv->name);
|
||||
break;
|
||||
}
|
||||
case PIC_TT_SYNTAX: {
|
||||
case PIC_TT_MACRO: {
|
||||
break;
|
||||
}
|
||||
case PIC_TT_SC: {
|
||||
|
|
425
src/macro.c
425
src/macro.c
|
@ -13,65 +13,18 @@
|
|||
static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *);
|
||||
static pic_value macroexpand_list(pic_state *, pic_value, struct pic_senv *);
|
||||
|
||||
struct pic_senv *
|
||||
pic_null_syntactic_env(pic_state *pic)
|
||||
static struct pic_senv *
|
||||
new_senv(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 = NULL;
|
||||
senv->tbl = xh_new_int();
|
||||
senv->stx = (struct pic_syntax **)pic_calloc(pic, PIC_MACROS_SIZE, sizeof(struct pic_syntax *));
|
||||
senv->xlen = 0;
|
||||
senv->xcapa = PIC_MACROS_SIZE;
|
||||
senv->up = up;
|
||||
senv->name = xh_new_int();
|
||||
|
||||
return senv;
|
||||
}
|
||||
|
||||
#define register_core_syntax(pic,senv,kind,name) do { \
|
||||
pic_sym sym = pic_intern_cstr(pic, name); \
|
||||
senv->stx[senv->xlen] = pic_syntax_new(pic, kind, sym); \
|
||||
xh_put_int(senv->tbl, sym, ~senv->xlen); \
|
||||
senv->xlen++; \
|
||||
} while (0)
|
||||
|
||||
struct pic_senv *
|
||||
pic_minimal_syntactic_env(pic_state *pic)
|
||||
{
|
||||
struct pic_senv *senv = pic_null_syntactic_env(pic);
|
||||
|
||||
register_core_syntax(pic, senv, PIC_STX_DEFLIBRARY, "define-library");
|
||||
register_core_syntax(pic, senv, PIC_STX_IMPORT, "import");
|
||||
register_core_syntax(pic, senv, PIC_STX_EXPORT, "export");
|
||||
|
||||
return senv;
|
||||
}
|
||||
|
||||
struct pic_senv *
|
||||
pic_core_syntactic_env(pic_state *pic)
|
||||
{
|
||||
struct pic_senv *senv = pic_minimal_syntactic_env(pic);
|
||||
|
||||
register_core_syntax(pic, senv, PIC_STX_DEFINE, "define");
|
||||
register_core_syntax(pic, senv, PIC_STX_SET, "set!");
|
||||
register_core_syntax(pic, senv, PIC_STX_QUOTE, "quote");
|
||||
register_core_syntax(pic, senv, PIC_STX_LAMBDA, "lambda");
|
||||
register_core_syntax(pic, senv, PIC_STX_IF, "if");
|
||||
register_core_syntax(pic, senv, PIC_STX_BEGIN, "begin");
|
||||
register_core_syntax(pic, senv, PIC_STX_DEFMACRO, "define-macro");
|
||||
register_core_syntax(pic, senv, PIC_STX_DEFSYNTAX, "define-syntax");
|
||||
|
||||
return senv;
|
||||
}
|
||||
|
||||
#undef register_core_syntax
|
||||
|
||||
static struct pic_senv *
|
||||
new_global_senv(pic_state *pic)
|
||||
{
|
||||
return pic->lib->senv;
|
||||
}
|
||||
|
||||
static struct pic_senv *
|
||||
new_local_senv(pic_state *pic, pic_value formals, struct pic_senv *up)
|
||||
{
|
||||
|
@ -79,12 +32,7 @@ new_local_senv(pic_state *pic, pic_value formals, struct pic_senv *up)
|
|||
pic_value a;
|
||||
pic_sym sym;
|
||||
|
||||
senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV);
|
||||
senv->up = up;
|
||||
senv->tbl = xh_new_int();
|
||||
senv->stx = NULL;
|
||||
senv->xlen = 0;
|
||||
senv->xcapa = 0;
|
||||
senv = new_senv(pic, up);
|
||||
|
||||
for (a = formals; pic_pair_p(a); a = pic_cdr(pic, a)) {
|
||||
pic_value v = pic_car(pic, a);
|
||||
|
@ -96,14 +44,14 @@ new_local_senv(pic_state *pic, pic_value formals, struct pic_senv *up)
|
|||
pic_error(pic, "syntax error");
|
||||
}
|
||||
sym = pic_sym(v);
|
||||
xh_put_int(senv->tbl, sym, pic_gensym(pic, sym));
|
||||
xh_put_int(senv->name, sym, pic_gensym(pic, sym));
|
||||
}
|
||||
if (! pic_sym_p(a)) {
|
||||
a = macroexpand(pic, a, up);
|
||||
}
|
||||
if (pic_sym_p(a)) {
|
||||
sym = pic_sym(a);
|
||||
xh_put_int(senv->tbl, sym, pic_gensym(pic, sym));
|
||||
xh_put_int(senv->name, sym, pic_gensym(pic, sym));
|
||||
}
|
||||
else if (! pic_nil_p(a)) {
|
||||
pic_error(pic, "syntax error");
|
||||
|
@ -111,30 +59,15 @@ new_local_senv(pic_state *pic, pic_value formals, struct pic_senv *up)
|
|||
return senv;
|
||||
}
|
||||
|
||||
struct pic_syntax *
|
||||
pic_syntax_new(pic_state *pic, int kind, pic_sym sym)
|
||||
struct pic_macro *
|
||||
macro_new(pic_state *pic, struct pic_proc *proc, struct pic_senv *mac_env)
|
||||
{
|
||||
struct pic_syntax *stx;
|
||||
struct pic_macro *mac;
|
||||
|
||||
stx = (struct pic_syntax *)pic_obj_alloc(pic, sizeof(struct pic_syntax), PIC_TT_SYNTAX);
|
||||
stx->kind = kind;
|
||||
stx->sym = sym;
|
||||
stx->macro = NULL;
|
||||
stx->senv = NULL;
|
||||
return stx;
|
||||
}
|
||||
|
||||
struct pic_syntax *
|
||||
pic_syntax_new_macro(pic_state *pic, pic_sym sym, struct pic_proc *macro, struct pic_senv *mac_env)
|
||||
{
|
||||
struct pic_syntax *stx;
|
||||
|
||||
stx = (struct pic_syntax *)pic_obj_alloc(pic, sizeof(struct pic_syntax), PIC_TT_SYNTAX);
|
||||
stx->kind = PIC_STX_MACRO;
|
||||
stx->sym = sym;
|
||||
stx->macro = macro;
|
||||
stx->senv = mac_env;
|
||||
return stx;
|
||||
mac = (struct pic_macro *)pic_obj_alloc(pic, sizeof(struct pic_macro), PIC_TT_MACRO);
|
||||
mac->senv = mac_env;
|
||||
mac->proc = proc;
|
||||
return mac;
|
||||
}
|
||||
|
||||
static struct pic_sc *
|
||||
|
@ -149,29 +82,28 @@ sc_new(pic_state *pic, pic_value expr, struct pic_senv *senv)
|
|||
}
|
||||
|
||||
static bool
|
||||
pic_identifier_p(pic_value obj)
|
||||
identifier_p(pic_value obj)
|
||||
{
|
||||
if (pic_sym_p(obj)) {
|
||||
return true;
|
||||
}
|
||||
if (pic_sc_p(obj)) {
|
||||
return pic_identifier_p(pic_sc(obj)->expr);
|
||||
return identifier_p(pic_sc(obj)->expr);
|
||||
}
|
||||
return false;
|
||||
}
|
||||
|
||||
static pic_value
|
||||
strip(pic_state *pic, pic_value expr)
|
||||
static bool
|
||||
identifier_eq_p(pic_state *pic, struct pic_senv *e1, pic_value x, struct pic_senv *e2, pic_value y)
|
||||
{
|
||||
if (pic_sc_p(expr)) {
|
||||
return strip(pic, pic_sc(expr)->expr);
|
||||
if (! (identifier_p(x) && identifier_p(y))) {
|
||||
return false;
|
||||
}
|
||||
else if (pic_pair_p(expr)) {
|
||||
return pic_cons(pic,
|
||||
strip(pic, pic_car(pic, expr)),
|
||||
strip(pic, pic_cdr(pic, expr)));
|
||||
}
|
||||
return expr;
|
||||
|
||||
x = macroexpand(pic, x, e1);
|
||||
y = macroexpand(pic, y, e2);
|
||||
|
||||
return pic_eq_p(x, y);
|
||||
}
|
||||
|
||||
void
|
||||
|
@ -185,30 +117,19 @@ pic_import(pic_state *pic, pic_value spec)
|
|||
pic_error(pic, "library not found");
|
||||
}
|
||||
for (xh_begin(lib->exports, &it); ! xh_isend(&it); xh_next(&it)) {
|
||||
|
||||
#if DEBUG
|
||||
if (it.e->val >= 0) {
|
||||
printf("* importing %s as %s\n", pic_symbol_name(pic, (long)it.e->key), pic_symbol_name(pic, it.e->val));
|
||||
printf("* importing %s as %s\n",
|
||||
pic_symbol_name(pic, (long)it.e->key),
|
||||
pic_symbol_name(pic, it.e->val));
|
||||
}
|
||||
else {
|
||||
printf("* importing %s\n", pic_symbol_name(pic, (long)it.e->key));
|
||||
}
|
||||
#endif
|
||||
if (it.e->val >= 0) {
|
||||
xh_put_int(pic->lib->senv->tbl, (long)it.e->key, it.e->val);
|
||||
}
|
||||
else { /* syntax object */
|
||||
size_t idx;
|
||||
struct pic_senv *senv = pic->lib->senv;
|
||||
|
||||
idx = senv->xlen;
|
||||
if (idx >= senv->xcapa) {
|
||||
pic_abort(pic, "macro table overflow");
|
||||
}
|
||||
/* bring macro object from imported lib */
|
||||
senv->stx[idx] = lib->senv->stx[~it.e->val];
|
||||
xh_put_int(senv->tbl, (long)it.e->key, ~idx);
|
||||
senv->xlen++;
|
||||
}
|
||||
xh_put_int(pic->lib->senv->name, (long)it.e->key, it.e->val);
|
||||
}
|
||||
}
|
||||
|
||||
|
@ -217,7 +138,7 @@ pic_export(pic_state *pic, pic_sym sym)
|
|||
{
|
||||
xh_entry *e;
|
||||
|
||||
e = xh_get_int(pic->lib->senv->tbl, sym);
|
||||
e = xh_get_int(pic->lib->senv->name, sym);
|
||||
if (! e) {
|
||||
pic_error(pic, "symbol not defined");
|
||||
}
|
||||
|
@ -225,40 +146,55 @@ pic_export(pic_state *pic, pic_sym sym)
|
|||
}
|
||||
|
||||
static void
|
||||
defsyntax(pic_state *pic, const char *name, struct pic_proc *macro, struct pic_senv *mac_env)
|
||||
defsyntax(pic_state *pic, pic_sym sym, struct pic_proc *macro, struct pic_senv *mac_env)
|
||||
{
|
||||
pic_sym sym;
|
||||
struct pic_syntax *stx;
|
||||
struct pic_senv *global_senv = pic->lib->senv;
|
||||
size_t idx;
|
||||
struct pic_macro *mac;
|
||||
pic_sym uniq;
|
||||
|
||||
sym = pic_intern_cstr(pic, name);
|
||||
stx = pic_syntax_new_macro(pic, sym, macro, mac_env);
|
||||
mac = macro_new(pic, macro, mac_env);
|
||||
|
||||
idx = global_senv->xlen;
|
||||
if (idx >= global_senv->xcapa) {
|
||||
pic_abort(pic, "macro table overflow");
|
||||
}
|
||||
global_senv->stx[idx] = stx;
|
||||
xh_put_int(global_senv->tbl, sym, ~idx);
|
||||
global_senv->xlen++;
|
||||
uniq = pic_gensym(pic, sym);
|
||||
xh_put_int(pic->lib->senv->name, sym, uniq);
|
||||
xh_put_int(pic->macros, uniq, (long)mac);
|
||||
}
|
||||
|
||||
static void
|
||||
defmacro(pic_state *pic, const char *name, struct pic_proc *macro)
|
||||
defmacro(pic_state *pic, pic_sym sym, struct pic_proc *macro)
|
||||
{
|
||||
defsyntax(pic, name, macro, NULL);
|
||||
defsyntax(pic, sym, macro, NULL);
|
||||
}
|
||||
|
||||
void
|
||||
pic_defmacro(pic_state *pic, const char *name, struct pic_proc *macro)
|
||||
{
|
||||
defmacro(pic, name, macro);
|
||||
defmacro(pic, pic_intern_cstr(pic, name), macro);
|
||||
|
||||
/* auto export! */
|
||||
pic_export(pic, pic_intern_cstr(pic, name));
|
||||
}
|
||||
|
||||
static pic_sym
|
||||
symbol_rename(pic_state *pic, pic_sym sym, struct pic_senv *senv)
|
||||
{
|
||||
xh_entry *e;
|
||||
pic_sym uniq;
|
||||
|
||||
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 (! senv->up)
|
||||
break;
|
||||
senv = senv->up;
|
||||
}
|
||||
uniq = pic_gensym(pic, sym);
|
||||
xh_put_int(senv->name, sym, uniq);
|
||||
return uniq;
|
||||
}
|
||||
|
||||
static pic_value
|
||||
macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
|
||||
{
|
||||
|
@ -278,34 +214,17 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
|
|||
return macroexpand(pic, sc->expr, sc->senv);
|
||||
}
|
||||
case PIC_TT_SYMBOL: {
|
||||
xh_entry *e;
|
||||
pic_sym uniq;
|
||||
|
||||
if (! pic_interned_p(pic, pic_sym(expr))) {
|
||||
return expr;
|
||||
}
|
||||
while (true) {
|
||||
if ((e = xh_get_int(senv->tbl, pic_sym(expr))) != NULL) {
|
||||
if (e->val >= 0)
|
||||
return pic_symbol_value(e->val);
|
||||
else
|
||||
return pic_obj_value(senv->stx[~e->val]);
|
||||
}
|
||||
if (! senv->up)
|
||||
break;
|
||||
senv = senv->up;
|
||||
}
|
||||
uniq = pic_gensym(pic, pic_sym(expr));
|
||||
xh_put_int(senv->tbl, pic_sym(expr), uniq);
|
||||
return pic_symbol_value(uniq);
|
||||
return pic_symbol_value(symbol_rename(pic, pic_sym(expr), senv));
|
||||
}
|
||||
case PIC_TT_PAIR: {
|
||||
pic_value car, v;
|
||||
xh_entry *e;
|
||||
|
||||
car = macroexpand(pic, pic_car(pic, expr), senv);
|
||||
if (pic_syntax_p(car)) {
|
||||
switch (pic_syntax(car)->kind) {
|
||||
case PIC_STX_DEFLIBRARY: {
|
||||
if (pic_sym_p(car)) {
|
||||
pic_sym tag = pic_sym(car);
|
||||
|
||||
if (tag == pic->sDEFINE_LIBRARY) {
|
||||
struct pic_lib *prev = pic->lib;
|
||||
|
||||
if (pic_length(pic, expr) < 2) {
|
||||
|
@ -335,14 +254,16 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
|
|||
|
||||
return pic_none_value();
|
||||
}
|
||||
case PIC_STX_IMPORT: {
|
||||
|
||||
else if (tag == pic->sIMPORT) {
|
||||
pic_value spec;
|
||||
pic_for_each (spec, pic_cdr(pic, expr)) {
|
||||
pic_import(pic, spec);
|
||||
}
|
||||
return pic_none_value();
|
||||
}
|
||||
case PIC_STX_EXPORT: {
|
||||
|
||||
else if (tag == pic->sEXPORT) {
|
||||
pic_value spec;
|
||||
pic_for_each (spec, pic_cdr(pic, expr)) {
|
||||
if (! pic_sym_p(spec)) {
|
||||
|
@ -353,7 +274,8 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
|
|||
}
|
||||
return pic_none_value();
|
||||
}
|
||||
case PIC_STX_DEFSYNTAX: {
|
||||
|
||||
else if (tag == pic->sDEFINE_SYNTAX) {
|
||||
pic_value var, val;
|
||||
struct pic_proc *proc;
|
||||
|
||||
|
@ -361,7 +283,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
|
|||
pic_error(pic, "syntax error");
|
||||
}
|
||||
|
||||
var = strip(pic, pic_cadr(pic, expr));
|
||||
var = pic_cadr(pic, expr);
|
||||
if (! pic_sym_p(var)) {
|
||||
pic_error(pic, "syntax error");
|
||||
}
|
||||
|
@ -378,12 +300,13 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
|
|||
abort();
|
||||
}
|
||||
assert(pic_proc_p(v));
|
||||
defsyntax(pic, pic_symbol_name(pic, pic_sym(var)), pic_proc_ptr(v), senv);
|
||||
defsyntax(pic, pic_sym(var), pic_proc_ptr(v), senv);
|
||||
|
||||
pic_gc_arena_restore(pic, ai);
|
||||
return pic_none_value();
|
||||
}
|
||||
case PIC_STX_DEFMACRO: {
|
||||
|
||||
else if (tag == pic->sDEFINE_MACRO) {
|
||||
pic_value var, val;
|
||||
struct pic_proc *proc;
|
||||
|
||||
|
@ -420,41 +343,16 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
|
|||
abort();
|
||||
}
|
||||
assert(pic_proc_p(v));
|
||||
defmacro(pic, pic_symbol_name(pic, pic_sym(var)), pic_proc_ptr(v));
|
||||
defmacro(pic, pic_sym(var), pic_proc_ptr(v));
|
||||
|
||||
pic_gc_arena_restore(pic, ai);
|
||||
return pic_none_value();
|
||||
}
|
||||
case PIC_STX_MACRO: {
|
||||
if (pic_syntax(car)->senv == NULL) { /* legacy macro */
|
||||
v = pic_apply(pic, pic_syntax(car)->macro, pic_cdr(pic, expr));
|
||||
if (pic->err) {
|
||||
printf("macroexpand error: %s\n", pic_errmsg(pic));
|
||||
abort();
|
||||
}
|
||||
}
|
||||
else {
|
||||
v = pic_apply_argv(pic, pic_syntax(car)->macro, 3, expr, pic_obj_value(senv), pic_obj_value(pic_syntax(car)->senv));
|
||||
if (pic->err) {
|
||||
printf("macroexpand error: %s\n", pic_errmsg(pic));
|
||||
abort();
|
||||
}
|
||||
}
|
||||
pic_gc_arena_restore(pic, ai);
|
||||
pic_gc_protect(pic, v);
|
||||
|
||||
#if DEBUG
|
||||
puts("after expand-1:");
|
||||
pic_debug(pic, v);
|
||||
puts("");
|
||||
#endif
|
||||
|
||||
return macroexpand(pic, v, senv);
|
||||
}
|
||||
case PIC_STX_LAMBDA: {
|
||||
else if (tag == pic->sLAMBDA) {
|
||||
struct pic_senv *in = new_local_senv(pic, pic_cadr(pic, expr), senv);
|
||||
|
||||
v = pic_cons(pic, pic_symbol_value(pic_syntax(car)->sym),
|
||||
v = pic_cons(pic, car,
|
||||
pic_cons(pic,
|
||||
macroexpand_list(pic, pic_cadr(pic, expr), in),
|
||||
macroexpand_list(pic, pic_cddr(pic, expr), in)));
|
||||
|
@ -463,7 +361,8 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
|
|||
pic_gc_protect(pic, v);
|
||||
return v;
|
||||
}
|
||||
case PIC_STX_DEFINE: {
|
||||
|
||||
else if (tag == pic->sDEFINE) {
|
||||
pic_sym var;
|
||||
pic_value formals;
|
||||
|
||||
|
@ -485,11 +384,11 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
|
|||
pic_error(pic, "binding to non-symbol object");
|
||||
}
|
||||
var = pic_sym(a);
|
||||
xh_put_int(senv->tbl, var, pic_gensym(pic, var));
|
||||
xh_put_int(senv->name, var, pic_gensym(pic, var));
|
||||
|
||||
/* binding value */
|
||||
v = pic_cons(pic, pic_symbol_value(pic_syntax(car)->sym),
|
||||
pic_cons(pic,
|
||||
v = pic_cons(pic, car,
|
||||
pic_cons(pic,
|
||||
macroexpand_list(pic, pic_cadr(pic, expr), in),
|
||||
macroexpand_list(pic, pic_cddr(pic, expr), in)));
|
||||
|
||||
|
@ -506,24 +405,62 @@ 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->tbl, var) == NULL) {
|
||||
xh_put_int(senv->tbl, var, pic_gensym(pic, var));
|
||||
if (xh_get_int(senv->name, var) == NULL) {
|
||||
xh_put_int(senv->name, var, pic_gensym(pic, var));
|
||||
}
|
||||
|
||||
v = pic_cons(pic, pic_symbol_value(tag),
|
||||
macroexpand_list(pic, pic_cdr(pic, expr), senv));
|
||||
pic_gc_arena_restore(pic, ai);
|
||||
pic_gc_protect(pic, v);
|
||||
return v;
|
||||
}
|
||||
FALLTHROUGH;
|
||||
case PIC_STX_SET:
|
||||
case PIC_STX_IF:
|
||||
case PIC_STX_BEGIN:
|
||||
v = pic_cons(pic, pic_symbol_value(pic_syntax(car)->sym), macroexpand_list(pic, pic_cdr(pic, expr), senv));
|
||||
|
||||
else if (tag == pic->sSETBANG || tag == pic->sIF || tag == pic->sBEGIN) {
|
||||
v = pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv));
|
||||
pic_gc_arena_restore(pic, ai);
|
||||
pic_gc_protect(pic, v);
|
||||
return v;
|
||||
case PIC_STX_QUOTE:
|
||||
v = pic_cons(pic, pic_symbol_value(pic_syntax(car)->sym), pic_cdr(pic, expr));
|
||||
}
|
||||
|
||||
else if (tag == pic->sQUOTE) {
|
||||
v = pic_cons(pic, car, pic_cdr(pic, expr));
|
||||
pic_gc_arena_restore(pic, ai);
|
||||
pic_gc_protect(pic, v);
|
||||
return v;
|
||||
}
|
||||
|
||||
/* macro */
|
||||
if ((e = xh_get_int(pic->macros, tag)) != NULL) {
|
||||
pic_value v;
|
||||
struct pic_macro *mac;
|
||||
|
||||
mac = (struct pic_macro *)e->val;
|
||||
if (mac->senv == NULL) { /* legacy macro */
|
||||
v = pic_apply(pic, mac->proc, pic_cdr(pic, expr));
|
||||
if (pic->err) {
|
||||
printf("macroexpand error: %s\n", pic_errmsg(pic));
|
||||
abort();
|
||||
}
|
||||
}
|
||||
else {
|
||||
v = pic_apply_argv(pic, mac->proc, 3, expr, pic_obj_value(senv), pic_obj_value(mac->senv));
|
||||
if (pic->err) {
|
||||
printf("macroexpand error: %s\n", pic_errmsg(pic));
|
||||
abort();
|
||||
}
|
||||
}
|
||||
pic_gc_arena_restore(pic, ai);
|
||||
pic_gc_protect(pic, v);
|
||||
|
||||
#if DEBUG
|
||||
puts("after expand-1:");
|
||||
pic_debug(pic, v);
|
||||
puts("");
|
||||
#endif
|
||||
|
||||
return macroexpand(pic, v, senv);
|
||||
}
|
||||
}
|
||||
|
||||
v = pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv));
|
||||
|
@ -549,7 +486,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
|
|||
case PIC_TT_CONT:
|
||||
case PIC_TT_UNDEF:
|
||||
case PIC_TT_SENV:
|
||||
case PIC_TT_SYNTAX:
|
||||
case PIC_TT_MACRO:
|
||||
case PIC_TT_LIB:
|
||||
case PIC_TT_VAR:
|
||||
case PIC_TT_IREP:
|
||||
|
@ -575,18 +512,15 @@ macroexpand_list(pic_state *pic, pic_value list, struct pic_senv *senv)
|
|||
pic_value
|
||||
pic_macroexpand(pic_state *pic, pic_value expr)
|
||||
{
|
||||
struct pic_senv *senv;
|
||||
pic_value v;
|
||||
|
||||
senv = new_global_senv(pic);
|
||||
|
||||
#if DEBUG
|
||||
puts("before expand:");
|
||||
pic_debug(pic, expr);
|
||||
puts("");
|
||||
#endif
|
||||
|
||||
v = macroexpand(pic, expr, senv);
|
||||
v = macroexpand(pic, expr, pic->lib->senv);
|
||||
|
||||
#if DEBUG
|
||||
puts("after expand:");
|
||||
|
@ -597,6 +531,46 @@ pic_macroexpand(pic_state *pic, pic_value expr)
|
|||
return v;
|
||||
}
|
||||
|
||||
struct pic_senv *
|
||||
pic_null_syntactic_env(pic_state *pic)
|
||||
{
|
||||
return new_senv(pic, NULL);
|
||||
}
|
||||
|
||||
#define register_core_syntax(pic,senv,id) do { \
|
||||
pic_sym sym = pic_intern_cstr(pic, id); \
|
||||
xh_put_int(senv->name, sym, sym); \
|
||||
} while (0)
|
||||
|
||||
struct pic_senv *
|
||||
pic_minimal_syntactic_env(pic_state *pic)
|
||||
{
|
||||
struct pic_senv *senv = pic_null_syntactic_env(pic);
|
||||
|
||||
register_core_syntax(pic, senv, "define-library");
|
||||
register_core_syntax(pic, senv, "import");
|
||||
register_core_syntax(pic, senv, "export");
|
||||
|
||||
return senv;
|
||||
}
|
||||
|
||||
struct pic_senv *
|
||||
pic_core_syntactic_env(pic_state *pic)
|
||||
{
|
||||
struct pic_senv *senv = pic_minimal_syntactic_env(pic);
|
||||
|
||||
register_core_syntax(pic, senv, "define");
|
||||
register_core_syntax(pic, senv, "set!");
|
||||
register_core_syntax(pic, senv, "quote");
|
||||
register_core_syntax(pic, senv, "lambda");
|
||||
register_core_syntax(pic, senv, "if");
|
||||
register_core_syntax(pic, senv, "begin");
|
||||
register_core_syntax(pic, senv, "define-macro");
|
||||
register_core_syntax(pic, senv, "define-syntax");
|
||||
|
||||
return senv;
|
||||
}
|
||||
|
||||
/* once read.c is implemented move there */
|
||||
static pic_value
|
||||
pic_macro_include(pic_state *pic)
|
||||
|
@ -655,7 +629,7 @@ pic_macro_identifier_p(pic_state *pic)
|
|||
|
||||
pic_get_args(pic, "o", &obj);
|
||||
|
||||
return pic_bool_value(pic_identifier_p(obj));
|
||||
return pic_bool_value(identifier_p(obj));
|
||||
}
|
||||
|
||||
static pic_value
|
||||
|
@ -675,14 +649,7 @@ pic_macro_identifier_eq_p(pic_state *pic)
|
|||
}
|
||||
e2 = pic_senv(f);
|
||||
|
||||
if (! (pic_identifier_p(x) && pic_identifier_p(y))) {
|
||||
return pic_false_value();
|
||||
}
|
||||
|
||||
x = macroexpand(pic, x, e1);
|
||||
y = macroexpand(pic, y, e2);
|
||||
|
||||
return pic_bool_value(pic_eq_p(x, y));
|
||||
return pic_bool_value(identifier_eq_p(pic, e1, x, e2, y));
|
||||
}
|
||||
|
||||
static pic_value
|
||||
|
@ -690,19 +657,12 @@ er_macro_rename(pic_state *pic)
|
|||
{
|
||||
pic_sym sym;
|
||||
struct pic_senv *mac_env;
|
||||
pic_value v;
|
||||
|
||||
pic_get_args(pic, "m", &sym);
|
||||
|
||||
mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1));
|
||||
|
||||
v = macroexpand(pic, pic_symbol_value(sym), mac_env);
|
||||
if (pic_syntax_p(v)) {
|
||||
return pic_symbol_value(sym);
|
||||
}
|
||||
else {
|
||||
return v;
|
||||
}
|
||||
return pic_symbol_value(symbol_rename(pic, sym, mac_env));
|
||||
}
|
||||
|
||||
static pic_value
|
||||
|
@ -710,6 +670,7 @@ er_macro_compare(pic_state *pic)
|
|||
{
|
||||
pic_value a, b;
|
||||
struct pic_senv *use_env;
|
||||
pic_sym m, n;
|
||||
|
||||
pic_get_args(pic, "oo", &a, &b);
|
||||
|
||||
|
@ -718,10 +679,10 @@ er_macro_compare(pic_state *pic)
|
|||
|
||||
use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
|
||||
|
||||
a = macroexpand(pic, a, use_env);
|
||||
b = macroexpand(pic, b, use_env);
|
||||
m = symbol_rename(pic, pic_sym(a), use_env);
|
||||
n = symbol_rename(pic, pic_sym(b), use_env);
|
||||
|
||||
return pic_bool_value(pic_eq_p(a, b));
|
||||
return pic_bool_value(m == n);
|
||||
}
|
||||
|
||||
static pic_value
|
||||
|
@ -773,19 +734,12 @@ ir_macro_inject(pic_state *pic)
|
|||
{
|
||||
pic_sym sym;
|
||||
struct pic_senv *use_env;
|
||||
pic_value v;
|
||||
|
||||
pic_get_args(pic, "m", &sym);
|
||||
|
||||
use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
|
||||
|
||||
v = macroexpand(pic, pic_symbol_value(sym), use_env);
|
||||
if (pic_syntax_p(v)) {
|
||||
return pic_symbol_value(sym);
|
||||
}
|
||||
else {
|
||||
return v;
|
||||
}
|
||||
return pic_symbol_value(symbol_rename(pic, sym, use_env));
|
||||
}
|
||||
|
||||
static pic_value
|
||||
|
@ -793,6 +747,7 @@ ir_macro_compare(pic_state *pic)
|
|||
{
|
||||
pic_value a, b;
|
||||
struct pic_senv *use_env;
|
||||
pic_sym m, n;
|
||||
|
||||
pic_get_args(pic, "oo", &a, &b);
|
||||
|
||||
|
@ -801,10 +756,10 @@ ir_macro_compare(pic_state *pic)
|
|||
|
||||
use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
|
||||
|
||||
a = macroexpand(pic, a, use_env);
|
||||
b = macroexpand(pic, b, use_env);
|
||||
m = symbol_rename(pic, pic_sym(a), use_env);
|
||||
n = symbol_rename(pic, pic_sym(b), use_env);
|
||||
|
||||
return pic_bool_value(pic_eq_p(a, b));
|
||||
return pic_bool_value(m == n);
|
||||
}
|
||||
|
||||
static pic_value
|
||||
|
@ -829,13 +784,13 @@ ir_macro_wrap(pic_state *pic, pic_value expr, struct pic_senv *use_env, pic_valu
|
|||
static pic_value
|
||||
ir_macro_unwrap(pic_state *pic, pic_value expr, struct pic_senv *mac_env, pic_value *assoc)
|
||||
{
|
||||
if (pic_sym_p(expr) || pic_syntax_p(expr)) {
|
||||
if (pic_sym_p(expr) || pic_macro_p(expr)) {
|
||||
pic_value r;
|
||||
if (pic_test(r = pic_assq(pic, expr, *assoc))) {
|
||||
return pic_cdr(pic, r);
|
||||
}
|
||||
r = macroexpand(pic, expr, mac_env);
|
||||
if (pic_syntax_p(r)) {
|
||||
if (pic_macro_p(r)) {
|
||||
return expr;
|
||||
}
|
||||
else {
|
||||
|
|
30
src/proc.c
30
src/proc.c
|
@ -72,6 +72,36 @@ pic_proc_cv_set(pic_state *pic, struct pic_proc *proc, size_t i, pic_value v)
|
|||
proc->env->values[i] = v;
|
||||
}
|
||||
|
||||
static pic_value
|
||||
papply_call(pic_state *pic)
|
||||
{
|
||||
size_t argc;
|
||||
pic_value *argv, arg, arg_list;
|
||||
struct pic_proc *proc;
|
||||
|
||||
pic_get_args(pic, "*", &argc, &argv);
|
||||
|
||||
proc = pic_proc_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0));
|
||||
arg = pic_proc_cv_ref(pic, pic_get_proc(pic), 1);
|
||||
|
||||
arg_list = pic_list_by_array(pic, argc, argv);
|
||||
arg_list = pic_cons(pic, arg, arg_list);
|
||||
return pic_apply(pic, proc, arg_list);
|
||||
}
|
||||
|
||||
struct pic_proc *
|
||||
pic_papply(pic_state *pic, struct pic_proc *proc, pic_value arg)
|
||||
{
|
||||
struct pic_proc *pa_proc;
|
||||
|
||||
pa_proc = pic_proc_new(pic, papply_call);
|
||||
pic_proc_cv_init(pic, pa_proc, 2);
|
||||
pic_proc_cv_set(pic, pa_proc, 0, pic_obj_value(proc));
|
||||
pic_proc_cv_set(pic, pa_proc, 1, arg);
|
||||
|
||||
return pa_proc;
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_proc_proc_p(pic_state *pic)
|
||||
{
|
||||
|
|
|
@ -64,6 +64,9 @@ pic_open(int argc, char *argv[], char **envp)
|
|||
pic->glen = 0;
|
||||
pic->gcapa = PIC_GLOBALS_SIZE;
|
||||
|
||||
/* macros */
|
||||
pic->macros = xh_new_int();
|
||||
|
||||
/* libraries */
|
||||
pic->lib_tbl = pic_nil_value();
|
||||
pic->lib = NULL;
|
||||
|
@ -142,9 +145,13 @@ pic_close(pic_state *pic)
|
|||
pic->arena_idx = 0;
|
||||
pic->lib_tbl = pic_undef_value();
|
||||
|
||||
xh_clear(pic->macros);
|
||||
|
||||
/* free all values */
|
||||
pic_gc_run(pic);
|
||||
|
||||
xh_destroy(pic->macros);
|
||||
|
||||
/* free heaps */
|
||||
finalize_heap(pic->heap);
|
||||
free(pic->heap);
|
||||
|
|
|
@ -134,8 +134,8 @@ write(pic_state *pic, pic_value obj, XFILE *file)
|
|||
case PIC_TT_SENV:
|
||||
xfprintf(file, "#<senv %p>", pic_ptr(obj));
|
||||
break;
|
||||
case PIC_TT_SYNTAX:
|
||||
xfprintf(file, "#<syntax %p>", pic_ptr(obj));
|
||||
case PIC_TT_MACRO:
|
||||
xfprintf(file, "#<macro %p>", pic_ptr(obj));
|
||||
break;
|
||||
case PIC_TT_SC:
|
||||
xfprintf(file, "#<sc %p: ", pic_ptr(obj));
|
||||
|
|
Loading…
Reference in New Issue