From 9b0224708249c61a0569e79f0c1e5b4363b656b1 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 9 Jan 2014 16:34:22 +0900 Subject: [PATCH 01/10] initial explicit renaming macro prototype --- include/picrin/macro.h | 1 + src/macro.c | 75 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 76 insertions(+) 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/src/macro.c b/src/macro.c index 0cd38949..88bb005e 100644 --- a/src/macro.c +++ b/src/macro.c @@ -659,6 +659,80 @@ 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_get_args(pic, "m", &sym); + + mac_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 1)); + + return macroexpand(pic, pic_symbol_value(sym), mac_env); +} + +static pic_value +er_macro_compare(pic_state *pic) +{ + pic_sym x, y; + struct pic_senv *use_env; + pic_value a, b; + + pic_get_args(pic, "mm", &x, &y); + + use_env = pic_senv_ptr(pic_proc_cv_ref(pic, pic_get_proc(pic), 0)); + + a = macroexpand(pic, pic_symbol_value(x), use_env); + b = macroexpand(pic, pic_symbol_value(y), 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 +741,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); } From 2e66b533c1b20a1a7ecd11769ab68d2190ae7f1e Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 10 Jan 2014 16:22:07 +0900 Subject: [PATCH 02/10] fix a small bug in a comment --- src/macro.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/macro.c b/src/macro.c index 88bb005e..ee91b61c 100644 --- a/src/macro.c +++ b/src/macro.c @@ -25,7 +25,7 @@ new_uniq_sym(pic_state *pic, pic_sym base) str = (char *)pic_alloc(pic, strlen(pic_symbol_name(pic, base)) + (int)log10(s) + 3); sprintf(str, "%s@%d", pic_symbol_name(pic, base), s); - /* don't put the symbol to ic->sym_tbl to keep it uninterned */ + /* don't put the symbol to pic->sym_tbl to keep it uninterned */ if (pic->slen >= pic->scapa) { pic->scapa *= 2; pic->sym_pool = pic_realloc(pic, pic->sym_pool, sizeof(const char *) * pic->scapa); From 6bdc9b360e66016b5d03e6ba4f75c479b2e8d94b Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 10 Jan 2014 16:22:36 +0900 Subject: [PATCH 03/10] [bugfix] wrong external representation for syntax type --- src/port.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/port.c b/src/port.c index a1e84e3e..794f51a5 100644 --- a/src/port.c +++ b/src/port.c @@ -102,7 +102,7 @@ write(pic_state *pic, pic_value obj) printf("#", pic_ptr(obj)); break; case PIC_TT_SYNTAX: - printf("#", pic_ptr(obj)); + printf("#", pic_ptr(obj)); break; case PIC_TT_SC: printf("# Date: Fri, 10 Jan 2014 17:49:27 +0900 Subject: [PATCH 04/10] [bugfix] wrong error message --- src/vm.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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++; } From 57253f9a6c4d586f9a3207b481c06aef4f08ee77 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 10 Jan 2014 17:52:31 +0900 Subject: [PATCH 05/10] compare is allowed to take non-symbol values --- src/macro.c | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src/macro.c b/src/macro.c index ee91b61c..15cff9a1 100644 --- a/src/macro.c +++ b/src/macro.c @@ -675,16 +675,18 @@ er_macro_rename(pic_state *pic) static pic_value er_macro_compare(pic_state *pic) { - pic_sym x, y; - struct pic_senv *use_env; pic_value a, b; + struct pic_senv *use_env; - pic_get_args(pic, "mm", &x, &y); + 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, pic_symbol_value(x), use_env); - b = macroexpand(pic, pic_symbol_value(y), use_env); + a = macroexpand(pic, a, use_env); + b = macroexpand(pic, b, use_env); return pic_bool_value(pic_eq_p(a, b)); } From 62e52be061047cf55a477295c4d1913b319f1845 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 10 Jan 2014 17:55:02 +0900 Subject: [PATCH 06/10] [bugfix] macroexpand may return a non-symbol value even if passed a symbol. --- src/macro.c | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/macro.c b/src/macro.c index 15cff9a1..4c9eec94 100644 --- a/src/macro.c +++ b/src/macro.c @@ -664,12 +664,19 @@ 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)); - return macroexpand(pic, pic_symbol_value(sym), mac_env); + 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 From 45c49fdec3ff3dda9873be748e3926a5464683fb Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Fri, 10 Jan 2014 17:55:58 +0900 Subject: [PATCH 07/10] don't rename each symbol more than a time --- src/macro.c | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/src/macro.c b/src/macro.c index 4c9eec94..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) From c66a217e87f360ed9b27855bc11164e715a5599a Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 11 Jan 2014 12:55:34 +0900 Subject: [PATCH 08/10] Types that can be passed to the rename procedure is only a symbol --- piclib/built-in.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/piclib/built-in.scm b/piclib/built-in.scm index 6921d192..13aff947 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -245,9 +245,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 =>) From 64855bfcec97ca74aefcc5f4b2b368a19da7f7ed Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 11 Jan 2014 12:56:07 +0900 Subject: [PATCH 09/10] er-macro-transformer is no longer defined using sc --- piclib/built-in.scm | 9 --------- 1 file changed, 9 deletions(-) diff --git a/piclib/built-in.scm b/piclib/built-in.scm index 13aff947..70458e17 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 From 82dd55f77f552ccef15d0dd6310256911724db2f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Sat, 11 Jan 2014 12:56:51 +0900 Subject: [PATCH 10/10] er macro no longer requires identifier? defined --- piclib/built-in.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/piclib/built-in.scm b/piclib/built-in.scm index 70458e17..10c890a7 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -70,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)) @@ -121,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))