Make sure history is correct for identifiers in declarations.

Plumb selectors through map-decl-ids and pass to procedure.

diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm
index 14757f77d6210c8b890171371f8879e034a52a9a..7444436ab6f987ce274e970f49b649d12b0ecbc1 100644 (file)
--- a/src/runtime/mit-syntax.scm
+++ b/src/runtime/mit-syntax.scm
@@ -305,9 +305,8 @@ USA.
        (subform-hists decls hist)))
 
 (define (classify-decl decl senv hist)
-  (map-decl-ids (lambda (id)
-                 ;; Need to get the right hist here.
-                 (classify-id id senv hist))
+  (map-decl-ids (lambda (id selector)
+                 (classify-id id senv (hist-select selector hist)))
                decl))
 
 (define (classify-id id senv hist)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 281df7bacfc5a08f0e6332b3d1576ab7b52cb745..dfc58f02feff1de75d387a12a0b67338bfffdd42 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4403,8 +4403,11 @@ USA.
          syntax*
          syntax-error)
   (export (runtime syntax)
+         biselect-cadr
          biselect-car
+         biselect-cddr
          biselect-cdr
+         biselect-list-elts
          biselect-subform
          biselector:cadddr
          biselector:caddr

diff --git a/src/runtime/syntax-declaration.scm b/src/runtime/syntax-declaration.scm
index 42ea88d761fc1fdb56a3665baf39351f6f77f17a..ede42ac19e348e121533514f73b1394ac6d4ead6 100644 (file)
--- a/src/runtime/syntax-declaration.scm
+++ b/src/runtime/syntax-declaration.scm
@@ -51,94 +51,114 @@ USA.
                    (cdr declaration))))
         (entry (assq (car declaration) known-declarations)))
     (if (and entry (syntax-match? (cadr entry) (cdr declaration)))
-       ((cddr entry) declaration procedure)
+       ((cddr entry) procedure declaration biselector:cr)
        (begin
          (warn "Unknown declaration:" declaration)
          declaration))))
 
+(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 (declaration procedure)
+             (lambda (procedure declaration selector)
                (cons (car declaration)
-                     (map procedure (cdr declaration))))))
+                     (map+ procedure
+                           (cdr declaration)
+                           (biselect-cdr selector))))))
          ;; The names in USUAL-INTEGRATIONS are always global.
          '(
-           USUAL-INTEGRATIONS
-           IGNORABLE
-           IGNORE
-           INTEGRATE
-           INTEGRATE-OPERATOR
-           INTEGRATE-SAFELY
-           TYPE-CHECKS
-           NO-TYPE-CHECKS
-           RANGE-CHECKS
-           NO-RANGE-CHECKS
+           usual-integrations
+           ignorable
+           ignore
+           integrate
+           integrate-operator
+           integrate-safely
+           type-checks
+           no-type-checks
+           range-checks
+           no-range-checks
            ))
 
-(define-declaration 'INTEGRATE-EXTERNAL
+(define-declaration 'integrate-external
   `(* ,(lambda (object)
         (or (string? object)
             (pathname? object))))
-  (lambda (declaration procedure)
-    procedure
+  (lambda (procedure declaration selector)
+    (declare (ignore procedure selector))
     declaration))
 \f
 (for-each
  (lambda (keyword)
-   (define-declaration keyword '(DATUM)
-     (lambda (declaration procedure)
+   (define-declaration keyword '(datum)
+     (lambda (procedure declaration selector)
        (list (car declaration)
-            (let loop ((varset (cadr declaration)))
+            (let loop
+                ((varset (cadr declaration))
+                 (selector (biselect-cadr selector)))
               (cond ((syntax-match? '('set * identifier) varset)
                      (cons (car varset)
-                           (map procedure (cdr varset))))
+                           (map+ procedure
+                                 (cdr varset)
+                                 (biselect-cdr selector))))
                     ((syntax-match?* '(('union * datum)
                                        ('intersection * datum)
                                        ('difference datum datum))
                                      varset)
                      (cons (car varset)
-                           (map loop (cdr varset))))
+                           (map+ loop
+                                 (cdr varset)
+                                 (biselect-cdr selector))))
                     (else varset)))))))
- '(CONSTANT
-   IGNORE-ASSIGNMENT-TRAPS
-   IGNORE-REFERENCE-TRAPS
-   PURE-FUNCTION
-   SIDE-EFFECT-FREE
-   USUAL-DEFINITION
-   UUO-LINK))
+ '(constant
+   ignore-assignment-traps
+   ignore-reference-traps
+   pure-function
+   side-effect-free
+   usual-definition
+   uuo-link))
 
-(define-declaration 'REPLACE-OPERATOR '(* (IDENTIFIER * (DATUM DATUM)))
-  (lambda (declaration procedure)
+(define-declaration 'replace-operator '(* (identifier * (datum datum)))
+  (lambda (procedure declaration selector)
     (cons (car declaration)
-         (map (lambda (rule)
-                (cons (procedure (car rule))
-                      (map (lambda (clause)
-                             (list (car clause)
-                                   (if (identifier? (cadr clause))
-                                       (procedure (cadr clause))
-                                       (cadr clause))))
-                           (cdr rule))))
-              (cdr declaration)))))
+         (map+ (lambda (rule selector)
+                 (cons (procedure (car rule) (biselect-car selector))
+                       (map+ (lambda (clause selector)
+                               (list (car clause)
+                                     (if (identifier? (cadr clause))
+                                         (procedure
+                                          (cadr clause)
+                                          (biselect-cadr selector))
+                                         (cadr clause))))
+                             (cdr rule)
+                             (biselect-cdr selector))))
+               (cdr declaration)
+               (biselect-cdr selector)))))
 
-(define-declaration 'REDUCE-OPERATOR '(* (IDENTIFIER DATUM * DATUM))
-  (lambda (declaration procedure)
+(define-declaration 'reduce-operator '(* (identifier datum * datum))
+  (lambda (procedure declaration selector)
     (cons (car declaration)
-         (map (lambda (rule)
-                (cons* (procedure (car rule))
-                       (if (identifier? (cadr rule))
-                           (procedure (cadr rule))
-                           (cadr rule))
-                       (map (lambda (clause)
-                              (if (syntax-match?*
-                                   '(('null-value identifier datum)
-                                     ('singleton identifier)
-                                     ('wrapper identifier ? datum))
-                                   clause)
-                                  (cons* (car clause)
-                                         (procedure (cadr clause))
-                                         (cddr clause))
-                                  clause))
-                            (cddr rule))))
-              (cdr declaration)))))
\ No newline at end of file
+         (map+ (lambda (rule selector)
+                 (cons* (procedure (car rule) (biselect-car selector))
+                        (if (identifier? (cadr rule))
+                            (procedure (cadr rule) (biselect-cadr selector))
+                            (cadr rule))
+                        (map+ (lambda (clause selector)
+                                (if (syntax-match?*
+                                     '(('null-value identifier datum)
+                                       ('singleton identifier)
+                                       ('wrapper identifier ? datum))
+                                     clause)
+                                    (cons* (car clause)
+                                           (procedure (cadr clause)
+                                                      (biselect-cadr selector))
+                                           (cddr clause))
+                                    clause))
+                              (cddr rule)
+                              (biselect-cddr selector))))
+               (cdr declaration)
+               (biselect-cdr selector)))))
\ No newline at end of file

diff --git a/src/runtime/syntax-rename.scm b/src/runtime/syntax-rename.scm
index f4f8d26b3ce1ee1f6994c8c983abe26313e18ea5..8029925b73bed8917a0af8caf7c70eeccfc01982 100644 (file)
--- a/src/runtime/syntax-rename.scm
+++ b/src/runtime/syntax-rename.scm
@@ -339,7 +339,10 @@ USA.
        (make-scode-open-block
        (map substitution (scode-open-block-names expression))
        (map (lambda (declaration)
-              (map-decl-ids substitution declaration))
+              (map-decl-ids (lambda (id selector)
+                              (declare (ignore selector))
+                              (substitution id))
+                            declaration))
             (scode-open-block-declarations expression))
        (alpha-substitute substitution (scode-open-block-actions expression)))))
 
@@ -347,7 +350,10 @@ USA.
      (lambda (substitution expression)
        (make-scode-declaration
        (map (lambda (declaration)
-              (map-decl-ids substitution declaration))
+              (map-decl-ids (lambda (id selector)
+                              (declare (ignore selector))
+                              (substitution id))
+                            declaration))
             (scode-declaration-text expression))
        (alpha-substitute substitution
                          (scode-declaration-expression expression)))))

diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm
index ddbcc57d2c14149311e8989e04e68b4e72242f9d..856da4569cbe4263efdbd93ec1a0487a97a65174 100644 (file)
--- a/src/runtime/syntax.scm
+++ b/src/runtime/syntax.scm
@@ -262,19 +262,16 @@ USA.
 ;;;; Binary selectors
 
 (define (biselect-car selector)
-  (let ((n (integer-length selector)))
-    (+ (shift-left 1 n)
-       (- selector (shift-left 1 (- n 1))))))
+  (biselect-append biselector:car selector))
 
 (define (biselect-cdr selector)
-  (+ (shift-left 1 (integer-length selector))
-     selector))
+  (biselect-append biselector:cdr selector))
 
-(define (biselect-subform selector form)
-  (if (> selector 1)
-      (biselect-subform (quotient selector 2)
-                       (if (even? selector) (car form) (cdr form)))
-      form))
+(define (biselect-cadr selector)
+  (biselect-append biselector:cadr selector))
+
+(define (biselect-cddr selector)
+  (biselect-append biselector:cddr selector))
 
 ;; Selector order is:
 ;; (= biselector:cadr (biselect-append biselector:car biselector:cdr))
@@ -286,6 +283,18 @@ USA.
          biselector:cr
          selectors))
 
+(define (biselect-list-elts list selector)
+  (if (pair? list)
+      (cons (biselect-car selector)
+           (biselect-list-elts (cdr list) (biselect-cdr selector)))
+      '()))
+
+(define (biselect-subform selector form)
+  (if (> selector 1)
+      (biselect-subform (quotient selector 2)
+                       (if (even? selector) (car form) (cdr form)))
+      form))
+
 (define-integrable biselector:cr     #b00001)
 (define-integrable biselector:car    #b00010)
 (define-integrable biselector:cdr    #b00011)