[WIP] replace macro expander
remove define-syntax, add define-macro instead saner display when writing identifiers
This commit is contained in:
Yuichi Nishiwaki
parent
454146ab52
commit
3a59a95960
|
|
@ -411,14 +411,24 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
|
|||
case PIC_TT_BLOB: {
|
||||
break;
|
||||
}
|
||||
case PIC_TT_ID: {
|
||||
struct pic_id *id = (struct pic_id *)obj;
|
||||
gc_mark(pic, id->var);
|
||||
gc_mark_object(pic, (struct pic_object *)id->env);
|
||||
break;
|
||||
}
|
||||
case PIC_TT_ENV: {
|
||||
struct pic_env *env = (struct pic_env *)obj;
|
||||
xh_entry *it;
|
||||
|
||||
if (env->up) {
|
||||
gc_mark_object(pic, (struct pic_object *)env->up);
|
||||
}
|
||||
gc_mark(pic, env->defer);
|
||||
gc_mark_object(pic, (struct pic_object *)env->map);
|
||||
for (it = xh_begin(&env->map); it != NULL; it = xh_next(it)) {
|
||||
gc_mark_object(pic, xh_key(it, struct pic_object *));
|
||||
gc_mark_object(pic, xh_val(it, struct pic_object *));
|
||||
}
|
||||
break;
|
||||
}
|
||||
case PIC_TT_LIB: {
|
||||
|
|
@ -519,7 +529,7 @@ gc_mark_global_symbols(pic_state *pic)
|
|||
{
|
||||
M(sDEFINE); M(sLAMBDA); M(sIF); M(sBEGIN); M(sQUOTE); M(sSETBANG);
|
||||
M(sQUASIQUOTE); M(sUNQUOTE); M(sUNQUOTE_SPLICING);
|
||||
M(sDEFINE_SYNTAX); M(sIMPORT); M(sEXPORT);
|
||||
M(sDEFINE_MACRO); M(sIMPORT); M(sEXPORT);
|
||||
M(sDEFINE_LIBRARY);
|
||||
M(sCOND_EXPAND); M(sAND); M(sOR); M(sELSE); M(sLIBRARY);
|
||||
M(sONLY); M(sRENAME); M(sPREFIX); M(sEXCEPT);
|
||||
|
|
@ -532,7 +542,7 @@ gc_mark_global_symbols(pic_state *pic)
|
|||
M(sGREF); M(sLREF); M(sCREF); M(sRETURN);
|
||||
|
||||
M(uDEFINE); M(uLAMBDA); M(uIF); M(uBEGIN); M(uQUOTE); M(uSETBANG);
|
||||
M(uDEFINE_SYNTAX); M(uIMPORT); M(uEXPORT);
|
||||
M(uDEFINE_MACRO); M(uIMPORT); M(uEXPORT);
|
||||
M(uDEFINE_LIBRARY);
|
||||
M(uCOND_EXPAND);
|
||||
M(uCONS); M(uCAR); M(uCDR); M(uNILP);
|
||||
|
|
@ -681,7 +691,12 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
|
|||
case PIC_TT_ERROR: {
|
||||
break;
|
||||
}
|
||||
case PIC_TT_ID: {
|
||||
break;
|
||||
}
|
||||
case PIC_TT_ENV: {
|
||||
struct pic_env *env = (struct pic_env *)obj;
|
||||
xh_destroy(&env->map);
|
||||
break;
|
||||
}
|
||||
case PIC_TT_LIB: {
|
||||
|
|
|
|||
|
|
@ -98,7 +98,7 @@ typedef struct {
|
|||
|
||||
pic_sym *sDEFINE, *sLAMBDA, *sIF, *sBEGIN, *sQUOTE, *sSETBANG;
|
||||
pic_sym *sQUASIQUOTE, *sUNQUOTE, *sUNQUOTE_SPLICING;
|
||||
pic_sym *sDEFINE_SYNTAX, *sIMPORT, *sEXPORT;
|
||||
pic_sym *sDEFINE_MACRO, *sIMPORT, *sEXPORT;
|
||||
pic_sym *sDEFINE_LIBRARY;
|
||||
pic_sym *sCOND_EXPAND, *sAND, *sOR, *sELSE, *sLIBRARY;
|
||||
pic_sym *sONLY, *sRENAME, *sPREFIX, *sEXCEPT;
|
||||
|
|
@ -112,7 +112,7 @@ typedef struct {
|
|||
pic_sym *sCALL_WITH_VALUES, *sTAILCALL_WITH_VALUES;
|
||||
|
||||
pic_sym *uDEFINE, *uLAMBDA, *uIF, *uBEGIN, *uQUOTE, *uSETBANG;
|
||||
pic_sym *uDEFINE_SYNTAX, *uIMPORT, *uEXPORT;
|
||||
pic_sym *uDEFINE_MACRO, *uIMPORT, *uEXPORT;
|
||||
pic_sym *uDEFINE_LIBRARY;
|
||||
pic_sym *uCOND_EXPAND;
|
||||
pic_sym *uCONS, *uCAR, *uCDR, *uNILP;
|
||||
|
|
@ -127,6 +127,7 @@ typedef struct {
|
|||
pic_value features;
|
||||
|
||||
xhash syms; /* name to symbol */
|
||||
int ucnt;
|
||||
struct pic_dict *globals;
|
||||
struct pic_dict *macros;
|
||||
pic_value libs;
|
||||
|
|
@ -193,8 +194,6 @@ bool pic_equal_p(pic_state *, pic_value, pic_value);
|
|||
pic_sym *pic_intern(pic_state *, pic_str *);
|
||||
pic_sym *pic_intern_cstr(pic_state *, const char *);
|
||||
const char *pic_symbol_name(pic_state *, pic_sym *);
|
||||
pic_sym *pic_gensym(pic_state *, pic_sym *);
|
||||
bool pic_interned_p(pic_state *, pic_sym *);
|
||||
|
||||
pic_value pic_read(pic_state *, struct pic_port *);
|
||||
pic_value pic_read_cstr(pic_state *, const char *);
|
||||
|
|
|
|||
|
|
@ -9,24 +9,35 @@
|
|||
extern "C" {
|
||||
#endif
|
||||
|
||||
struct pic_id {
|
||||
PIC_OBJECT_HEADER
|
||||
pic_value var;
|
||||
struct pic_env *env;
|
||||
};
|
||||
|
||||
struct pic_env {
|
||||
PIC_OBJECT_HEADER
|
||||
struct pic_dict *map;
|
||||
xhash map;
|
||||
pic_value defer;
|
||||
struct pic_env *up;
|
||||
};
|
||||
|
||||
#define pic_id_p(v) (pic_type(v) == PIC_TT_ID)
|
||||
#define pic_id_ptr(v) ((struct pic_id *)pic_ptr(v))
|
||||
|
||||
#define pic_env_p(v) (pic_type(v) == PIC_TT_ENV)
|
||||
#define pic_env_ptr(v) ((struct pic_env *)pic_ptr(v))
|
||||
|
||||
bool pic_identifier_p(pic_state *pic, pic_value obj);
|
||||
bool pic_identifier_eq_p(pic_state *, struct pic_env *, pic_sym *, struct pic_env *, pic_sym *);
|
||||
|
||||
struct pic_id *pic_make_id(pic_state *, pic_value, struct pic_env *);
|
||||
struct pic_env *pic_make_env(pic_state *, struct pic_env *);
|
||||
|
||||
pic_sym *pic_add_rename(pic_state *, struct pic_env *, pic_sym *);
|
||||
pic_sym *pic_find_rename(pic_state *, struct pic_env *, pic_sym *);
|
||||
void pic_put_rename(pic_state *, struct pic_env *, pic_sym *, pic_sym *);
|
||||
pic_sym *pic_uniq(pic_state *, pic_value);
|
||||
|
||||
pic_sym *pic_add_variable(pic_state *, struct pic_env *, pic_value);
|
||||
void pic_put_variable(pic_state *, struct pic_env *, pic_value, pic_sym *);
|
||||
pic_sym *pic_find_variable(pic_state *, struct pic_env *, pic_value);
|
||||
|
||||
pic_sym *pic_var_name(pic_state *, pic_value);
|
||||
|
||||
#if defined(__cplusplus)
|
||||
}
|
||||
|
|
|
|||
|
|
@ -157,6 +157,7 @@ enum pic_tt {
|
|||
PIC_TT_PROC,
|
||||
PIC_TT_PORT,
|
||||
PIC_TT_ERROR,
|
||||
PIC_TT_ID,
|
||||
PIC_TT_CXT,
|
||||
PIC_TT_ENV,
|
||||
PIC_TT_LIB,
|
||||
|
|
@ -314,6 +315,8 @@ pic_type_repr(enum pic_tt tt)
|
|||
return "port";
|
||||
case PIC_TT_ERROR:
|
||||
return "error";
|
||||
case PIC_TT_ID:
|
||||
return "id";
|
||||
case PIC_TT_CXT:
|
||||
return "cxt";
|
||||
case PIC_TT_PROC:
|
||||
|
|
|
|||
|
|
@ -110,14 +110,14 @@ import_table(pic_state *pic, pic_value spec, struct pic_dict *imports)
|
|||
pic_errorf(pic, "library not found: ~a", spec);
|
||||
}
|
||||
pic_dict_for_each (nick, lib->exports, iter) {
|
||||
pic_sym *realname, *rename;
|
||||
pic_sym *realname, *uid;
|
||||
|
||||
realname = pic_sym_ptr(pic_dict_ref(pic, lib->exports, nick));
|
||||
|
||||
if ((rename = pic_find_rename(pic, lib->env, realname)) == NULL) {
|
||||
if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(realname))) == NULL) {
|
||||
pic_errorf(pic, "attempted to export undefined variable '~s'", pic_obj_value(realname));
|
||||
}
|
||||
pic_dict_set(pic, imports, nick, pic_obj_value(rename));
|
||||
pic_dict_set(pic, imports, nick, pic_obj_value(uid));
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -133,7 +133,7 @@ import(pic_state *pic, pic_value spec)
|
|||
import_table(pic, spec, imports);
|
||||
|
||||
pic_dict_for_each (sym, imports, it) {
|
||||
pic_put_rename(pic, pic->lib->env, sym, pic_sym_ptr(pic_dict_ref(pic, imports, sym)));
|
||||
pic_put_variable(pic, pic->lib->env, pic_obj_value(sym), pic_sym_ptr(pic_dict_ref(pic, imports, sym)));
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -4,74 +4,155 @@
|
|||
|
||||
#include "picrin.h"
|
||||
|
||||
pic_sym *
|
||||
pic_add_rename(pic_state *pic, struct pic_env *env, pic_sym *sym)
|
||||
static bool
|
||||
pic_var_p(pic_value obj)
|
||||
{
|
||||
pic_sym *rename = pic_gensym(pic, sym);
|
||||
|
||||
pic_put_rename(pic, env, sym, rename);
|
||||
|
||||
return rename;
|
||||
return pic_sym_p(obj) || pic_id_p(obj);
|
||||
}
|
||||
|
||||
void
|
||||
pic_put_rename(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *rename)
|
||||
struct pic_id *
|
||||
pic_make_id(pic_state *pic, pic_value var, struct pic_env *env)
|
||||
{
|
||||
pic_dict_set(pic, env->map, sym, pic_obj_value(rename));
|
||||
struct pic_id *id;
|
||||
|
||||
assert(pic_var_p(var));
|
||||
|
||||
id = (struct pic_id *)pic_obj_alloc(pic, sizeof(struct pic_id), PIC_TT_ID);
|
||||
id->var = var;
|
||||
id->env = env;
|
||||
return id;
|
||||
}
|
||||
|
||||
struct pic_env *
|
||||
pic_make_env(pic_state *pic, struct pic_env *up)
|
||||
{
|
||||
struct pic_env *env;
|
||||
|
||||
env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV);
|
||||
env->up = up;
|
||||
env->defer = pic_nil_value();
|
||||
xh_init_ptr(&env->map, sizeof(pic_sym *));
|
||||
return env;
|
||||
}
|
||||
|
||||
pic_sym *
|
||||
pic_find_rename(pic_state *pic, struct pic_env *env, pic_sym *sym)
|
||||
pic_var_name(pic_state PIC_UNUSED(*pic), pic_value var)
|
||||
{
|
||||
if (! pic_dict_has(pic, env->map, sym)) {
|
||||
return NULL;
|
||||
assert(pic_var_p(var));
|
||||
|
||||
while (pic_id_p(var)) {
|
||||
var = pic_id_ptr(var)->var;
|
||||
}
|
||||
return pic_sym_ptr(pic_dict_ref(pic, env->map, sym));
|
||||
return pic_sym_ptr(var);
|
||||
}
|
||||
|
||||
static void
|
||||
define_macro(pic_state *pic, pic_sym *rename, struct pic_proc *mac)
|
||||
pic_sym *
|
||||
pic_uniq(pic_state *pic, pic_value var)
|
||||
{
|
||||
pic_dict_set(pic, pic->macros, rename, pic_obj_value(mac));
|
||||
}
|
||||
pic_str *str;
|
||||
|
||||
static struct pic_proc *
|
||||
find_macro(pic_state *pic, pic_sym *rename)
|
||||
{
|
||||
if (! pic_dict_has(pic, pic->macros, rename)) {
|
||||
return NULL;
|
||||
}
|
||||
return pic_proc_ptr(pic_dict_ref(pic, pic->macros, rename));
|
||||
assert(pic_var_p(var));
|
||||
|
||||
str = pic_format(pic, "%s.%d", pic_symbol_name(pic, pic_var_name(pic, var)), pic->ucnt++);
|
||||
|
||||
return pic_intern(pic, str);
|
||||
}
|
||||
|
||||
static pic_sym *
|
||||
make_identifier(pic_state *pic, pic_sym *sym, struct pic_env *env)
|
||||
lookup(pic_state PIC_UNUSED(*pic), pic_value var, struct pic_env *env)
|
||||
{
|
||||
pic_sym *rename;
|
||||
xh_entry *e;
|
||||
|
||||
while (true) {
|
||||
if ((rename = pic_find_rename(pic, env, sym)) != NULL) {
|
||||
return rename;
|
||||
assert(pic_var_p(var));
|
||||
|
||||
while (env != NULL) {
|
||||
if ((e = xh_get_ptr(&env->map, pic_ptr(var))) != NULL) {
|
||||
return xh_val(e, pic_sym *);
|
||||
}
|
||||
if (! env->up)
|
||||
break;
|
||||
env = env->up;
|
||||
}
|
||||
if (! pic_interned_p(pic, sym)) {
|
||||
return sym;
|
||||
return NULL;
|
||||
}
|
||||
|
||||
static pic_sym *
|
||||
resolve(pic_state *pic, pic_value var, struct pic_env *env)
|
||||
{
|
||||
pic_sym *uid;
|
||||
|
||||
assert(pic_var_p(var));
|
||||
|
||||
while ((uid = lookup(pic, var, env)) == NULL) {
|
||||
if (pic_sym_p(var)) {
|
||||
return NULL;
|
||||
}
|
||||
else {
|
||||
return pic_gensym(pic, sym);
|
||||
env = pic_id_ptr(var)->env;
|
||||
var = pic_id_ptr(var)->var;
|
||||
}
|
||||
return uid;
|
||||
}
|
||||
|
||||
pic_sym *
|
||||
pic_add_variable(pic_state *pic, struct pic_env *env, pic_value var)
|
||||
{
|
||||
pic_sym *uid;
|
||||
|
||||
assert(pic_var_p(var));
|
||||
|
||||
uid = pic_uniq(pic, var);
|
||||
|
||||
pic_put_variable(pic, env, var, uid);
|
||||
|
||||
return uid;
|
||||
}
|
||||
|
||||
void
|
||||
pic_put_variable(pic_state PIC_UNUSED(*pic), struct pic_env *env, pic_value var, pic_sym *uid)
|
||||
{
|
||||
assert(pic_var_p(var));
|
||||
|
||||
xh_put_ptr(&env->map, pic_ptr(var), &uid);
|
||||
}
|
||||
|
||||
pic_sym *
|
||||
pic_find_variable(pic_state PIC_UNUSED(*pic), struct pic_env *env, pic_value var)
|
||||
{
|
||||
xh_entry *e;
|
||||
|
||||
assert(pic_var_p(var));
|
||||
|
||||
if ((e = xh_get_ptr(&env->map, pic_ptr(var))) == NULL) {
|
||||
return NULL;
|
||||
}
|
||||
return xh_val(e, pic_sym *);
|
||||
}
|
||||
|
||||
static void
|
||||
define_macro(pic_state *pic, pic_sym *uid, struct pic_proc *mac)
|
||||
{
|
||||
pic_dict_set(pic, pic->macros, uid, pic_obj_value(mac));
|
||||
}
|
||||
|
||||
static struct pic_proc *
|
||||
find_macro(pic_state *pic, pic_sym *uid)
|
||||
{
|
||||
if (! pic_dict_has(pic, pic->macros, uid)) {
|
||||
return NULL;
|
||||
}
|
||||
return pic_proc_ptr(pic_dict_ref(pic, pic->macros, uid));
|
||||
}
|
||||
|
||||
static pic_value macroexpand(pic_state *, pic_value, struct pic_env *);
|
||||
static pic_value macroexpand_lambda(pic_state *, pic_value, struct pic_env *);
|
||||
|
||||
static pic_value
|
||||
macroexpand_symbol(pic_state *pic, pic_sym *sym, struct pic_env *env)
|
||||
macroexpand_var(pic_state *pic, pic_value var, struct pic_env *env)
|
||||
{
|
||||
return pic_obj_value(make_identifier(pic, sym, env));
|
||||
pic_sym *uid;
|
||||
|
||||
if ((uid = resolve(pic, var, env)) == NULL) {
|
||||
pic_errorf(pic, "unbound variable found: ~s", var);
|
||||
}
|
||||
return pic_obj_value(uid);
|
||||
}
|
||||
|
||||
static pic_value
|
||||
|
|
@ -142,15 +223,15 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_env *env)
|
|||
in = pic_make_env(pic, env);
|
||||
|
||||
for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) {
|
||||
pic_value v = pic_car(pic, a);
|
||||
pic_value var = pic_car(pic, a);
|
||||
|
||||
if (! pic_sym_p(v)) {
|
||||
if (! pic_var_p(var)) {
|
||||
pic_errorf(pic, "syntax error");
|
||||
}
|
||||
pic_add_rename(pic, in, pic_sym_ptr(v));
|
||||
pic_add_variable(pic, in, var);
|
||||
}
|
||||
if (pic_sym_p(a)) {
|
||||
pic_add_rename(pic, in, pic_sym_ptr(a));
|
||||
if (pic_var_p(a)) {
|
||||
pic_add_variable(pic, in, a);
|
||||
}
|
||||
else if (! pic_nil_p(a)) {
|
||||
pic_errorf(pic, "syntax error");
|
||||
|
|
@ -167,14 +248,14 @@ macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_env *env)
|
|||
static pic_value
|
||||
macroexpand_define(pic_state *pic, pic_value expr, struct pic_env *env)
|
||||
{
|
||||
pic_sym *sym, *rename;
|
||||
pic_sym *uid;
|
||||
pic_value var, val;
|
||||
|
||||
while (pic_length(pic, expr) >= 2 && pic_pair_p(pic_cadr(pic, expr))) {
|
||||
var = pic_car(pic, pic_cadr(pic, expr));
|
||||
val = pic_cdr(pic, pic_cadr(pic, expr));
|
||||
|
||||
expr = pic_list3(pic, pic_obj_value(pic->uDEFINE), var, pic_cons(pic, pic_obj_value(pic->uLAMBDA), pic_cons(pic, val, pic_cddr(pic, expr))));
|
||||
expr = pic_list3(pic, pic_obj_value(pic->uDEFINE), var, pic_cons(pic, pic_obj_value(pic->sLAMBDA), pic_cons(pic, val, pic_cddr(pic, expr))));
|
||||
}
|
||||
|
||||
if (pic_length(pic, expr) != 3) {
|
||||
|
|
@ -182,37 +263,35 @@ macroexpand_define(pic_state *pic, pic_value expr, struct pic_env *env)
|
|||
}
|
||||
|
||||
var = pic_cadr(pic, expr);
|
||||
if (! pic_sym_p(var)) {
|
||||
pic_errorf(pic, "binding to non-symbol object");
|
||||
if (! pic_var_p(var)) {
|
||||
pic_errorf(pic, "binding to non-variable object");
|
||||
}
|
||||
sym = pic_sym_ptr(var);
|
||||
if ((rename = pic_find_rename(pic, env, sym)) == NULL) {
|
||||
rename = pic_add_rename(pic, env, sym);
|
||||
if ((uid = pic_find_variable(pic, env, var)) == NULL) {
|
||||
uid = pic_add_variable(pic, env, var);
|
||||
}
|
||||
val = macroexpand(pic, pic_list_ref(pic, expr, 2), env);
|
||||
|
||||
return pic_list3(pic, pic_obj_value(pic->uDEFINE), pic_obj_value(rename), val);
|
||||
return pic_list3(pic, pic_obj_value(pic->uDEFINE), pic_obj_value(uid), val);
|
||||
}
|
||||
|
||||
static pic_value
|
||||
macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_env *env)
|
||||
macroexpand_defmacro(pic_state *pic, pic_value expr, struct pic_env *env)
|
||||
{
|
||||
pic_value var, val;
|
||||
pic_sym *sym, *rename;
|
||||
pic_sym *uid;
|
||||
|
||||
if (pic_length(pic, expr) != 3) {
|
||||
pic_errorf(pic, "syntax error");
|
||||
}
|
||||
|
||||
var = pic_cadr(pic, expr);
|
||||
if (! pic_sym_p(var)) {
|
||||
pic_errorf(pic, "binding to non-symbol object");
|
||||
if (! pic_var_p(var)) {
|
||||
pic_errorf(pic, "binding to non-variable object");
|
||||
}
|
||||
sym = pic_sym_ptr(var);
|
||||
if ((rename = pic_find_rename(pic, env, sym)) == NULL) {
|
||||
rename = pic_add_rename(pic, env, sym);
|
||||
if ((uid = pic_find_variable(pic, env, var)) == NULL) {
|
||||
uid = pic_add_variable(pic, env, var);
|
||||
} else {
|
||||
pic_warnf(pic, "redefining syntax variable: ~s", pic_obj_value(sym));
|
||||
pic_warnf(pic, "redefining syntax variable: ~s", var);
|
||||
}
|
||||
|
||||
val = pic_cadr(pic, pic_cdr(pic, expr));
|
||||
|
|
@ -227,13 +306,7 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_env *env)
|
|||
pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var);
|
||||
}
|
||||
|
||||
val = pic_apply1(pic, pic_proc_ptr(val), pic_obj_value(env));
|
||||
|
||||
if (! pic_proc_p(val)) {
|
||||
pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var);
|
||||
}
|
||||
|
||||
define_macro(pic, rename, pic_proc_ptr(val));
|
||||
define_macro(pic, uid, pic_proc_ptr(val));
|
||||
|
||||
return pic_undef_value();
|
||||
}
|
||||
|
|
@ -241,7 +314,7 @@ macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_env *env)
|
|||
static pic_value
|
||||
macroexpand_macro(pic_state *pic, struct pic_proc *mac, pic_value expr, struct pic_env *env)
|
||||
{
|
||||
pic_value v, args;
|
||||
pic_value v;
|
||||
|
||||
#if DEBUG
|
||||
puts("before expand-1:");
|
||||
|
|
@ -249,10 +322,8 @@ macroexpand_macro(pic_state *pic, struct pic_proc *mac, pic_value expr, struct p
|
|||
puts("");
|
||||
#endif
|
||||
|
||||
args = pic_list2(pic, expr, pic_obj_value(env));
|
||||
|
||||
pic_try {
|
||||
v = pic_apply(pic, mac, args);
|
||||
v = pic_apply2(pic, mac, expr, pic_obj_value(env));
|
||||
} pic_catch {
|
||||
pic_errorf(pic, "macroexpand error while application: %s", pic_errmsg(pic));
|
||||
}
|
||||
|
|
@ -270,40 +341,44 @@ static pic_value
|
|||
macroexpand_node(pic_state *pic, pic_value expr, struct pic_env *env)
|
||||
{
|
||||
switch (pic_type(expr)) {
|
||||
case PIC_TT_ID:
|
||||
case PIC_TT_SYMBOL: {
|
||||
return macroexpand_symbol(pic, pic_sym_ptr(expr), env);
|
||||
return macroexpand_var(pic, expr, env);
|
||||
}
|
||||
case PIC_TT_PAIR: {
|
||||
pic_value car;
|
||||
struct pic_proc *mac;
|
||||
|
||||
if (! pic_list_p(expr)) {
|
||||
pic_errorf(pic, "cannot macroexpand improper list: ~s", expr);
|
||||
}
|
||||
|
||||
car = macroexpand(pic, pic_car(pic, expr), env);
|
||||
if (pic_sym_p(car)) {
|
||||
pic_sym *tag = pic_sym_ptr(car);
|
||||
if (pic_var_p(pic_car(pic, expr))) {
|
||||
pic_sym *functor;
|
||||
|
||||
if (tag == pic->uDEFINE_SYNTAX) {
|
||||
return macroexpand_defsyntax(pic, expr, env);
|
||||
if ((functor = resolve(pic, pic_car(pic, expr), env)) == NULL) {
|
||||
goto call;
|
||||
}
|
||||
else if (tag == pic->uLAMBDA) {
|
||||
|
||||
if (functor == pic->uDEFINE_MACRO) {
|
||||
return macroexpand_defmacro(pic, expr, env);
|
||||
}
|
||||
else if (functor == pic->uLAMBDA) {
|
||||
return macroexpand_defer(pic, expr, env);
|
||||
}
|
||||
else if (tag == pic->uDEFINE) {
|
||||
else if (functor == pic->uDEFINE) {
|
||||
return macroexpand_define(pic, expr, env);
|
||||
}
|
||||
else if (tag == pic->uQUOTE) {
|
||||
else if (functor == pic->uQUOTE) {
|
||||
return macroexpand_quote(pic, expr);
|
||||
}
|
||||
|
||||
if ((mac = find_macro(pic, tag)) != NULL) {
|
||||
if ((mac = find_macro(pic, functor)) != NULL) {
|
||||
return macroexpand_node(pic, macroexpand_macro(pic, mac, expr, env), env);
|
||||
}
|
||||
}
|
||||
call:
|
||||
|
||||
return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), env));
|
||||
return macroexpand_list(pic, expr, env);
|
||||
}
|
||||
default:
|
||||
return expr;
|
||||
|
|
@ -362,22 +437,6 @@ pic_macroexpand(pic_state *pic, pic_value expr, struct pic_lib *lib)
|
|||
return v;
|
||||
}
|
||||
|
||||
struct pic_env *
|
||||
pic_make_env(pic_state *pic, struct pic_env *up)
|
||||
{
|
||||
struct pic_env *env;
|
||||
struct pic_dict *map;
|
||||
|
||||
map = pic_make_dict(pic);
|
||||
|
||||
env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV);
|
||||
env->up = up;
|
||||
env->defer = pic_nil_value();
|
||||
env->map = map;
|
||||
|
||||
return env;
|
||||
}
|
||||
|
||||
static pic_value
|
||||
defmacro_call(pic_state *pic)
|
||||
{
|
||||
|
|
@ -398,7 +457,7 @@ pic_defmacro(pic_state *pic, pic_sym *name, pic_sym *id, pic_func_t func)
|
|||
|
||||
trans = pic_make_proc(pic, func, pic_symbol_name(pic, name));
|
||||
|
||||
pic_put_rename(pic, pic->lib->env, name, id);
|
||||
pic_put_variable(pic, pic->lib->env, pic_obj_value(name), id);
|
||||
|
||||
proc = pic_make_proc(pic, defmacro_call, "defmacro_call");
|
||||
pic_attr_set(pic, pic_obj_value(proc), "@@transformer", pic_obj_value(trans));
|
||||
|
|
@ -410,30 +469,6 @@ pic_defmacro(pic_state *pic, pic_sym *name, pic_sym *id, pic_func_t func)
|
|||
pic_export(pic, name);
|
||||
}
|
||||
|
||||
bool
|
||||
pic_identifier_p(pic_state *pic, pic_value obj)
|
||||
{
|
||||
return pic_sym_p(obj) && ! pic_interned_p(pic, pic_sym_ptr(obj));
|
||||
}
|
||||
|
||||
bool
|
||||
pic_identifier_eq_p(pic_state *pic, struct pic_env *env1, pic_sym *sym1, struct pic_env *env2, pic_sym *sym2)
|
||||
{
|
||||
pic_sym *a, *b;
|
||||
|
||||
a = make_identifier(pic, sym1, env1);
|
||||
if (a != make_identifier(pic, sym1, env1)) {
|
||||
a = sym1;
|
||||
}
|
||||
|
||||
b = make_identifier(pic, sym2, env2);
|
||||
if (b != make_identifier(pic, sym2, env2)) {
|
||||
b = sym2;
|
||||
}
|
||||
|
||||
return pic_eq_p(pic_obj_value(a), pic_obj_value(b));
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_macro_identifier_p(pic_state *pic)
|
||||
{
|
||||
|
|
@ -441,40 +476,62 @@ pic_macro_identifier_p(pic_state *pic)
|
|||
|
||||
pic_get_args(pic, "o", &obj);
|
||||
|
||||
return pic_bool_value(pic_identifier_p(pic, obj));
|
||||
return pic_bool_value(pic_id_p(obj));
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_macro_make_identifier(pic_state *pic)
|
||||
{
|
||||
pic_value obj;
|
||||
pic_sym *sym;
|
||||
pic_value var, env;
|
||||
|
||||
pic_get_args(pic, "mo", &sym, &obj);
|
||||
pic_get_args(pic, "oo", &var, &env);
|
||||
|
||||
pic_assert_type(pic, obj, env);
|
||||
pic_assert_type(pic, var, var);
|
||||
pic_assert_type(pic, env, env);
|
||||
|
||||
return pic_obj_value(make_identifier(pic, sym, pic_env_ptr(obj)));
|
||||
return pic_obj_value(pic_make_id(pic, var, pic_env_ptr(env)));
|
||||
}
|
||||
|
||||
static pic_value
|
||||
pic_macro_identifier_eq_p(pic_state *pic)
|
||||
pic_macro_variable_p(pic_state *pic)
|
||||
{
|
||||
pic_sym *sym1, *sym2;
|
||||
pic_value env1, env2;
|
||||
pic_value obj;
|
||||
|
||||
pic_get_args(pic, "omom", &env1, &sym1, &env2, &sym2);
|
||||
pic_get_args(pic, "o", &obj);
|
||||
|
||||
pic_assert_type(pic, env1, env);
|
||||
pic_assert_type(pic, env2, env);
|
||||
return pic_bool_value(pic_var_p(obj));
|
||||
}
|
||||
|
||||
return pic_bool_value(pic_identifier_eq_p(pic, pic_env_ptr(env1), sym1, pic_env_ptr(env2), sym2));
|
||||
static pic_value
|
||||
pic_macro_variable_eq_p(pic_state *pic)
|
||||
{
|
||||
pic_value var1, var2;
|
||||
pic_sym *uid1, *uid2;
|
||||
|
||||
pic_get_args(pic, "oo", &var1, &var2);
|
||||
|
||||
pic_assert_type(pic, var1, var);
|
||||
pic_assert_type(pic, var2, var);
|
||||
|
||||
if (pic_eq_p(var1, var2)) {
|
||||
return pic_true_value();
|
||||
}
|
||||
|
||||
uid1 = resolve(pic, var1, NULL);
|
||||
uid2 = resolve(pic, var2, NULL);
|
||||
|
||||
if (uid1 || uid2) {
|
||||
return pic_bool_value(uid1 == uid2);
|
||||
}
|
||||
return pic_false_value();
|
||||
}
|
||||
|
||||
void
|
||||
pic_init_macro(pic_state *pic)
|
||||
{
|
||||
pic_defun(pic, "identifier?", pic_macro_identifier_p);
|
||||
pic_defun(pic, "identifier=?", pic_macro_identifier_eq_p);
|
||||
pic_defun(pic, "make-identifier", pic_macro_make_identifier);
|
||||
|
||||
pic_defun(pic, "variable?", pic_macro_variable_p);
|
||||
pic_defun(pic, "variable=?", pic_macro_variable_eq_p);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -109,7 +109,7 @@ pic_init_core(pic_state *pic)
|
|||
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->uLAMBDA);
|
||||
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->uIF);
|
||||
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->uBEGIN);
|
||||
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_SYNTAX, pic->uDEFINE_SYNTAX);
|
||||
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_MACRO, pic->uDEFINE_MACRO);
|
||||
|
||||
pic_init_undef(pic); DONE;
|
||||
pic_init_bool(pic); DONE;
|
||||
|
|
@ -222,6 +222,9 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf)
|
|||
/* symbol table */
|
||||
xh_init_str(&pic->syms, sizeof(pic_sym *));
|
||||
|
||||
/* unique symbol count */
|
||||
pic->ucnt = 0;
|
||||
|
||||
/* global variables */
|
||||
pic->globals = NULL;
|
||||
|
||||
|
|
@ -265,7 +268,7 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf)
|
|||
S(sQUASIQUOTE, "quasiquote");
|
||||
S(sUNQUOTE, "unquote");
|
||||
S(sUNQUOTE_SPLICING, "unquote-splicing");
|
||||
S(sDEFINE_SYNTAX, "define-syntax");
|
||||
S(sDEFINE_MACRO, "define-macro");
|
||||
S(sIMPORT, "import");
|
||||
S(sEXPORT, "export");
|
||||
S(sDEFINE_LIBRARY, "define-library");
|
||||
|
|
@ -308,7 +311,7 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf)
|
|||
|
||||
pic_gc_arena_restore(pic, ai);
|
||||
|
||||
#define U(slot,name) pic->slot = pic_gensym(pic, pic_intern_cstr(pic, name))
|
||||
#define U(slot,name) pic->slot = pic_uniq(pic, pic_obj_value(pic_intern_cstr(pic, name)))
|
||||
|
||||
U(uDEFINE, "define");
|
||||
U(uLAMBDA, "lambda");
|
||||
|
|
@ -316,7 +319,7 @@ pic_open(int argc, char *argv[], char **envp, pic_allocf allocf)
|
|||
U(uBEGIN, "begin");
|
||||
U(uSETBANG, "set!");
|
||||
U(uQUOTE, "quote");
|
||||
U(uDEFINE_SYNTAX, "define-syntax");
|
||||
U(uDEFINE_MACRO, "define-macro");
|
||||
U(uIMPORT, "import");
|
||||
U(uEXPORT, "export");
|
||||
U(uDEFINE_LIBRARY, "define-library");
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
|
||||
#include "picrin.h"
|
||||
|
||||
pic_sym *
|
||||
static pic_sym *
|
||||
pic_make_symbol(pic_state *pic, pic_str *str)
|
||||
{
|
||||
pic_sym *sym;
|
||||
|
|
@ -42,25 +42,6 @@ pic_intern_cstr(pic_state *pic, const char *str)
|
|||
return pic_intern(pic, pic_make_str(pic, str, strlen(str)));
|
||||
}
|
||||
|
||||
pic_sym *
|
||||
pic_gensym(pic_state *pic, pic_sym *base)
|
||||
{
|
||||
return pic_make_symbol(pic, base->str);
|
||||
}
|
||||
|
||||
bool
|
||||
pic_interned_p(pic_state *pic, pic_sym *sym)
|
||||
{
|
||||
xh_entry *e;
|
||||
|
||||
e = xh_get_str(&pic->syms, pic_str_cstr(pic, sym->str));
|
||||
if (e) {
|
||||
return sym == xh_val(e, pic_sym *);
|
||||
} else {
|
||||
return false;
|
||||
}
|
||||
}
|
||||
|
||||
const char *
|
||||
pic_symbol_name(pic_state *pic, pic_sym *sym)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -394,9 +394,9 @@ pic_get_args(pic_state *pic, const char *format, ...)
|
|||
}
|
||||
|
||||
void
|
||||
pic_define_syntactic_keyword(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *rsym)
|
||||
pic_define_syntactic_keyword(pic_state *pic, struct pic_env *env, pic_sym *sym, pic_sym *uid)
|
||||
{
|
||||
pic_put_rename(pic, env, sym, rsym);
|
||||
pic_put_variable(pic, env, pic_obj_value(sym), uid);
|
||||
|
||||
if (pic->lib && pic->lib->env == env) {
|
||||
pic_export(pic, sym);
|
||||
|
|
@ -406,17 +406,17 @@ pic_define_syntactic_keyword(pic_state *pic, struct pic_env *env, pic_sym *sym,
|
|||
void
|
||||
pic_define_noexport(pic_state *pic, const char *name, pic_value val)
|
||||
{
|
||||
pic_sym *sym, *rename;
|
||||
pic_sym *sym, *uid;
|
||||
|
||||
sym = pic_intern_cstr(pic, name);
|
||||
|
||||
if ((rename = pic_find_rename(pic, pic->lib->env, sym)) == NULL) {
|
||||
rename = pic_add_rename(pic, pic->lib->env, sym);
|
||||
if ((uid = pic_find_variable(pic, pic->lib->env, pic_obj_value(sym))) == NULL) {
|
||||
uid = pic_add_variable(pic, pic->lib->env, pic_obj_value(sym));
|
||||
} else {
|
||||
pic_warnf(pic, "redefining global");
|
||||
}
|
||||
|
||||
pic_dict_set(pic, pic->globals, rename, val);
|
||||
pic_dict_set(pic, pic->globals, uid, val);
|
||||
}
|
||||
|
||||
void
|
||||
|
|
@ -430,29 +430,29 @@ pic_define(pic_state *pic, const char *name, pic_value val)
|
|||
pic_value
|
||||
pic_ref(pic_state *pic, struct pic_lib *lib, const char *name)
|
||||
{
|
||||
pic_sym *sym, *rename;
|
||||
pic_sym *sym, *uid;
|
||||
|
||||
sym = pic_intern_cstr(pic, name);
|
||||
|
||||
if ((rename = pic_find_rename(pic, lib->env, sym)) == NULL) {
|
||||
if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(sym))) == NULL) {
|
||||
pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name);
|
||||
}
|
||||
|
||||
return pic_dict_ref(pic, pic->globals, rename);
|
||||
return pic_dict_ref(pic, pic->globals, uid);
|
||||
}
|
||||
|
||||
void
|
||||
pic_set(pic_state *pic, struct pic_lib *lib, const char *name, pic_value val)
|
||||
{
|
||||
pic_sym *sym, *rename;
|
||||
pic_sym *sym, *uid;
|
||||
|
||||
sym = pic_intern_cstr(pic, name);
|
||||
|
||||
if ((rename = pic_find_rename(pic, lib->env, sym)) == NULL) {
|
||||
if ((uid = pic_find_variable(pic, lib->env, pic_obj_value(sym))) == NULL) {
|
||||
pic_errorf(pic, "symbol \"%s\" not defined in library ~s", name, lib->name);
|
||||
}
|
||||
|
||||
pic_dict_set(pic, pic->globals, rename, val);
|
||||
pic_dict_set(pic, pic->globals, uid, val);
|
||||
}
|
||||
|
||||
pic_value
|
||||
|
|
@ -477,7 +477,7 @@ pic_defun(pic_state *pic, const char *name, pic_func_t cfunc)
|
|||
}
|
||||
|
||||
void
|
||||
pic_defun_vm(pic_state *pic, const char *name, pic_sym *rename, pic_func_t func)
|
||||
pic_defun_vm(pic_state *pic, const char *name, pic_sym *uid, pic_func_t func)
|
||||
{
|
||||
struct pic_proc *proc;
|
||||
pic_sym *sym;
|
||||
|
|
@ -486,9 +486,9 @@ pic_defun_vm(pic_state *pic, const char *name, pic_sym *rename, pic_func_t func)
|
|||
|
||||
sym = pic_intern_cstr(pic, name);
|
||||
|
||||
pic_put_rename(pic, pic->lib->env, sym, rename);
|
||||
pic_put_variable(pic, pic->lib->env, pic_obj_value(sym), uid);
|
||||
|
||||
pic_dict_set(pic, pic->globals, rename, pic_obj_value(proc));
|
||||
pic_dict_set(pic, pic->globals, uid, pic_obj_value(proc));
|
||||
|
||||
pic_export(pic, sym);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -302,6 +302,9 @@ write_core(struct writer_control *p, pic_value obj)
|
|||
}
|
||||
xfprintf(file, ")");
|
||||
break;
|
||||
case PIC_TT_ID:
|
||||
xfprintf(file, "#<identifier %s>", pic_symbol_name(pic, pic_var_name(pic, obj)));
|
||||
break;
|
||||
default:
|
||||
xfprintf(file, "#<%s %p>", pic_type_repr(pic_type(obj)), pic_ptr(obj));
|
||||
break;
|
||||
|
|
|
|||
Loading…
Reference in New Issue