* psyntax.ss (build-data): Don't quote self-evaluating expressions

in output.  (We normally *would* like also these expressions to be
quoted, but until Guile's native macros and syncase cooperates
better, it is less destructive not to quote.)
(self-evaluating?): Removed null? (In Guile, the empty list is not
self-evaluating).
(sc-chi): Export chi as sc-chi.
(external-macro): New syntax type.

* psyntax.pp: Regenerated.

* compile-psyntax.scm: Set expansion-eval-closure.

* syncase.scm: Set expansion-eval-closure to
the-syncase-eval-closure during booting so that variables are
created in the correct module.
(syncase): Set expansion-eval-closure.
(define-syntax define-syntax-public eval-when fluid-let-syntax
identifier-syntax let-syntax letrec-syntax syntax syntax-case
syntax-rules with-syntax include): Removed definitions (these are
created from within psyntax.pp).
Enable expansion of Guile macros during a syntax-case
transformation.

ice-9/ChangeLog

@@ -1,4 +1,17 @@
-2003-01-15  Mikael Djurfeldt  <djurfeldt@nada.kth.se>
+2003-01-16  Mikael Djurfeldt  <djurfeldt@nada.kth.se>
+
+	* psyntax.ss (build-data): Don't quote self-evaluating expressions
+	in output.  (We normally *would* like also these expressions to be
+	quoted, but until Guile's native macros and syncase cooperates
+	better, it is less destructive not to quote.)
+	(self-evaluating?): Removed null? (In Guile, the empty list is not
+	self-evaluating).
+	(sc-chi): Export chi as sc-chi.
+	(external-macro): New syntax type.
+
+	* psyntax.pp: Regenerated.
+
+	* compile-psyntax.scm: Set expansion-eval-closure.
 
 	* boot-9.scm (use-syntax): Return *unspecified*.
 
@@ -10,7 +23,8 @@
 	identifier-syntax let-syntax letrec-syntax syntax syntax-case
 	syntax-rules with-syntax include): Removed definitions (these are
 	created from within psyntax.pp).
-
+	Enable expansion of Guile macros during a syntax-case
+	transformation.
 
 2003-01-10  Mikael Djurfeldt  <djurfeldt@nada.kth.se>
 

ice-9/compile-psyntax.scm

@@ -12,14 +12,16 @@
 
 (let ((in (open-input-file source))
       (out (open-output-file (string-append target ".tmp"))))
-  (let loop ((x (read in)))
+  (with-fluids ((expansion-eval-closure
-    (if (eof-object? x)
+		 (module-eval-closure (current-module))))
-	(begin
+    (let loop ((x (read in)))
-	  (close-port out)
+      (if (eof-object? x)
-	  (close-port in))
+	  (begin
-	(begin
+	    (close-port out)
-	  (write (sc-expand3 x 'c '(compile load eval)) out)
+	    (close-port in))
-	  (newline out)
+	  (begin
-	  (loop (read in))))))
+	    (write (sc-expand3 x 'c '(compile load eval)) out)
+	    (newline out)
+	    (loop (read in)))))))
 
 (system (format #f "mv -f ~s.tmp ~s" target target))

ice-9/psyntax.ss

@@ -1,6 +1,6 @@
 ;;;; -*-scheme-*-
 ;;;;
-;;;; 	Copyright (C) 2001 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2001, 2003 Free Software Foundation, Inc.
 ;;;; 
 ;;;; This program is free software; you can redistribute it and/or modify
 ;;;; it under the terms of the GNU General Public License as published by
@@ -418,9 +418,10 @@
     ((_ src name) name)
     ((_ src level name) name)))
 
-(define-syntax build-data
+(define (build-data src exp)
-  (syntax-rules ()
+  (if (self-evaluating? exp)
-    ((_ src exp) `',exp)))
+      exp
+      (list 'quote exp)))
 
 (define build-sequence
   (lambda (src exps)
@@ -454,7 +455,7 @@
   (syntax-rules ()
     ((_ e)
      (let ((x e))
-       (or (boolean? x) (number? x) (string? x) (char? x) (null? x) (keyword? x))))))
+       (or (boolean? x) (number? x) (string? x) (char? x) (keyword? x))))))
 )
 
 (define-structure (syntax-object expression wrap))
@@ -504,6 +505,7 @@
 
 ;;; <binding> ::= (macro . <procedure>)           macros
 ;;;               (core . <procedure>)            core forms
+;;;               (external-macro . <procedure>)  external-macro
 ;;;               (begin)                         begin
 ;;;               (define)                        define
 ;;;               (define-syntax)                 define-syntax
@@ -918,6 +920,7 @@
 ;;;    type                   value         explanation
 ;;;    -------------------------------------------------------------------
 ;;;    core                   procedure     core form (including singleton)
+;;;    external-macro         procedure     external macro
 ;;;    lexical                name          lexical variable reference
 ;;;    global                 name          global variable reference
 ;;;    begin                  none          begin keyword
@@ -971,7 +974,7 @@
                  ((macro)
                   (syntax-type (chi-macro (binding-value b) e r w rib)
                     r empty-wrap s rib))
-                 ((core) (values type (binding-value b) e w s))
+                 ((core external-macro) (values type (binding-value b) e w s))
                  ((local-syntax)
                   (values 'local-syntax-form (binding-value b) e w s))
                  ((begin) (values 'begin-form #f e w s))
@@ -1077,15 +1080,20 @@
                       (chi-install-global n (chi e r w))))
                 (chi-void)))))
           ((define-form)
-           (let ((n (id-var-name value w)))
+           (let* ((n (id-var-name value w))
-             (case (binding-type (lookup n r))
+		  (type (binding-type (lookup n r))))
+             (case type
                ((global)
                 (eval-if-c&e m
                   (build-global-definition s n (chi e r w))))
                ((displaced-lexical)
                 (syntax-error (wrap value w) "identifier out of context"))
-               (else (syntax-error (wrap value w)
+               (else
-                       "cannot define keyword at top level")))))
+		(if (eq? type 'external-macro)
+		    (eval-if-c&e m
+				 (build-global-definition s n (chi e r w)))
+		    (syntax-error (wrap value w)
+				  "cannot define keyword at top level"))))))
           (else (eval-if-c&e m (chi-expr type value e r w s))))))))
 
 (define chi
@@ -1100,7 +1108,7 @@
     (case type
       ((lexical)
        (build-lexical-reference 'value s value))
-      ((core) (value e r w s))
+      ((core external-macro) (value e r w s))
       ((lexical-call)
        (chi-application
          (build-lexical-reference 'fun (source-annotation (car e)) value)
@@ -1351,7 +1359,7 @@
     (let ((p (local-eval-hook expanded)))
       (if (procedure? p)
           p
-          (syntax-error p "nonprocedure transfomer")))))
+          (syntax-error p "nonprocedure transformer")))))
 
 (define chi-void
   (lambda ()
@@ -2055,6 +2063,8 @@
        (match* (unannotate (syntax-object-expression e))
          p (syntax-object-wrap e) '()))
       (else (match* (unannotate e) p empty-wrap '())))))
+
+(set! sc-chi chi)
 ))
 )
 

ice-9/syncase.scm

@@ -75,6 +75,7 @@
 
 (define sc-expand #f)
 (define sc-expand3 #f)
+(define sc-chi #f)
 (define install-global-transformer #f)
 (define syntax-dispatch #f)
 (define syntax-error #f)
@@ -130,21 +131,47 @@
 (fluid-set! expansion-eval-closure the-syncase-eval-closure)
 
 (define (putprop symbol key binding)
-  (let* ((v ((fluid-ref expansion-eval-closure) symbol #t)))
+  (let* ((eval-closure (fluid-ref expansion-eval-closure))
-    (if (symbol-property symbol 'primitive-syntax)
+	 ;; Why not simply do (eval-closure symbol #t)?
-	(if (eq? (fluid-ref expansion-eval-closure) the-syncase-eval-closure)
+	 ;; Answer: That would overwrite imported bindings
-	    (set-object-property! (module-variable the-root-module symbol)
+	 (v (or (eval-closure symbol #f) ;lookup
-				  key
+		(eval-closure symbol #t) ;create it locally
-				  binding))
+		)))
+    ;; Don't destroy Guile macros corresponding to
+    ;; primitive syntax when syncase boots.
+    (if (not (and (symbol-property symbol 'primitive-syntax)
+		  (eq? eval-closure the-syncase-eval-closure)))
 	(variable-set! v sc-macro))
+    ;; Properties are tied to variable objects
     (set-object-property! v key binding)))
 
 (define (getprop symbol key)
   (let* ((v ((fluid-ref expansion-eval-closure) symbol #f)))
-    (and v (or (object-property v key)
+    (and v
-	       (let ((root-v (module-local-variable the-root-module symbol)))
+	 (or (object-property v key)
-		 (and (equal? root-v v)
+	     (and (variable-bound? v)
-		      (object-property root-v key)))))))
+		  (macro? (variable-ref v))
+		  (macro-transformer (variable-ref v)) ;non-primitive
+		  guile-macro)))))
+
+(define guile-macro
+  (cons 'external-macro
+	(lambda (e r w s)
+	  (if (symbol? e)
+	      ;; pass the expression through
+	      e
+	      (let* ((eval-closure (fluid-ref expansion-eval-closure))
+		     (m (variable-ref (eval-closure (car e) #f))))
+		(if (eq? (macro-type m) 'syntax)
+		    ;; pass the expression through
+		    e
+		    ;; perform Guile macro transform
+		    (let ((e ((macro-transformer m)
+			      e
+			      (append r (list eval-closure)))))
+		      (if (null? r)
+			  (sc-expand e)
+			  (sc-chi e r w)))))))))
 
 (define generated-symbols (make-weak-key-hash-table 1019))