Merge branch 'strip-syntax'

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.
 

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 *);

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))

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);

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)
 {