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

Eliminate non-hygienic macros.
---

diff --git a/v7/src/compiler/machines/i386/instr1.scm b/v7/src/compiler/machines/i386/instr1.scm
index bd3c85896..54b8e1355 100644
--- a/v7/src/compiler/machines/i386/instr1.scm
+++ b/v7/src/compiler/machines/i386/instr1.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: instr1.scm,v 1.15 2001/12/23 17:20:58 cph Exp $
+$Id: instr1.scm,v 1.16 2002/02/12 05:57:50 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
@@ -57,70 +57,74 @@ USA.
 
 (let-syntax
     ((define-arithmetic-instruction
-      (non-hygienic-macro-transformer
-       (lambda (mnemonic opcode digit)
-	 `(define-instruction ,mnemonic
-	    ((W (? target r/mW) (R (? source)))
-	     (BYTE (8 ,(1+ opcode)))
-	     (ModR/M source target))
-
-	    ((W (R (? target)) (? source r/mW))
-	     (BYTE (8 ,(+ opcode 3)))
-	     (ModR/M target source))
-
-	    ((W (? target r/mW) (& (? value sign-extended-byte)))
-	     (BYTE (8 #x83))
-	     (ModR/M ,digit target)
-	     (BYTE (8 value SIGNED)))
-
-	    ((W (R 0) (& (? value)))	; AX/EAX
-	     (BYTE (8 ,(+ opcode 5)))
-	     (IMMEDIATE value))
-
-	    ((W (? target r/mW) (& (? value)))
-	     (BYTE (8 #x81))
-	     (ModR/M ,digit target)
-	     (IMMEDIATE value))
-
-	    ((W (? target r/mW) (&U (? value zero-extended-byte)))
-	     (BYTE (8 #x83))
-	     (ModR/M ,digit target)
-	     (BYTE (8 value UNSIGNED)))
-
-	    ((W (R 0) (&U (? value)))	; AX/EAX
-	     (BYTE (8 ,(+ opcode 5)))
-	     (IMMEDIATE value OPERAND UNSIGNED))
-
-	    ((W (? target r/mW) (&U (? value)))
-	     (BYTE (8 #x81))
-	     (ModR/M ,digit target)
-	     (IMMEDIATE value OPERAND UNSIGNED))
-
-	    ((B (? target r/mB) (R (? source)))
-	     (BYTE (8 ,opcode))
-	     (ModR/M source target))
-
-	    ((B (R (? target)) (? source r/mB))
-	     (BYTE (8 ,(+ opcode 2)))
-	     (ModR/M target source))
-
-	    ((B (R 0) (& (? value)))	; AL
-	     (BYTE (8 ,(+ opcode 4))
-		   (8 value SIGNED)))
-
-	    ((B (R 0) (&U (? value)))	; AL
-	     (BYTE (8 ,(+ opcode 4))
-		   (8 value UNSIGNED)))
-
-	    ((B (? target r/mB) (& (? value)))
-	     (BYTE (8 #x80))
-	     (ModR/M ,digit target)
-	     (BYTE (8 value SIGNED)))
-
-	    ((B (? target r/mB) (&U (? value)))
-	     (BYTE (8 #x80))
-	     (ModR/M ,digit target)
-	     (BYTE (8 value UNSIGNED))))))))
+      (sc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 (let ((mnemonic (cadr form))
+	       (opcode (caddr form))
+	       (digit (cadddr form)))
+	   `(define-instruction ,mnemonic
+	      ((W (? target r/mW) (R (? source)))
+	       (BYTE (8 ,(+ opcode 1)))
+	       (ModR/M source target))
+
+	      ((W (R (? target)) (? source r/mW))
+	       (BYTE (8 ,(+ opcode 3)))
+	       (ModR/M target source))
+
+	      ((W (? target r/mW) (& (? value sign-extended-byte)))
+	       (BYTE (8 #x83))
+	       (ModR/M ,digit target)
+	       (BYTE (8 value SIGNED)))
+
+	      ((W (R 0) (& (? value)))	; AX/EAX
+	       (BYTE (8 ,(+ opcode 5)))
+	       (IMMEDIATE value))
+
+	      ((W (? target r/mW) (& (? value)))
+	       (BYTE (8 #x81))
+	       (ModR/M ,digit target)
+	       (IMMEDIATE value))
+
+	      ((W (? target r/mW) (&U (? value zero-extended-byte)))
+	       (BYTE (8 #x83))
+	       (ModR/M ,digit target)
+	       (BYTE (8 value UNSIGNED)))
+
+	      ((W (R 0) (&U (? value)))	; AX/EAX
+	       (BYTE (8 ,(+ opcode 5)))
+	       (IMMEDIATE value OPERAND UNSIGNED))
+
+	      ((W (? target r/mW) (&U (? value)))
+	       (BYTE (8 #x81))
+	       (ModR/M ,digit target)
+	       (IMMEDIATE value OPERAND UNSIGNED))
+
+	      ((B (? target r/mB) (R (? source)))
+	       (BYTE (8 ,opcode))
+	       (ModR/M source target))
+
+	      ((B (R (? target)) (? source r/mB))
+	       (BYTE (8 ,(+ opcode 2)))
+	       (ModR/M target source))
+
+	      ((B (R 0) (& (? value)))	; AL
+	       (BYTE (8 ,(+ opcode 4))
+		     (8 value SIGNED)))
+
+	      ((B (R 0) (&U (? value)))	; AL
+	       (BYTE (8 ,(+ opcode 4))
+		     (8 value UNSIGNED)))
+
+	      ((B (? target r/mB) (& (? value)))
+	       (BYTE (8 #x80))
+	       (ModR/M ,digit target)
+	       (BYTE (8 value SIGNED)))
+
+	      ((B (? target r/mB) (&U (? value)))
+	       (BYTE (8 #x80))
+	       (ModR/M ,digit target)
+	       (BYTE (8 value UNSIGNED)))))))))
 
   (define-arithmetic-instruction ADC #x10 2)
   (define-arithmetic-instruction ADD #x00 0)
@@ -160,19 +164,24 @@ USA.
 
 (let-syntax
     ((define-bit-test-instruction
-      (non-hygienic-macro-transformer
-       (lambda (mnemonic opcode digit)
-	 `(define-instruction ,mnemonic
-	    (((? target r/mW) (& (? posn)))
-	     (BYTE (8 #x0f)
-		   (8 #xba))
-	     (ModR/M ,digit target)
-	     (BYTE (8 posn UNSIGNED)))
-
-	    (((? target r/mW) (R (? posn)))
-	     (BYTE (8 #x0f)
-		   (8 ,opcode))
-	     (ModR/M posn target)))))))
+      (sc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 (let ((mnemonic (cadr form))
+	       (opcode (caddr form))
+	       (digit (cadddr form)))
+	   `(define-instruction ,mnemonic
+
+	      (((? target r/mW) (& (? posn)))
+	       (BYTE (8 #x0f)
+		     (8 #xba))
+	       (ModR/M ,digit target)
+	       (BYTE (8 posn UNSIGNED)))
+
+	      (((? target r/mW) (R (? posn)))
+	       (BYTE (8 #x0f)
+		     (8 ,opcode))
+	       (ModR/M posn target))))))))
 
   (define-bit-test-instruction BT  #xa3 4)
   (define-bit-test-instruction BTC #xbb 7)
@@ -215,14 +224,18 @@ USA.
 
 (let-syntax
     ((define-string-instruction
-      (non-hygienic-macro-transformer
-       (lambda (mnemonic opcode)
-	 `(define-instruction ,mnemonic
-	    ((W)
-	     (BYTE (8 ,(1+ opcode))))
+      (sc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 (let ((mnemonic (cadr form))
+	       (opcode (caddr form)))
+	   `(define-instruction ,mnemonic
 
-	    ((B)
-	     (BYTE (8 ,opcode))))))))
+	      ((W)
+	       (BYTE (8 ,(+ opcode 1))))
+
+	      ((B)
+	       (BYTE (8 ,opcode)))))))))
 
   (define-string-instruction CMPS #xa6)
   (define-string-instruction LODS #xac)
@@ -252,35 +265,42 @@ USA.
 
 (let-syntax
     ((define-inc/dec
-      (non-hygienic-macro-transformer
-       (lambda (mnemonic digit opcode)
-	 `(define-instruction ,mnemonic
-	    ((W (R (? reg)))
-	     (BYTE (8 (+ ,opcode reg))))
-
-	    ((W (? target r/mW))
-	     (BYTE (8 #xff))
-	     (ModR/M ,digit target))
-
-	    ((B (? target r/mB))
-	     (BYTE (8 #xfe))
-	     (ModR/M ,digit target)))))))
+      (sc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 (let ((mnemonic (cadr form))
+	       (digit (caddr form))
+	       (opcode (cadddr form)))
+	   `(define-instruction ,mnemonic
+	      ((W (R (? reg)))
+	       (BYTE (8 (+ ,opcode reg))))
+
+	      ((W (? target r/mW))
+	       (BYTE (8 #xff))
+	       (ModR/M ,digit target))
+
+	      ((B (? target r/mB))
+	       (BYTE (8 #xfe))
+	       (ModR/M ,digit target))))))))
 
   (define-inc/dec DEC 1 #x48)
   (define-inc/dec INC 0 #x40))
 
 (let-syntax
     ((define-mul/div
-      (non-hygienic-macro-transformer
-       (lambda (mnemonic digit)
-	 `(define-instruction ,mnemonic
-	    ((W (R 0) (? operand r/mW))
-	     (BYTE (8 #xf7))
-	     (ModR/M ,digit operand))
-
-	    ((B (R 0) (? operand r/mB))
-	     (BYTE (8 #xf6))
-	     (ModR/M ,digit operand)))))))
+      (sc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 (let ((mnemonic (cadr form))
+	       (digit (caddr form)))
+	   `(define-instruction ,mnemonic
+	      ((W (R 0) (? operand r/mW))
+	       (BYTE (8 #xf7))
+	       (ModR/M ,digit operand))
+
+	      ((B (R 0) (? operand r/mB))
+	       (BYTE (8 #xf6))
+	       (ModR/M ,digit operand))))))))
 
   (define-mul/div DIV 6)
   (define-mul/div IDIV 7)
@@ -354,42 +374,46 @@ USA.
 (define-trivial-instruction INTO #xce)
 (define-trivial-instruction INVD #x0f #x08)	; 486 only
 (define-trivial-instruction IRET #xcf)
-
+
 (let-syntax
     ((define-jump-instruction
-      (non-hygienic-macro-transformer
-       (lambda (mnemonic opcode1 opcode2)
-	 `(define-instruction ,mnemonic
-	    ;; This assumes that *ADDRESS-SIZE* is 4 (32-bit mode)
-	    (((@PCR (? dest)))
-	     (VARIABLE-WIDTH
-	      (disp `(- ,dest (+ *PC* 2)))
-	      ((-128 127)
+      (sc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 (let ((mnemonic (cadr form))
+	       (opcode1 (caddr form))
+	       (opcode2 (cadddr form)))
+	   `(define-instruction ,mnemonic
+	      ;; This assumes that *ADDRESS-SIZE* is 4 (32-bit mode)
+	      (((@PCR (? dest)))
+	       (VARIABLE-WIDTH
+		(disp `(- ,dest (+ *PC* 2)))
+		((-128 127)
+		 (BYTE (8 ,opcode1)
+		       (8 disp SIGNED)))
+		((() ())
+		 (BYTE (8 #x0f)
+		       (8 ,opcode2)
+		       (32 (- disp 4) SIGNED)))))
+
+	      ((B (@PCR (? dest)))
 	       (BYTE (8 ,opcode1)
-		     (8 disp SIGNED)))
-	      ((() ())
+		     (8 `(- ,dest (+ *PC* 1)) SIGNED)))
+
+	      ((W (@PCR (? dest)))
 	       (BYTE (8 #x0f)
-		     (8 ,opcode2)
-		     (32 (- disp 4) SIGNED)))))
-
-	    ((B (@PCR (? dest)))
-	     (BYTE (8 ,opcode1)
-		   (8 `(- ,dest (+ *PC* 1)) SIGNED)))
-
-	    ((W (@PCR (? dest)))
-	     (BYTE (8 #x0f)
-		   (8 ,opcode2))
-	     (IMMEDIATE `(- ,dest (+ *PC* 4)) ADDRESS))	; fcn(*ADDRESS-SIZE*)
-
-	    ((B (@PCO (? displ)))
-	     (BYTE (8 ,opcode1)
-		   (8 displ SIGNED)))
-
-	    ((W (@PCO (? displ)))
-	     (BYTE (8 #x0f)
-		   (8 ,opcode2))
-	     (IMMEDIATE displ ADDRESS)))))))
-
+		     (8 ,opcode2))
+	       (IMMEDIATE `(- ,dest (+ *PC* 4)) ADDRESS)) ; fcn(*ADDRESS-SIZE*)
+
+	      ((B (@PCO (? displ)))
+	       (BYTE (8 ,opcode1)
+		     (8 displ SIGNED)))
+
+	      ((W (@PCO (? displ)))
+	       (BYTE (8 #x0f)
+		     (8 ,opcode2))
+	       (IMMEDIATE displ ADDRESS))))))))
+
   (define-jump-instruction JA   #x77 #x87)
   (define-jump-instruction JAE  #x73 #x83)
   (define-jump-instruction JB   #x72 #x82)
@@ -420,19 +444,22 @@ USA.
   (define-jump-instruction JPO  #x7b #x8b)
   (define-jump-instruction JS   #x78 #x88)
   (define-jump-instruction JZ   #x74 #x84))
-  
+
 (let-syntax
     ((define-loop-instruction
-      (non-hygienic-macro-transformer
-       (lambda (mnemonic opcode)
-	 `(define-instruction ,mnemonic
-	    ((B (@PCR (? dest)))
-	     (BYTE (8 ,opcode)
-		   (8 `(- ,dest (+ *PC* 1)) SIGNED)))
-
-	    ((B (@PCO (? displ)))
-	     (BYTE (8 ,opcode)
-		   (8 displ SIGNED))))))))
+      (sc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 (let ((mnemonic (cadr form))
+	       (opcode (caddr form)))
+	   `(define-instruction ,mnemonic
+	      ((B (@PCR (? dest)))
+	       (BYTE (8 ,opcode)
+		     (8 `(- ,dest (+ *PC* 1)) SIGNED)))
+
+	      ((B (@PCO (? displ)))
+	       (BYTE (8 ,opcode)
+		     (8 displ SIGNED)))))))))
 
   (define-loop-instruction JCXZ   #xe3)
   (define-loop-instruction JECXZ  #xe3)
@@ -467,7 +494,7 @@ USA.
   (((? dest r/mW))
    (BYTE (8 #xff))
    (ModR/M 4 dest))
-
+
   ((B (@PCR (? dest)))
    (BYTE (8 #xeb)
 	 (8 `(- ,dest (+ *PC* 1)) SIGNED)))
@@ -492,7 +519,7 @@ USA.
    (BYTE (8 #xea))
    (BYTE (16 seg))
    (IMMEDIATE off ADDRESS)))
-
+
 (define-trivial-instruction LAHF #x9f)
 
 (define-instruction LAR
@@ -510,13 +537,17 @@ USA.
 
 (let-syntax
     ((define-load/store-state
-      (non-hygienic-macro-transformer
-       (lambda (mnemonic opcode digit)
-	 `(define-instruction ,mnemonic
-	    (((? operand mW))
-	     (BYTE (8 #x0f)
-		   (8 ,opcode))
-	     (ModR/M ,digit operand)))))))
+      (sc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 (let ((mnemonic (cadr form))
+	       (opcode (caddr form))
+	       (digit (cadddr form)))
+	   `(define-instruction ,mnemonic
+	      (((? operand mW))
+	       (BYTE (8 #x0f)
+		     (8 ,opcode))
+	       (ModR/M ,digit operand))))))))
 
   (define-load/store-state INVLPG #x01 7)	; 486 only
   (define-load/store-state LGDT   #x01 2)
diff --git a/v7/src/compiler/machines/i386/instr2.scm b/v7/src/compiler/machines/i386/instr2.scm
index 660b6afb1..9dbd256f4 100644
--- a/v7/src/compiler/machines/i386/instr2.scm
+++ b/v7/src/compiler/machines/i386/instr2.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: instr2.scm,v 1.9 2001/12/23 17:20:58 cph Exp $
+$Id: instr2.scm,v 1.10 2002/02/12 05:57:54 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
@@ -32,14 +32,17 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (let-syntax
     ((define-load-segment
-      (non-hygienic-macro-transformer
-       (lambda (mnemonic . bytes)
-	 `(define-instruction ,mnemonic
-	    (((R (? reg)) (? pointer mW))
-	     (BYTE ,@(map (lambda (byte)
-			    `(8 ,byte))
-			  bytes))
-	     (ModR/M reg pointer)))))))
+      (sc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 (let ((mnemonic (cadr form))
+	       (bytes (cddr form)))
+	   `(define-instruction ,mnemonic
+	      (((R (? reg)) (? pointer mW))
+	       (BYTE ,@(map (lambda (byte)
+			      `(8 ,byte))
+			    bytes))
+	       (ModR/M reg pointer))))))))
 
   (define-load-segment LDS #xc5)
   (define-load-segment LSS #x0f #xb2)
@@ -55,34 +58,40 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (let-syntax
     ((define-data-extension
-      (non-hygienic-macro-transformer
-       (lambda (mnemonic opcode)
-	 `(define-instruction ,mnemonic
-	    ((B (R (? target)) (? source r/mB))
-	     (BYTE (8 #x0f)
-		   (8 ,opcode))
-	     (ModR/M target source))
-
-	    ((H (R (? target)) (? source r/mW))
-	     (BYTE (8 #x0f)
-		   (8 ,(1+ opcode)))
-	     (ModR/M target source)))))))
+      (sc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 (let ((mnemonic (cadr form))
+	       (opcode (caddr form)))
+	   `(define-instruction ,mnemonic
+	      ((B (R (? target)) (? source r/mB))
+	       (BYTE (8 #x0f)
+		     (8 ,opcode))
+	       (ModR/M target source))
+
+	      ((H (R (? target)) (? source r/mW))
+	       (BYTE (8 #x0f)
+		     (8 ,(1+ opcode)))
+	       (ModR/M target source))))))))
 
   (define-data-extension MOVSX #xbe)
   (define-data-extension MOVZX #xb6))
 
 (let-syntax
     ((define-unary
-      (non-hygienic-macro-transformer
-       (lambda (mnemonic digit)
-	 `(define-instruction ,mnemonic
-	    ((W (? operand r/mW))
-	     (BYTE (8 #xf7))
-	     (ModR/M ,digit operand))
-
-	    ((B (? operand r/mB))
-	     (BYTE (8 #xf6))
-	     (ModR/M ,digit operand)))))))
+      (sc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 (let ((mnemonic (cadr form))
+	       (digit (caddr form)))
+	   `(define-instruction ,mnemonic
+	      ((W (? operand r/mW))
+	       (BYTE (8 #xf7))
+	       (ModR/M ,digit operand))
+
+	      ((B (? operand r/mB))
+	       (BYTE (8 #xf6))
+	       (ModR/M ,digit operand))))))))
 
   (define-unary NEG 3)
   (define-unary NOT 2))
@@ -329,34 +338,37 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (let-syntax
     ((define-rotate/shift
-      (non-hygienic-macro-transformer
-       (lambda (mnemonic digit)
-	 `(define-instruction ,mnemonic
-	   ((W (? operand r/mW) (& 1))
-	    (BYTE (8 #xd1))
-	    (ModR/M ,digit operand))
-
-	   ((W (? operand r/mW) (& (? value)))
-	    (BYTE (8 #xc1))
-	    (ModR/M ,digit operand)
-	    (BYTE (8 value)))
-
-	   ((W (? operand r/mW) (R 1))
-	    (BYTE (8 #xd3))
-	    (ModR/M ,digit operand))
-
-	   ((B (? operand r/mB) (& 1))
-	    (BYTE (8 #xd0))
-	    (ModR/M ,digit operand))
-
-	   ((B (? operand r/mB) (& (? value)))
-	    (BYTE (8 #xc0))
-	    (ModR/M ,digit operand)
-	    (BYTE (8 value)))
-
-	   ((B (? operand r/mB) (R 1))
-	    (BYTE (8 #xd2))
-	    (ModR/M ,digit operand)))))))
+      (sc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 (let ((mnemonic (cadr form))
+	       (digit (caddr form)))
+	   `(define-instruction ,mnemonic
+	     ((W (? operand r/mW) (& 1))
+	      (BYTE (8 #xd1))
+	      (ModR/M ,digit operand))
+
+	     ((W (? operand r/mW) (& (? value)))
+	      (BYTE (8 #xc1))
+	      (ModR/M ,digit operand)
+	      (BYTE (8 value)))
+
+	     ((W (? operand r/mW) (R 1))
+	      (BYTE (8 #xd3))
+	      (ModR/M ,digit operand))
+
+	     ((B (? operand r/mB) (& 1))
+	      (BYTE (8 #xd0))
+	      (ModR/M ,digit operand))
+
+	     ((B (? operand r/mB) (& (? value)))
+	      (BYTE (8 #xc0))
+	      (ModR/M ,digit operand)
+	      (BYTE (8 value)))
+
+	     ((B (? operand r/mB) (R 1))
+	      (BYTE (8 #xd2))
+	      (ModR/M ,digit operand))))))))
 
   (define-rotate/shift RCL 2)
   (define-rotate/shift RCR 3)
@@ -369,19 +381,21 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (let-syntax
     ((define-double-shift
-      (non-hygienic-macro-transformer
-       (lambda (mnemonic opcode)
-	 `(define-instruction ,mnemonic
-	    ((W (? target r/mW) (R (? source)) (& (? count)))
-	     (BYTE (8 #x0f)
-		   (8 ,opcode))
-	     (ModR/M target source)
-	     (BYTE (8 count)))
-
-	    ((W (? target r/mW) (R (? source)) (R 1))
-	     (BYTE (8 #x0f)
-		   (8 ,(1+ opcode)))
-	     (ModR/M target source)))))))
+      (sc-macro-transformer
+       (lambda (form environment)
+	 (let ((mnemonic (cadr form))
+	       (opcode (caddr form)))
+	   `(define-instruction ,mnemonic
+	      ((W (? target r/mW) (R (? source)) (& (? count)))
+	       (BYTE (8 #x0f)
+		     (8 ,opcode))
+	       (ModR/M target source)
+	       (BYTE (8 count)))
+
+	      ((W (? target r/mW) (R (? source)) (R 1))
+	       (BYTE (8 #x0f)
+		     (8 ,(1+ opcode)))
+	       (ModR/M target source))))))))
 
   (define-double-shift SHLD #xa4)
   (define-double-shift SHRD #xac))
@@ -405,13 +419,16 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (let-syntax
     ((define-setcc-instruction
-      (non-hygienic-macro-transformer
-       (lambda (mnemonic opcode)
-	 `(define-instruction ,mnemonic
-	    (((? target r/mB))
-	     (BYTE (8 #x0f)
-		   (8 ,opcode))
-	     (ModR/M 0 target)))))))		; 0?
+      (sc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 (let ((mnemonic (cadr form))
+	       (opcode (caddr form)))
+	   `(define-instruction ,mnemonic
+	      (((? target r/mB))
+	       (BYTE (8 #x0f)
+		     (8 ,opcode))
+	       (ModR/M 0 target))))))))	; 0?
 
   (define-setcc-instruction SETA   #x97)
   (define-setcc-instruction SETAE  #x93)
diff --git a/v7/src/compiler/machines/i386/instrf.scm b/v7/src/compiler/machines/i386/instrf.scm
index cd88b838f..d57d5fc9f 100644
--- a/v7/src/compiler/machines/i386/instrf.scm
+++ b/v7/src/compiler/machines/i386/instrf.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: instrf.scm,v 1.17 2001/12/23 17:20:58 cph Exp $
+$Id: instrf.scm,v 1.18 2002/02/12 05:57:58 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
@@ -25,43 +25,50 @@ along with this program; if not, write to the Free Software
 
 (let-syntax
     ((define-binary-flonum
-      (non-hygienic-macro-transformer
-       (lambda (mnemonic pmnemonic imnemonic digit opcode1 opcode2)
-	 `(begin
-	    (define-instruction ,mnemonic
-	      (((ST 0) (ST (? i)))
-	       (BYTE (8 #xd8)
-		     (8 (+ ,opcode1 i))))
-
-	      (((ST (? i)) (ST 0))
-	       (BYTE (8 #xdc)
-		     (8 (+ ,opcode2 i))))
-
-	      (()
-	       (BYTE (8 #xde)
-		     (8 (+ ,opcode2 1))))
-
-	      ((D (? source mW))
-	       (BYTE (8 #xdc))
-	       (ModR/M ,digit source))
-
-	      ((S (? source mW))
-	       (BYTE (8 #xd8))
-	       (ModR/M ,digit source)))
-
-	    (define-instruction ,pmnemonic
-	      (((ST (? i)) (ST 0))
-	       (BYTE (8 #xde)
-		     (8 (+ ,opcode2 i)))))
-
-	    (define-instruction ,imnemonic
-	      ((L (? source mW))
-	       (BYTE (8 #xda))
-	       (ModR/M ,digit source))
-
-	      ((H (? source mW))
-	       (BYTE (8 #xde))
-	       (ModR/M ,digit source))))))))
+       (sc-macro-transformer
+	(lambda (form environment)
+	  environment
+	  (let ((mnemonic (list-ref form 1))
+		(pmnemonic (list-ref form 2))
+		(imnemonic (list-ref form 3))
+		(digit (list-ref form 4))
+		(opcode1 (list-ref form 5))
+		(opcode2 (list-ref form 6)))
+	    `(begin
+	       (define-instruction ,mnemonic
+		 (((ST 0) (ST (? i)))
+		  (BYTE (8 #xd8)
+			(8 (+ ,opcode1 i))))
+
+		 (((ST (? i)) (ST 0))
+		  (BYTE (8 #xdc)
+			(8 (+ ,opcode2 i))))
+
+		 (()
+		  (BYTE (8 #xde)
+			(8 (+ ,opcode2 1))))
+
+		 ((D (? source mW))
+		  (BYTE (8 #xdc))
+		  (ModR/M ,digit source))
+
+		 ((S (? source mW))
+		  (BYTE (8 #xd8))
+		  (ModR/M ,digit source)))
+
+	       (define-instruction ,pmnemonic
+		 (((ST (? i)) (ST 0))
+		  (BYTE (8 #xde)
+			(8 (+ ,opcode2 i)))))
+
+	       (define-instruction ,imnemonic
+		 ((L (? source mW))
+		  (BYTE (8 #xda))
+		  (ModR/M ,digit source))
+
+		 ((H (? source mW))
+		  (BYTE (8 #xde))
+		  (ModR/M ,digit source)))))))))
 
   ;; The i486 book (and 387, etc.) has inconsistent instruction
   ;; descriptions and opcode assignments for FSUB and siblings,
@@ -107,24 +114,28 @@ along with this program; if not, write to the Free Software
 
 (let-syntax
     ((define-flonum-comparison
-      (non-hygienic-macro-transformer
-       (lambda (mnemonic digit opcode)
-	 `(define-instruction ,mnemonic
-	    (((ST 0) (ST (? i)))
-	     (BYTE (8 #xd8)
-		   (8 (+ ,opcode i))))
-
-	    (()
-	     (BYTE (8 #xd8)
-		   (8 (+ ,opcode 1))))
-
-	    ((D (? source mW))
-	     (BYTE (8 #xdc))
-	     (ModR/M ,digit source))
-
-	    ((S (? source mW))
-	     (BYTE (8 #xd8))
-	     (ModR/M ,digit source)))))))
+       (sc-macro-transformer
+	(lambda (form environment)
+	  environment
+	  (let ((mnemonic (cadr form))
+		(digit (caddr form))
+		(opcode (cadddr form)))
+	    `(define-instruction ,mnemonic
+	       (((ST 0) (ST (? i)))
+		(BYTE (8 #xd8)
+		      (8 (+ ,opcode i))))
+
+	       (()
+		(BYTE (8 #xd8)
+		      (8 (+ ,opcode 1))))
+
+	       ((D (? source mW))
+		(BYTE (8 #xdc))
+		(ModR/M ,digit source))
+
+	       ((S (? source mW))
+		(BYTE (8 #xd8))
+		(ModR/M ,digit source))))))))
 
   (define-flonum-comparison FCOM  2 #xd0)
   (define-flonum-comparison FCOMP 3 #xd8))
@@ -140,38 +151,45 @@ along with this program; if not, write to the Free Software
 
 (let-syntax
     ((define-flonum-integer-comparison
-      (non-hygienic-macro-transformer
-       (lambda (mnemonic digit)
-	 `(define-instruction ,mnemonic
-	    ((L (? source mW))
-	     (BYTE (8 #xda))
-	     (ModR/M ,digit source))
-
-	    ((H (? source mW))
-	     (BYTE (8 #xde))
-	     (ModR/M ,digit source)))))))
+       (sc-macro-transformer
+	(lambda (form environment)
+	  environment
+	  (let ((mnemonic (cadr form))
+		(digit (caddr form)))
+	    `(define-instruction ,mnemonic
+	       ((L (? source mW))
+		(BYTE (8 #xda))
+		(ModR/M ,digit source))
+
+	       ((H (? source mW))
+		(BYTE (8 #xde))
+		(ModR/M ,digit source))))))))
 
   (define-flonum-integer-comparison FICOM  2)
   (define-flonum-integer-comparison FICOMP 3))
-
+
 (let-syntax
     ((define-flonum-integer-memory
-      (non-hygienic-macro-transformer
-       (lambda (mnemonic digit1 digit2)
-	 `(define-instruction ,mnemonic
-	    ,@(if (not digit2)
-		  `()
-		  `(((Q (? source mW))
-		     (BYTE (8 #xdf))
-		     (ModR/M ,digit2 source))))
-
-	    ((L (? source mW))
-	     (BYTE (8 #xdb))
-	     (ModR/M ,digit1 source))
-
-	    ((H (? source mW))
-	     (BYTE (8 #xdf))
-	     (ModR/M ,digit1 source)))))))
+       (sc-macro-transformer
+	(lambda (form environment)
+	  environment
+	  (let ((mnemonic (cadr form))
+		(digit1 (caddr form))
+		(digit2 (cadddr form)))
+	    `(define-instruction ,mnemonic
+	       ,@(if (not digit2)
+		     `()
+		     `(((Q (? source mW))
+			(BYTE (8 #xdf))
+			(ModR/M ,digit2 source))))
+
+	       ((L (? source mW))
+		(BYTE (8 #xdb))
+		(ModR/M ,digit1 source))
+
+	       ((H (? source mW))
+		(BYTE (8 #xdf))
+		(ModR/M ,digit1 source))))))))
 
   (define-flonum-integer-memory FILD  0 5)
   (define-flonum-integer-memory FIST  2 #f)
@@ -183,26 +201,32 @@ along with this program; if not, write to the Free Software
 
 (let-syntax
     ((define-flonum-memory
-      (non-hygienic-macro-transformer
-       (lambda (mnemonic digit1 digit2 opcode1 opcode2)
-	 `(define-instruction ,mnemonic
-	    (((ST (? i)))
-	     (BYTE (8 ,opcode1)
-		   (8 (+ ,opcode2 i))))
-
-	    ((D (? operand mW))
-	     (BYTE (8 #xdd))
-	     (ModR/M ,digit1 operand))
-
-	    ((S (? operand mW))
-	     (BYTE (8 #xd9))
-	     (ModR/M ,digit1 operand))
-
-	    ,@(if (not digit2)
-		  `()
-		  `(((X (? operand mW))
-		     (BYTE (8 #xdb))
-		     (ModR/M ,digit2 operand)))))))))
+       (sc-macro-transformer
+	(lambda (form environment)
+	  environment
+	  (let ((mnemonic (list-ref form 1))
+		(digit1 (list-ref form 2))
+		(digit2 (list-ref form 3))
+		(opcode1 (list-ref form 4))
+		(opcode2 (list-ref form 5)))
+	    `(define-instruction ,mnemonic
+	       (((ST (? i)))
+		(BYTE (8 ,opcode1)
+		      (8 (+ ,opcode2 i))))
+
+	       ((D (? operand mW))
+		(BYTE (8 #xdd))
+		(ModR/M ,digit1 operand))
+
+	       ((S (? operand mW))
+		(BYTE (8 #xd9))
+		(ModR/M ,digit1 operand))
+
+	       ,@(if (not digit2)
+		     `()
+		     `(((X (? operand mW))
+			(BYTE (8 #xdb))
+			(ModR/M ,digit2 operand))))))))))
 
   (define-flonum-memory FLD  0 5  #xd9 #xc0)
   (define-flonum-memory FST  2 #f #xdd #xd0)
@@ -215,24 +239,29 @@ along with this program; if not, write to the Free Software
 (define-trivial-instruction FLDLG2 #xd9 #xec)
 (define-trivial-instruction FLDLN2 #xd9 #xed)
 (define-trivial-instruction FLDZ   #xd9 #xee)
-
+
 (let-syntax
     ((define-flonum-state
-      (non-hygienic-macro-transformer
-       (lambda (mnemonic opcode digit mnemonic2)
-	 `(begin
-	    ,@(if (not mnemonic2)
-		  `()
-		  `((define-instruction ,mnemonic2
-		      (((? source mW))
-		       (BYTE (8 #x9b)			; (FWAIT)
-			     (8 ,opcode))
-		       (ModR/M ,digit source)))))
-
-	    (define-instruction ,mnemonic
-	      (((? source mW))
-	       (BYTE (8 ,opcode))
-	       (ModR/M ,digit source))))))))
+       (sc-macro-transformer
+	(lambda (form environment)
+	  environment
+	  (let ((mnemonic (list-ref form 1))
+		(opcode (list-ref form 2))
+		(digit (list-ref form 3))
+		(mnemonic2 (list-ref form 4)))
+	    `(begin
+	       ,@(if (not mnemonic2)
+		     `()
+		     `((define-instruction ,mnemonic2
+			 (((? source mW))
+			  (BYTE (8 #x9b) ; (FWAIT)
+				(8 ,opcode))
+			  (ModR/M ,digit source)))))
+
+	       (define-instruction ,mnemonic
+		 (((? source mW))
+		  (BYTE (8 ,opcode))
+		  (ModR/M ,digit source)))))))))
 
   (define-flonum-state FNLDCW  #xd9 5 FLDCW)
   (define-flonum-state FLDENV  #xd9 4 #f)
@@ -271,21 +300,25 @@ along with this program; if not, write to the Free Software
   (((R 0))
    (BYTE (8 #xdf)
 	 (8 #xe0))))
-
+
 (define-trivial-instruction FTST #xd9 #xe4)
 
 (let-syntax
     ((define-binary-flonum
-      (non-hygienic-macro-transformer
-       (lambda (mnemonic opcode1 opcode2)
-	 `(define-instruction ,mnemonic
-	    (((ST 0) (ST (? i)))
-	     (BYTE (8 ,opcode1)
-		   (8 (+ ,opcode2 i))))
-
-	    (()
-	     (BYTE (8 ,opcode1)
-		   (8 (+ ,opcode2 1)))))))))
+       (sc-macro-transformer
+	(lambda (form environment)
+	  environment
+	  (let ((mnemonic (cadr form))
+		(opcode1 (caddr form))
+		(opcode2 (cadddr form)))
+	    `(define-instruction ,mnemonic
+	       (((ST 0) (ST (? i)))
+		(BYTE (8 ,opcode1)
+		      (8 (+ ,opcode2 i))))
+
+	       (()
+		(BYTE (8 ,opcode1)
+		      (8 (+ ,opcode2 1))))))))))
 
   (define-binary-flonum FUCOM  #xdd #xe0)
   (define-binary-flonum FUCOMP #xdd #xe8)
diff --git a/v7/src/compiler/machines/i386/lapgen.scm b/v7/src/compiler/machines/i386/lapgen.scm
index 30eb0320e..5b4718991 100644
--- a/v7/src/compiler/machines/i386/lapgen.scm
+++ b/v7/src/compiler/machines/i386/lapgen.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: lapgen.scm,v 1.30 2001/12/23 17:20:58 cph Exp $
+$Id: lapgen.scm,v 1.31 2002/02/12 05:58:02 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
@@ -568,17 +568,18 @@ USA.
 
 
 (let-syntax ((define-codes
-	      (non-hygienic-macro-transformer
-	       (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
@@ -605,23 +606,28 @@ USA.
   (LAP (MOV B (R ,eax) (& ,code))
        ,@(invoke-hook/call entry:compiler-scheme-to-interface/call)))
 
-(let-syntax ((define-entries
-	      (non-hygienic-macro-transformer
-	       (lambda (start high . names)
-		 (define (loop names index high)
-		   (cond ((null? names)
-			  '())
-			 ((>= index high)
-			  (warn "define-entries: Too many for byte offsets.")
-			  (loop names index (+ high 32000)))
-			 (else
-			  (cons `(DEFINE-INTEGRABLE
-				   ,(symbol-append 'ENTRY:COMPILER-
-						   (car names))
-				   (byte-offset-reference regnum:regs-pointer
-							  ,index))
-				(loop (cdr names) (+ index 4) high)))))
-		 `(BEGIN ,@(loop names start high))))))
+(let-syntax
+    ((define-entries
+       (sc-macro-transformer
+	(lambda (form environment)
+	  environment
+	  `(BEGIN
+	     ,@(let loop
+		   ((names (cdddr form))
+		    (index (cadr form))
+		    (high (caddr form)))
+		 (if (pair? names)
+		     (if (< index high)
+			 (cons `(DEFINE-INTEGRABLE
+				  ,(symbol-append 'ENTRY:COMPILER-
+						  (car names))
+				  (byte-offset-reference regnum:regs-pointer
+							 ,index))
+			       (loop (cdr names) (+ index 4) high))
+			 (begin
+			   (warn "define-entries: Too many for byte offsets.")
+			   (loop names index (+ high 32000))))
+		     '())))))))
   (define-entries #x40 #x80		; (* 16 4)
     scheme-to-interface			; Main entry point (only one necessary)
     scheme-to-interface/call		; Used by rules3&4, for convenience.
@@ -667,7 +673,7 @@ USA.
     shortcircuit-apply-size-8
     interrupt-continuation-2
     conditionally-serialize))
-
+
 ;; Operation tables
 
 (define (define-arithmetic-method operator methods method)
@@ -686,4 +692,4 @@ USA.
 	      (for-each (lambda (edge)
 			  (determine-interrupt-checks (edge-right-node edge)))
 		(rgraph-entry-edges rgraph)))
-    rgraphs))
+    rgraphs))
\ No newline at end of file
diff --git a/v7/src/compiler/machines/i386/rules3.scm b/v7/src/compiler/machines/i386/rules3.scm
index ac6ce6ae9..68ca6241d 100644
--- a/v7/src/compiler/machines/i386/rules3.scm
+++ b/v7/src/compiler/machines/i386/rules3.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: rules3.scm,v 1.37 2001/12/23 17:20:58 cph Exp $
+$Id: rules3.scm,v 1.38 2002/02/12 05:58:07 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
@@ -96,7 +96,7 @@ USA.
        (POP (R ,eax))
        (AND W (R ,eax) (R ,regnum:datum-mask)) ;clear type code
        (JMP (R ,eax))))
-
+
 (define-rule statement
   (INVOCATION:LEXPR (? number-pushed) (? continuation) (? label))
   continuation
@@ -125,7 +125,7 @@ USA.
   (expect-no-exit-interrupt-checks)
   (LAP ,@(clear-map!)
        (JMP (@PCRO ,(free-uuo-link-label name frame-size) 3))))
-
+
 (define-rule statement
   (INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name))
   continuation
@@ -169,106 +169,78 @@ USA.
 (define-rule statement
   (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive))
   continuation				; ignored
-  ;;
-  (let-syntax ((invoke
-		(non-hygienic-macro-transformer
-		 #|
-		 (lambda (code entry)
-		   entry			; ignored (for now)
-		   `(invoke-interface ,code))
-		 |#
-		 (lambda (code entry)
-		   code			; ignored
-		   `(invoke-hook ,entry)))))
-
-    (if (eq? primitive compiled-error-procedure)
-	(LAP ,@(clear-map!)
-	     (MOV W (R ,ecx) (& ,frame-size))
-	     ,@(invoke code:compiler-error entry:compiler-error))
-	(let ((arity (primitive-procedure-arity primitive)))
-	  (cond ((not (negative? arity))
-		 (with-values (lambda () (get-cached-label))
-		   (lambda (pc-label pc-reg)
-		     pc-reg		; ignored
-		     (if pc-label
-			 (let ((get-code
-				(object->machine-register! primitive ecx)))
-			   (LAP ,@get-code
-				,@(clear-map!)
-				,@(invoke code:compiler-primitive-apply
-					  entry:compiler-primitive-apply)))
-			 (let ((prim-label (constant->label primitive))
-			       (offset-label (generate-label 'PRIMOFF)))
-			   (LAP ,@(clear-map!)
-				,@(invoke-hook/call
-				   entry:compiler-short-primitive-apply)
-				(LABEL ,offset-label)
-				(LONG S (- ,prim-label ,offset-label))))))))
-		((= arity -1)
-		 (let ((get-code (object->machine-register! primitive ecx)))
-		   (LAP ,@get-code
-			,@(clear-map!)
-			(MOV W ,reg:lexpr-primitive-arity
-			     (& ,(-1+ frame-size)))
-			,@(invoke code:compiler-primitive-lexpr-apply
-				  entry:compiler-primitive-lexpr-apply))))
-		(else
-		 ;; Unknown primitive arity.  Go through apply.
-		 (let ((get-code (object->machine-register! primitive ecx)))
-		   (LAP ,@get-code
-			,@(clear-map!)
-			(MOV W (R ,edx) (& ,frame-size))
-			,@(invoke-interface code:compiler-apply)))))))))
+  (if (eq? primitive compiled-error-procedure)
+      (LAP ,@(clear-map!)
+	   (MOV W (R ,ecx) (& ,frame-size))
+	   ,@(invoke-hook entry:compiler-error))
+      (let ((arity (primitive-procedure-arity primitive)))
+	(cond ((not (negative? arity))
+	       (with-values (lambda () (get-cached-label))
+		 (lambda (pc-label pc-reg)
+		   pc-reg		; ignored
+		   (if pc-label
+		       (let ((get-code
+			      (object->machine-register! primitive ecx)))
+			 (LAP ,@get-code
+			      ,@(clear-map!)
+			      ,@(invoke-hook entry:compiler-primitive-apply)))
+		       (let ((prim-label (constant->label primitive))
+			     (offset-label (generate-label 'PRIMOFF)))
+			 (LAP ,@(clear-map!)
+			      ,@(invoke-hook/call
+				 entry:compiler-short-primitive-apply)
+			      (LABEL ,offset-label)
+			      (LONG S (- ,prim-label ,offset-label))))))))
+	      ((= arity -1)
+	       (let ((get-code (object->machine-register! primitive ecx)))
+		 (LAP ,@get-code
+		      ,@(clear-map!)
+		      (MOV W ,reg:lexpr-primitive-arity
+			   (& ,(-1+ frame-size)))
+		      ,@(invoke-hook entry:compiler-primitive-lexpr-apply))))
+	      (else
+	       ;; Unknown primitive arity.  Go through apply.
+	       (let ((get-code (object->machine-register! primitive ecx)))
+		 (LAP ,@get-code
+		      ,@(clear-map!)
+		      (MOV W (R ,edx) (& ,frame-size))
+		      ,@(invoke-interface code:compiler-apply))))))))
 
 (let-syntax
-    ((define-special-primitive-invocation
-      (non-hygienic-macro-transformer
-       (lambda (name)
-	 `(define-rule statement
-	    (INVOCATION:SPECIAL-PRIMITIVE
-	     (? frame-size)
-	     (? continuation)
-	     ,(make-primitive-procedure name true))
-	    frame-size continuation
-	    (expect-no-exit-interrupt-checks)
-	    (special-primitive-invocation
-	     ,(symbol-append 'CODE:COMPILER- name))))))
-
-     (define-optimized-primitive-invocation
-      (non-hygienic-macro-transformer
-       (lambda (name)
-	 `(define-rule statement
-	    (INVOCATION:SPECIAL-PRIMITIVE
-	     (? frame-size)
-	     (? continuation)
-	     ,(make-primitive-procedure name true))
-	    frame-size continuation
-	    (expect-no-exit-interrupt-checks)
-	    (optimized-primitive-invocation
-	     ,(symbol-append 'ENTRY:COMPILER- name)))))))
-
-  (let-syntax ((define-primitive-invocation
-		(non-hygienic-macro-transformer
-		 (lambda (name)
-		   #|
-		   `(define-special-primitive-invocation ,name)
-		   |#
-		   `(define-optimized-primitive-invocation ,name)))))
-
-    (define-primitive-invocation &+)
-    (define-primitive-invocation &-)
-    (define-primitive-invocation &*)
-    (define-primitive-invocation &/)
-    (define-primitive-invocation &=)
-    (define-primitive-invocation &<)
-    (define-primitive-invocation &>)
-    (define-primitive-invocation 1+)
-    (define-primitive-invocation -1+)
-    (define-primitive-invocation zero?)
-    (define-primitive-invocation positive?)
-    (define-primitive-invocation negative?)
-    (define-primitive-invocation quotient)
-    (define-primitive-invocation remainder)))
+    ((define-primitive-invocation
+       (sc-macro-transformer
+	(lambda (form environment)
+	  (let ((name (cadr form)))
+	    `(define-rule statement
+	       (INVOCATION:SPECIAL-PRIMITIVE
+		(? frame-size)
+		(? continuation)
+		,(make-primitive-procedure name #t))
+	       frame-size continuation
+	       (expect-no-exit-interrupt-checks)
+	       #|
+	       (special-primitive-invocation
+		,(close-syntax (symbol-append 'CODE:COMPILER- name)
+			       environment))
+	       |#
+	       (optimized-primitive-invocation
+		,(close-syntax (symbol-append 'ENTRY:COMPILER- name)
+			       environment))))))))
+
+  (define-primitive-invocation &+)
+  (define-primitive-invocation &-)
+  (define-primitive-invocation &*)
+  (define-primitive-invocation &/)
+  (define-primitive-invocation &=)
+  (define-primitive-invocation &<)
+  (define-primitive-invocation &>)
+  (define-primitive-invocation 1+)
+  (define-primitive-invocation -1+)
+  (define-primitive-invocation zero?)
+  (define-primitive-invocation positive?)
+  (define-primitive-invocation negative?)
+  (define-primitive-invocation quotient)
+  (define-primitive-invocation remainder))
 
 (define (special-primitive-invocation code)
   (LAP ,@(clear-map!)
@@ -277,7 +249,7 @@ USA.
 (define (optimized-primitive-invocation entry)
   (LAP ,@(clear-map!)
        ,@(invoke-hook entry)))
-
+
 ;;; Invocation Prefixes
 
 (define-rule statement
@@ -288,7 +260,7 @@ USA.
   (INVOCATION-PREFIX:DYNAMIC-LINK 0 (REGISTER 4) (? any))
   any					; ignored
   (LAP))
-
+
 (define-rule statement
   (INVOCATION-PREFIX:MOVE-FRAME-UP
    (? frame-size)
@@ -437,7 +409,7 @@ USA.
   (expect-no-entry-interrupt-checks)
   (make-external-label (continuation-code-word internal-label)
 		       internal-label))
-
+
 (define-rule statement
   (CONTINUATION-HEADER (? internal-label))
   #|
@@ -794,7 +766,7 @@ USA.
 (define (make-closure-code-longword frame/min frame/max pc-offset)
   (make-closure-longword (make-procedure-code-word frame/min frame/max)
 			 pc-offset))
-
+
 (define-rule statement
   (CLOSURE-HEADER (? internal-label) (? nentries) (? entry))
   (generate/closure-header internal-label nentries entry))
diff --git a/v7/src/compiler/machines/i386/rulfix.scm b/v7/src/compiler/machines/i386/rulfix.scm
index 7550599b8..764c17ac6 100644
--- a/v7/src/compiler/machines/i386/rulfix.scm
+++ b/v7/src/compiler/machines/i386/rulfix.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: rulfix.scm,v 1.33 2001/12/23 17:20:58 cph Exp $
+$Id: rulfix.scm,v 1.34 2002/02/12 05:58:12 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
@@ -113,7 +113,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 			 #f))
   (fixnum-1-arg target source
    (lambda (target)
-     (multiply-fixnum-constant target (* n fixnum-1) false))))
+     (multiply-fixnum-constant target (* n fixnum-1) #f))))
 
 (define-rule statement
   (ASSIGN (REGISTER (? target))
@@ -123,7 +123,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 			 #f))
   (fixnum-1-arg target source
    (lambda (target)
-     (multiply-fixnum-constant target (* n fixnum-1) false))))
+     (multiply-fixnum-constant target (* n fixnum-1) #f))))
 
 (define-rule statement
   (ASSIGN (REGISTER (? target))
@@ -256,7 +256,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (define (integer-power-of-2? n)
   (let loop ((power 1) (exponent 0))
-    (cond ((< n power) false)
+    (cond ((< n power) #f)
 	  ((= n power) exponent)
 	  (else
 	   (loop (* 2 power) (1+ exponent))))))
@@ -386,11 +386,11 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (define-arithmetic-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg
   (lambda (target)
-    (add-fixnum-constant target 1 false)))
+    (add-fixnum-constant target 1 #f)))
 
 (define-arithmetic-method 'MINUS-ONE-PLUS-FIXNUM fixnum-methods/1-arg
   (lambda (target)
-    (add-fixnum-constant target -1 false)))
+    (add-fixnum-constant target -1 #f)))
 
 (define-arithmetic-method 'FIXNUM-NOT fixnum-methods/1-arg
   (lambda (target)
@@ -403,27 +403,31 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (let-syntax
     ((binary-operation
-      (non-hygienic-macro-transformer
-       (lambda (name instr commutative? idempotent?)
-	 `(define-arithmetic-method ',name fixnum-methods/2-args
-	    (fixnum-2-args/standard
-	     ,commutative?
-	     (lambda (target source2)
-	       (if (and ,idempotent? (equal? target source2))
-		   (LAP)
-		   (LAP (,instr W ,',target ,',source2))))))))))
-
-  #| (binary-operation PLUS-FIXNUM ADD true false) |#
-  (binary-operation MINUS-FIXNUM SUB false false)
-  (binary-operation FIXNUM-AND AND true true)
-  (binary-operation FIXNUM-OR OR true true)
-  (binary-operation FIXNUM-XOR XOR true false))
+      (sc-macro-transformer
+       (lambda (form environment)
+	 (let ((name (list-ref form 1))
+	       (instr (list-ref form 2))
+	       (commutative? (list-ref form 3))
+	       (idempotent? (list-ref form 4)))
+	   `(define-arithmetic-method ',name fixnum-methods/2-args
+	      (fixnum-2-args/standard
+	       ,commutative?
+	       (lambda (target source2)
+		 (if (and ,idempotent? (equal? target source2))
+		     (LAP)
+		     (LAP (,instr W ,',target ,',source2)))))))))))
+
+  #| (binary-operation PLUS-FIXNUM ADD #t #f) |#
+  (binary-operation MINUS-FIXNUM SUB #f #f)
+  (binary-operation FIXNUM-AND AND #t #t)
+  (binary-operation FIXNUM-OR OR #t #t)
+  (binary-operation FIXNUM-XOR XOR #t #f))
 
 (define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args
   (let* ((operate
 	  (lambda (target source2)
 	    (LAP (ADD W ,target ,source2))))
-	 (standard (fixnum-2-args/standard true operate)))
+	 (standard (fixnum-2-args/standard #t operate)))
 
   (lambda (target source1 source2 overflow?)
     (if overflow?
@@ -446,7 +450,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (define-arithmetic-method 'FIXNUM-ANDC fixnum-methods/2-args
   (fixnum-2-args/standard
-   false
+   #f
    (lambda (target source2)
      (if (equal? target source2)
 	 (load-fixnum-constant 0 target)
@@ -459,7 +463,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (define-arithmetic-method 'MULTIPLY-FIXNUM fixnum-methods/2-args
   (fixnum-2-args/standard
-   false
+   #f
    (lambda (target source2)
      (cond ((not (equal? target source2))
 	    (LAP (SAR W ,target (& ,scheme-type-width))
@@ -505,7 +509,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
       overflow?				; ignored
       (require-register! ecx)
       (two-arg-register-operation operate
-				  false
+				  #f
 				  target
 				  source1
 				  source2))))
@@ -573,7 +577,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	   (LAP))
 	  (else
 	   (LAP (AND W ,target (& ,(* n fixnum-1))))))))
-
+
 (define-arithmetic-method 'FIXNUM-ANDC fixnum-methods/2-args-constant
   (lambda (target n overflow?)
     overflow?				; ignored
@@ -596,7 +600,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	  (else
 	   (LAP (SHR W ,target (& ,(- 0 n)))
 		,@(word->fixnum target))))))
-
+
 (define-rule statement
   (ASSIGN (REGISTER (? target))
 	  (FIXNUM->OBJECT
diff --git a/v7/src/compiler/machines/i386/rulflo.scm b/v7/src/compiler/machines/i386/rulflo.scm
index 04019397a..02f8ca8c1 100644
--- a/v7/src/compiler/machines/i386/rulflo.scm
+++ b/v7/src/compiler/machines/i386/rulflo.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: rulflo.scm,v 1.24 2001/12/23 17:20:58 cph Exp $
+$Id: rulflo.scm,v 1.25 2002/02/12 05:58:16 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
@@ -238,22 +238,25 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (define flonum-methods/1-arg
   (list 'FLONUM-METHODS/1-ARG))
-
+
 ;;; Notice the weird ,', syntax here.
 ;;; If LAP changes, this may also have to change.
 
 (let-syntax
     ((define-flonum-operation
-      (non-hygienic-macro-transformer
-       (lambda (primitive-name opcode)
-	 `(define-arithmetic-method ',primitive-name flonum-methods/1-arg
-	    (flonum-unary-operation/general
-	     (lambda (target source)
-	       (if (and (zero? target) (zero? source))
-		   (LAP (,opcode))
-		   (LAP (FLD (ST ,', source))
-			(,opcode)
-			(FSTP (ST ,',(1+ target))))))))))))
+       (sc-macro-transformer
+	(lambda (form environment)
+	  environment
+	  (let ((primitive-name (cadr form))
+		(opcode (caddr form)))
+	    `(define-arithmetic-method ',primitive-name flonum-methods/1-arg
+	       (flonum-unary-operation/general
+		(lambda (target source)
+		  (if (and (zero? target) (zero? source))
+		      (LAP (,opcode))
+		      (LAP (FLD (ST ,', source))
+			   (,opcode)
+			   (FSTP (ST ,',(1+ target)))))))))))))
   (define-flonum-operation FLONUM-NEGATE FCHS)
   (define-flonum-operation FLONUM-ABS FABS)
   (define-flonum-operation FLONUM-SIN FSIN)
@@ -463,10 +466,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	     (try-reuse-1 (lambda () (try-reuse-2 default)))
 	     (try-reuse-2 (lambda () (try-reuse-1 default)))))
 	((not (eq? (register-type target) 'FLOAT))
-	 (error "flonum-2-args: Wrong type register"
-		target 'FLOAT))
-	(else
-	 (default))))
+	 (error "flonum-2-args: Wrong type register" target 'FLOAT))
+	(else (default))))
 
 (define (flonum-2-args/operator operation)
   (lookup-arithmetic-method operation flonum-methods/2-args))
@@ -491,58 +492,66 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (let-syntax
     ((define-flonum-operation
-      (non-hygienic-macro-transformer
-       (lambda (primitive-name op1%2 op1%2p op2%1 op2%1p)
-	 `(begin
-	    (define-arithmetic-method ',primitive-name flonum-methods/2-args
-	      (flonum-binary-operation
-	       (lambda (target source1 source2)
-		 (cond ((= target source1)
-			(cond ((zero? target)
-			       (LAP (,op1%2 (ST 0) (ST ,',source2))))
-			      ((zero? source2)
-			       (LAP (,op2%1 (ST ,',target) (ST 0))))
-			      (else
-			       (LAP (FLD (ST ,',source2))
-				    (,op2%1p (ST ,',(1+ target)) (ST 0))))))
-		       ((= target source2)
-			(cond ((zero? target)
-			       (LAP (,op2%1 (ST 0) (ST ,',source1))))
-			      ((zero? source1)
-			       (LAP (,op1%2 (ST ,',target) (ST 0))))
-			      (else
-			       (LAP (FLD (ST ,',source1))
-				    (,op1%2p (ST ,',(1+ target)) (ST 0))))))
-		       (else
-			(LAP (FLD (ST ,',source1))
-			     (,op1%2 (ST 0) (ST ,',(1+ source2)))
-			     (FSTP (ST ,',(1+ target)))))))))
-
-	    (define-arithmetic-method ',primitive-name flonum-methods/1%1-arg
-	      (flonum-unary-operation/general
-	       (lambda (target source)
-		 (if (= source target)
-		     (LAP (FLD1)
-			  (,op1%2p (ST ,',(1+ target)) (ST 0)))
-		     (LAP (FLD1)
-			  (,op1%2 (ST 0) (ST ,',(1+ source)))
-			  (FSTP (ST ,',(1+ target))))))))
-
-	    (define-arithmetic-method ',primitive-name flonum-methods/1-arg%1
-	      (flonum-unary-operation/general
-	       (lambda (target source)
-		 (if (= source target)
-		     (LAP (FLD1)
-			  (,op2%1p (ST ,',(1+ target)) (ST 0)))
-		     (LAP (FLD1)
-			  (,op2%1 (ST 0) (ST ,',(1+ source)))
-			  (FSTP (ST ,',(1+ target)))))))))))))
+       (sc-macro-transformer
+	(lambda (form environment)
+	  environment
+	  (let ((primitive-name (list-ref form 1))
+		(op1%2 (list-ref form 2))
+		(op1%2p (list-ref form 3))
+		(op2%1 (list-ref form 4))
+		(op2%1p (list-ref form 5)))
+	    `(begin
+	       (define-arithmetic-method ',primitive-name flonum-methods/2-args
+		 (flonum-binary-operation
+		  (lambda (target source1 source2)
+		    (cond ((= target source1)
+			   (cond ((zero? target)
+				  (LAP (,op1%2 (ST 0) (ST ,',source2))))
+				 ((zero? source2)
+				  (LAP (,op2%1 (ST ,',target) (ST 0))))
+				 (else
+				  (LAP (FLD (ST ,',source2))
+				       (,op2%1p (ST ,',(1+ target)) (ST 0))))))
+			  ((= target source2)
+			   (cond ((zero? target)
+				  (LAP (,op2%1 (ST 0) (ST ,',source1))))
+				 ((zero? source1)
+				  (LAP (,op1%2 (ST ,',target) (ST 0))))
+				 (else
+				  (LAP (FLD (ST ,',source1))
+				       (,op1%2p (ST ,',(1+ target)) (ST 0))))))
+			  (else
+			   (LAP (FLD (ST ,',source1))
+				(,op1%2 (ST 0) (ST ,',(1+ source2)))
+				(FSTP (ST ,',(1+ target)))))))))
+
+	       (define-arithmetic-method ',primitive-name
+		 flonum-methods/1%1-arg
+		 (flonum-unary-operation/general
+		  (lambda (target source)
+		    (if (= source target)
+			(LAP (FLD1)
+			     (,op1%2p (ST ,',(1+ target)) (ST 0)))
+			(LAP (FLD1)
+			     (,op1%2 (ST 0) (ST ,',(1+ source)))
+			     (FSTP (ST ,',(1+ target))))))))
+
+	       (define-arithmetic-method ',primitive-name
+		 flonum-methods/1-arg%1
+		 (flonum-unary-operation/general
+		  (lambda (target source)
+		    (if (= source target)
+			(LAP (FLD1)
+			     (,op2%1p (ST ,',(1+ target)) (ST 0)))
+			(LAP (FLD1)
+			     (,op2%1 (ST 0) (ST ,',(1+ source)))
+			     (FSTP (ST ,',(1+ target))))))))))))))
 
   (define-flonum-operation FLONUM-ADD FADD FADDP FADD FADDP)
   (define-flonum-operation FLONUM-SUBTRACT F%SUB F%SUBP F%SUBR F%SUBPR)
   (define-flonum-operation FLONUM-MULTIPLY FMUL FMULP FMUL FMULP)
   (define-flonum-operation FLONUM-DIVIDE F%DIV F%DIVP F%DIVR F%DIVPR))
-
+
 (define-arithmetic-method 'FLONUM-ATAN2 flonum-methods/2-args
   (lambda (target source1 source2)
     (if (and (not (machine-register? source1))
@@ -556,14 +565,13 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	(begin
 	  (prefix-instructions! (load-machine-register! source1 fr0))
 	  (need-register! fr0)
-	  (let ((source2 (if (= source2 source1)
-			     fr0
-			     (flonum-source! source2))))
+	  (let ((source2
+		 (if (= source2 source1) fr0 (flonum-source! source2))))
 	    (delete-dead-registers!)
 	    (rtl-target:=machine-register! target fr0)
 	    (LAP (FLD (ST ,source2))
 		 (FPATAN)))))))
-
+
 (define-arithmetic-method 'FLONUM-REMAINDER flonum-methods/2-args
   (flonum-binary-operation
    (lambda (target source1 source2)
@@ -590,7 +598,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 				 0
 				 target))))
 	      (FXCH (ST 0) (ST ,source2)))))))
-
+
 (define-rule statement
   (ASSIGN (REGISTER (? target))
 	  (FLONUM-2-ARGS FLONUM-SUBTRACT