From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 12 Feb 2002 00:26:34 +0000 (+0000)
Subject: Eliminate non-hygienic macros.
X-Git-Tag: 20090517-FFI~2257
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6a2ab0c1b52034f762c9b7eb8485643caac196c9;p=mit-scheme.git

Eliminate non-hygienic macros.
---

diff --git a/v7/src/compiler/back/asmmac.scm b/v7/src/compiler/back/asmmac.scm
index 9a5e068ca..7287b3b25 100644
--- a/v7/src/compiler/back/asmmac.scm
+++ b/v7/src/compiler/back/asmmac.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: asmmac.scm,v 1.13 2002/02/08 03:54:10 cph Exp $
+$Id: asmmac.scm,v 1.14 2002/02/12 00:25:08 cph Exp $
 
 Copyright (c) 1988, 1990, 1999, 2001, 2002 Massachusetts Institute of Technology
 
@@ -27,11 +27,10 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 (define-syntax define-instruction
   (sc-macro-transformer
    (lambda (form environment)
-     environment
      (if (syntax-match? '(SYMBOL * (DATUM + DATUM)) (cdr form))
 	 `(ADD-INSTRUCTION!
 	   ',(cadr form)
-	   ,(compile-database (cddr form)
+	   ,(compile-database (cddr form) environment
 	      (lambda (pattern actions)
 		pattern
 		(if (not (pair? actions))
@@ -39,16 +38,16 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 		(parse-instruction (car actions) (cdr actions) #f))))
 	 (ill-formed-syntax form)))))
 
-(define (compile-database cases procedure)
+(define (compile-database cases environment procedure)
   `(LIST
     ,@(map (lambda (rule)
-	     (parse-rule (car rule) (cdr rule)
-	       (lambda (pattern variables qualifier actions)
+	     (call-with-values (lambda () (parse-rule (car rule) (cdr rule)))
+	       (lambda (pattern variables qualifiers actions)
 		 `(CONS ',pattern
 			,(rule-result-expression variables
-						 qualifier
-						 (procedure pattern
-							    actions))))))
+						 qualifiers
+						 (procedure pattern actions)
+						 environment)))))
 	   cases)))
 
 (define optimize-group-syntax
diff --git a/v7/src/compiler/base/macros.scm b/v7/src/compiler/base/macros.scm
index cb24f62c6..90f5b737c 100644
--- a/v7/src/compiler/base/macros.scm
+++ b/v7/src/compiler/base/macros.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: macros.scm,v 4.26 2002/02/09 05:43:15 cph Exp $
+$Id: macros.scm,v 4.27 2002/02/12 00:25:26 cph Exp $
 
 Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology
 
@@ -312,16 +312,18 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	 (let ((type (cadr form))
 	       (pattern (caddr form))
 	       (body (cdddr form)))
-	   (parse-rule pattern body
-	     (lambda (pattern variables qualifier actions)
+	   (call-with-values (lambda () (parse-rule pattern body))
+	     (lambda (pattern variables qualifiers actions)
 	       `(,(case type
 		    ((STATEMENT) 'ADD-STATEMENT-RULE!)
 		    ((PREDICATE) 'ADD-STATEMENT-RULE!)
 		    ((REWRITING) 'ADD-REWRITING-RULE!)
 		    (else (close-syntax type environment)))
 		 ',pattern
-		 ,(rule-result-expression variables qualifier
-					  `(BEGIN ,@actions))))))
+		 ,(rule-result-expression variables
+					  qualifiers
+					  `(BEGIN ,@actions)
+					  environment)))))
 	 (ill-formed-syntax form)))))
 
 (define-syntax lap
diff --git a/v7/src/compiler/base/pmpars.scm b/v7/src/compiler/base/pmpars.scm
index d19b51724..526351fa3 100644
--- a/v7/src/compiler/base/pmpars.scm
+++ b/v7/src/compiler/base/pmpars.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: pmpars.scm,v 1.4 1999/01/02 06:06:43 cph Exp $
+$Id: pmpars.scm,v 1.5 2002/02/12 00:25:30 cph Exp $
 
 Copyright (c) 1988, 1999 Massachusetts Institute of Technology
 
@@ -38,36 +38,34 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 ;;; arguments, will return either false, indicating that the
 ;;; qualifications failed, or the result of the body.
 
-(define (parse-rule pattern body receiver)
-  (extract-variables
-   pattern
-   (lambda (pattern variables)
-     (extract-qualifier
-      body
-      (lambda (qualifiers actions)
-	(let ((names (pattern-variables pattern)))
-	  (receiver pattern
+(define (parse-rule pattern body)
+  (call-with-values (lambda () (extract-variables pattern))
+    (lambda (pattern variables)
+      (call-with-values (lambda () (extract-qualifiers body))
+	(lambda (qualifiers actions)
+	  (let ((names (pattern-variables pattern)))
+	    (values pattern
 		    (reorder-variables variables names)
 		    qualifiers
 		    actions)))))))
 
-(define (extract-variables pattern receiver)
+(define (extract-variables pattern)
   (if (pair? pattern)
       (if (memq (car pattern) '(? ?@))
-	  (receiver (make-pattern-variable (cadr pattern))
-		    (list (cons (cadr pattern)
-				(if (null? (cddr pattern))
-				    '()
-				    (list (cons (car pattern)
-						(cddr pattern)))))))
-	  (extract-variables (car pattern)
+	  (values (make-pattern-variable (cadr pattern))
+		  (list (cons (cadr pattern)
+			      (if (null? (cddr pattern))
+				  '()
+				  (list (cons (car pattern)
+					      (cddr pattern)))))))
+	  (call-with-values (lambda () (extract-variables (car pattern)))
 	    (lambda (car-pattern car-variables)
-	      (extract-variables (cdr pattern)
+	      (call-with-values (lambda () (extract-variables (cdr pattern)))
 		(lambda (cdr-pattern cdr-variables)
-		  (receiver (cons car-pattern cdr-pattern)
-			    (merge-variables-lists car-variables
-						   cdr-variables)))))))
-      (receiver pattern '())))
+		  (values (cons car-pattern cdr-pattern)
+			  (merge-variables-lists car-variables
+						 cdr-variables)))))))
+      (values pattern '())))
 
 (define (merge-variables-lists x y)
   (cond ((null? x) y)
@@ -81,62 +79,64 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	       (cons (car x)
 		     (merge-variables-lists (cdr x)
 					    y)))))))
-
-(define (extract-qualifier body receiver)
+
+(define (extract-qualifiers body)
   (if (and (pair? (car body))
 	   (eq? (caar body) 'QUALIFIER))
-      (receiver (cdar body) (cdr body))
-      (receiver '() body)))
+      (values (cdar body) (cdr body))
+      (values '() body)))
 
 (define (reorder-variables variables names)
   (map (lambda (name) (assq name variables))
        names))
+
+(define (rule-result-expression variables qualifiers body environment)
+  (reverse-syntactic-environments environment
+    (lambda (environment)
+      (call-with-values
+	  (lambda () (process-transformations variables environment))
+	(lambda (outer-vars inner-vars xforms xqualifiers)
+	  (let ((r-lambda (close-syntax 'LAMBDA environment))
+		(r-let (close-syntax 'LET environment))
+		(r-and (close-syntax 'AND environment)))
+	    `(,r-lambda ,outer-vars
+			(,r-let ,(map list inner-vars xforms)
+				(,r-and ,@xqualifiers
+					,@qualifiers
+					(,r-lambda () ,body))))))))))
 
-(define (rule-result-expression variables qualifiers body)
-  (let ((body `(lambda () ,body)))
-    (process-transformations variables
-      (lambda (outer-vars inner-vars xforms xqualifiers)
-	(if (null? inner-vars)
-	    `(lambda ,outer-vars
-	       ,(if (null? qualifiers)
-		    body
-		    `(and ,@qualifiers ,body)))
-	    `(lambda ,outer-vars
-	       (let ,(map list inner-vars xforms)
-		 (and ,@xqualifiers
-		      ,@qualifiers
-		      ,body))))))))
-
-(define (process-transformations variables receiver)
-  (if (null? variables)
-      (receiver '() '() '() '())
-      (process-transformations (cdr variables)
-	(lambda (outer inner xform qual)
-	  (let ((name (caar variables))
-		(variable (cdar variables)))
-	    (cond ((null? variable)
-		   (receiver (cons name outer)
-			     inner
-			     xform
-			     qual))
-		  ((not (null? (cdr variable)))
-		   (error "process-trasformations: Multiple qualifiers"
-			  (car variables)))
-		  (else
-		   (let ((var (car variable)))
-		     (define (handle-xform rename)
-		       (if (eq? (car var) '?)
-			   (receiver (cons rename outer)
-				     (cons name inner)
-				     (cons `(,(cadr var) ,rename)
-					   xform)
-				     (cons name qual))
-			   (receiver (cons rename outer)
-				     (cons name inner)
-				     (cons `(MAP ,(cadr var) ,rename)
-					   xform)
-				     (cons `(APPLY BOOLEAN/AND ,name) qual))))
-		     (handle-xform
-		      (if (null? (cddr var))
-			  name
-			  (caddr var)))))))))))
\ No newline at end of file
+(define (process-transformations variables environment)
+  (let ((r-map (close-syntax 'MAP environment))
+	(r-apply (close-syntax 'APPLY environment))
+	(r-boolean/and (close-syntax 'BOOLEAN/AND environment)))
+    (let loop ((variables variables))
+      (if (pair? variables)
+	  (call-with-values (lambda () (loop (cdr variables)))
+	    (lambda (outer-vars inner-vars xforms qualifiers)
+	      (let ((name (caar variables))
+		    (variable (cdar variables)))
+		(if (pair? variable)
+		    (let ((var (car variable)))
+		      (if (not (null? (cdr variable)))
+			  (error "Multiple variable qualifiers:"
+				 (car variables)))
+		      (let ((xform (cadr var))
+			    (outer-var
+			     (if (pair? (cddr var))
+				 (caddr var)
+				 name)))
+			(if (eq? (car var) '?)
+			    (values (cons outer-var outer-vars)
+				    (cons name inner-vars)
+				    (cons `(,xform ,outer-var) xforms)
+				    (cons name qualifiers))
+			    (values (cons outer-var outer-vars)
+				    (cons name inner-vars)
+				    (cons `(,r-map ,xform ,outer-var) xforms)
+				    (cons `(,r-apply ,r-boolean/and ,name)
+					  qualifiers)))))
+		    (values (cons name outer-vars)
+			    inner-vars
+			    xforms
+			    qualifiers)))))
+	  (values '() '() '() '())))))
\ No newline at end of file
diff --git a/v7/src/compiler/machines/i386/assmd.scm b/v7/src/compiler/machines/i386/assmd.scm
index e974f1d43..2dbf7b7bd 100644
--- a/v7/src/compiler/machines/i386/assmd.scm
+++ b/v7/src/compiler/machines/i386/assmd.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: assmd.scm,v 1.5 2001/12/23 17:20:57 cph Exp $
+$Id: assmd.scm,v 1.6 2002/02/12 00:26:30 cph Exp $
 
-Copyright (c) 1992, 1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1992, 1999, 2001, 2002 Massachusetts Institute of Technology
 
 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
@@ -26,8 +26,10 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (let-syntax
     ((ucode-type
-      (non-hygienic-macro-transformer
-       (lambda (name) `',(microcode-type name)))))
+      (sc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 (apply microcode-type (cdr form))))))
 
 (define-integrable maximum-padding-length
   ;; Instructions can be any number of bytes long.
diff --git a/v7/src/compiler/machines/i386/dassm1.scm b/v7/src/compiler/machines/i386/dassm1.scm
index ddc110f23..cc79d3bbd 100644
--- a/v7/src/compiler/machines/i386/dassm1.scm
+++ b/v7/src/compiler/machines/i386/dassm1.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: dassm1.scm,v 1.12 2001/12/23 17:20:57 cph Exp $
+$Id: dassm1.scm,v 1.13 2002/02/12 00:26:34 cph Exp $
 
-Copyright (c) 1992-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1992-1999, 2001, 2002 Massachusetts Institute of Technology
 
 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
@@ -145,8 +145,10 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	(cond ((not (< index end)) 'DONE)
 	      ((object-type?
 		(let-syntax ((ucode-type
-			      (non-hygienic-macro-transformer
-			       (lambda (name) (microcode-type name)))))
+			      (sc-macro-transformer
+			       (lambda (form environment)
+				 environment
+				 (apply microcode-type (cdr form))))))
 		  (ucode-type linkage-section))
 		(system-vector-ref block index))
 	       (loop (disassembler/write-linkage-section block