diff --git a/include/picrin/macro.h b/include/picrin/macro.h index 0a01e00d..f7f9c36f 100644 --- a/include/picrin/macro.h +++ b/include/picrin/macro.h @@ -45,6 +45,7 @@ struct pic_sc { #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); diff --git a/piclib/built-in.scm b/piclib/built-in.scm index 6921d192..10c890a7 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -10,14 +10,6 @@ (lambda (expr use-env mac-env) (make-syntactic-closure use-env '() (f expr mac-env)))) - (define (er-macro-transformer f) - (lambda (expr use-env mac-env) - (define (rename identifier) - (make-syntactic-closure mac-env '() identifier)) - (define (compare x y) - (identifier=? use-env x use-env y)) - (make-syntactic-closure use-env '() (f expr rename compare)))) - (define (walk f obj) (if (pair? obj) (cons (walk f (car obj)) @@ -37,7 +29,6 @@ (export sc-macro-transformer rsc-macro-transformer - er-macro-transformer ir-macro-transformer)) ;;; bootstrap utilities @@ -79,7 +70,7 @@ (define-syntax let (er-macro-transformer (lambda (expr r compare) - (if (identifier? (cadr expr)) + (if (symbol? (cadr expr)) (begin (define name (cadr expr)) (define bindings (caddr expr)) @@ -130,7 +121,7 @@ (lambda (expr r compare?) (let ((x (cadr expr))) (cond - ((symbol? x) (list (r 'quote) x)) ; should test with identifier? + ((symbol? x) (list (r 'quote) x)) ((pair? x) (cond ((compare? (r 'unquote) (car x)) (cadr x)) @@ -245,9 +236,9 @@ (er-macro-transformer (lambda (expr r c) `(,(r 'define-syntax) ,(cadr expr) - ,(r '(sc-macro-transformer - (lambda (expr env) - (error "invalid use of auxiliary syntax")))))))) + (,(r 'sc-macro-transformer) + (,(r 'lambda) (expr env) + (,(r 'error) "invalid use of auxiliary syntax"))))))) (define-auxiliary-syntax else) (define-auxiliary-syntax =>) diff --git a/src/macro.c b/src/macro.c index b289a956..fdd2b7b4 100644 --- a/src/macro.c +++ b/src/macro.c @@ -36,6 +36,20 @@ new_uniq_sym(pic_state *pic, pic_sym base) return uniq; } +static bool +uniq_sym_p(pic_state *pic, pic_sym sym) +{ + const char *name; + + assert(sym >= 0); + + name = pic->sym_pool[sym]; + if (sym == pic_intern_cstr(pic, name)) + return false; + else + return true; +} + struct pic_senv * pic_null_syntactic_env(pic_state *pic) { @@ -293,6 +307,10 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv) case PIC_TT_SYMBOL: { struct xh_entry *e; pic_sym uniq; + + if (uniq_sym_p(pic, pic_sym(expr))) { + return expr; + } while (true) { if ((e = xh_get(senv->tbl, pic_symbol_name(pic, pic_sym(expr)))) != NULL) { if (e->val >= 0) @@ -659,6 +677,89 @@ pic_macro_identifier_eq_p(pic_state *pic) return pic_bool_value(pic_eq_p(x, y)); } +static pic_value +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; + } +} + +static pic_value +er_macro_compare(pic_state *pic) +{ + pic_value a, b; + struct pic_senv *use_env; + + pic_get_args(pic, "oo", &a, &b); + + if (! pic_symbol_p(a) || ! pic_symbol_p(b)) + return pic_false_value(); /* should be an error? */ + + 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); + + return pic_bool_value(pic_eq_p(a, b)); +} + +static pic_value +er_macro_call(pic_state *pic) +{ + pic_value expr, use_env, mac_env; + struct pic_proc *rename, *compare, *cb; + + pic_get_args(pic, "ooo", &expr, &use_env, &mac_env); + + if (! pic_senv_p(use_env)) { + pic_error(pic, "unexpected type of argument 1"); + } + if (! pic_senv_p(mac_env)) { + pic_error(pic, "unexpected type of argument 3"); + } + + rename = pic_proc_new(pic, er_macro_rename); + pic_proc_cv_reserve(pic, rename, 2); + pic_proc_cv_set(pic, rename, 0, use_env); + pic_proc_cv_set(pic, rename, 1, mac_env); + + compare = pic_proc_new(pic, er_macro_compare); + pic_proc_cv_reserve(pic, compare, 2); + pic_proc_cv_set(pic, compare, 0, use_env); + pic_proc_cv_set(pic, compare, 1, mac_env); + + cb = pic_proc_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0)); + + return pic_apply_argv(pic, cb, 3, expr, pic_obj_value(rename), pic_obj_value(compare)); +} + +static pic_value +pic_macro_er_macro_transformer(pic_state *pic) +{ + struct pic_proc *cb, *proc; + + pic_get_args(pic, "l", &cb); + + proc = pic_proc_new(pic, er_macro_call); + pic_proc_cv_reserve(pic, proc, 1); + pic_proc_cv_set(pic, proc, 0, pic_obj_value(cb)); + + return pic_obj_value(proc); +} + void pic_init_macro(pic_state *pic) { @@ -667,6 +768,7 @@ pic_init_macro(pic_state *pic) pic_defun(pic, "make-syntactic-closure", pic_macro_make_sc); pic_defun(pic, "identifier?", pic_macro_identifier_p); pic_defun(pic, "identifier=?", pic_macro_identifier_eq_p); + pic_defun(pic, "er-macro-transformer", pic_macro_er_macro_transformer); } ENDLIBRARY(pic); } diff --git a/src/vm.c b/src/vm.c index c106e3bc..a5ea64de 100644 --- a/src/vm.c +++ b/src/vm.c @@ -198,7 +198,7 @@ pic_get_args(pic_state *pic, const char *format, ...) *m = pic_sym(v); } else { - pic_error(pic, "pic_get_args: expected vector"); + pic_error(pic, "pic_get_args: expected symbol"); } i++; }