Rewrite the declaration processor to make it reusable for alpha

substitution.

diff --git a/v7/src/runtime/mit-syntax.scm b/v7/src/runtime/mit-syntax.scm
index 7574195ef667d2a9a82b330ef1fb9efdb4722866..aa1194fb1bd5969693ee4cb233e0ac60c9a6c830 100644 (file)
--- a/v7/src/runtime/mit-syntax.scm
+++ b/v7/src/runtime/mit-syntax.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: mit-syntax.scm,v 14.4 2002/02/19 19:09:12 cph Exp $
+;;; $Id: mit-syntax.scm,v 14.5 2002/03/01 03:09:54 cph Exp $
 ;;;
 ;;; Copyright (c) 1989-1991, 2001, 2002 Massachusetts Institute of Technology
 ;;;
@@ -874,171 +874,24 @@
 
 (define (map-declaration-references declarations environment history selector)
   (select-map (lambda (declaration selector)
-               (let ((entry (assq (car declaration) known-declarations)))
-                 (if entry
-                     ((cdr entry) declaration environment history selector)
-                     (begin
-                       (warn "Ill-formed declaration:" declaration)
-                       declaration))))
+               (process-declaration declaration selector
+                 (lambda (form selector)
+                   (classify/variable-subexpression form
+                                                    environment
+                                                    history
+                                                    selector))
+                 (lambda (declaration selector)
+                   (syntax-error (history/add-subproblem declaration
+                                                         environment
+                                                         history
+                                                         selector)
+                                 "Ill-formed declaration:"
+                                 declaration))))
              declarations
              selector))
 
-(define (define-declaration name mapper)
-  (let ((entry (assq name known-declarations)))
-    (if entry
-       (set-cdr! entry mapper)
-       (begin
-         (set! known-declarations
-               (cons (cons name mapper) known-declarations))
-         unspecific))))
-
-(define known-declarations '())
-
-(define (classify/variable-subexpressions forms environment history selector)
-  (select-map (lambda (form selector)
-               (classify/variable-subexpression form
-                                                environment
-                                                history
-                                                selector))
-             forms
-             selector))
-
 (define (classify/variable-subexpression form environment history selector)
   (let ((item (classify/subexpression form environment history selector)))
     (if (not (variable-item? item))
        (syntax-error history "Variable required in this context:" form))
-    (variable-item/name item)))
-\f
-(let ((ignore
-       (lambda (declaration environment history selector)
-        environment history selector
-        declaration)))
-  ;; The names in USUAL-INTEGRATIONS are always global.
-  (define-declaration 'USUAL-INTEGRATIONS ignore)
-  (define-declaration 'AUTOMAGIC-INTEGRATIONS ignore)
-  (define-declaration 'ETA-SUBSTITUTION ignore)
-  (define-declaration 'OPEN-BLOCK-OPTIMIZATIONS ignore)
-  (define-declaration 'NO-AUTOMAGIC-INTEGRATIONS ignore)
-  (define-declaration 'NO-ETA-SUBSTITUTION ignore)
-  (define-declaration 'NO-OPEN-BLOCK-OPTIMIZATIONS ignore))
-
-(let ((tail-identifiers
-       (lambda (declaration environment history selector)
-        (if (not (syntax-match? '(* IDENTIFIER) (cdr declaration)))
-            (syntax-error history "Ill-formed declaration:" declaration))
-        `(,(car declaration)
-          ,@(classify/variable-subexpressions (cdr declaration)
-                                              environment
-                                              history
-                                              (selector/add-cdr selector))))))
-  (define-declaration 'INTEGRATE tail-identifiers)
-  (define-declaration 'INTEGRATE-OPERATOR tail-identifiers)
-  (define-declaration 'INTEGRATE-SAFELY tail-identifiers)
-  (define-declaration 'IGNORE tail-identifiers))
-
-(define-declaration 'INTEGRATE-EXTERNAL
-  (lambda (declaration environment history selector)
-    environment selector
-    (if (not (list-of-type? (cdr declaration)
-              (lambda (object)
-                (or (string? object)
-                    (pathname? object)))))
-       (syntax-error history "Ill-formed declaration:" declaration))
-    declaration))
-
-(let ((varset
-       (lambda (declaration environment history selector)
-        (if (not (syntax-match? '(DATUM) (cdr declaration)))
-            (syntax-error history "Ill-formed declaration:" declaration))
-        `(,(car declaration)
-          ,(let loop
-               ((varset (cadr declaration))
-                (selector (selector/add-cadr selector)))
-             (cond ((syntax-match? '('SET * IDENTIFIER) varset)
-                    `(,(car varset)
-                      ,@(classify/variable-subexpressions
-                         (cdr varset)
-                         environment
-                         history
-                         (selector/add-cdr selector))))
-                   ((or (syntax-match? '('UNION * DATUM) varset)
-                        (syntax-match? '('INTERSECTION * DATUM) varset)
-                        (syntax-match? '('DIFFERENCE DATUM DATUM) varset))
-                    `(,(car varset)
-                      ,@(select-map loop
-                                    (cdr varset)
-                                    (selector/add-cdr selector))))
-                   (else varset)))))))
-  (define-declaration 'CONSTANT varset)
-  (define-declaration 'IGNORE-ASSIGNMENT-TRAPS varset)
-  (define-declaration 'IGNORE-REFERENCE-TRAPS varset)
-  (define-declaration 'PURE-FUNCTION varset)
-  (define-declaration 'SIDE-EFFECT-FREE varset)
-  (define-declaration 'USUAL-DEFINITION varset)
-  (define-declaration 'UUO-LINK varset))
-\f
-(define-declaration 'REPLACE-OPERATOR
-  (lambda (declaration environment history selector)
-    (if (not (syntax-match? '(* DATUM) (cdr declaration)))
-       (syntax-error history "Ill-formed declaration:" declaration))
-    `(,(car declaration)
-      ,@(select-map
-        (lambda (rule selector)
-          (if (not (syntax-match? '(IDENTIFIER * (DATUM DATUM)) rule))
-              (syntax-error history "Ill-formed declaration:" declaration))
-          `(,(classify/variable-subexpression (car rule)
-                                              environment
-                                              history
-                                              (selector/add-car selector))
-            ,@(select-map
-               (lambda (clause selector)
-                 `(,(car clause)
-                   ,(if (identifier? (cadr clause))
-                        (classify/variable-subexpression (cadr clause)
-                                                         environment
-                                                         history
-                                                         (selector/add-cadr
-                                                          selector))
-                        (cadr clause))))
-               (cdr rule)
-               (selector/add-cdr selector))))
-        (cdr declaration)
-        (selector/add-cdr selector)))))
-
-(define-declaration 'REDUCE-OPERATOR
-  (lambda (declaration environment history selector)
-    `(,(car declaration)
-      ,@(select-map
-        (lambda (rule selector)
-          (if (not (syntax-match? '(IDENTIFIER DATUM * DATUM) rule))
-              (syntax-error history "Ill-formed declaration:" declaration))
-          `(,(classify/variable-subexpression (car rule)
-                                              environment
-                                              history
-                                              (selector/add-car selector))
-            ,(if (identifier? (cadr rule))
-                 (classify/variable-subexpression (cadr rule)
-                                                  environment
-                                                  history
-                                                  (selector/add-cadr
-                                                   selector))
-                 (cadr rule))
-            ,@(select-map
-               (lambda (clause selector)
-                 (if (or (syntax-match? '('NULL-VALUE IDENTIFIER DATUM)
-                                        clause)
-                         (syntax-match? '('SINGLETON IDENTIFIER) clause)
-                         (syntax-match? '('WRAPPER IDENTIFIER ? DATUM)
-                                        clause))
-                     `(,(car clause)
-                       ,(classify/variable-subexpression (cadr clause)
-                                                         environment
-                                                         history
-                                                         (selector/add-cadr
-                                                          selector))
-                       ,@(cddr clause))
-                     clause))
-               (cddr rule)
-               (selector/add-cddr selector))))
-        (cdr declaration)
-        (selector/add-cdr selector)))))
\ No newline at end of file
+    (variable-item/name item)))
\ No newline at end of file

diff --git a/v7/src/runtime/syntax-output.scm b/v7/src/runtime/syntax-output.scm
index 86284210a1946745a1a89efa1b7344805b4e3bc4..4741f860e051f43331ee67a6e886354eb118dfd9 100644 (file)
--- a/v7/src/runtime/syntax-output.scm
+++ b/v7/src/runtime/syntax-output.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: syntax-output.scm,v 14.1 2002/02/03 03:38:57 cph Exp $
+;;; $Id: syntax-output.scm,v 14.2 2002/03/01 03:09:58 cph Exp $
 ;;;
 ;;; Copyright (c) 1989-1991, 2001, 2002 Massachusetts Institute of Technology
 ;;;
@@ -147,4 +147,139 @@
   ((ucode-primitive string->symbol) "#[let-procedure]"))
 
 (define lambda-tag:fluid-let
-  ((ucode-primitive string->symbol) "#[fluid-let-procedure]"))
\ No newline at end of file
+  ((ucode-primitive string->symbol) "#[fluid-let-procedure]"))
+\f
+;;;; Declarations
+
+(define (define-declaration name pattern mapper)
+  (let ((entry (assq name known-declarations)))
+    (if entry
+       (set-cdr! entry (cons pattern mapper))
+       (begin
+         (set! known-declarations
+               (cons (cons name (cons pattern mapper))
+                     known-declarations))
+         unspecific))))
+
+(define (process-declaration declaration
+                            selector
+                            map-identifier
+                            ill-formed-declaration)
+  (if (pair? declaration)
+      (let ((entry (assq (car declaration) known-declarations)))
+       (if (and entry (syntax-match? (cadr entry) (cdr declaration)))
+           ((cddr entry) declaration selector map-identifier)
+           (begin
+             (warn "Unknown declaration:" declaration)
+             declaration)))
+      (ill-formed-declaration declaration selector)))
+
+(define known-declarations '())
+
+(for-each (lambda (keyword)
+           (define-declaration keyword '()
+             (lambda (declaration selector map-identifier)
+               selector map-identifier
+               declaration)))
+         '(AUTOMAGIC-INTEGRATIONS
+           NO-AUTOMAGIC-INTEGRATIONS
+           ETA-SUBSTITUTION
+           NO-ETA-SUBSTITUTION
+           OPEN-BLOCK-OPTIMIZATIONS
+           NO-OPEN-BLOCK-OPTIMIZATIONS))
+
+(for-each (lambda (keyword)
+           (define-declaration keyword '(* IDENTIFIER)
+             (lambda (declaration selector map-identifier)
+               (cons (car declaration)
+                     (select-map map-identifier
+                                 (cdr declaration)
+                                 (selector/add-cdr selector))))))
+         ;; The names in USUAL-INTEGRATIONS are always global.
+         '(USUAL-INTEGRATIONS
+           INTEGRATE
+           INTEGRATE-OPERATOR
+           INTEGRATE-SAFELY
+           IGNORE))
+
+(define-declaration 'INTEGRATE-EXTERNAL
+  `(* ,(lambda (object)
+        (or (string? object)
+            (pathname? object))))
+  (lambda (declaration selector map-identifier)
+    selector map-identifier
+    declaration))
+\f
+(for-each
+ (lambda (keyword)
+   (define-declaration keyword '(DATUM)
+     (lambda (declaration selector map-identifier)
+       (list (car declaration)
+            (let loop
+                ((varset (cadr declaration))
+                 (selector (selector/add-cadr selector)))
+              (cond ((syntax-match? '('SET * IDENTIFIER) varset)
+                     (cons (car varset)
+                           (select-map map-identifier
+                                       (cdr varset)
+                                       (selector/add-cdr selector))))
+                    ((or (syntax-match? '('UNION * DATUM) varset)
+                         (syntax-match? '('INTERSECTION * DATUM) varset)
+                         (syntax-match? '('DIFFERENCE DATUM DATUM) varset))
+                     (cons (car varset)
+                           (select-map loop
+                                       (cdr varset)
+                                       (selector/add-cdr selector))))
+                    (else varset)))))))
+ '(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 selector map-identifier)
+    (cons (car declaration)
+         (select-map
+          (lambda (rule selector)
+            (cons (map-identifier (car rule) (selector/add-car selector))
+                  (select-map
+                   (lambda (clause selector)
+                     (list (car clause)
+                           (if (identifier? (cadr clause))
+                               (map-identifier (cadr clause)
+                                               (selector/add-cadr selector))
+                               (cadr clause))))
+                   (cdr rule))))
+          (cdr declaration)
+          (selector/add-cdr selector)))))
+
+(define-declaration 'REDUCE-OPERATOR '(* (IDENTIFIER DATUM * DATUM))
+  (lambda (declaration selector map-identifier)
+    (cons (car declaration)
+         (select-map
+          (lambda (rule selector)
+            (cons* (map-identifier (car rule) (selector/add-car selector))
+                   (if (identifier? (cadr rule))
+                       (map-identifier (cadr rule)
+                                       (selector/add-cadr selector))
+                       (cadr rule))
+                   (select-map
+                    (lambda (clause selector)
+                      (if (or (syntax-match? '('NULL-VALUE IDENTIFIER DATUM)
+                                             clause)
+                              (syntax-match? '('SINGLETON IDENTIFIER)
+                                             clause)
+                              (syntax-match? '('WRAPPER IDENTIFIER ? DATUM)
+                                             clause))
+                          (cons* (car clause)
+                                 (map-identifier (cadr clause)
+                                                 (selector/add-cadr selector))
+                                 (cddr clause))
+                          clause))
+                    (cddr rule)
+                    (selector/add-cddr selector))))
+          (cdr declaration)
+          (selector/add-cdr selector)))))
\ No newline at end of file