a different tack for syncase macro representation

* libguile/macros.c (macro_print): Show syntax-case bindings, if present.
  (macro_mark): Mark the extra two words if they're there.
  (scm_make_syncase_macro, scm_make_extended_syncase_macro): OK! A new
  take at the "how do we represent syncase macros in Guile" problem.
  Whereas we need a disjoint type, but would like it to be compatible
  with old predicates (e.g. `macro?'), and need to be able to extend
  existing syntax definitions (e.g. `cond'), let's add a bit to macros to
  indicate whether they have syncase macro bindings or not, and a fourth
  macro type for native syncase macros.
  (scm_macro_type): Return 'syntax-case for native syntax-case macros.
  Note that other macro types may have syntax-case bindings.
  (scm_macro_name): Return #f if the transformer is not a procedure.
  (scm_syncase_macro_type, scm_syncase_macro_binding): New accessors for
  the syncase macro bindings.

* libguile/macros.h: Add API for syncase macros.

* module/ice-9/boot-9.scm (module-define-keyword!): Adapt to use syncase
  macros, though they are not yet used. Reorder other syncase API.

* module/ice-9/psyntax.scm (chi-expr): Fix syntax-violation invocation.

libguile/macros.c

@@ -48,10 +48,13 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate)
       || scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE,
 					macro, port, pstate)))
     {
+      scm_puts ("#<", port);
+
+      if (SCM_MACRO_TYPE (macro) < 4 && SCM_MACRO_IS_EXTENDED (macro))
+	scm_puts ("extended-", port);
+
       if (!SCM_CLOSUREP (code) && !SCM_PROGRAM_P (code))
-	scm_puts ("#<primitive-", port);
+	scm_puts ("primitive-", port);
-      else
-	scm_puts ("#<", port);
 
       if (SCM_MACRO_TYPE (macro) == 0)
 	scm_puts ("syntax", port);
@@ -63,6 +66,8 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate)
 	scm_puts ("macro!", port);
       if (SCM_MACRO_TYPE (macro) == 3)
 	scm_puts ("builtin-macro!", port);
+      if (SCM_MACRO_TYPE (macro) == 4)
+	scm_puts ("syncase-macro", port);
 
       scm_putc (' ', port);
       scm_iprin1 (scm_macro_name (macro), port, pstate);
@@ -77,12 +82,30 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate)
 	  scm_iprin1 (src, port, pstate);
 	}
 
+      if (SCM_MACRO_IS_EXTENDED (macro))
+        {
+          scm_putc (' ', port);
+          scm_write (SCM_SMOB_OBJECT_2 (macro), port);
+          scm_putc (' ', port);
+          scm_write (SCM_SMOB_OBJECT_3 (macro), port);
+        }
+
       scm_putc ('>', port);
     }
 
   return 1;
 }
 
+static SCM
+macro_mark (SCM macro)
+{
+  if (SCM_MACRO_IS_EXTENDED (macro))
+    { scm_gc_mark (SCM_SMOB_OBJECT_2 (macro));
+      scm_gc_mark (SCM_SMOB_OBJECT_3 (macro));
+    }
+  return SCM_SMOB_OBJECT (macro);
+}
+
 static SCM
 makmac (SCM code, scm_t_bits flags)
 {
@@ -164,6 +187,40 @@ SCM_DEFINE (scm_makmacro, "procedure->macro", 1, 0, 0,
 
 #endif
 
+SCM_DEFINE (scm_make_syncase_macro, "make-syncase-macro", 2, 0, 0,
+            (SCM type, SCM binding),
+	    "Return a @dfn{macro} that requires expansion by syntax-case.\n"
+            "While users should not call this function, it is useful to know\n"
+            "that syntax-case macros are represented as Guile primitive macros.")
+#define FUNC_NAME s_scm_make_syncase_macro
+{
+  SCM z;
+  SCM_VALIDATE_SYMBOL (1, type);
+
+  SCM_NEWSMOB3 (z, scm_tc16_macro, SCM_UNPACK (binding), SCM_UNPACK (type),
+                SCM_UNPACK (binding));
+  SCM_SET_SMOB_FLAGS (z, 4 | SCM_F_MACRO_EXTENDED);
+  return z;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_extended_syncase_macro, "make-extended-syncase-macro", 3, 0, 0,
+            (SCM m, SCM type, SCM binding),
+	    "Extend a core macro @var{m} with a syntax-case binding.")
+#define FUNC_NAME s_scm_make_extended_syncase_macro
+{
+  SCM z;
+  SCM_VALIDATE_SMOB (1, m, macro);
+  SCM_VALIDATE_SYMBOL (2, type);
+
+  SCM_NEWSMOB3 (z, scm_tc16_macro, SCM_SMOB_DATA (m), SCM_UNPACK (type),
+                SCM_UNPACK (binding));
+  SCM_SET_SMOB_FLAGS (z, SCM_SMOB_FLAGS (m) | SCM_F_MACRO_EXTENDED);
+  return z;
+}
+#undef FUNC_NAME
+
+
 
 SCM_DEFINE (scm_macro_p, "macro?", 1, 0, 0, 
             (SCM obj),
@@ -182,14 +239,15 @@ SCM_SYMBOL (scm_sym_macro, "macro");
 #endif
 SCM_SYMBOL (scm_sym_mmacro, "macro!");
 SCM_SYMBOL (scm_sym_bimacro, "builtin-macro!");
+SCM_SYMBOL (scm_sym_syncase_macro, "syncase-macro");
 
 SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0, 
             (SCM m),
-	    "Return one of the symbols @code{syntax}, @code{macro} or\n"
+	    "Return one of the symbols @code{syntax}, @code{macro},\n"
-	    "@code{macro!}, depending on whether @var{m} is a syntax\n"
+	    "@code{macro!}, or @code{syntax-case}, depending on whether\n"
-	    "transformer, a regular macro, or a memoizing macro,\n"
+            "@var{m} is a syntax transformer, a regular macro, a memoizing\n"
-	    "respectively.  If @var{m} is not a macro, @code{#f} is\n"
+            "macro, or a syntax-case macro, respectively.  If @var{m} is\n"
-	    "returned.")
+            "not a macro, @code{#f} is returned.")
 #define FUNC_NAME s_scm_macro_type
 {
   if (!SCM_SMOB_PREDICATE (scm_tc16_macro, m))
@@ -202,6 +260,7 @@ SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0,
 #endif
     case 2: return scm_sym_mmacro;
     case 3: return scm_sym_bimacro;
+    case 4: return scm_sym_syncase_macro;
     default: scm_wrong_type_arg (FUNC_NAME, 1, m);
     }
 }
@@ -214,7 +273,9 @@ SCM_DEFINE (scm_macro_name, "macro-name", 1, 0, 0,
 #define FUNC_NAME s_scm_macro_name
 {
   SCM_VALIDATE_SMOB (1, m, macro);
-  return scm_procedure_name (SCM_PACK (SCM_SMOB_DATA (m)));
+  if (scm_is_true (scm_procedure_p (SCM_SMOB_OBJECT (m))))
+    return scm_procedure_name (SCM_SMOB_OBJECT (m));
+  return SCM_BOOL_F;
 }
 #undef FUNC_NAME
 
@@ -236,6 +297,34 @@ SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_syncase_macro_type, "syncase-macro-type", 1, 0, 0, 
+            (SCM m),
+	    "Return the type of the macro @var{m}.")
+#define FUNC_NAME s_scm_syncase_macro_type
+{
+  SCM_VALIDATE_SMOB (1, m, macro);
+
+  if (SCM_MACRO_IS_EXTENDED (m))
+    return SCM_SMOB_OBJECT_2 (m);
+  else
+    return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_syncase_macro_binding, "syncase-macro-binding", 1, 0, 0, 
+            (SCM m),
+	    "Return the binding of the macro @var{m}.")
+#define FUNC_NAME s_scm_syncase_macro_binding
+{
+  SCM_VALIDATE_SMOB (1, m, macro);
+
+  if (SCM_MACRO_IS_EXTENDED (m))
+    return SCM_SMOB_OBJECT_3 (m);
+  else
+    return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
 SCM
 scm_make_synt (const char *name, SCM (*macroizer) (), SCM (*fcn)() )
 {
@@ -249,7 +338,7 @@ void
 scm_init_macros ()
 {
   scm_tc16_macro = scm_make_smob_type ("macro", 0);
-  scm_set_smob_mark (scm_tc16_macro, scm_markcdr);
+  scm_set_smob_mark (scm_tc16_macro, macro_mark);
   scm_set_smob_print (scm_tc16_macro, macro_print);
 #include "libguile/macros.x"
 }

libguile/macros.h

@@ -29,9 +29,15 @@
 #define SCM_ASSYNT(_cond, _msg, _subr) \
   if (!(_cond)) scm_misc_error (_subr, _msg, SCM_EOL);
 
+#define SCM_MACRO_TYPE_BITS  (3)
+#define SCM_MACRO_TYPE_MASK  ((1<<SCM_MACRO_TYPE_BITS)-1)
+#define SCM_F_MACRO_EXTENDED (1<<SCM_MACRO_TYPE_BITS)
+
 #define SCM_MACROP(x) SCM_SMOB_PREDICATE (scm_tc16_macro, (x))
-#define SCM_MACRO_TYPE(m) SCM_SMOB_FLAGS (m)
+#define SCM_MACRO_TYPE(m) (SCM_SMOB_FLAGS (m) & SCM_MACRO_TYPE_MASK)
+#define SCM_MACRO_IS_EXTENDED(m) (SCM_SMOB_FLAGS (m) & SCM_F_MACRO_EXTENDED)
 #define SCM_BUILTIN_MACRO_P(x) (SCM_MACROP (x) && SCM_MACRO_TYPE (x) == 3)
+#define SCM_SYNCASE_MACRO_P(x) (SCM_MACROP (x) && SCM_MACRO_TYPE (x) == 4)
 #define SCM_MACRO_CODE(m) SCM_SMOB_OBJECT (m)
 
 SCM_API scm_t_bits scm_tc16_macro;
@@ -39,10 +45,15 @@ SCM_API scm_t_bits scm_tc16_macro;
 SCM_INTERNAL SCM scm_i_makbimacro (SCM code);
 SCM_API SCM scm_makmmacro (SCM code);
 SCM_API SCM scm_makacro (SCM code);
+SCM_API SCM scm_make_syncase_macro (SCM type, SCM binding);
+SCM_API SCM scm_make_extended_syncase_macro (SCM builtin, SCM type,
+                                             SCM binding);
 SCM_API SCM scm_macro_p (SCM obj);
 SCM_API SCM scm_macro_type (SCM m);
 SCM_API SCM scm_macro_name (SCM m);
 SCM_API SCM scm_macro_transformer (SCM m);
+SCM_API SCM scm_syncase_macro_type (SCM m);
+SCM_API SCM scm_syncase_macro_binding (SCM m);
 SCM_API SCM scm_make_synt (const char *name,
 			   SCM (*macroizer) (SCM),
 			   SCM (*fcn) ());

module/ice-9/boot-9.scm

@@ -161,12 +161,13 @@
 ;;; Keywords are syntactic bindings; variables are value bindings.
 (define (module-define-keyword! mod sym type val)
   (let ((v (or (module-local-variable mod sym)
-               (let ((v (make-variable val)))
+               (let ((v (make-undefined-variable)))
                  (module-add! mod sym v)
                  v))))
-    (if (or (not (variable-bound? v))
+    (variable-set! v
-            (not (macro? (variable-ref v))))
+                   (if (and (variable-bound? v) (macro? (variable-ref v)))
-        (variable-set! v val))
+                       (make-extended-syncase-macro (variable-ref v) type val)
+                       (make-syncase-macro type val)))
     (set-object-property! v '*sc-expander* (cons type val))))
 
 (define (module-lookup-keyword mod sym)
@@ -180,20 +181,25 @@
           ;; probably should unbind the variable too
           (set-object-properties! v (delq p (object-properties v)))))))
 
-(define sc-expand #f)
+;;; API provided by psyntax
-(define sc-expand3 #f)
-(define install-global-transformer #f)
-(define $sc-dispatch #f)
 (define syntax-violation #f)
-(define (annotation? x) #f)
-
 (define datum->syntax #f)
 (define syntax->datum #f)
-
 (define identifier? #f)
 (define generate-temporaries #f)
 (define bound-identifier=? #f)
 (define free-identifier=? #f)
+(define sc-expand #f)
+(define sc-expand3 #f)
+
+;;; Implementation detail of psyntax -- the thing that does expand-time
+;;; dispatch for syntax-case macros
+(define $sc-dispatch #f)
+
+;;; Useless crap I'd like to get rid of
+(define install-global-transformer #f)
+(define (annotation? x) #f)
+
 
 (define andmap
   (lambda (f first . rest)
@@ -213,14 +219,9 @@
                     (apply f (cons x xr))
                     (and (apply f (cons x xr)) (andmap first rest)))))))))
 
-(define (syncase-error who format-string why what)
-  (%start-stack 'syncase-stack
-                (lambda ()
-                  (scm-error 'misc-error who "~A ~S" (list why what) '()))))
-
-;; Until the module system is booted, this will be the current expander.
 (primitive-load-path "ice-9/psyntax-pp")
 
+;; Until the module system is booted, this will be the current expander.
 (define %pre-modules-transformer sc-expand)
 
 

module/ice-9/psyntax.scm

@@ -1167,8 +1167,8 @@
        (syntax-violation #f "reference to pattern variable outside syntax form"
                          (source-wrap e w s mod)))
       ((displaced-lexical)
-       (syntax-violation #f (source-wrap e w s mod)
+       (syntax-violation #f "reference to identifier outside its scope"
-         "reference to identifier outside its scope"))
+                          (source-wrap e w s mod)))
       (else (syntax-violation #f "unexpected syntax"
                               (source-wrap e w s mod))))))