Syntax renaming now handles declarations correctly.

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 76c0b85a055153ff58c2308afd7ca6e9b57ca056..909df86bce2862460826bdeac84d238185a682a5 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4812,6 +4812,7 @@ USA.
   (files "syntax-declaration")
   (parent (runtime syntax))
   (export (runtime syntax)
+         fold-decl-ids
          map-decl-ids))
 
 (define-package (runtime syntax mit)

diff --git a/src/runtime/syntax-declaration.scm b/src/runtime/syntax-declaration.scm
index 84335d6f6514aa0667168e1b2af57a94bac88bca..a87190dcc7e982975348a7b14ba3b871e1123ed8 100644 (file)
--- a/src/runtime/syntax-declaration.scm
+++ b/src/runtime/syntax-declaration.scm
@@ -29,47 +29,58 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define (define-declaration name pattern mapper)
-  (let ((entry (assq name known-declarations)))
+(define (define-declaration name pattern mapper folder)
+  (let ((entry (assq name known-declarations))
+       (value (list pattern mapper folder)))
     (if entry
-       (set-cdr! entry (cons pattern mapper))
+       (set-cdr! entry value)
        (begin
          (set! known-declarations
-               (cons (cons name (cons pattern mapper))
+               (cons (cons name value)
                      known-declarations))
          unspecific))))
 
 (define (map-decl-ids procedure declaration)
+  (operate-on-decl-ids (lambda (handlers declaration)
+                        ((car handlers) procedure declaration biselector:cr))
+                      declaration))
+
+(define (fold-decl-ids procedure initial declaration)
+  (operate-on-decl-ids (lambda (handlers declaration)
+                        ((cadr handlers) procedure initial declaration))
+                      declaration))
+
+(define (operate-on-decl-ids procedure declaration)
   (if (not (pair? declaration))
       (error "Ill-formed declaration:" declaration))
   (let* ((declaration
          ;++ This is a kludge -- rather than strip syntactic closures,
          ;++ it should be aware of the environment.
-         (if (symbol? (car declaration))
-             declaration
-             (cons (strip-syntactic-closures (car declaration))
-                   (cdr declaration))))
+         (cons (identifier->symbol (car declaration))
+               (cdr declaration)))
         (entry (assq (car declaration) known-declarations)))
     (if (and entry (syntax-match? (cadr entry) (cdr declaration)))
-       ((cddr entry) procedure declaration biselector:cr)
+       (procedure (cddr entry) declaration)
        (begin
          (warn "Unknown declaration:" declaration)
          declaration))))
 
+(define known-declarations '())
+
 (define (map+ procedure items selector)
   (map procedure
        items
        (biselect-list-elts items selector)))
 
-(define known-declarations '())
-
 (for-each (lambda (keyword)
            (define-declaration keyword '(* identifier)
              (lambda (procedure declaration selector)
                (cons (car declaration)
                      (map+ procedure
                            (cdr declaration)
-                           (biselect-cdr selector))))))
+                           (biselect-cdr selector))))
+             (lambda (procedure initial declaration)
+               (fold procedure initial (cdr declaration)))))
          ;; The names in USUAL-INTEGRATIONS are always global.
          '(
            usual-integrations
@@ -90,13 +101,19 @@ USA.
             (pathname? object))))
   (lambda (procedure declaration selector)
     (declare (ignore procedure selector))
-    declaration))
+    declaration)
+  (lambda (procedure initial declaration)
+    (declare (ignore procedure declaration))
+    initial))
 
 (define-declaration 'target-metadata
-  `(* (symbol * datum))
+  '(* (symbol * datum))
   (lambda (procedure declaration selector)
     (declare (ignore procedure selector))
-    declaration))
+    declaration)
+  (lambda (procedure initial declaration)
+    (declare (ignore procedure declaration))
+    initial))
 \f
 (for-each
  (lambda (keyword)
@@ -119,7 +136,17 @@ USA.
                            (map+ loop
                                  (cdr varset)
                                  (biselect-cdr selector))))
-                    (else varset)))))))
+                    (else varset)))))
+     (lambda (procedure initial declaration)
+       (let loop ((varset (cadr declaration)) (value initial))
+        (cond ((syntax-match? '('set * identifier) varset)
+               (fold procedure value (cdr varset)))
+              ((syntax-match?* '(('union * datum)
+                                 ('intersection * datum)
+                                 ('difference datum datum))
+                               varset)
+               (fold loop value (cdr varset)))
+              (else value))))))
  '(constant
    ignore-assignment-traps
    ignore-reference-traps
@@ -143,7 +170,17 @@ USA.
                              (cdr rule)
                              (biselect-cdr selector))))
                (cdr declaration)
-               (biselect-cdr selector)))))
+               (biselect-cdr selector))))
+  (lambda (procedure initial declaration)
+    (fold (lambda (rule value)
+           (fold (lambda (clause value*)
+                   (if (identifier? (cadr clause))
+                       (procedure (cadr clause) value*)
+                       value*))
+                 (procedure (car rule) value)
+                 (cdr rule)))
+         initial
+         (cdr declaration))))
 
 (define-declaration 'reduce-operator '(* (identifier datum * datum))
   (lambda (procedure declaration selector)
@@ -167,4 +204,20 @@ USA.
                               (cddr rule)
                               (biselect-cddr selector))))
                (cdr declaration)
-               (biselect-cdr selector)))))
\ No newline at end of file
+               (biselect-cdr selector))))
+  (lambda (procedure initial declaration)
+    (fold (lambda (rule value)
+           (fold (lambda (clause value*)
+                   (if (syntax-match?* '(('null-value identifier datum)
+                                         ('singleton identifier)
+                                         ('wrapper identifier ? datum))
+                                       clause)
+                       (procedure (cadr clause) value*)
+                       value*))
+                 (let ((value* (procedure (car rule) value)))
+                   (if (identifier? (cadr rule))
+                       (procedure (cadr rule) value*)
+                       value*))
+                 (cddr rule)))
+         initial
+         (cdr declaration))))
\ No newline at end of file

diff --git a/src/runtime/syntax-rename.scm b/src/runtime/syntax-rename.scm
index 752b806e545bd4ea1b7cb8fa55137dce47387711..cf0138263509611fab2180373029cf4f63eb1f26 100644 (file)
--- a/src/runtime/syntax-rename.scm
+++ b/src/runtime/syntax-rename.scm
@@ -222,9 +222,22 @@ USA.
    (define-cs-handler scode-open-block?
      (lambda (expression mark-safe!)
        (mark-local-bindings (scode-open-block-names expression)
-                           (scode-open-block-actions expression)
+                           (make-scode-declaration
+                            (scode-open-block-declarations expression)
+                            (scode-open-block-actions expression))
                            mark-safe!)))
 
+   (define-cs-handler scode-declaration?
+     (lambda (expression mark-safe!)
+       (fold (lambda (declaration ids)
+              (fold-decl-ids (lambda (id ids)
+                               (lset-adjoin eq? ids id))
+                             ids
+                             declaration))
+            (compute-substitution (scode-declaration-expression expression)
+                                  mark-safe!)
+            (scode-declaration-text expression))))
+
    (define-cs-handler quoted-identifier?
      (simple-subexpression quoted-identifier-identifier))