From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 14 Feb 2002 22:03:32 +0000 (+0000)
Subject: Change most instruction-set macros to use reverse syntactic closure
X-Git-Tag: 20090517-FFI~2238
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3f361264651d37ee99b4c00cbb0d03a5821cc183;p=mit-scheme.git

Change most instruction-set macros to use reverse syntactic closure
style, and propagate changes down through the maze of supporting
procedures.
---

diff --git a/v7/src/compiler/back/asmmac.scm b/v7/src/compiler/back/asmmac.scm
index 59d5e5eb3..e2096626e 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.16 2002/02/14 15:56:53 cph Exp $
+$Id: asmmac.scm,v 1.17 2002/02/14 22:03:32 cph Exp $
 
 Copyright (c) 1988, 1990, 1999, 2001, 2002 Massachusetts Institute of Technology
 
@@ -52,48 +52,47 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 					    environment)))))
 	   cases)))
 
-(define optimize-group-syntax
-  (let ()
-    (define (find-constant components)
-      (cond ((null? components)
-	     '())
-	    ((car-constant? components)
-	     (compact (car-constant-value components)
-		      (cdr components)))
-	    (else
-	     (cons (car components)
-		   (find-constant (cdr components))))))
+(define (optimize-group-syntax components early? environment)
+  (define (find-constant components)
+    (cond ((null? components)
+	   '())
+	  ((car-constant? components)
+	   (compact (car-constant-value components)
+		    (cdr components)))
+	  (else
+	   (cons (car components)
+		 (find-constant (cdr components))))))
 
-    (define (compact bit-string components)
-      (cond ((null? components)
-	     (cons (make-constant bit-string) '()))
-	    ((car-constant? components)
-	     (compact (instruction-append bit-string
-					  (car-constant-value components))
-		      (cdr components)))
-	    (else
-	     (cons (make-constant bit-string)
-		   (cons (car components)
-			 (find-constant (cdr components)))))))
+  (define (compact bit-string components)
+    (cond ((null? components)
+	   (cons (make-constant bit-string) '()))
+	  ((car-constant? components)
+	   (compact (instruction-append bit-string
+					(car-constant-value components))
+		    (cdr components)))
+	  (else
+	   (cons (make-constant bit-string)
+		 (cons (car components)
+		       (find-constant (cdr components)))))))
 
-    (define-integrable (car-constant? expression)
-      (and (eq? (caar expression) 'QUOTE)
-	   (bit-string? (cadar expression))))
+  (define (car-constant? components)
+    (and (identifier=? environment (caar components)
+		       system-global-environment 'QUOTE)
+	 (bit-string? (cadar components))))
 
-    (define-integrable (car-constant-value constant)
-      (cadar constant))
+  (define-integrable (car-constant-value constant)
+    (cadar constant))
 
-    (define-integrable (make-constant bit-string)
-      `',bit-string)
+  (define-integrable (make-constant bit-string)
+    `',bit-string)
 
-    (lambda (components early?)
-      (let ((components (find-constant components)))
-	(cond ((null? components)
-	       (error "OPTIMIZE-GROUP-SYNTAX: No components in group!"))
-	      ((null? (cdr components))
-	       (car components))
-	      (else
-	       `(,(if early?
-		      'OPTIMIZE-GROUP-EARLY
-		      'OPTIMIZE-GROUP)
-		 ,@components)))))))
\ No newline at end of file
+  (let ((components (find-constant components)))
+    (if (not (pair? components))
+	(error "No components in group!"))
+    (if (pair? (cdr components))
+	`(,(close-syntax (if early?
+			     'OPTIMIZE-GROUP-EARLY
+			     'OPTIMIZE-GROUP)
+			 environment)
+	  ,@components)
+	(car components))))
\ No newline at end of file
diff --git a/v7/src/compiler/back/syntax.scm b/v7/src/compiler/back/syntax.scm
index 0cb32c04d..9f8a73a8d 100644
--- a/v7/src/compiler/back/syntax.scm
+++ b/v7/src/compiler/back/syntax.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: syntax.scm,v 1.28 2001/12/20 18:47:01 cph Exp $
+$Id: syntax.scm,v 1.29 2002/02/14 22:03:32 cph Exp $
 
-Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1988-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
@@ -80,11 +80,11 @@ USA.
 (define instructions
   '())
 
-(define (integer-syntaxer expression coercion-type size)
+(define (integer-syntaxer expression environment coercion-type size)
   (let ((name (make-coercion-name coercion-type size)))
     (if (exact-integer? expression)
 	`',((lookup-coercion name) expression)
-	`(SYNTAX-EVALUATION ,expression ,name))))
+	`(,(close-syntax 'SYNTAX-EVALUATION environment) ,expression ,name))))
 
 (define (syntax-evaluation expression coercion)
   (if (exact-integer? expression)
@@ -132,33 +132,25 @@ USA.
 
 ;;;; Variable width expression processing
 
-(define (choose-clause value clauses)
-  (if (null? clauses)
-      (error "CHOOSE-CLAUSE: value out of range" value))
-  (if (let ((low (caddr (car clauses)))
-	    (high (cadddr (car clauses))))
-	(and (or (null? low)
-		 (<= low value))
-	     (or (null? high)
-		 (<= value high))))
-      (car clauses)
-      (choose-clause value (cdr clauses))))
-
-(define (variable-width-expression-syntaxer name expression clauses)
+(define (variable-width-expression-syntaxer name expression environment
+					    clauses)
   (if (exact-integer? expression)
       (let ((chosen (choose-clause expression clauses)))
-	`(LET ((,name ,expression))
-	   (DECLARE (INTEGRATE ,name))
-	   ,name			;ignore if not referenced
-	   (CAR ,(car chosen))))
-      `(SYNTAX-VARIABLE-WIDTH-EXPRESSION
+	`(,(close-syntax 'LET environment)
+	  ((,name ,expression))
+	  (,(close-syntax 'DECLARE environment) (INTEGRATE ,name))
+	  ,name				;ignore if not referenced
+	  (,(close-syntax 'CAR environment) ,(car chosen))))
+      `(,(close-syntax 'SYNTAX-VARIABLE-WIDTH-EXPRESSION environment)
 	,expression
-	(LIST
-	 ,@(map (LAMBDA (clause)
-		  `(CONS (LAMBDA (,name)
-			   ,name	;ignore if not referenced
-			   ,(car clause))
-			 ',(cdr clause)))
+	(,(close-syntax 'LIST environment)
+	 ,@(map (lambda (clause)
+		  `(,(close-syntax 'CONS environment)
+		    (,(close-syntax 'LAMBDA environment)
+		     (,name)
+		     ,name		;ignore if not referenced
+		     ,(car clause))
+		    ',(cdr clause)))
 		clauses)))))
 
 (define (syntax-variable-width-expression expression clauses)
@@ -168,6 +160,18 @@ USA.
       `(VARIABLE-WIDTH-EXPRESSION
 	,expression
 	,@clauses)))
+
+(define (choose-clause value clauses)
+  (if (not (pair? clauses))
+      (error "Value out of range:" value))
+  (if (let ((low (caddr (car clauses)))
+	    (high (cadddr (car clauses))))
+	(and (or (null? low)
+		 (<= low value))
+	     (or (null? high)
+		 (<= value high))))
+      (car clauses)
+      (choose-clause value (cdr clauses))))
 
 ;;;; Coercion Machinery
 
diff --git a/v7/src/compiler/machines/alpha/insmac.scm b/v7/src/compiler/machines/alpha/insmac.scm
index 0c82455e7..2664d3604 100644
--- a/v7/src/compiler/machines/alpha/insmac.scm
+++ b/v7/src/compiler/machines/alpha/insmac.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: insmac.scm,v 1.5 2002/02/13 05:56:24 cph Exp $
+$Id: insmac.scm,v 1.6 2002/02/14 22:03:32 cph Exp $
 
 Copyright (c) 1992-1999, 2001, 2002 Massachusetts Institute of Technology
 
@@ -38,99 +38,107 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	      #F))))))
 
 (define-syntax define-transformer
-  (sc-macro-transformer
+  (rsc-macro-transformer
    (lambda (form environment)
-     `(DEFINE ,(cadr form) ,(close-syntax (caddr form) environment)))))
+     `(,(close-syntax 'DEFINE environment) ,@(cdr form)))))
 
 ;;;; Fixed width instruction parsing
 
-(define (parse-instruction first-word tail early?)
+(define (parse-instruction first-word tail early? environment)
   (if (not (null? tail))
-      (error "parse-instruction: Unknown format" (cons first-word tail)))
+      (error "Unknown format:" (cons first-word tail)))
   (let loop ((first-word first-word))
     (case (car first-word)
       ((LONG)
-       (process-fields (cdr first-word) early?))
+       (process-fields (cdr first-word) early? environment))
       ((VARIABLE-WIDTH)
-       (process-variable-width first-word early?))
+       (process-variable-width first-word early? environment))
       ((IF)
-       `(IF ,(cadr first-word)
-	    ,(loop (caddr first-word))
-	    ,(loop (cadddr first-word))))
+       `(,(close-syntax 'IF environment)
+	 ,(cadr first-word)
+	 ,(loop (caddr first-word))
+	 ,(loop (cadddr first-word))))
       (else
-       (error "parse-instruction: Unknown format" first-word)))))
+       (error "Unknown format:" first-word)))))
 
-(define (process-variable-width descriptor early?)
+(define (process-variable-width descriptor early? environment)
   (let ((binding (cadr descriptor))
 	(clauses (cddr descriptor)))
-    `(LIST
+    `(,(close-syntax 'LIST environment)
       ,(variable-width-expression-syntaxer
 	(car binding)			; name
 	(cadr binding)			; expression
+	environment
 	(map (lambda (clause)
-	       (expand-fields
-		(cdadr clause)
-		early?
-		(lambda (code size)
-		  (if (not (zero? (remainder size 32)))
-		      (error "process-variable-width: bad clause size" size))
-		  `((LIST ,(optimize-group-syntax code early?))
-		    ,size
-		    ,@(car clause)))))
-	     clauses)))))
-
-(define (process-fields fields early?)
-  (expand-fields fields
-		 early?
+	       (call-with-values
+		   (lambda ()
+		     (expand-fields (cdadr clause) early? environment))
 		 (lambda (code size)
 		   (if (not (zero? (remainder size 32)))
-		       (error "process-fields: bad syllable size" size))
-		   `(LIST ,(optimize-group-syntax code early?)))))
-
-(define (expand-fields fields early? receiver)
-  (define (expand first-word word-size fields receiver)
-    (if (null? fields)
-	(receiver '() 0)
-	(expand-field
-	 (car fields) early?
-	 (lambda (car-field car-size)
-	   (if (= 32 (+ word-size car-size))
-	       (expand '() 0 (cdr fields)
-		       (lambda (tail tail-size)
-			 (receiver
-			  (append (cons car-field first-word) tail)
-			  (+ car-size tail-size))))
-	       (expand (cons car-field first-word)
-		       (+ car-size word-size)
-		       (cdr fields)
-		       (lambda (tail tail-size)
-			 (receiver
-			  (if (zero? car-size)
-			      (cons car-field tail)
-			      tail)
-			  (+ car-size tail-size)))))))))
-  (expand '() 0 fields receiver))
-
-(define (expand-field field early? receiver)
+		       (error "Bad clause size:" size))
+		   `((,(close-syntax 'LIST environment)
+		      ,(optimize-group-syntax code early? environment))
+		     ,size
+		     ,@(car clause)))))
+	     clauses)))))
+
+(define (process-fields fields early? environment)
+  (call-with-values (lambda () (expand-fields fields early? environment))
+    (lambda (code size)
+      (if (not (zero? (remainder size 32)))
+	  (error "process-fields: bad syllable size" size))
+      `(,(close-syntax 'LIST environment)
+	,(optimize-group-syntax code early? environment)))))
+
+(define (expand-fields fields early? environment)
+  (let expand ((first-word '()) (word-size 0) (fields fields))
+    (if (pair? fields)
+	(call-with-values
+	    (lambda () (expand-field (car fields) early? environment))
+	  (lambda (car-field car-size)
+	    (if (= 32 (+ word-size car-size))
+		(call-with-values (lambda () (expand '() 0 (cdr fields)))
+		  (lambda (tail tail-size)
+		    (values (append (cons car-field first-word) tail)
+			    (+ car-size tail-size))))
+		(call-with-values
+		    (lambda ()
+		      (expand (cons car-field first-word)
+			      (+ car-size word-size)
+			      (cdr fields)))
+		  (lambda (tail tail-size)
+		    (values (if (zero? car-size)
+				(cons car-field tail)
+				tail)
+			    (+ car-size tail-size)))))))
+	(values '() 0))))
+
+(define (expand-field field early? environment)
   early?				; ignored for now
   (let ((size (car field))
 	(expression (cadr field)))
 
     (define (default type)
-      (receiver (integer-syntaxer expression type size)
-		size))
+      (values (integer-syntaxer expression environment type size)
+	      size))
 
-    (if (null? (cddr field))
-	(default 'UNSIGNED)
+    (if (pair? (cddr field))
 	(case (caddr field)
 	  ((PC-REL)
-	   (receiver
-	    (integer-syntaxer ``(- ,,expression (+ *PC* 4))
-			      (cadddr field)
-			      size)
-	    size))
+	   (values (integer-syntaxer ``(,',(close-syntax '- environment)
+					,,expression
+					(,',(close-syntax '+ environment)
+					 ,',(close-syntax '*PC* environment)
+					 4))
+				     environment
+				     (cadddr field)
+				     size)
+		   size))
 	  ((BLOCK-OFFSET)
-	   (receiver (list 'list ''BLOCK-OFFSET expression)
-		     size))
+	   (values `(,(close-syntax 'LIST environment)
+		     'BLOCK-OFFSET
+		     ,expression)
+		   size))
 	  (else
-	   (default (caddr field)))))))
\ No newline at end of file
+	   (default (caddr field))))
+	(default 'UNSIGNED))))
\ No newline at end of file
diff --git a/v7/src/compiler/machines/bobcat/insmac.scm b/v7/src/compiler/machines/bobcat/insmac.scm
index 7ae872281..36722d232 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.131 2002/02/14 15:58:56 cph Exp $
+$Id: insmac.scm,v 1.132 2002/02/14 22:03:32 cph Exp $
 
 Copyright (c) 1988, 1990, 1999, 2001, 2002 Massachusetts Institute of Technology
 
@@ -41,30 +41,29 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 		(make-position-independent pattern actions environment))))))))
 
 (define-syntax extension-word
-  (sc-macro-transformer
+  (rsc-macro-transformer
    (lambda (form environment)
      environment
      (call-with-values (lambda () (expand-descriptors (cdr form) environment))
        (lambda (instruction size source destination)
 	 (if (or source destination)
-	     (error "Source or destination used" 'EXTENSION-WORD))
+	     (error "Source or destination used:" form))
 	 (if (not (zero? (remainder size 16)))
-	     (error "EXTENSION-WORD: Extensions must be 16 bit multiples"
-		    size))
-	 (optimize-group-syntax instruction #f))))))
+	     (error "Extensions must be 16 bit multiples:" size))
+	 (optimize-group-syntax instruction #f environment))))))
 
 (define-syntax variable-extension
-  (sc-macro-transformer
+  (rsc-macro-transformer
    (lambda (form environment)
      (let ((binding (cadr form))
 	   (clauses (cddr form)))
        (variable-width-expression-syntaxer
 	(car binding)
-	(close-syntax (cadr binding) environment)
+	(cadr binding)
+	environment
 	(map (lambda (clause)
-	       `((LIST ,(make-syntactic-closure environment
-			    (list (car binding))
-			  (caddr clause)))
+	       `((,(close-syntax 'LIST environment)
+		  ,(caddr clause))
 		 ,(cadr clause)
 		 ,@(car clause)))
 	     clauses))))))
@@ -77,8 +76,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	(extension (cdddr actions)))
     `(,(close-syntax 'MAKE-EFFECTIVE-ADDRESS environment)
       ',keyword
-      ,(integer-syntaxer mode 'UNSIGNED 3)
-      ,(integer-syntaxer register 'UNSIGNED 3)
+      ,(integer-syntaxer mode environment 'UNSIGNED 3)
+      ,(integer-syntaxer register environment 'UNSIGNED 3)
       (,(close-syntax 'LAMBDA environment)
        (IMMEDIATE-SIZE INSTRUCTION-TAIL)
        IMMEDIATE-SIZE			;ignore if not referenced
@@ -117,15 +116,16 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (define (process-ea-field field environment)
   (if (exact-integer? field)
-      (integer-syntaxer field 'UNSIGNED 3)
+      (integer-syntaxer field environment 'UNSIGNED 3)
       (let ((binding (cadr field))
 	    (clauses (cddr field)))
 	(variable-width-expression-syntaxer
 	 (car binding)
 	 (cadr binding)
+	 environment
 	 (map (lambda (clause)
 		`((,(close-syntax 'LIST environment)
-		   ,(integer-syntaxer (cadr clause) 'UNSIGNED 3))
+		   ,(integer-syntaxer (cadr clause) environment 'UNSIGNED 3))
 		  3
 		  ,@(car clause)))
 	      clauses)))))
@@ -225,7 +225,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
     `(LIST
       ,(variable-width-expression-syntaxer
 	(car binding)
-	(close-syntax (cadr binding) environment)
+	(cadr binding)
+	environment
 	(map (lambda (clause)
 	       (if (pair? (cddr clause))
 		   (error "Extension found in clause:" clause))
@@ -289,9 +290,11 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 		    ,code))
 		 (else
 		  (error "PARSE-WORD: multiple tail elements" tail))))))
-    (if (not (null? instruction))
+    (if (pair? instruction)
 	`(,(if (null? code) 'CONS 'CONS-SYNTAX)
-	  ,(optimize-group-syntax instruction early-instruction-parsing?)
+	  ,(optimize-group-syntax instruction
+				  early-instruction-parsing?
+				  environment)
 	  ,code)
 	code)))
 
@@ -314,7 +317,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
     (handle)))
 
 (define (with-early-selectors handle)
-  (fluid-let ((early-instruction-parsing? true)
+  (fluid-let ((early-instruction-parsing? #t)
 	      (ea-keyword-selector 'EA-KEYWORD-EARLY)
 	      (ea-categories-selector 'EA-CATEGORIES-EARLY)
 	      (ea-mode-selector 'EA-MODE-EARLY)
@@ -329,30 +332,43 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	 (if (pair? (cddr descriptor)) (caddr descriptor) 'UNSIGNED)))
     (case coercion-type
       ((UNSIGNED SIGNED SHIFT-NUMBER QUICK BFWIDTH SCALE-FACTOR)
-       (values `(,(integer-syntaxer expression coercion-type size))
+       (values `(,(integer-syntaxer expression environment coercion-type size))
 	       size #f #f))
       ((SHORT-LABEL)
-       (values `(,(integer-syntaxer ``(- ,,expression (+ *PC* 2))
+       (values `(,(integer-syntaxer ``(,',(close-syntax '- environment)
+					,,expression
+					(,',(close-syntax '+ environment)
+					 ,',(close-syntax '*PC* environment)
+					 2))
+				    environment
 				    'SHORT-LABEL
 				    size))
 	       size #f #f))
       ((SOURCE-EA)
-       (values `((,ea-mode-selector ,expression)
-		 (,ea-register-selector ,expression))
+       (values `((,(close-syntax ea-mode-selector environment) ,expression)
+		 (,(close-syntax ea-register-selector environment)
+		  ,expression))
 	       size
-	       `((,ea-extension-selector ,expression) ,(cadddr descriptor))
+	       `((,(close-syntax ea-extension-selector environment)
+		  ,expression)
+		 ,(cadddr descriptor))
 	       #f))
       ((DESTINATION-EA)
-       (values `((,ea-mode-selector ,expression)
-		 (,ea-register-selector ,expression))
+       (values `((,(close-syntax ea-mode-selector environment) ,expression)
+		 (,(close-syntax ea-register-selector environment)
+		  ,expression))
 	       size
 	       #f
-	       `((,ea-extension-selector ,expression) '())))
+	       `((,(close-syntax ea-extension-selector environment)
+		  ,expression)
+		 '())))
       ((DESTINATION-EA-REVERSED)
-       (values `((,ea-register-selector ,expression)
-		 (,ea-mode-selector ,expression))
+       (values `((,(close-syntax ea-register-selector environment) ,expression)
+		 (,(close-syntax ea-mode-selector environment) ,expression))
 	       size
 	       #f
-	       `((,ea-extension-selector ,expression) '())))
+	       `((,(close-syntax ea-extension-selector environment)
+		  ,expression)
+		 '())))
       (else
        (error "Badly-formed descriptor:" descriptor)))))
\ No newline at end of file
diff --git a/v7/src/compiler/machines/i386/insmac.scm b/v7/src/compiler/machines/i386/insmac.scm
index 808562682..8b598954c 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.16 2002/02/14 15:58:08 cph Exp $
+$Id: insmac.scm,v 1.17 2002/02/14 22:03:32 cph Exp $
 
 Copyright (c) 1992, 1999, 2001, 2002 Massachusetts Institute of Technology
 
@@ -56,8 +56,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	      `(,(close-syntax 'MAKE-EFFECTIVE-ADDRESS environment)
 		',keyword
 		',categories
-		,(integer-syntaxer mode 'UNSIGNED 2)
-		,(integer-syntaxer register 'UNSIGNED 3)
+		,(integer-syntaxer mode environment 'UNSIGNED 2)
+		,(integer-syntaxer register environment 'UNSIGNED 3)
 		,(if (null? tail)
 		     `()
 		     (process-fields tail #f environment))))))))))
@@ -104,6 +104,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
       ,(variable-width-expression-syntaxer
 	(car binding)
 	(cadr binding)
+	environment
 	(map (lambda (clause)
 	       (call-with-values
 		   (lambda () (expand-fields (cdr clause) early? environment))
@@ -139,7 +140,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 		(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)
+			   ,(integer-syntaxer digit-or-reg environment
+					      'UNSIGNED 3)
 			   (,(close-syntax 'CONS-SYNTAX environment)
 			    (,(close-syntax 'EA/MODE environment) ,r/m)
 			    (,(close-syntax 'APPEND-SYNTAX! environment)
@@ -160,6 +162,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 		 `(,(close-syntax 'CONS-SYNTAX environment)
 		   ,(integer-syntaxer
 		     value
+		     environment
 		     domain
 		     (case mode
 		       ((OPERAND) *operand-size*)
@@ -182,7 +185,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 			    (caddar components)
 			    'UNSIGNED)))
 	      (values `(,(close-syntax 'CONS-SYNTAX environment)
-			,(integer-syntaxer expression type size)
+			,(integer-syntaxer expression environment type size)
 			,byte-tail)
 		      (+ size byte-size)))))
 	(values tail 0))))
\ No newline at end of file
diff --git a/v7/src/compiler/machines/mips/insmac.scm b/v7/src/compiler/machines/mips/insmac.scm
index fae2d92cb..4fd30dc3c 100644
--- a/v7/src/compiler/machines/mips/insmac.scm
+++ b/v7/src/compiler/machines/mips/insmac.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: insmac.scm,v 1.5 2001/12/23 17:20:58 cph Exp $
+$Id: insmac.scm,v 1.6 2002/02/14 22:03:32 cph Exp $
 
-Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1988-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
@@ -27,110 +27,121 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 ;;;; Definition macros
 
 (define-syntax define-symbol-transformer
-  (non-hygienic-macro-transformer
-   (lambda (name . alist)
-     `(DEFINE-INTEGRABLE (,name SYMBOL)
-	(LET ((PLACE (ASSQ SYMBOL ',alist)))
-	  (IF (PAIR? PLACE)
-	      (CDR PLACE)
-	      #F))))))
+  (sc-macro-transformer
+   (lambda (form environment)
+     environment
+     (if (syntax-match? '(IDENTIFIER * SYMBOL) (cdr form))
+	 `(DEFINE-INTEGRABLE (,(cadr form) SYMBOL)
+	    (LET ((PLACE (ASSQ SYMBOL ',(cddr form))))
+	      (IF (PAIR? PLACE)
+		  (CDR PLACE)
+		  #F)))
+	 (ill-formed-syntax form)))))
 
 (define-syntax define-transformer
-  (non-hygienic-macro-transformer
-   (lambda (name value)
-     `(DEFINE ,name ,value))))
+  (rsc-macro-transformer
+   (lambda (form environment)
+     `(,(close-syntax 'DEFINE environment) ,@(cdr form)))))
 
 ;;;; Fixed width instruction parsing
 
-(define (parse-instruction first-word tail early?)
+(define (parse-instruction first-word tail early? environment)
   (if (not (null? tail))
-      (error "parse-instruction: Unknown format" (cons first-word tail)))
+      (error "Unknown format:" (cons first-word tail)))
   (let loop ((first-word first-word))
     (case (car first-word)
       ((LONG)
-       (process-fields (cdr first-word) early?))
+       (process-fields (cdr first-word) early? environment))
       ((VARIABLE-WIDTH)
-       (process-variable-width first-word early?))
+       (process-variable-width first-word early? environment))
       ((IF)
-       `(IF ,(cadr first-word)
-	    ,(loop (caddr first-word))
-	    ,(loop (cadddr first-word))))
+       `(,(close-syntax 'IF environment)
+	 ,(cadr first-word)
+	 ,(loop (caddr first-word))
+	 ,(loop (cadddr first-word))))
       (else
-       (error "parse-instruction: Unknown format" first-word)))))
+       (error "Unknown format:" first-word)))))
 
-(define (process-variable-width descriptor early?)
+(define (process-variable-width descriptor early? environment)
   (let ((binding (cadr descriptor))
 	(clauses (cddr descriptor)))
-    `(LIST
+    `(,(close-syntax 'LIST environment)
       ,(variable-width-expression-syntaxer
 	(car binding)			; name
 	(cadr binding)			; expression
+	environment
 	(map (lambda (clause)
-	       (expand-fields
-		(cdadr clause)
-		early?
-		(lambda (code size)
-		  (if (not (zero? (remainder size 32)))
-		      (error "process-variable-width: bad clause size" size))
-		  `((LIST ,(optimize-group-syntax code early?))
-		    ,size
-		    ,@(car clause)))))
-	     clauses)))))
-
-(define (process-fields fields early?)
-  (expand-fields fields
-		 early?
+	       (call-with-values
+		   (lambda ()
+		     (expand-fields (cdadr clause) early? environment))
 		 (lambda (code size)
 		   (if (not (zero? (remainder size 32)))
-		       (error "process-fields: bad syllable size" size))
-		   `(LIST ,(optimize-group-syntax code early?)))))
-
-(define (expand-fields fields early? receiver)
-  (define (expand first-word word-size fields receiver)
-    (if (null? fields)
-	(receiver '() 0)
-	(expand-field
-	 (car fields) early?
-	 (lambda (car-field car-size)
-	   (if (and (eq? endianness 'LITTLE)
-		    (= 32 (+ word-size car-size)))
-	       (expand '() 0 (cdr fields)
-		       (lambda (tail tail-size)
-			 (receiver
-			  (append (cons car-field first-word) tail)
-			  (+ car-size tail-size))))
-	       (expand (cons car-field first-word)
-		       (+ car-size word-size)
-		       (cdr fields)
-		       (lambda (tail tail-size)
-			 (receiver
-			  (if (or (zero? car-size)
-				  (not (eq? endianness 'LITTLE)))
-			      (cons car-field tail)
-			      tail)
-			  (+ car-size tail-size)))))))))
-  (expand '() 0 fields receiver))
-
-(define (expand-field field early? receiver)
+		       (error "Bad clause size:" size))
+		   `((,(close-syntax 'LIST environment)
+		      ,(optimize-group-syntax code early? environment))
+		     ,size
+		     ,@(car clause)))))
+	     clauses)))))
+
+(define (process-fields fields early? environment)
+  (call-with-values (lambda () (expand-fields fields early? environment))
+    (lambda (code size)
+      (if (not (zero? (remainder size 32)))
+	  (error "Bad syllable size:" size))
+      `(,(close-syntax 'LIST environment)
+	,(optimize-group-syntax code early? environment)))))
+
+(define (expand-fields fields early? environment)
+  (let expand ((first-word '()) (word-size 0) (fields fields))
+    (if (pair? fields)
+	(call-with-values
+	    (lambda () (expand-field (car fields) early? environment))
+	  (lambda (car-field car-size)
+	    (if (and (eq? endianness 'LITTLE)
+		     (= 32 (+ word-size car-size)))
+		(call-with-values (lambda () (expand '() 0 (cdr fields)))
+		  (lambda (tail tail-size)
+		    (values (append (cons car-field first-word) tail)
+			    (+ car-size tail-size))))
+		(call-with-values
+		    (lambda ()
+		      (expand (cons car-field first-word)
+			      (+ car-size word-size)
+			      (cdr fields)))
+		  (lambda (tail tail-size)
+		    (values (if (or (zero? car-size)
+				    (not (eq? endianness 'LITTLE)))
+				(cons car-field tail)
+				tail)
+			    (+ car-size tail-size)))))))
+	(values '() 0))))
+
+(define (expand-field field early? environment)
   early?				; ignored for now
   (let ((size (car field))
 	(expression (cadr field)))
 
     (define (default type)
-      (receiver (integer-syntaxer expression type size)
-		size))
+      (values (integer-syntaxer expression environment type size)
+	      size))
 
-    (if (null? (cddr field))
-	(default 'UNSIGNED)
+    (if (pair? (cddr field))
 	(case (caddr field)
 	  ((PC-REL)
-	   (receiver
-	    (integer-syntaxer ``(- ,,expression (+ *PC* 4))
-			      (cadddr field)
-			      size)
-	    size))
+	   (values (integer-syntaxer ``(,',(close-syntax '- environment)
+					,,expression
+					(,',(close-syntax '+ environment)
+					 ,',(close-syntax '*PC* environment)
+					 4))
+				     environment
+				     (cadddr field)
+				     size)
+		   size))
 	  ((BLOCK-OFFSET)
-	   (receiver (list 'list ''BLOCK-OFFSET expression)
-		     size))
+	   (values `(,(close-syntax 'LIST environment)
+		     'BLOCK-OFFSET
+		     ,expression)
+		   size))
 	  (else
-	   (default (caddr field)))))))
\ No newline at end of file
+	   (default (caddr field))))
+	(default 'UNSIGNED))))
\ No newline at end of file
diff --git a/v7/src/compiler/machines/sparc/insmac.scm b/v7/src/compiler/machines/sparc/insmac.scm
index e17576830..25abb0b9d 100644
--- a/v7/src/compiler/machines/sparc/insmac.scm
+++ b/v7/src/compiler/machines/sparc/insmac.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: insmac.scm,v 1.4 2001/12/23 17:20:58 cph Exp $
+$Id: insmac.scm,v 1.5 2002/02/14 22:03:32 cph Exp $
 
-Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1988-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
@@ -27,110 +27,121 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 ;;;; Definition macros
 
 (define-syntax define-symbol-transformer
-  (non-hygienic-macro-transformer
-   (lambda (name . alist)
-     `(DEFINE-INTEGRABLE (,name SYMBOL)
-	(LET ((PLACE (ASSQ SYMBOL ',alist)))
-	  (IF (PAIR? PLACE)
-	      (CDR PLACE)
-	      #F))))))
+  (sc-macro-transformer
+   (lambda (form environment)
+     environment
+     (if (syntax-match? '(IDENTIFIER * SYMBOL) (cdr form))
+	 `(DEFINE-INTEGRABLE (,(cadr form) SYMBOL)
+	    (LET ((PLACE (ASSQ SYMBOL ',(cddr form))))
+	      (IF (PAIR? PLACE)
+		  (CDR PLACE)
+		  #F)))
+	 (ill-formed-syntax form)))))
 
 (define-syntax define-transformer
-  (non-hygienic-macro-transformer
-   (lambda (name value)
-     `(DEFINE ,name ,value))))
+  (rsc-macro-transformer
+   (lambda (form environment)
+     `(,(close-syntax 'DEFINE environment) ,@(cdr form)))))
 
 ;;;; Fixed width instruction parsing
 
-(define (parse-instruction first-word tail early?)
+(define (parse-instruction first-word tail early? environment)
   (if (not (null? tail))
-      (error "parse-instruction: Unknown format" (cons first-word tail)))
+      (error "Unknown format:" (cons first-word tail)))
   (let loop ((first-word first-word))
     (case (car first-word)
       ((LONG)
-       (process-fields (cdr first-word) early?))
+       (process-fields (cdr first-word) early? environment))
       ((VARIABLE-WIDTH)
-       (process-variable-width first-word early?))
+       (process-variable-width first-word early? environment))
       ((IF)
-       `(IF ,(cadr first-word)
-	    ,(loop (caddr first-word))
-	    ,(loop (cadddr first-word))))
+       `(,(close-syntax 'IF environment)
+	 ,(cadr first-word)
+	 ,(loop (caddr first-word))
+	 ,(loop (cadddr first-word))))
       (else
-       (error "parse-instruction: Unknown format" first-word)))))
+       (error "Unknown format:" first-word)))))
 
-(define (process-variable-width descriptor early?)
+(define (process-variable-width descriptor early? environment)
   (let ((binding (cadr descriptor))
 	(clauses (cddr descriptor)))
-    `(LIST
+    `(,(close-syntax 'LIST environment)
       ,(variable-width-expression-syntaxer
 	(car binding)			; name
 	(cadr binding)			; expression
+	environment
 	(map (lambda (clause)
-	       (expand-fields
-		(cdadr clause)
-		early?
-		(lambda (code size)
-		  (if (not (zero? (remainder size 32)))
-		      (error "process-variable-width: bad clause size" size))
-		  `((LIST ,(optimize-group-syntax code early?))
-		    ,size
-		    ,@(car clause)))))
-	     clauses)))))
-
-(define (process-fields fields early?)
-  (expand-fields fields
-		 early?
+	       (call-with-values
+		   (lambda ()
+		     (expand-fields (cdadr clause) early? environment))
 		 (lambda (code size)
 		   (if (not (zero? (remainder size 32)))
-		       (error "process-fields: bad syllable size" size))
-		   `(LIST ,(optimize-group-syntax code early?)))))
-
-(define (expand-fields fields early? receiver)
-  (define (expand first-word word-size fields receiver)
-    (if (null? fields)
-	(receiver '() 0)
-	(expand-field
-	 (car fields) early?
-	 (lambda (car-field car-size)
-	   (if (and (eq? endianness 'LITTLE)
-		    (= 32 (+ word-size car-size)))
-	       (expand '() 0 (cdr fields)
-		       (lambda (tail tail-size)
-			 (receiver
-			  (append (cons car-field first-word) tail)
-			  (+ car-size tail-size))))
-	       (expand (cons car-field first-word)
-		       (+ car-size word-size)
-		       (cdr fields)
-		       (lambda (tail tail-size)
-			 (receiver
-			  (if (or (zero? car-size)
-				  (not (eq? endianness 'LITTLE)))
-			      (cons car-field tail)
-			      tail)
-			  (+ car-size tail-size)))))))))
-  (expand '() 0 fields receiver))
-
-(define (expand-field field early? receiver)
+		       (error "Bad clause size:" size))
+		   `((,(close-syntax 'LIST environment)
+		      ,(optimize-group-syntax code early? environment))
+		     ,size
+		     ,@(car clause)))))
+	     clauses)))))
+
+(define (process-fields fields early? environment)
+  (call-with-values (lambda () (expand-fields fields early? environment))
+    (lambda (code size)
+      (if (not (zero? (remainder size 32)))
+	  (error "Bad syllable size:" size))
+      `(,(close-syntax 'LIST environment)
+	,(optimize-group-syntax code early? environment)))))
+
+(define (expand-fields fields early? environment)
+  (let expand ((first-word '()) (word-size 0) (fields fields))
+    (if (pair? fields)
+	(call-with-values
+	    (lambda () (expand-field (car fields) early? environment))
+	  (lambda (car-field car-size)
+	    (if (and (eq? endianness 'LITTLE)
+		     (= 32 (+ word-size car-size)))
+		(call-with-values (lambda () (expand '() 0 (cdr fields)))
+		  (lambda (tail tail-size)
+		    (values (append (cons car-field first-word) tail)
+			    (+ car-size tail-size))))
+		(call-with-values
+		    (lambda ()
+		      (expand (cons car-field first-word)
+			      (+ car-size word-size)
+			      (cdr fields)))
+		  (lambda (tail tail-size)
+		    (values (if (or (zero? car-size)
+				    (not (eq? endianness 'LITTLE)))
+				(cons car-field tail)
+				tail)
+			    (+ car-size tail-size)))))))
+	(values '() 0))))
+
+(define (expand-field field early? environment)
   early?				; ignored for now
   (let ((size (car field))
 	(expression (cadr field)))
 
     (define (default type)
-      (receiver (integer-syntaxer expression type size)
-		size))
+      (values (integer-syntaxer expression environment type size)
+	      size))
 
-    (if (null? (cddr field))
-	(default 'UNSIGNED)
+    (if (pair? (cddr field))
 	(case (caddr field)
 	  ((PC-REL)
-	   (receiver
-	    (integer-syntaxer ``(- ,,expression (+ *PC* 4))
-			      (cadddr field)
-			      size)
-	    size))
+	   (values (integer-syntaxer ``(,',(close-syntax '- environment)
+					,,expression
+					(,',(close-syntax '+ environment)
+					 ,',(close-syntax '*PC* environment)
+					 4))
+				     environment
+				     (cadddr field)
+				     size)
+		   size))
 	  ((BLOCK-OFFSET)
-	   (receiver (list 'list ''BLOCK-OFFSET expression)
-		     size))
+	   (values `(,(close-syntax 'LIST environment)
+		     'BLOCK-OFFSET
+		     ,expression)
+		   size))
 	  (else
-	   (default (caddr field)))))))
\ No newline at end of file
+	   (default (caddr field))))
+	(default 'UNSIGNED))))
\ No newline at end of file
diff --git a/v7/src/compiler/machines/spectrum/insmac.scm b/v7/src/compiler/machines/spectrum/insmac.scm
index f86f829cf..49cfe2eb5 100644
--- a/v7/src/compiler/machines/spectrum/insmac.scm
+++ b/v7/src/compiler/machines/spectrum/insmac.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: insmac.scm,v 1.5 2001/12/23 17:20:58 cph Exp $
+$Id: insmac.scm,v 1.6 2002/02/14 22:03:32 cph Exp $
 
-Copyright (c) 1988, 1989, 1990, 1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1988-1990, 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
@@ -27,104 +27,112 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 ;;;; Definition macros
 
 (define-syntax define-symbol-transformer
-  (non-hygienic-macro-transformer
-   (lambda (name . alist)
-     `(DEFINE-INTEGRABLE (,name SYMBOL)
-	(LET ((PLACE (ASSQ SYMBOL ',alist)))
-	  (IF (PAIR? PLACE)
-	      (CDR PLACE)
-	      #F))))))
+  (sc-macro-transformer
+   (lambda (form environment)
+     environment
+     (if (syntax-match? '(IDENTIFIER * SYMBOL) (cdr form))
+	 `(DEFINE-INTEGRABLE (,(cadr form) SYMBOL)
+	    (LET ((PLACE (ASSQ SYMBOL ',(cddr form))))
+	      (IF (PAIR? PLACE)
+		  (CDR PLACE)
+		  #F)))
+	 (ill-formed-syntax form)))))
 
 (define-syntax define-transformer
-  (non-hygienic-macro-transformer
-   (lambda (name value)
-     `(DEFINE ,name ,value))))
+  (rsc-macro-transformer
+   (lambda (form environment)
+     `(,(close-syntax 'DEFINE environment) ,@(cdr form)))))
 
 ;;;; Fixed width instruction parsing
 
-(define (parse-instruction first-word tail early?)
-  (cond ((not (null? tail))
-	 (error "parse-instruction: Unknown format" (cons first-word tail)))
-	((eq? (car first-word) 'LONG)
-	 (process-fields (cdr first-word) early?))
-	((eq? (car first-word) 'VARIABLE-WIDTH)
-	 (process-variable-width first-word early?))
-	(else
-	 (error "parse-instruction: Unknown format" first-word))))
-
-(define (process-variable-width descriptor early?)
+(define (parse-instruction first-word tail early? environment)
+  (if (not (null? tail))
+      (error "Unknown format:" (cons first-word tail)))
+  (case (car first-word)
+    ((LONG) (process-fields (cdr first-word) early? environment))
+    ((VARIABLE-WIDTH) (process-variable-width first-word early? environment))
+    (else (error "Unknown format:" first-word))))
+
+(define (process-variable-width descriptor early? environment)
   (let ((binding (cadr descriptor))
 	(clauses (cddr descriptor)))
-    `(LIST
+    `(,(close-syntax 'LIST environment)
       ,(variable-width-expression-syntaxer
 	(car binding)			; name
 	(cadr binding)			; expression
+	environment
 	(map (lambda (clause)
-	       (expand-fields
-		(cdadr clause)
-		early?
-		(lambda (code size)
-		  (if (not (zero? (remainder size 32)))
-		      (error "process-variable-width: bad clause size" size))
-		  `((LIST ,(optimize-group-syntax code early?))
-		    ,size
-		    ,@(car clause)))))
-	     clauses)))))
-
-(define (process-fields fields early?)
-  (expand-fields fields
-		 early?
+	       (call-with-values
+		   (lambda ()
+		     (expand-fields (cdadr clause) early? environment))
 		 (lambda (code size)
 		   (if (not (zero? (remainder size 32)))
-		       (error "process-fields: bad syllable size" size))
-		   `(LIST ,(optimize-group-syntax code early?)))))
-
-(define (expand-fields fields early? receiver)
-  (define (expand first-word word-size fields receiver)
-    (if (null? fields)
-	(receiver '() 0)
-	(expand-field
-	 (car fields) early?
-	 (lambda (car-field car-size)
-	   (if (and (eq? endianness 'LITTLE)
-		    (= 32 (+ word-size car-size)))
-	       (expand '() 0 (cdr fields)
-		       (lambda (tail tail-size)
-			 (receiver
-			  (append (cons car-field first-word) tail)
-			  (+ car-size tail-size))))
-	       (expand (cons car-field first-word)
-		       (+ car-size word-size)
-		       (cdr fields)
-		       (lambda (tail tail-size)
-			 (receiver
-			  (if (or (zero? car-size)
-				  (not (eq? endianness 'LITTLE)))
-			      (cons car-field tail)
-			      tail)
-			  (+ car-size tail-size)))))))))
-  (expand '() 0 fields receiver))
-
-(define (expand-field field early? receiver)
+		       (error "Bad clause size:" size))
+		   `((,(close-syntax 'LIST environment)
+		      ,(optimize-group-syntax code early? environment))
+		     ,size
+		     ,@(car clause)))))
+	     clauses)))))
+
+(define (process-fields fields early? environment)
+  (call-with-values (lambda () (expand-fields fields early? environment))
+    (lambda (code size)
+      (if (not (zero? (remainder size 32)))
+	  (error "Bad syllable size:" size))
+      `(,(close-syntax 'LIST environment)
+	,(optimize-group-syntax code early? environment)))))
+
+(define (expand-fields fields early? environment)
+  (let expand ((first-word '()) (word-size 0) (fields fields))
+    (if (pair? fields)
+	(call-with-values
+	    (lambda () (expand-field (car fields) early? environment))
+	  (lambda (car-field car-size)
+	    (if (and (eq? endianness 'LITTLE)
+		     (= 32 (+ word-size car-size)))
+		(call-with-values (lambda () (expand '() 0 (cdr fields)))
+		  (lambda (tail tail-size)
+		    (values (append (cons car-field first-word) tail)
+			    (+ car-size tail-size))))
+		(call-with-values
+		    (lambda ()
+		      (expand (cons car-field first-word)
+			      (+ car-size word-size)
+			      (cdr fields)))
+		  (lambda (tail tail-size)
+		    (values (if (or (zero? car-size)
+				    (not (eq? endianness 'LITTLE)))
+				(cons car-field tail)
+				tail)
+			    (+ car-size tail-size)))))))
+	(values '() 0))))
+
+(define (expand-field field early? environment)
   early?				; ignored for now
   (let ((size (car field))
 	(expression (cadr field)))
 
     (define (default type)
-      (receiver (integer-syntaxer expression type size)
-		size))
+      (values (integer-syntaxer expression environment type size)
+	      size))
 
-    (if (null? (cddr field))
-	(default 'UNSIGNED)
+    (if (pair? (cddr field))
 	(case (caddr field)
 	  ((PC-REL)
-	   (receiver
-	    (integer-syntaxer ``(- ,,expression (+ *PC* 8))
-			      (cadddr field)
-			      size)
-	    size))
+	   (values (integer-syntaxer ``(,',(close-syntax '- environment)
+					,,expression
+					(,',(close-syntax '+ environment)
+					 ,',(close-syntax '*PC* environment)
+					 8))
+				     environment
+				     (cadddr field)
+				     size)
+		   size))
 	  ((BLOCK-OFFSET)
-	   (receiver (list 'list ''BLOCK-OFFSET expression)
-		     size))
+	   (values `(,(close-syntax 'LIST environment)
+		     'BLOCK-OFFSET
+		     ,expression)
+		   size))
 	  (else
-	   (default (caddr field)))))))
\ No newline at end of file
+	   (default (caddr field))))
+	(default 'UNSIGNED))))
\ No newline at end of file
diff --git a/v7/src/compiler/machines/vax/insmac.scm b/v7/src/compiler/machines/vax/insmac.scm
index 0fa772135..930cc7fa6 100644
--- a/v7/src/compiler/machines/vax/insmac.scm
+++ b/v7/src/compiler/machines/vax/insmac.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: insmac.scm,v 1.15 2001/12/23 17:20:58 cph Exp $
+$Id: insmac.scm,v 1.16 2002/02/14 22:03:32 cph Exp $
 
-Copyright (c) 1987, 1989, 1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1987, 1989, 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
@@ -30,132 +30,138 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
   'EA-DATABASE)
 
 (define-syntax define-ea-database
-  (non-hygienic-macro-transformer
-   (lambda rules
-     `(DEFINE ,ea-database-name
-	,(compile-database rules
+  (rsc-macro-transformer
+   (lambda (form environment)
+     `(,(close-syntax 'DEFINE environment)
+       ,ea-database-name
+       ,(compile-database (cdr form) environment
 	  (lambda (pattern actions)
 	    (let ((keyword (car pattern))
 		  (categories (car actions))
 		  (value (cdr actions)))
-	      (declare (integrate keyword categories value))
-	      `(MAKE-EFFECTIVE-ADDRESS
+	      `(,(close-syntax 'MAKE-EFFECTIVE-ADDRESS environment)
 		',keyword
 		',categories
-		,(process-fields value false)))))))))
+		,(process-fields value #f environment)))))))))
 
 (define-syntax define-ea-transformer
-  (non-hygienic-macro-transformer
-   (lambda (name category type)
-     `(DEFINE (,name EXPRESSION)
-	(LET ((EA (PROCESS-EA EXPRESSION ',type)))
-	  (AND EA
-	       (MEMQ ',category (EA-CATEGORIES EA))
-	       EA))))))
+  (sc-macro-transformer
+   (lambda (form environment)
+     environment
+     (if (syntax-match? '(IDENTIFIER DATUM DATUM) (cdr form))
+	 `(DEFINE (,(cadr form) EXPRESSION)
+	    (LET ((EA (PROCESS-EA EXPRESSION ',(cadddr form))))
+	      (AND EA
+		   (MEMQ ',(caddr form) (EA-CATEGORIES EA))
+		   EA)))
+	 (ill-formed-syntax form)))))
 
 (define-syntax define-symbol-transformer
-  (non-hygienic-macro-transformer
-   (lambda (name . alist)
-     `(DEFINE-INTEGRABLE (,name SYMBOL)
-	(LET ((PLACE (ASSQ SYMBOL ',alist)))
-	  (IF (PAIR? PLACE)
-	      (CDR PLACE)
-	      #F))))))
+  (sc-macro-transformer
+   (lambda (form environment)
+     environment
+     (if (syntax-match? '(IDENTIFIER * SYMBOL) (cdr form))
+	 `(DEFINE-INTEGRABLE (,(cadr form) SYMBOL)
+	    (LET ((PLACE (ASSQ SYMBOL ',(cddr form))))
+	      (IF (PAIR? PLACE)
+		  (CDR PLACE)
+		  #F)))
+	 (ill-formed-syntax form)))))
 
 (define-syntax define-transformer
-  (non-hygienic-macro-transformer
-   (lambda (name value)
-     `(DEFINE ,name ,value))))
+  (rsc-macro-transformer
+   (lambda (form environment)
+     `(,(close-syntax 'DEFINE environment) ,@(cdr form)))))
 
-(define (parse-instruction opcode tail early?)
-  (process-fields (cons opcode tail) early?))
+(define (parse-instruction opcode tail early? environment)
+  (process-fields (cons opcode tail) early? environment))
 
-(define (process-fields fields early?)
+(define (process-fields fields early? environment)
   (if (and (null? (cdr fields))
 	   (eq? (caar fields) 'VARIABLE-WIDTH))
-      (expand-variable-width (car fields) early?)
-      (expand-fields fields
-		     early?
-		     (lambda (code size)
-		       (if (not (zero? (remainder size 8)))
-			   (error "process-fields: bad syllable size" size))
-		       code))))
+      (expand-variable-width (car fields) early? environment)
+      (call-with-values (lambda () (expand-fields fields early? environment))
+	(lambda (code size)
+	  (if (not (zero? (remainder size 8)))
+	      (error "Bad syllable size:" size))
+	  code))))
 
-(define (expand-variable-width field early?)
+(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
 	(cadr binding)			; expression
+	environment
 	(map (lambda (clause)
-	       (expand-fields
-		(cdr clause)
-		early?
-		(lambda (code size)
-		  (if (not (zero? (remainder size 8)))
-		      (error "expand-variable-width: bad clause size" size))
-		  `(,code ,size ,@(car clause)))))
+	       (call-with-values
+		   (lambda () (expand-fields (cdr clause) early? environment))
+		 (lambda (code size)
+		   (if (not (zero? (remainder size 8)))
+		       (error "Bad clause size:" size))
+		   `(,code ,size ,@(car clause)))))
 	     clauses)))))
 
-(define (expand-fields fields early? receiver)
-  (if (null? fields)
-      (receiver ''() 0)
-      (expand-fields (cdr fields) early?
-       (lambda (tail tail-size)
-	 (case (caar fields)
-	   ((BYTE)
-	    (collect-byte (cdar fields)
-			  tail
-			  (lambda (code size)
-			    (receiver code (+ size tail-size)))))
-	   ((OPERAND)
-	    (receiver
-	     `(APPEND-SYNTAX!
-	       ,(if early?
-		    `(EA-VALUE-EARLY ',(cadar fields) ,(caddar fields))
-		    `(EA-VALUE ,(caddar fields)))
-	       ,tail)
-	     tail-size))
-	   ;; Displacements are like signed bytes.  They are a different
-	   ;; keyword to allow the disassembler to do its thing correctly.
-	   ((DISPLACEMENT)
-	    (let* ((desc (cadar fields))
-		   (size (car desc)))
-	      (receiver
-	       `(CONS-SYNTAX ,(integer-syntaxer (cadr desc) 'SIGNED size)
-			     ,tail)
-	       (+ size tail-size))))
-	   ((IMMEDIATE)
-	    (receiver
-	     `(CONS-SYNTAX
-	       (COERCE-TO-TYPE ,(cadar fields)
-			       *IMMEDIATE-TYPE*
-			       ,(and (cddar fields)
-				     (eq? (caddar fields)
-					 'UNSIGNED)))
-	       ,tail)
-	     tail-size))
-	   (else
-	    (error "expand-fields: Unknown field kind" (caar fields))))))))
-
-(define (collect-byte components tail receiver)
-  (define (inner components receiver)
-    (if (null? components)
-	(receiver tail 0)
-	(inner (cdr components)
-	       (lambda (byte-tail byte-size)
-		 (let ((size (caar components))
-		       (expression (cadar components))
-		       (type (if (null? (cddar components))
-				 'UNSIGNED
-				 (caddar components))))
-		   (receiver
-		    `(CONS-SYNTAX
-		      ,(integer-syntaxer expression type size)
-		      ,byte-tail)
-		    (+ size byte-size)))))))
-  (inner components receiver))
-		 
-     
+(define (expand-fields fields early? environment)
+  (if (pair? fields)
+      (call-with-values
+	  (lambda () (expand-fields (cdr fields) early? environment))
+	(lambda (tail tail-size)
+	  (case (caar fields)
+	    ((BYTE)
+	     (call-with-values
+		 (lambda () (collect-byte (cdar fields) tail environment))
+	       (lambda (code size)
+		 (values code (+ size tail-size)))))
+	    ((OPERAND)
+	     (values `(,(close-syntax 'APPEND-SYNTAX! environment)
+		       ,(if early?
+			    `(,(close-syntax 'EA-VALUE-EARLY environment)
+			      ',(cadar fields)
+			      ,(caddar fields))
+			    `(,(close-syntax 'EA-VALUE environment)
+			      ,(caddar fields)))
+		       ,tail)
+		     tail-size))
+	    ;; Displacements are like signed bytes.  They are a
+	    ;; different keyword to allow the disassembler to do its
+	    ;; thing correctly.
+	    ((DISPLACEMENT)
+	     (let* ((desc (cadar fields))
+		    (size (car desc)))
+	       (values `(,(close-syntax 'CONS-SYNTAX environment)
+			 ,(integer-syntaxer (cadr desc)
+					    environment
+					    'SIGNED
+					    size)
+			 ,tail)
+		       (+ size tail-size))))
+	    ((IMMEDIATE)
+	     (values `(,(close-syntax 'CONS-SYNTAX environment)
+		       (,(close-syntax 'COERCE-TO-TYPE environment)
+			,(cadar fields)
+			,(close-syntax '*IMMEDIATE-TYPE* environment)
+			,(and (cddar fields)
+			      (eq? (caddar fields) 'UNSIGNED)))
+		       ,tail)
+		     tail-size))
+	    (else
+	     (error "Unknown field kind:" (caar fields))))))
+      (values `'() 0)))
 
+(define (collect-byte components tail environment)
+  (let inner ((components components))
+    (if (pair? components)
+	(call-with-values (lambda () (inner (cdr components)))
+	  (lambda (byte-tail byte-size)
+	    (let ((size (caar components))
+		  (expression (cadar components))
+		  (type (if (pair? (cddar components))
+			    (caddar components)
+			    'UNSIGNED)))
+	      (values `(,(close-syntax 'CONS-SYNTAX environment)
+			,(integer-syntaxer expression environment type size)
+			,byte-tail)
+		      (+ size byte-size)))))
+	(values tail 0))))
\ No newline at end of file