From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 22 Feb 2002 03:42:52 +0000 (+0000)
Subject: Eliminate non-hygienic macros.
X-Git-Tag: 20090517-FFI~2223
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=34d01ac9cc10f257e6262731dcedd02e58faa7a3;p=mit-scheme.git

Eliminate non-hygienic macros.
---

diff --git a/v7/src/compiler/machines/bobcat/instr3.scm b/v7/src/compiler/machines/bobcat/instr3.scm
index db2e73f0f..3e5a904c1 100644
--- a/v7/src/compiler/machines/bobcat/instr3.scm
+++ b/v7/src/compiler/machines/bobcat/instr3.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: instr3.scm,v 1.19 2001/12/20 21:45:24 cph Exp $
+$Id: instr3.scm,v 1.20 2002/02/22 03:27:42 cph Exp $
 
-Copyright (c) 1988, 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
@@ -46,69 +46,71 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (let-syntax
     ((define-branch-instruction
-       (lambda (opcode prefix field . fall-through)
-	 `(define-instruction ,opcode
-	    ((,@prefix B (@PCO (? o)))
-	     (WORD ,@field
-		   (8 o SIGNED)))
-
-	    ((,@prefix B (@PCR (? l)))
-	     (WORD ,@field
-		   (8 l SHORT-LABEL)))
-
-	    ((,@prefix W (@PCO (? o)))
-	     (WORD ,@field
-		   (8 #b00000000))
-	     (immediate-word o))
-
-	    ((,@prefix W (@PCR (? l)))
-	     (WORD ,@field
-		   (8 #b00000000))
-	     (relative-word l))
-
-	    ;; 68020 only
-
-	    ((,@prefix L (@PCO (? o)))
-	     (WORD ,@field
-		   (8 #b11111111))
-	     (immediate-long o))
-
-	    ((,@prefix L (@PCR (? l)))
-	     (WORD ,@field
-		   (8 #b11111111))
-	     (relative-long l))
-
-	    ((,@prefix (@PCO (? o)))
-	     (GROWING-WORD (disp o)
-	      ((0 0)
-	       ,@fall-through)
-	      ((-128 127)
-	       (WORD ,@field
-		     (8 disp SIGNED)))
-	      ((-32768 32767)
-	       (WORD ,@field
-		     (8 #b00000000)
-		     (16 disp SIGNED)))
-	      ((() ())
-	       (WORD ,@field
-		     (8 #b11111111)
-		     (32 disp SIGNED)))))
-
-	    ((,@prefix (@PCR (? l)))
-	     (GROWING-WORD (disp `(- ,l (+ *PC* 2)))
-	      ((0 0)
-	       ,@fall-through)
-	      ((-128 127)
-	       (WORD ,@field
-		     (8 disp SIGNED)))
-	      ((-32768 32767)
-	       (WORD ,@field
-		     (8 #b00000000)
-		     (16 disp SIGNED)))
-	      ((() ())
-	       (WORD ,@field
-		     (8 #b11111111)
-		     (32 disp SIGNED)))))))))
+       (sc-macro-transformer
+	(lambda (form environment)
+	  environment
+	  `(DEFINE-INSTRUCTION ,(cadr form)
+	     ((,@(caddr form) B (@PCO (? o)))
+	      (WORD ,@(cadddr form)
+		    (8 o SIGNED)))
+
+	     ((,@(caddr form) B (@PCR (? l)))
+	      (WORD ,@(cadddr form)
+		    (8 l SHORT-LABEL)))
+
+	     ((,@(caddr form) W (@PCO (? o)))
+	      (WORD ,@(cadddr form)
+		    (8 #b00000000))
+	      (immediate-word o))
+
+	     ((,@(caddr form) W (@PCR (? l)))
+	      (WORD ,@(cadddr form)
+		    (8 #b00000000))
+	      (relative-word l))
+
+	     ;; 68020 only
+
+	     ((,@(caddr form) L (@PCO (? o)))
+	      (WORD ,@(cadddr form)
+		    (8 #b11111111))
+	      (immediate-long o))
+
+	     ((,@(caddr form) L (@PCR (? l)))
+	      (WORD ,@(cadddr form)
+		    (8 #b11111111))
+	      (relative-long l))
+
+	     ((,@(caddr form) (@PCO (? o)))
+	      (GROWING-WORD (disp o)
+			    ((0 0)
+			     ,@(cddddr form))
+			    ((-128 127)
+			     (WORD ,@(cadddr form)
+				   (8 disp SIGNED)))
+			    ((-32768 32767)
+			     (WORD ,@(cadddr form)
+				   (8 #b00000000)
+				   (16 disp SIGNED)))
+			    ((() ())
+			     (WORD ,@(cadddr form)
+				   (8 #b11111111)
+				   (32 disp SIGNED)))))
+
+	     ((,@(caddr form) (@PCR (? l)))
+	      (GROWING-WORD (disp `(- ,l (+ *PC* 2)))
+			    ((0 0)
+			     ,@(cddddr form))
+			    ((-128 127)
+			     (WORD ,@(cadddr form)
+				   (8 disp SIGNED)))
+			    ((-32768 32767)
+			     (WORD ,@(cadddr form)
+				   (8 #b00000000)
+				   (16 disp SIGNED)))
+			    ((() ())
+			     (WORD ,@(cadddr form)
+				   (8 #b11111111)
+				   (32 disp SIGNED))))))))))
 
   (define-branch-instruction B ((? c cc)) ((4 #b0110) (4 c))
     (WORD (16 #b0100111001110001)))
diff --git a/v7/src/compiler/machines/bobcat/instr4.scm b/v7/src/compiler/machines/bobcat/instr4.scm
index 32e15e1d1..f0c53c3c7 100644
--- a/v7/src/compiler/machines/bobcat/instr4.scm
+++ b/v7/src/compiler/machines/bobcat/instr4.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: instr4.scm,v 1.5 2001/12/20 21:45:24 cph Exp $
+$Id: instr4.scm,v 1.6 2002/02/22 03:30:17 cph Exp $
 
-Copyright (c) 1987, 1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1987, 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
@@ -29,55 +29,63 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (let-syntax
     ((define-bitfield-manipulation-1
-       (lambda (keyword bits ea-mode)
-	 `(define-instruction ,keyword
-	    (((? ea ,ea-mode) (& (? offset)) (& (? width)) (D (? reg)))
-	     (WORD (4 #b1110)
-		   (4 ,bits)
-		   (2 #b11)
-		   (6 ea DESTINATION-EA))
-	     (EXTENSION-WORD (1 #b0)
-			     (3 reg)
-			     (1 #b0)
-			     (5 offset)
-			     (1 #b0)
-			     (5 width BFWIDTH)))
-
-	    (((? ea ,ea-mode) (& (? offset)) (D (? r-width)) (D (? reg)))
-	     (WORD (4 #b1110)
-		   (4 ,bits)
-		   (2 #b11)
-		   (6 ea DESTINATION-EA))
-	     (EXTENSION-WORD (1 #b0)
-			     (3 reg)
-			     (1 #b0)
-			     (5 offset)
-			     (3 #b100)
-			     (3 r-width)))
-
-	    (((? ea ,ea-mode) (D (? r-offset)) (& (? width)) (D (? reg)))
-	     (WORD (4 #b1110)
-		   (4 ,bits)
-		   (2 #b11)
-		   (6 ea DESTINATION-EA))
-	     (EXTENSION-WORD (1 #b0)
-			     (3 reg)
-			     (3 #b100)
-			     (3 r-offset)
-			     (1 #b0)
-			     (5 width BFWIDTH)))
-
-	    (((? ea ,ea-mode) (D (? r-offset)) (D (? r-width)) (D (? reg)))
-	     (WORD (4 #b1110)
-		   (4 ,bits)
-		   (2 #b11)
-		   (6 ea DESTINATION-EA))
-	     (EXTENSION-WORD (1 #b0)
-			     (3 reg)
-			     (3 #b100)
-			     (3 r-offset)
-			     (3 #b100)
-			     (3 r-width)))))))
+       (sc-macro-transformer
+	(lambda (form environment)
+	  environment
+	  `(DEFINE-INSTRUCTION ,(cadr form)
+	     (((? ea ,(cadddr form)) (& (? offset)) (& (? width)) (D (? reg)))
+	      (WORD (4 #b1110)
+		    (4 ,(caddr form))
+		    (2 #b11)
+		    (6 ea DESTINATION-EA))
+	      (EXTENSION-WORD (1 #b0)
+			      (3 reg)
+			      (1 #b0)
+			      (5 offset)
+			      (1 #b0)
+			      (5 width BFWIDTH)))
+
+	     (((? ea ,(cadddr form)) (& (? offset))
+				     (D (? r-width))
+				     (D (? reg)))
+	      (WORD (4 #b1110)
+		    (4 ,(caddr form))
+		    (2 #b11)
+		    (6 ea DESTINATION-EA))
+	      (EXTENSION-WORD (1 #b0)
+			      (3 reg)
+			      (1 #b0)
+			      (5 offset)
+			      (3 #b100)
+			      (3 r-width)))
+
+	     (((? ea ,(cadddr form)) (D (? r-offset))
+				     (& (? width))
+				     (D (? reg)))
+	      (WORD (4 #b1110)
+		    (4 ,(caddr form))
+		    (2 #b11)
+		    (6 ea DESTINATION-EA))
+	      (EXTENSION-WORD (1 #b0)
+			      (3 reg)
+			      (3 #b100)
+			      (3 r-offset)
+			      (1 #b0)
+			      (5 width BFWIDTH)))
+
+	     (((? ea ,(cadddr form)) (D (? r-offset))
+				     (D (? r-width))
+				     (D (? reg)))
+	      (WORD (4 #b1110)
+		    (4 ,(caddr form))
+		    (2 #b11)
+		    (6 ea DESTINATION-EA))
+	      (EXTENSION-WORD (1 #b0)
+			      (3 reg)
+			      (3 #b100)
+			      (3 r-offset)
+			      (3 #b100)
+			      (3 r-width))))))))
 
   (define-bitfield-manipulation-1 BFEXTS #b1011 ea-d/c)
   (define-bitfield-manipulation-1 BFEXTU #b1001 ea-d/c)
@@ -88,51 +96,53 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (let-syntax
     ((define-bitfield-manipulation-2
-       (lambda (keyword bits ea-mode)
-	 `(define-instruction ,keyword
-	    (((? ea ,ea-mode) (& (? offset)) (& (? width)))
-	     (WORD (4 #b1110)
-		   (4 ,bits)
-		   (2 #b11)
-		   (6 ea DESTINATION-EA))
-	     (EXTENSION-WORD (4 #b0000)
-			     (1 #b0)
-			     (5 offset)
-			     (1 #b0)
-			     (5 width BFWIDTH)))
-
-	    (((? ea ,ea-mode) (& (? offset)) (D (? r-width)))
-	     (WORD (4 #b1110)
-		   (4 ,bits)
-		   (2 #b11)
-		   (6 ea DESTINATION-EA))
-	     (EXTENSION-WORD (4 #b0000)
-			     (1 #b0)
-			     (5 offset)
-			     (3 #b100)
-			     (3 r-width)))
-
-	    (((? ea ,ea-mode) (D (? r-offset)) (& (? width)))
-	     (WORD (4 #b1110)
-		   (4 ,bits)
-		   (2 #b11)
-		   (6 ea DESTINATION-EA))
-	     (EXTENSION-WORD (4 #b0000)
-			     (3 #b100)
-			     (3 r-offset)
-			     (1 #b0)
-			     (5 width BFWIDTH)))
-
-	    (((? ea ,ea-mode) (D (? r-offset)) (D (? r-width)))
-	     (WORD (4 #b1110)
-		   (4 ,bits)
-		   (2 #b11)
-		   (6 ea DESTINATION-EA))
-	     (EXTENSION-WORD (4 #b0000)
-			     (3 #b100)
-			     (3 r-offset)
-			     (3 #b100)
-			     (3 r-width)))))))
+       (sc-macro-transformer
+	(lambda (form environment)
+	  environment
+	  `(DEFINE-INSTRUCTION ,(cadr form)
+	     (((? ea ,(cadddr form)) (& (? offset)) (& (? width)))
+	      (WORD (4 #b1110)
+		    (4 ,(caddr form))
+		    (2 #b11)
+		    (6 ea DESTINATION-EA))
+	      (EXTENSION-WORD (4 #b0000)
+			      (1 #b0)
+			      (5 offset)
+			      (1 #b0)
+			      (5 width BFWIDTH)))
+
+	     (((? ea ,(cadddr form)) (& (? offset)) (D (? r-width)))
+	      (WORD (4 #b1110)
+		    (4 ,(caddr form))
+		    (2 #b11)
+		    (6 ea DESTINATION-EA))
+	      (EXTENSION-WORD (4 #b0000)
+			      (1 #b0)
+			      (5 offset)
+			      (3 #b100)
+			      (3 r-width)))
+
+	     (((? ea ,(cadddr form)) (D (? r-offset)) (& (? width)))
+	      (WORD (4 #b1110)
+		    (4 ,(caddr form))
+		    (2 #b11)
+		    (6 ea DESTINATION-EA))
+	      (EXTENSION-WORD (4 #b0000)
+			      (3 #b100)
+			      (3 r-offset)
+			      (1 #b0)
+			      (5 width BFWIDTH)))
+
+	     (((? ea ,(cadddr form)) (D (? r-offset)) (D (? r-width)))
+	      (WORD (4 #b1110)
+		    (4 ,(caddr form))
+		    (2 #b11)
+		    (6 ea DESTINATION-EA))
+	      (EXTENSION-WORD (4 #b0000)
+			      (3 #b100)
+			      (3 r-offset)
+			      (3 #b100)
+			      (3 r-width))))))))
 
   (define-bitfield-manipulation-2 BFCHG  #b1010 ea-d/c&a)
   (define-bitfield-manipulation-2 BFCLR  #b1100 ea-d/c&a)
diff --git a/v7/src/compiler/machines/bobcat/lapgen.scm b/v7/src/compiler/machines/bobcat/lapgen.scm
index fffb5eb0b..d2f5d6605 100644
--- a/v7/src/compiler/machines/bobcat/lapgen.scm
+++ b/v7/src/compiler/machines/bobcat/lapgen.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: lapgen.scm,v 4.52 2001/12/20 21:45:24 cph Exp $
+$Id: lapgen.scm,v 4.53 2002/02/22 03:35:12 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
@@ -745,16 +745,20 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (let-syntax
     ((binary-fixnum
-      (lambda (name instr identity?)
-	`(begin
-	   (define-fixnum-method ',name fixnum-methods/2-args
-	     (lambda (target source)
-	       (LAP (,instr L ,',source ,',target))))
-	   (define-fixnum-method ',name fixnum-methods/2-args-constant
-	     (lambda (target n)
-	       (if (,identity? n)
-		   (LAP)
-		   (LAP (,instr L (& ,',(* n fixnum-1)) ,',target)))))))))
+      (sc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 `(BEGIN
+	    (DEFINE-FIXNUM-METHOD ',(cadr form) FIXNUM-METHODS/2-ARGS
+	      (LAMBDA (TARGET SOURCE)
+		(LAP (,(caddr form) L ,',SOURCE ,',TARGET))))
+	    (DEFINE-FIXNUM-METHOD ',(cadr form) FIXNUM-METHODS/2-ARGS-CONSTANT
+	      (LAMBDA (TARGET N)
+		(IF (,(cadddr form) N)
+		    (LAP)
+		    (LAP (,(caddr form) L
+					(& ,',(* N FIXNUM-1))
+					,',TARGET))))))))))
 
   (binary-fixnum PLUS-FIXNUM ADD zero?)
   (binary-fixnum FIXNUM-OR OR zero?)
@@ -981,12 +985,14 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (let-syntax
     ((define-flonum-operation
-       (lambda (primitive-name instruction-name)
-	 `(DEFINE-FLONUM-METHOD ',primitive-name FLONUM-METHODS/1-ARG
-	    (LAMBDA (SOURCE TARGET)
-	      (IF (EFFECTIVE-ADDRESS/FLOAT-REGISTER? SOURCE)
-		  (LAP (,instruction-name ,',source ,',target))
-		  (LAP (,instruction-name D ,',source ,',target))))))))
+       (sc-macro-transformer
+	(lambda (form environment)
+	  environment
+	  `(DEFINE-FLONUM-METHOD ',(cadr form) FLONUM-METHODS/1-ARG
+	     (LAMBDA (SOURCE TARGET)
+	       (IF (EFFECTIVE-ADDRESS/FLOAT-REGISTER? SOURCE)
+		   (LAP (,(caddr form) ,',SOURCE ,',TARGET))
+		   (LAP (,(caddr form) D ,',SOURCE ,',TARGET)))))))))
   (define-flonum-operation flonum-negate fneg)
   (define-flonum-operation flonum-abs fabs)
   (define-flonum-operation flonum-sin fsin)
@@ -1009,12 +1015,14 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (let-syntax
     ((define-flonum-operation
-       (lambda (primitive-name instruction-name)
-	 `(DEFINE-FLONUM-METHOD ',primitive-name FLONUM-METHODS/2-ARGS
-	   (LAMBDA (TARGET SOURCE)
-	     (IF (EFFECTIVE-ADDRESS/FLOAT-REGISTER? SOURCE)
-		 (LAP (,instruction-name ,',source ,',target))
-		 (LAP (,instruction-name D ,',source ,',target))))))))
+       (sc-macro-transformer
+	(lambda (form environment)
+	  environment
+	  `(DEFINE-FLONUM-METHOD ',(cadr form) FLONUM-METHODS/2-ARGS
+	     (LAMBDA (TARGET SOURCE)
+	       (IF (EFFECTIVE-ADDRESS/FLOAT-REGISTER? SOURCE)
+		   (LAP (,(caddr form) ,',SOURCE ,',TARGET))
+		   (LAP (,(caddr form) D ,',SOURCE ,',TARGET)))))))))
   (define-flonum-operation flonum-add fadd)
   (define-flonum-operation flonum-subtract fsub)
   (define-flonum-operation flonum-multiply fmul)
@@ -1172,16 +1180,18 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 (define-integrable reg:stack-guard (INST-EA (@AO 6 #X002C)))
 
 (let-syntax ((define-codes
-	       (lambda (start . names)
-		 (define (loop names index)
-		   (if (null? names)
-		       '()
-		       (cons `(DEFINE-INTEGRABLE
-				,(symbol-append 'CODE:COMPILER-
-						(car names))
-				,index)
-			     (loop (cdr names) (1+ index)))))
-		 `(BEGIN ,@(loop names start)))))
+	       (sc-macro-transformer
+		(lambda (form environment)
+		  environment
+		  `(BEGIN
+		     ,@(let loop ((names (cddr form)) (index (cadr form)))
+			 (if (pair? names)
+			     (cons `(DEFINE-INTEGRABLE
+				      ,(symbol-append 'CODE:COMPILER-
+						      (car names))
+				      ,index)
+				   (loop (cdr names) (+ index 1)))
+			     '())))))))
   (define-codes #x012
     primitive-apply primitive-lexpr-apply
     apply error lexpr-apply link
@@ -1195,16 +1205,18 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
     quotient remainder modulo))
 
 (let-syntax ((define-entries
-	       (lambda (start . names)
-		 (define (loop names index)
-		   (if (null? names)
-		       '()
-		       (cons `(DEFINE-INTEGRABLE
-				,(symbol-append 'ENTRY:COMPILER-
-						(car names))
-				(INST-EA (@AO 6 ,index)))
-			     (loop (cdr names) (+ index 8)))))
-		 `(BEGIN ,@(loop names start)))))
+	       (sc-macro-transformer
+		(lambda (form environment)
+		  environment
+		  `(BEGIN
+		     ,@(let loop ((names (cddr form)) (index (cadr form)))
+			 (if (pair? names)
+			     (cons `(DEFINE-INTEGRABLE
+				      ,(symbol-append 'ENTRY:COMPILER-
+						      (car names))
+				      (INST-EA (@AO 6 ,index)))
+				   (loop (cdr names) (+ index 8)))
+			     '())))))))
   (define-entries #x40
     scheme-to-interface			; Main entry point (only one necessary)
     scheme-to-interface-jsr		; Used by rules3&4, for convenience.
diff --git a/v7/src/compiler/machines/bobcat/machin.scm b/v7/src/compiler/machines/bobcat/machin.scm
index 492f0f4f9..db17848d9 100644
--- a/v7/src/compiler/machines/bobcat/machin.scm
+++ b/v7/src/compiler/machines/bobcat/machin.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: machin.scm,v 4.33 2001/12/20 21:45:24 cph Exp $
+$Id: machin.scm,v 4.34 2002/02/22 03:36:54 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
@@ -170,18 +170,19 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (define-integrable MC68K/closure-format 'MC68040) ; or MC68020
 
-(let-syntax ((define/format-dependent
-	       (lambda (name)
-		 `(define ,name
-		    (case MC68K/closure-format
-		      ((MC68020)
-		       ,(intern
-			 (string-append "MC68020/" (symbol->string name))))
-		      ((MC68040)
-		       ,(intern
-			 (string-append "MC68040/" (symbol->string name))))
-		      (else
-		       (error "Unknown closure format" closure-format)))))))
+(let-syntax
+    ((define/format-dependent
+       (sc-macro-transformer
+	(lambda (form environment)
+	  (let ((name (cadr form)))
+	    `(DEFINE ,name
+	       (CASE MC68K/CLOSURE-FORMAT
+		 ((MC68020)
+		  ,(close-syntax (symbol-append 'MC68020/ name) environment))
+		 ((MC68040)
+		  ,(close-syntax (symbol-append 'MC68040/ name) environment))
+		 (ELSE
+		  (ERROR "Unknown closure format" CLOSURE-FORMAT)))))))))
 
 ;; Given: the number of entry points in a closure, and a particular
 ;; entry point number, compute the distance from that entry point to
diff --git a/v7/src/compiler/machines/bobcat/rules3.scm b/v7/src/compiler/machines/bobcat/rules3.scm
index 6ad2ebe15..372bb7c25 100644
--- a/v7/src/compiler/machines/bobcat/rules3.scm
+++ b/v7/src/compiler/machines/bobcat/rules3.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: rules3.scm,v 4.42 2001/12/20 21:45:24 cph Exp $
+$Id: rules3.scm,v 4.43 2002/02/22 03:40:24 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
@@ -164,26 +164,30 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (let-syntax
     ((define-special-primitive-invocation
-       (lambda (name)
-	 `(define-rule statement
-	    (INVOCATION:SPECIAL-PRIMITIVE
-	     (? frame-size)
-	     (? continuation)
-	     ,(make-primitive-procedure name true))
-	    frame-size continuation
-	    (special-primitive-invocation
-	     ,(symbol-append 'CODE:COMPILER- name)))))
+       (sc-macro-transformer
+	(lambda (form environment)
+	  `(DEFINE-RULE STATEMENT
+	     (INVOCATION:SPECIAL-PRIMITIVE
+	      (? frame-size)
+	      (? continuation)
+	      ,(make-primitive-procedure (cadr form) #t))
+	     FRAME-SIZE CONTINUATION
+	     (SPECIAL-PRIMITIVE-INVOCATION
+	      ,(close-syntax (symbol-append 'CODE:COMPILER- (cadr form))
+			     environment))))))
 
      (define-optimized-primitive-invocation
-       (lambda (name)
-	 `(define-rule statement
-	    (INVOCATION:SPECIAL-PRIMITIVE
-	     (? frame-size)
-	     (? continuation)
-	     ,(make-primitive-procedure name true))
-	    frame-size continuation
-	    (optimized-primitive-invocation
-	     ,(symbol-append 'ENTRY:COMPILER- name))))))
+       (sc-macro-transformer
+	(lambda (form environment)
+	  `(DEFINE-RULE STATEMENT
+	     (INVOCATION:SPECIAL-PRIMITIVE
+	      (? frame-size)
+	      (? continuation)
+	      ,(make-primitive-procedure (cadr form) #t))
+	     FRAME-SIZE CONTINUATION
+	     (OPTIMIZED-PRIMITIVE-INVOCATION
+	      ,(close-syntax (symbol-append 'ENTRY:COMPILER- (cadr form))
+			     environment)))))))
 
   (define-optimized-primitive-invocation &+)
   (define-optimized-primitive-invocation &-)
@@ -752,17 +756,18 @@ long-word aligned and there is no need for shuffling.
 				 (vector->list entries)))))
 
 (let-syntax ((define/format-dependent
-	       (lambda (name1 name2)
-		 `(define ,name1
-		    (case MC68K/closure-format
-		      ((MC68020)
-		       ,(intern
-			 (string-append "MC68020/" (symbol->string name2))))
-		      ((MC68040)
-		       ,(intern
-			 (string-append "MC68040/" (symbol->string name2))))
-		      (else
-		       (error "Unknown closure format" closure-format)))))))
+	       (sc-macro-transformer
+		(lambda (form environment)
+		  `(DEFINE ,(cadr form)
+		     (CASE MC68K/CLOSURE-FORMAT
+		       ((MC68020)
+			,(close-syntax (symbol-append 'MC68020/ (caddr form))
+				       environment))
+		       ((MC68040)
+			,(close-syntax (symbol-append 'MC68040/ (caddr form))
+				       environment))
+		       (ELSE
+			(ERROR "Unknown closure format:" CLOSURE-FORMAT))))))))
 
 (define/format-dependent generate/closure-header closure-header)
 (define/format-dependent generate/cons-closure cons-closure)
diff --git a/v7/src/compiler/machines/mips/assmd.scm b/v7/src/compiler/machines/mips/assmd.scm
index 6ae62d596..5228ea08b 100644
--- a/v7/src/compiler/machines/mips/assmd.scm
+++ b/v7/src/compiler/machines/mips/assmd.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: assmd.scm,v 1.4 2001/12/20 21:45:25 cph Exp $
+$Id: assmd.scm,v 1.5 2002/02/22 03:41:32 cph Exp $
 
-Copyright (c) 1988-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
@@ -24,7 +24,11 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (declare (usual-integrations))
 
-(let-syntax ((ucode-type (lambda (name) `',(microcode-type name))))
+(let-syntax ((ucode-type
+	      (sc-macro-transformer
+	       (lambda (form environment)
+		 environment
+		 (apply microcode-type (cdr form))))))
 
 (define-integrable maximum-padding-length
   ;; Instruction length is always a multiple of 32 bits
diff --git a/v7/src/compiler/machines/mips/dassm1.scm b/v7/src/compiler/machines/mips/dassm1.scm
index e704f67be..55f5d0bc2 100644
--- a/v7/src/compiler/machines/mips/dassm1.scm
+++ b/v7/src/compiler/machines/mips/dassm1.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: dassm1.scm,v 1.6 2001/12/20 21:45:25 cph Exp $
+$Id: dassm1.scm,v 1.7 2002/02/22 03:42:37 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
@@ -135,7 +135,10 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	(cond ((not (< index end)) 'DONE)
 	      ((object-type?
 		(let-syntax ((ucode-type
-			      (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
diff --git a/v7/src/compiler/machines/mips/dassm2.scm b/v7/src/compiler/machines/mips/dassm2.scm
index 058f6c05c..98b51e8b1 100644
--- a/v7/src/compiler/machines/mips/dassm2.scm
+++ b/v7/src/compiler/machines/mips/dassm2.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: dassm2.scm,v 1.6 2001/12/20 21:45:25 cph Exp $
+$Id: dassm2.scm,v 1.7 2002/02/22 03:42:52 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,10 +27,15 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (define (disassembler/read-variable-cache block index)
   (let-syntax ((ucode-type
-		(lambda (name) (microcode-type name)))
+		(sc-macro-transformer
+		 (lambda (form environment)
+		   environment
+		   (apply microcode-type (cdr form)))))
 	       (ucode-primitive
-		(lambda (name arity)
-		  (make-primitive-procedure name arity))))
+		(sc-macro-transformer
+		 (lambda (form environment)
+		   environment
+		   (apply make-primitive-procedure (cdr form))))))
     ((ucode-primitive primitive-object-set-type 2)
      (ucode-type quad)
      (system-vector-ref block index))))
@@ -193,10 +198,15 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
   (with-absolutely-no-interrupts
    (lambda ()
      (let-syntax ((ucode-type
-		   (lambda (name) (microcode-type name)))
+		   (sc-macro-transformer
+		    (lambda (form environment)
+		      environment
+		      (apply microcode-type (cdr form)))))
 		  (ucode-primitive
-		   (lambda (name arity)
-		     (make-primitive-procedure name arity))))
+		   (sc-macro-transformer
+		    (lambda (form environment)
+		      environment
+		      (apply make-primitive-procedure (cdr form))))))
        ((ucode-primitive primitive-object-set-type 2)
 	(ucode-type compiled-entry)
 	((ucode-primitive make-non-pointer-object 1)