From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 14 Feb 2002 15:58:56 +0000 (+0000)
Subject: Make sure that all expressions are properly closed.
X-Git-Tag: 20090517-FFI~2239
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2748d5817b23abeb0391facccc5753006dbc96a7;p=mit-scheme.git

Make sure that all expressions are properly closed.
---

diff --git a/v7/src/compiler/back/asmmac.scm b/v7/src/compiler/back/asmmac.scm
index 4f15182b8..59d5e5eb3 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.15 2002/02/14 01:24:24 cph Exp $
+$Id: asmmac.scm,v 1.16 2002/02/14 15:56:53 cph Exp $
 
 Copyright (c) 1988, 1990, 1999, 2001, 2002 Massachusetts Institute of Technology
 
@@ -25,10 +25,10 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 (declare (usual-integrations))
 
 (define-syntax define-instruction
-  (sc-macro-transformer
+  (rsc-macro-transformer
    (lambda (form environment)
      (if (syntax-match? '(SYMBOL * (DATUM + DATUM)) (cdr form))
-	 `(ADD-INSTRUCTION!
+	 `(,(close-syntax 'ADD-INSTRUCTION! environment)
 	   ',(cadr form)
 	   ,(compile-database (cddr form) environment
 	      (lambda (pattern actions)
@@ -40,15 +40,16 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	 (ill-formed-syntax form)))))
 
 (define (compile-database cases environment procedure)
-  `(LIST
+  `(,(close-syntax 'LIST environment)
     ,@(map (lambda (rule)
 	     (call-with-values (lambda () (parse-rule (car rule) (cdr rule)))
 	       (lambda (pattern variables qualifiers actions)
-		 `(CONS ',pattern
-			,(rule-result-expression variables
-						 qualifiers
-						 (procedure pattern actions)
-						 environment)))))
+		 `(,(close-syntax 'CONS environment)
+		   ',pattern
+		   ,(rule-result-expression variables
+					    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 90f5b737c..1e8566807 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.27 2002/02/12 00:25:26 cph Exp $
+$Id: macros.scm,v 4.28 2002/02/14 15:57:10 cph Exp $
 
 Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology
 
@@ -306,7 +306,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
       (ill-formed-syntax form)))
 
 (define-syntax define-rule
-  (sc-macro-transformer
+  (rsc-macro-transformer
    (lambda (form environment)
      (if (syntax-match? '(IDENTIFIER DATUM + DATUM) (cdr form))
 	 (let ((type (cadr form))
@@ -315,10 +315,11 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	   (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)))
+		    ((STATEMENT PREDICATE)
+		     (close-syntax 'ADD-STATEMENT-RULE! environment))
+		    ((REWRITING)
+		     (close-syntax 'ADD-REWRITING-RULE! environment))
+		    (else type))
 		 ',pattern
 		 ,(rule-result-expression variables
 					  qualifiers
diff --git a/v7/src/compiler/base/pmpars.scm b/v7/src/compiler/base/pmpars.scm
index 40456e2b9..c28d534a7 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.6 2002/02/12 00:29:16 cph Exp $
+$Id: pmpars.scm,v 1.7 2002/02/14 15:57:00 cph Exp $
 
 Copyright (c) 1988, 1999, 2002 Massachusetts Institute of Technology
 
@@ -91,19 +91,16 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
        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))))))))))
+  (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 (process-transformations variables environment)
   (let ((r-map (close-syntax 'MAP environment))
diff --git a/v7/src/compiler/machines/bobcat/insmac.scm b/v7/src/compiler/machines/bobcat/insmac.scm
index d5ebbf515..7ae872281 100644
--- a/v7/src/compiler/machines/bobcat/insmac.scm
+++ b/v7/src/compiler/machines/bobcat/insmac.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: insmac.scm,v 1.130 2002/02/13 18:45:24 cph Exp $
+$Id: insmac.scm,v 1.131 2002/02/14 15:58:56 cph Exp $
 
 Copyright (c) 1988, 1990, 1999, 2001, 2002 Massachusetts Institute of Technology
 
@@ -30,10 +30,11 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
   'EA-DATABASE)
 
 (define-syntax define-ea-database
-  (sc-macro-transformer
+  (rsc-macro-transformer
    (lambda (form environment)
-     `(DEFINE ,ea-database-name
-	,(compile-database (cdr form) environment
+     `(,(close-syntax 'DEFINE environment)
+       ,ea-database-name
+       ,(compile-database (cdr form) environment
 	  (lambda (pattern actions)
 	    (if (null? (cddr actions))
 		(make-position-dependent pattern actions environment)
@@ -74,16 +75,18 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	(mode (cadr actions))
 	(register (caddr actions))
 	(extension (cdddr actions)))
-    `(MAKE-EFFECTIVE-ADDRESS
+    `(,(close-syntax 'MAKE-EFFECTIVE-ADDRESS environment)
       ',keyword
-      ,(integer-syntaxer (close-syntax mode environment) 'UNSIGNED 3)
-      ,(integer-syntaxer (close-syntax register environment) 'UNSIGNED 3)
-      (LAMBDA (IMMEDIATE-SIZE INSTRUCTION-TAIL)
-	IMMEDIATE-SIZE			;ignore if not referenced
-	,(if (pair? extension)
-	     `(CONS-SYNTAX ,(close-syntax (car extension) environment)
-			   INSTRUCTION-TAIL)
-	     'INSTRUCTION-TAIL))
+      ,(integer-syntaxer mode 'UNSIGNED 3)
+      ,(integer-syntaxer register 'UNSIGNED 3)
+      (,(close-syntax 'LAMBDA environment)
+       (IMMEDIATE-SIZE INSTRUCTION-TAIL)
+       IMMEDIATE-SIZE			;ignore if not referenced
+       ,(if (pair? extension)
+	    `(,(close-syntax 'CONS-SYNTAX environment)
+	      ,(car extension)
+	      INSTRUCTION-TAIL)
+	    `INSTRUCTION-TAIL))
       ',categories)))
 
 (define (make-position-dependent pattern actions environment)
@@ -94,19 +97,23 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	  (mode (cadr code))
 	  (register (caddr code))
 	  (extension (cadddr code)))
-      `(LET ((,name (GENERATE-LABEL 'MARK)))
-	 (make-effective-address
-	  ',keyword
-	  ,(process-ea-field mode environment)
-	  ,(process-ea-field register environment)
-	  (LAMBDA (IMMEDIATE-SIZE INSTRUCTION-TAIL)
-	    IMMEDIATE-SIZE		;ignore if not referenced
-	    ,(if (pair? extension)
-		 `(CONS (LIST 'LABEL ,(close-syntax name environment))
-			(CONS-SYNTAX ,(close-syntax extension environment)
-				     INSTRUCTION-TAIL))
-		 `INSTRUCTION-TAIL))
-	  ',categories)))))
+      `(,(close-syntax 'LET environment)
+	((,name (,(close-syntax 'GENERATE-LABEL environment) 'MARK)))
+	(,(close-syntax 'MAKE-EFFECTIVE-ADDRESS environment)
+	 ',keyword
+	 ,(process-ea-field mode environment)
+	 ,(process-ea-field register environment)
+	 (,(close-syntax 'LAMBDA environment)
+	  (IMMEDIATE-SIZE INSTRUCTION-TAIL)
+	  IMMEDIATE-SIZE		;ignore if not referenced
+	  ,(if (pair? extension)
+	       `(,(close-syntax 'CONS environment)
+		 (,(close-syntax 'LIST environment) 'LABEL ,name)
+		 (,(close-syntax 'CONS-SYNTAX environment)
+		  ,extension
+		  INSTRUCTION-TAIL))
+	       `INSTRUCTION-TAIL))
+	 ',categories)))))
 
 (define (process-ea-field field environment)
   (if (exact-integer? field)
@@ -115,11 +122,10 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	    (clauses (cddr field)))
 	(variable-width-expression-syntaxer
 	 (car binding)
-	 (close-syntax (cadr binding) environment)
+	 (cadr binding)
 	 (map (lambda (clause)
-		`((LIST
-		   ,(integer-syntaxer (close-syntax (cadr clause) environment)
-				      'UNSIGNED 3))
+		`((,(close-syntax 'LIST environment)
+		   ,(integer-syntaxer (cadr clause) 'UNSIGNED 3))
 		  3
 		  ,@(car clause)))
 	      clauses)))))
diff --git a/v7/src/compiler/machines/i386/insmac.scm b/v7/src/compiler/machines/i386/insmac.scm
index 07ba1be92..808562682 100644
--- a/v7/src/compiler/machines/i386/insmac.scm
+++ b/v7/src/compiler/machines/i386/insmac.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: insmac.scm,v 1.15 2002/02/13 18:46:04 cph Exp $
+$Id: insmac.scm,v 1.16 2002/02/14 15:58:08 cph Exp $
 
 Copyright (c) 1992, 1999, 2001, 2002 Massachusetts Institute of Technology
 
@@ -42,27 +42,25 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
   'EA-DATABASE)
 
 (define-syntax define-ea-database
-  (sc-macro-transformer
+  (rsc-macro-transformer
    (lambda (form environment)
-     `(DEFINE ,ea-database-name
-	,(compile-database (cdr form) environment
-	   (lambda (pattern actions)
-	     (let ((keyword (car pattern))
-		   (categories (car actions))
-		   (mode (close-syntax (cadr actions) environment))
-		   (register (close-syntax (caddr actions) environment))
-		   (tail (cdddr actions)))
-	       `(MAKE-EFFECTIVE-ADDRESS
-		 ',keyword
-		 ',categories
-		 ,(integer-syntaxer mode 'UNSIGNED 2)
-		 ,(integer-syntaxer register 'UNSIGNED 3)
-		 ,(process-tail tail #f environment)))))))))
-
-(define (process-tail tail early? environment)
-  (if (null? tail)
-      `()
-      (process-fields tail early? environment)))
+     `(,(close-syntax 'DEFINE environment)
+       ,ea-database-name
+       ,(compile-database (cdr form) environment
+	  (lambda (pattern actions)
+	    (let ((keyword (car pattern))
+		  (categories (car actions))
+		  (mode (cadr actions))
+		  (register (caddr actions))
+		  (tail (cdddr actions)))
+	      `(,(close-syntax 'MAKE-EFFECTIVE-ADDRESS environment)
+		',keyword
+		',categories
+		,(integer-syntaxer mode 'UNSIGNED 2)
+		,(integer-syntaxer register 'UNSIGNED 3)
+		,(if (null? tail)
+		     `()
+		     (process-fields tail #f environment))))))))))
 
 ;; This one is necessary to distinguish between r/mW mW, etc.
 
@@ -96,16 +94,16 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
       (call-with-values (lambda () (expand-fields fields early? environment))
 	(lambda (code size)
 	  (if (not (zero? (remainder size 8)))
-	      (error "process-fields: bad syllable size" size))
+	      (error "Bad syllable size:" size))
 	  code))))
 
 (define (expand-variable-width field early? environment)
   (let ((binding (cadr field))
 	(clauses (cddr field)))
-    `(LIST
+    `(,(close-syntax 'LIST environment)
       ,(variable-width-expression-syntaxer
-	(car binding)			; name
-	(close-syntax (cadr binding) environment) ; expression
+	(car binding)
+	(cadr binding)
 	(map (lambda (clause)
 	       (call-with-values
 		   (lambda () (expand-fields (cdr clause) early? environment))
@@ -126,40 +124,40 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	    ;; (BYTE (8 #xff))
 	    ;; (BYTE (16 (+ foo #x23) SIGNED))
 	    (call-with-values
-		(lambda () (collect-byte (cdar fields) tail environment))
+		(lambda ()
+		  (collect-byte (cdar fields) tail environment))
 	      (lambda (code size)
 		(values code (+ size tail-size)))))
 	   ((ModR/M)
 	    ;; (ModR/M 2 source)	= /2 r/m(source)
 	    ;; (ModR/M r target)	= /r r/m(target)
 	    (if early?
-		(error "No early support for ModR/M -- Fix i386/insmac.scm")
-		(let ((field (car fields)))
-		  (let ((digit-or-reg (close-syntax (cadr field) environment))
-			(r/m (close-syntax (caddr field) environment)))
-		    (values
-		     `(CONS-SYNTAX
-		       (EA/REGISTER ,r/m)
-		       (CONS-SYNTAX
-			,(integer-syntaxer digit-or-reg 'UNSIGNED 3)
-			(CONS-SYNTAX
-			 (EA/MODE ,r/m)
-			 (APPEND-SYNTAX! (EA/EXTRA ,r/m)
-					 ,tail))))
-		     (+ 8 tail-size))))))
+		(error "No early support for ModR/M -- Fix i386/insmac.scm"))
+	    (let ((field (car fields)))
+	      (let ((digit-or-reg (cadr field))
+		    (r/m (caddr field)))
+		(values `(,(close-syntax 'CONS-SYNTAX environment)
+			  (,(close-syntax 'EA/REGISTER environment) ,r/m)
+			  (,(close-syntax 'CONS-SYNTAX environment)
+			   ,(integer-syntaxer digit-or-reg 'UNSIGNED 3)
+			   (,(close-syntax 'CONS-SYNTAX environment)
+			    (,(close-syntax 'EA/MODE environment) ,r/m)
+			    (,(close-syntax 'APPEND-SYNTAX! environment)
+			     (,(close-syntax 'EA/EXTRA environment) ,r/m)
+			     ,tail))))
+			(+ 8 tail-size)))))
 	   ;; For immediate operands whose size depends on the operand
 	   ;; size for the instruction (halfword vs. longword)
 	   ((IMMEDIATE)
 	    (values
 	     (let ((field (car fields)))
-	       (let ((value (close-syntax (cadr field) environment))
+	       (let ((value (cadr field))
 		     (mode (if (pair? (cddr field)) (caddr field) 'OPERAND))
 		     (domain
-		      (if (and (pair? (cddr field))
-			       (pair? (cdddr field)))
+		      (if (and (pair? (cddr field)) (pair? (cdddr field)))
 			  (cadddr field)
 			  'SIGNED)))
-		 `(CONS-SYNTAX
+		 `(,(close-syntax 'CONS-SYNTAX environment)
 		   ,(integer-syntaxer
 		     value
 		     domain
@@ -171,7 +169,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	     tail-size))
 	   (else
 	    (error "Unknown field kind:" (caar fields))))))
-      (values ''() 0)))
+      (values `'() 0)))
 
 (define (collect-byte components tail environment)
   (let loop ((components components))
@@ -179,11 +177,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	(call-with-values (lambda () (loop (cdr components)))
 	  (lambda (byte-tail byte-size)
 	    (let ((size (caar components))
-		  (expression (close-syntax (cadar components) environment))
+		  (expression (cadar components))
 		  (type (if (pair? (cddar components))
 			    (caddar components)
 			    'UNSIGNED)))
-	      (values `(CONS-SYNTAX ,(integer-syntaxer expression type size)
-				    ,byte-tail)
+	      (values `(,(close-syntax 'CONS-SYNTAX environment)
+			,(integer-syntaxer expression type size)
+			,byte-tail)
 		      (+ size byte-size)))))
 	(values tail 0))))
\ No newline at end of file