diff --git a/docs/libs.rst b/docs/libs.rst index b87d7980..f8d417c2 100644 --- a/docs/libs.rst +++ b/docs/libs.rst @@ -49,6 +49,7 @@ Utility functions and syntaces for macro definition. - define-macro - gensym +- ungensym - macroexpand - macroexpand-1 @@ -68,6 +69,7 @@ Syntactic closures. - er-macro-transformer - ir-macro-transformer +- strip-syntax Explicit renaming macro family. diff --git a/include/picrin.h b/include/picrin.h index b4036cb5..29640fa7 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -153,6 +153,7 @@ pic_sym pic_intern(pic_state *, const char *, size_t); 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); +pic_sym pic_ungensym(pic_state *, pic_sym); bool pic_interned_p(pic_state *, pic_sym); char *pic_strdup(pic_state *, const char *); diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm index 5682d8ca..96650e2a 100644 --- a/piclib/picrin/macro.scm +++ b/piclib/picrin/macro.scm @@ -106,6 +106,9 @@ (rename sym))) (f (walk inject expr) inject compare)))) + (define (strip-syntax form) + (walk ungensym form)) + (define-syntax define-macro (er-macro-transformer (lambda (expr r c) @@ -127,4 +130,5 @@ rsc-macro-transformer er-macro-transformer ir-macro-transformer + strip-syntax define-macro)) diff --git a/src/macro.c b/src/macro.c index 14b67d9c..9979db96 100644 --- a/src/macro.c +++ b/src/macro.c @@ -577,6 +577,16 @@ pic_macro_gensym(pic_state *pic) return pic_sym_value(uniq); } +static pic_value +pic_macro_ungensym(pic_state *pic) +{ + pic_sym sym; + + pic_get_args(pic, "m", &sym); + + return pic_sym_value(pic_ungensym(pic, sym)); +} + static pic_value pic_macro_macroexpand(pic_state *pic) { @@ -652,6 +662,7 @@ pic_init_macro(pic_state *pic) { pic_deflibrary ("(picrin macro)") { pic_defun(pic, "gensym", pic_macro_gensym); + pic_defun(pic, "ungensym", pic_macro_ungensym); pic_defun(pic, "macroexpand", pic_macro_macroexpand); pic_defun(pic, "macroexpand-1", pic_macro_macroexpand_1); pic_defun(pic, "identifier?", pic_macro_identifier_p); diff --git a/src/symbol.c b/src/symbol.c index 1ebbdc3d..2ea530d5 100644 --- a/src/symbol.c +++ b/src/symbol.c @@ -41,12 +41,18 @@ pic_sym pic_gensym(pic_state *pic, pic_sym base) { int uid = pic->uniq_sym_cnt++, len; - char *str; + char *str, mark; pic_sym uniq; - len = snprintf(NULL, 0, "%s@%d", pic_symbol_name(pic, base), uid); + if (pic_interned_p(pic, base)) { + mark = '@'; + } else { + mark = '.'; + } + + len = snprintf(NULL, 0, "%s%c%d", pic_symbol_name(pic, base), mark, uid); str = pic_alloc(pic, len + 1); - sprintf(str, "%s@%d", pic_symbol_name(pic, base), uid); + sprintf(str, "%s%c%d", pic_symbol_name(pic, base), mark, uid); /* don't put the symbol to pic->syms to keep it uninterned */ uniq = pic->sym_cnt++; @@ -55,6 +61,22 @@ pic_gensym(pic_state *pic, pic_sym base) return uniq; } +pic_sym +pic_ungensym(pic_state *pic, pic_sym base) +{ + const char *name, *occr; + + if (pic_interned_p(pic, base)) { + return base; + } + + name = pic_symbol_name(pic, base); + if ((occr = strrchr(name, '@')) == NULL) { + pic_abort(pic, "logic flaw"); + } + return pic_intern(pic, name, occr - name); +} + bool pic_interned_p(pic_state *pic, pic_sym sym) {