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

Eliminate non-hygienic macros.
---

diff --git a/v7/src/compiler/machines/alpha/instr1.scm b/v7/src/compiler/machines/alpha/instr1.scm
index d2d62910a..dc058edd5 100644
--- a/v7/src/compiler/machines/alpha/instr1.scm
+++ b/v7/src/compiler/machines/alpha/instr1.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: instr1.scm,v 1.5 2001/12/20 21:45:24 cph Exp $
+$Id: instr1.scm,v 1.6 2002/02/22 02:57:23 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
@@ -31,26 +31,28 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (let-syntax
     ((memory-format-instruction
-      (lambda (keyword opcode)
-	`(define-instruction ,keyword
-	   (((? destination) (OFFSET (? offset) (? base)))
-	    (VARIABLE-WIDTH (offset offset)
-	      ((#x-8000 #x7FFF)
-	       (LONG (6 ,opcode)
-		     (5 destination)
-		     (5 base)
-		     (16 offset SIGNED)))
-	      ((#x-80000000 #x7FFFFFFF)
-	       ;; LDAH    temp, left[offset](base)
-	       ;; LDx/STx destination, right[offset](temp)
-	       (LONG (6 #x09)		; LDAH
-		     (5 regnum:volatile-scratch) ; destination = temp
-		     (5 base)		;   base
-		     (16 (adjusted:high offset) SIGNED)
-		     (6 ,opcode)	; LDx/STx
-		     (5 destination)	;   destination
-		     (5 regnum:volatile-scratch) ; base = temp
-		     (16 (adjusted:low offset) SIGNED)))))))))
+      (sc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 `(DEFINE-INSTRUCTION ,(cadr form)
+	    (((? destination) (OFFSET (? offset) (? base)))
+	     (VARIABLE-WIDTH (offset offset)
+	       ((#x-8000 #x7FFF)
+		(LONG (6 ,(caddr form))
+		      (5 destination)
+		      (5 base)
+		      (16 offset SIGNED)))
+	       ((#x-80000000 #x7FFFFFFF)
+		;; LDAH    temp, left[offset](base)
+		;; LDx/STx destination, right[offset](temp)
+		(LONG (6 #x09)		; LDAH
+		      (5 regnum:volatile-scratch) ; destination = temp
+		      (5 base)		;   base
+		      (16 (adjusted:high offset) SIGNED)
+		      (6 ,(caddr form))	; LDx/STx
+		      (5 destination)	;   destination
+		      (5 regnum:volatile-scratch) ; base = temp
+		      (16 (adjusted:low offset) SIGNED))))))))))
   (memory-format-instruction LDA #x08)	 ; Load Address
   (memory-format-instruction LDAH #x09)	 ; Load Address High
   (memory-format-instruction LDF #x20)	 ; Load F floating from memory
@@ -79,7 +81,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	 (5 destination)
 	 (5 regnum:zero)
 	 (16 constant SIGNED))))
-
+
 (define-instruction COPY
   (((? source) (? destination))
    (LONG (6 #x11)			; Arithmetic/Logical
@@ -92,29 +94,35 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
   
 (let-syntax
     ((special-memory-instruction
-      (lambda (keyword functioncode)
-	`(define-instruction ,keyword
-	   (()
-	    (LONG (6 #x18)
-		  (5 #x0)
-		  (5 #x0)
-		  (16 ,functioncode))))))
+      (sc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 `(DEFINE-INSTRUCTION ,(cadr form)
+	    (()
+	     (LONG (6 #x18)
+		   (5 #x0)
+		   (5 #x0)
+		   (16 ,(caddr form))))))))
      (special-memory-instruction-Ra
-      (lambda (keyword functioncode)
-	`(define-instruction ,keyword
-	   (((? Ra))
-	    (LONG (6 #x18)
-		  (5 Ra)
-		  (5 #x0)
-		  (16 ,functioncode))))))
+      (sc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 `(DEFINE-INSTRUCTION ,(cadr form)
+	    (((? Ra))
+	     (LONG (6 #x18)
+		   (5 Ra)
+		   (5 #x0)
+		   (16 ,(caddr form))))))))
      (special-memory-instruction-Rb
-      (lambda (keyword functioncode)
-	`(define-instruction ,keyword
-	   (((? Rb))
-	    (LONG (6 #x18)
-		  (5 #x0)
-		  (5 Rb)
-		  (16 ,functioncode)))))))
+      (sc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 `(DEFINE-INSTRUCTION ,(cadr form)
+	    (((? Rb))
+	     (LONG (6 #x18)
+		   (5 #x0)
+		   (5 Rb)
+		   (16 ,(caddr form)))))))))
   (special-memory-instruction DRAINT #x0000)	; Drain instruction pipe
   (special-memory-instruction-Rb FETCH #x8000)	; Prefetch data
   (special-memory-instruction-Rb FETCH_M #xA000); Prefetch data, modify intent
@@ -123,27 +131,29 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
   (special-memory-instruction-Ra RPCC #xC000)	; Read process cycle counter
   (special-memory-instruction-Ra RS #xF000)	; Read and set (VAX converter)
   (special-memory-instruction TRAPB #x0000)	; Trap barrier
-)
+  )
 
 (let-syntax
     ((operate-format
-      (lambda (keyword opcode functioncode)
-	`(define-instruction ,keyword
-	   (((? source-1) (& (? constant)) (? destination))
-	    (LONG (6 ,opcode)
-		  (5 source-1)
-		  (8 constant UNSIGNED)
-		  (1 1)			 ; Must be one
-		  (7 ,functioncode)
-		  (5 destination)))
-	   (((? source-1) (? source-2) (? destination))
-	    (LONG (6 ,opcode)
-		  (5 source-1)
-		  (5 source-2)
-		  (3 0)			; Should be zero
-		  (1 0)			; Must be zero
-		  (7 ,functioncode)
-		  (5 destination)))))))
+      (sc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 `(DEFINE-INSTRUCTION ,(cadr form)
+	    (((? source-1) (& (? constant)) (? destination))
+	     (LONG (6 ,(caddr form))
+		   (5 source-1)
+		   (8 constant UNSIGNED)
+		   (1 1)		; Must be one
+		   (7 ,(cadddr form))
+		   (5 destination)))
+	    (((? source-1) (? source-2) (? destination))
+	     (LONG (6 ,(caddr form))
+		   (5 source-1)
+		   (5 source-2)
+		   (3 0)		; Should be zero
+		   (1 0)		; Must be zero
+		   (7 ,(cadddr form))
+		   (5 destination))))))))
   (operate-format ADDL #x10 #x00)	 ; Add longword
   (operate-format ADDLV #x10 #x40)	 ; Add longword, enable oflow trap
   (operate-format ADDQ #x10 #x20)	 ; Add quadword
@@ -211,15 +221,17 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
   (operate-format XOR #x11 #x40)	 ; Logical difference (xor)
   (operate-format ZAP #x12 #x30)	 ; Zero bytes
   (operate-format ZAPNOT #x12 #x31)	 ; Zero bytes not
-)
-
+  )
+
 (let-syntax
     ((pal-format
-      (lambda (keyword functioncode)
-	`(define-instruction ,keyword
-	   (()
-	    (LONG (6 0)
-		  (26 ,functioncode)))))))
+      (sc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 `(DEFINE-INSTRUCTION ,(cadr form)
+	    (()
+	     (LONG (6 0)
+		   (26 ,(caddr form)))))))))
 
   (pal-format BPT #x0080)		 ; Initiate program debugging
   (pal-format BUGCHK #x0081)		 ; Initiate program exception
@@ -254,8 +266,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
   ;; Privileged PALcode instructions.
   (pal-format HALT #x0000)
-)
-
+  )
+
 ;;;; Assembler pseudo-ops
 
 (define-instruction EXTERNAL-LABEL
@@ -274,4 +286,4 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 (define-instruction UWORD
   ;; Directly insert 32 bit word into output stream
   (((? expression))
-   (LONG (32 expression UNSIGNED))))
+   (LONG (32 expression UNSIGNED))))
\ No newline at end of file
diff --git a/v7/src/compiler/machines/alpha/instr2.scm b/v7/src/compiler/machines/alpha/instr2.scm
index 59db1a7a0..4e16783ed 100644
--- a/v7/src/compiler/machines/alpha/instr2.scm
+++ b/v7/src/compiler/machines/alpha/instr2.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: instr2.scm,v 1.3 2001/12/20 21:45:24 cph Exp $
+$Id: instr2.scm,v 1.4 2002/02/22 03:01:31 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
@@ -27,97 +27,102 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (declare (usual-integrations))
 
-; Unconditional jump instructions
+;;; Unconditional jump instructions
+
 (let-syntax
     ((memory-branch
-      (lambda (keyword hint)
-	`(define-instruction ,keyword
-	   (((? link-register) (? base))
-	    (LONG (6 #x1a)
-		  (5 link-register)
-		  (5 base)
-		  (2 ,hint)
-		  (14 0 SIGNED)))
-	   (((? base))
-	    (LONG (6 #x1a)
-		  (5 regnum:came-from)
-		  (5 base)
-		  (2 ,hint)
-		  (14 0 SIGNED)))
-	   (((? link-register) (? base) (@PCR (? probable-target)))
-	    (LONG (6 #x1a)
-		  (5 link-register)
-		  (5 base)
-		  (2 ,hint)
-		  (14 `(/ (remainder (- ,probable-target (+ *PC* 4))
-				     #x10000)
-			  4)
-		      SIGNED)))
-	   (((? link-register) (? base) (@PCO (? probable-target-address)))
-	    (LONG (6 #x1a)
-		  (5 link-register)
-		  (5 base)
-		  (2 ,hint)
-		  (14 `(/ (remainder ,probable-target-address
-				     #x10000)
-			  4)
-		      SIGNED)))))))
+      (sc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 `(DEFINE-INSTRUCTION ,(cadr form)
+	    (((? link-register) (? base))
+	     (LONG (6 #x1a)
+		   (5 link-register)
+		   (5 base)
+		   (2 ,(caddr form))
+		   (14 0 SIGNED)))
+	    (((? base))
+	     (LONG (6 #x1a)
+		   (5 regnum:came-from)
+		   (5 base)
+		   (2 ,(caddr form))
+		   (14 0 SIGNED)))
+	    (((? link-register) (? base) (@PCR (? probable-target)))
+	     (LONG (6 #x1a)
+		   (5 link-register)
+		   (5 base)
+		   (2 ,(caddr form))
+		   (14 `(/ (remainder (- ,probable-target (+ *PC* 4))
+				      #x10000)
+			   4)
+		       SIGNED)))
+	    (((? link-register) (? base) (@PCO (? probable-target-address)))
+	     (LONG (6 #x1a)
+		   (5 link-register)
+		   (5 base)
+		   (2 ,(caddr form))
+		   (14 `(/ (remainder ,probable-target-address
+				      #x10000)
+			   4)
+		       SIGNED))))))))
   (memory-branch JMP #x0)
   (memory-branch JSR #x1)
   (memory-branch RET #x2)
   (memory-branch COROUTINE #x3))
-
-; Conditional branch instructions
+
+;;; Conditional branch instructions
 
 (let-syntax
     ((branch
-      (lambda (keyword opcode reverse-op)
-	`(define-instruction ,keyword
-	   (((? reg) (@PCO (? offset)))
-	    (LONG (6 ,opcode)
-		  (5 reg)
-		  (21 (quotient offset 4) SIGNED)))
-	   (((? reg) (@PCR (? label)))
-	    (VARIABLE-WIDTH (offset `(/ (- ,label (+ *PC* 4)) 4))
-	      ((#x-100000 #xFFFFF)
-	       (LONG (6 ,opcode)
-		     (5 reg)
-		     (21 offset SIGNED)))
-	      ((#x-1FFFFFFE #x20000001)
-	       ;; -1:      <reverse> xxx
-	       ;;  0:      LDAH   temp, left[4*(offset-2)](R31)
-	       ;; +1:      BR     link, yyy
-	       ;;  2: yyy: ADDQ   temp, link, temp
-	       ;;  3:      LDA    temp, right[4*(offset-2)](temp)
-	       ;;  4:      JMP    came_from, temp, hint
-	       ;;  5: xxx:
-	       (LONG (6 ,reverse-op)	; reverse branch to (.+1)+4
-		     (5 reg)            ;   register
-		     (21 5 SIGNED)	;   offset = +5 instructions
-	             (6 #x09)		; LDAH
-		     (5 regnum:assembler-temp) ; destination = temp
-		     (5 31)		;   base = zero
-		     (16 (adjusted:high (* (- offset 2) 4)) SIGNED)
-		     (6 #x30)		; BR
-		     (5 26)		;   return address to link
-		     (21 0 SIGNED)	;   (.+4) + 0
-		     (6 #x10)		; ADDQ
-		     (5 regnum:assembler-temp) ; source = temp
-		     (5 26)		;   source = link
-		     (3 0)		;   should be 0
-		     (1 0)		;   must be 0
-		     (7 #x20)		;   function=ADDQ
-		     (5 regnum:assembler-temp) ; destination = temp
-		     (6 #x08)		; LDA
-		     (5 regnum:assembler-temp) ; destination = temp
-		     (5 regnum:assembler-temp) ; base = temp
-		     (16 (adjusted:low (* (- offset 2) 4)) SIGNED)
-		     (6 #x1a)		; JMP
-		     (5 regnum:assembler-temp) ; return address to "came from"
-		     (5 regnum:assembler-temp) ; base = temp
-		     (2 #x0)		;   jump hint
-		     (14 (/ (adjusted:low (* (- offset 5) 4)) 4)
-			 SIGNED)))))))))
+      (sc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 `(DEFINE-INSTRUCTION ,(cadr form)
+	    (((? reg) (@PCO (? offset)))
+	     (LONG (6 ,(caddr form))
+		   (5 reg)
+		   (21 (quotient offset 4) SIGNED)))
+	    (((? reg) (@PCR (? label)))
+	     (VARIABLE-WIDTH (offset `(/ (- ,label (+ *PC* 4)) 4))
+	       ((#x-100000 #xFFFFF)
+		(LONG (6 ,(caddr form))
+		      (5 reg)
+		      (21 offset SIGNED)))
+	       ((#x-1FFFFFFE #x20000001)
+		;; -1:      <reverse> xxx
+		;;  0:      LDAH   temp, left[4*(offset-2)](R31)
+		;; +1:      BR     link, yyy
+		;;  2: yyy: ADDQ   temp, link, temp
+		;;  3:      LDA    temp, right[4*(offset-2)](temp)
+		;;  4:      JMP    came_from, temp, hint
+		;;  5: xxx:
+		(LONG (6 ,(cadddr form)) ; reverse branch to (.+1)+4
+		      (5 reg)		;   register
+		      (21 5 SIGNED)	;   offset = +5 instructions
+		      (6 #x09)		; LDAH
+		      (5 regnum:assembler-temp) ; destination = temp
+		      (5 31)		;   base = zero
+		      (16 (adjusted:high (* (- offset 2) 4)) SIGNED)
+		      (6 #x30)		; BR
+		      (5 26)		;   return address to link
+		      (21 0 SIGNED)	;   (.+4) + 0
+		      (6 #x10)		; ADDQ
+		      (5 regnum:assembler-temp) ; source = temp
+		      (5 26)		;   source = link
+		      (3 0)		;   should be 0
+		      (1 0)		;   must be 0
+		      (7 #x20)		;   function=ADDQ
+		      (5 regnum:assembler-temp) ; destination = temp
+		      (6 #x08)		; LDA
+		      (5 regnum:assembler-temp) ; destination = temp
+		      (5 regnum:assembler-temp) ; base = temp
+		      (16 (adjusted:low (* (- offset 2) 4)) SIGNED)
+		      (6 #x1a)		; JMP
+		      (5 regnum:assembler-temp) ; return address to "came from"
+		      (5 regnum:assembler-temp) ; base = temp
+		      (2 #x0)		;   jump hint
+		      (14 (/ (adjusted:low (* (- offset 5) 4)) 4)
+			  SIGNED))))))))))
   (branch beq #x39 #x3d)
   (branch bge #x3e #x3a)
   (branch bgt #x3f #x3b)
@@ -132,90 +137,92 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
   (branch fble #x33 #x37)
   (branch fblt #x32 #x36)
   (branch fbne #x35 #x31))
-
-; Unconditional branch instructions
+
+;;; Unconditional branch instructions
 
 (let-syntax
     ((unconditional-branch
-      (lambda (keyword opcode hint)
-	`(define-instruction ,keyword
-	   (((? reg) (@PCO (? offset)))
-	    (LONG (6 ,opcode)
-		  (5 reg)
-		  (21 (quotient offset 4) SIGNED)))
-	   (((? reg) (@PCR (? label)))
-	    (VARIABLE-WIDTH (offset `(/ (- ,label (+ *PC* 4)) 4))
-	      ((#x-100000 #xFFFFF)
-	       (LONG (6 ,opcode)
-		     (5 reg)
-		     (21 offset SIGNED)))
-	      ((#x-1FFFFFFF #x20000000)
-	       ;; -1:      LDAH   temp, left[4*(offset-1)](R31)
-	       ;;  0:      BR     link, yyy
-	       ;;  1: yyy: ADDQ   temp, link, temp
-	       ;;  2:      LDA    temp, right[4*(offset-1)](temp)
-	       ;;  3:      JMP    came_from, temp, hint
-	       ;;  4: xxx:
-	       (LONG (6 #x09)		; LDAH
-		     (5 regnum:assembler-temp) ; destination = temp
-		     (5 31)		;   base = zero
-		     (16 (adjusted:high (* (- offset 1) 4)) SIGNED)
-		     (6 #x30)		; BR
-		     (5 26)		;   return address to link
-		     (21 0 SIGNED)	;   (.+4) + 0
-		     (6 #x10)		; ADDQ
-		     (5 regnum:assembler-temp) ; source = temp
-		     (5 26)		;   source = link
-		     (3 0)		;   should be 0
-		     (1 0)		;   must be 0
-		     (7 #x20)		;   function=ADDQ
-		     (5 regnum:assembler-temp) ; destination = temp
-		     (6 #x08)		; LDA
-		     (5 regnum:assembler-temp) ; destination = temp
-		     (5 regnum:assembler-temp) ; base = temp
-		     (16 (adjusted:low (* (- offset 1) 4)) SIGNED)
-		     (6 #x1a)		; JMP
-		     (5 reg)		;   return address register
-		     (5 regnum:assembler-temp) ; base = temp
-		     (2 ,hint)		;   jump hint
-		     (14 (/ (adjusted:low (* (- offset 4) 4)) 4) SIGNED)))))
-	   (((? reg) (OFFSET (? offset) (@PCR (? label))))
-	    (VARIABLE-WIDTH (offset `(/ (- (+ ,offset ,label)
-					   (+ *PC* 4))
-					4))
-	      ((#x-100000 #xFFFFF)
-	       (LONG (6 ,opcode)
-		     (5 reg)
-		     (21 offset SIGNED)))
-	      ((#x-1FFFFFFF #x20000000)
-	       ;; -1:      LDAH   temp, left[4*(offset-1)](R31)
-	       ;;  0:      BR     link, yyy
-	       ;;  1: yyy: ADDQ   temp, link, temp
-	       ;;  2:      LDQ    temp, right[4*(offset-1)]
-	       ;;  2:      JMP    came_from, temp, hint
-	       (LONG (6 #x09)		; LDAH
-		     (5 regnum:assembler-temp) ; destination = temp
-		     (5 31)		;   base = zero
-		     (16 (adjusted:high (* (- offset 1) 4)) SIGNED)
-		     (6 #x30)		; BR
-		     (5 26)		;   return address to link
-		     (21 0 SIGNED)	;   (.+4) + 0
-		     (6 #x10)		; ADDQ
-		     (5 regnum:assembler-temp) ; source = temp
-		     (5 26)		;   source = link
-		     (3 0)		;   should be 0
-		     (1 0)		;   must be 0
-		     (7 #x20)		;   function=ADDQ
-		     (5 regnum:assembler-temp) ; destination = temp
-		     (6 #x08)		; LDA
-		     (5 regnum:assembler-temp) ; destination = temp
-		     (5 regnum:assembler-temp) ; base = temp
-		     (16 (adjusted:low (* (- offset 1) 4)) SIGNED)
-		     (6 #x1a)		; JMP
-		     (5 reg)		;   return address register
-		     (5 regnum:assembler-temp) ; base = temp
-		     (2 ,hint)		;   jump hint
-		     (14 (/ (adjusted:low (* (- offset 4) 4)) 4)
-			 SIGNED)))))))))
+      (sc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 `(DEFINE-INSTRUCTION ,(cadr form)
+	    (((? reg) (@PCO (? offset)))
+	     (LONG (6 ,(caddr form))
+		   (5 reg)
+		   (21 (quotient offset 4) SIGNED)))
+	    (((? reg) (@PCR (? label)))
+	     (VARIABLE-WIDTH (offset `(/ (- ,label (+ *PC* 4)) 4))
+	       ((#x-100000 #xFFFFF)
+		(LONG (6 ,(caddr form))
+		      (5 reg)
+		      (21 offset SIGNED)))
+	       ((#x-1FFFFFFF #x20000000)
+		;; -1:      LDAH   temp, left[4*(offset-1)](R31)
+		;;  0:      BR     link, yyy
+		;;  1: yyy: ADDQ   temp, link, temp
+		;;  2:      LDA    temp, right[4*(offset-1)](temp)
+		;;  3:      JMP    came_from, temp, hint
+		;;  4: xxx:
+		(LONG (6 #x09)		; LDAH
+		      (5 regnum:assembler-temp) ; destination = temp
+		      (5 31)		;   base = zero
+		      (16 (adjusted:high (* (- offset 1) 4)) SIGNED)
+		      (6 #x30)		; BR
+		      (5 26)		;   return address to link
+		      (21 0 SIGNED)	;   (.+4) + 0
+		      (6 #x10)		; ADDQ
+		      (5 regnum:assembler-temp) ; source = temp
+		      (5 26)		;   source = link
+		      (3 0)		;   should be 0
+		      (1 0)		;   must be 0
+		      (7 #x20)		;   function=ADDQ
+		      (5 regnum:assembler-temp) ; destination = temp
+		      (6 #x08)		; LDA
+		      (5 regnum:assembler-temp) ; destination = temp
+		      (5 regnum:assembler-temp) ; base = temp
+		      (16 (adjusted:low (* (- offset 1) 4)) SIGNED)
+		      (6 #x1a)		; JMP
+		      (5 reg)		;   return address register
+		      (5 regnum:assembler-temp) ; base = temp
+		      (2 ,(cadddr form)) ;   jump hint
+		      (14 (/ (adjusted:low (* (- offset 4) 4)) 4) SIGNED)))))
+	    (((? reg) (OFFSET (? offset) (@PCR (? label))))
+	     (VARIABLE-WIDTH (offset `(/ (- (+ ,offset ,label)
+					    (+ *PC* 4))
+					 4))
+	       ((#x-100000 #xFFFFF)
+		(LONG (6 ,(caddr form))
+		      (5 reg)
+		      (21 offset SIGNED)))
+	       ((#x-1FFFFFFF #x20000000)
+		;; -1:      LDAH   temp, left[4*(offset-1)](R31)
+		;;  0:      BR     link, yyy
+		;;  1: yyy: ADDQ   temp, link, temp
+		;;  2:      LDQ    temp, right[4*(offset-1)]
+		;;  2:      JMP    came_from, temp, hint
+		(LONG (6 #x09)		; LDAH
+		      (5 regnum:assembler-temp) ; destination = temp
+		      (5 31)		;   base = zero
+		      (16 (adjusted:high (* (- offset 1) 4)) SIGNED)
+		      (6 #x30)		; BR
+		      (5 26)		;   return address to link
+		      (21 0 SIGNED)	;   (.+4) + 0
+		      (6 #x10)		; ADDQ
+		      (5 regnum:assembler-temp) ; source = temp
+		      (5 26)		;   source = link
+		      (3 0)		;   should be 0
+		      (1 0)		;   must be 0
+		      (7 #x20)		;   function=ADDQ
+		      (5 regnum:assembler-temp) ; destination = temp
+		      (6 #x08)		; LDA
+		      (5 regnum:assembler-temp) ; destination = temp
+		      (5 regnum:assembler-temp) ; base = temp
+		      (16 (adjusted:low (* (- offset 1) 4)) SIGNED)
+		      (6 #x1a)		; JMP
+		      (5 reg)		;   return address register
+		      (5 regnum:assembler-temp) ; base = temp
+		      (2 ,(cadddr form)) ;   jump hint
+		      (14 (/ (adjusted:low (* (- offset 4) 4)) 4)
+			  SIGNED))))))))))
   (unconditional-branch br #x30 #x0)
-  (unconditional-branch bsr #x34 #x1))
+  (unconditional-branch bsr #x34 #x1))
\ No newline at end of file
diff --git a/v7/src/compiler/machines/alpha/instr3.scm b/v7/src/compiler/machines/alpha/instr3.scm
index a3b8d22b9..34eeb92d3 100644
--- a/v7/src/compiler/machines/alpha/instr3.scm
+++ b/v7/src/compiler/machines/alpha/instr3.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: instr3.scm,v 1.3 2001/12/20 21:45:24 cph Exp $
+$Id: instr3.scm,v 1.4 2002/02/22 03:03:31 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
@@ -44,14 +44,16 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (let-syntax
     ((floating-operate
-      (lambda (keyword function-code)
-	`(define-instruction ,keyword
-	   (((? src-1) (? src-2) (? dest))
-	    (LONG (6 #x17)		; Opcode
-		  (5 src-1)
-		  (5 src-2)
-		  (11 ,function-code)
-		  (5 dest)))))))
+      (sc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 `(DEFINE-INSTRUCTION ,(cadr form)
+	    (((? src-1) (? src-2) (? dest))
+	     (LONG (6 #x17)		; Opcode
+		   (5 src-1)
+		   (5 src-2)
+		   (11 ,(caddr form))
+		   (5 dest))))))))
   (floating-operate CPYS #x20)
   (floating-operate CPYSE #x22)
   (floating-operate CPYSN #x21)
@@ -67,23 +69,25 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
   (floating-operate FCMOVNE #x2b)
   (floating-operate MF_FPCR #x25)
   (floating-operate MT_FPCR #x24))
-
+
 (let-syntax
     ((ieee
-      (lambda (keyword function-code)
-	`(define-instruction ,keyword
-	   (((? src-1) (? src-2) (? dest))
-	    (LONG (6 #x16)		; Opcode
-		  (5 src-1)
-		  (5 src-2)
-		  (11 ,function-code)
-		  (5 dest)))
-	   ((/ (? qualifier) (? src-1) (? src-2) (? dest))
-	    (LONG (6 #x16)		; Opcode
-		  (5 src-1)
-		  (5 src-2)
-		  (11 (+ ,function-code (encode-fp-qualifier qualifier)))
-		  (5 dest)))))))
+      (sc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 `(DEFINE-INSTRUCTION ,(cadr form)
+	    (((? src-1) (? src-2) (? dest))
+	     (LONG (6 #x16)		; Opcode
+		   (5 src-1)
+		   (5 src-2)
+		   (11 ,(caddr form))
+		   (5 dest)))
+	    ((/ (? qualifier) (? src-1) (? src-2) (? dest))
+	     (LONG (6 #x16)		; Opcode
+		   (5 src-1)
+		   (5 src-2)
+		   (11 (+ ,(caddr form) (encode-fp-qualifier qualifier)))
+		   (5 dest))))))))
   (ieee ADDS #x80)
   (ieee ADDT #xA0)
   (ieee CMPTEQ #xA5)
@@ -103,20 +107,22 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (let-syntax
     ((vax
-      (lambda (keyword function-code)
-	`(define-instruction ,keyword
-	   (((? src-1) (? src-2) (? dest))
-	    (LONG (6 #x15)		; Opcode
-		  (5 src-1)
-		  (5 src-2)
-		  (11 ,function-code)
-		  (5 dest)))
-	   ((/ (? qualifier) (? src-1) (? src-2) (? dest))
-	    (LONG (6 #x15)		; Opcode
-		  (5 src-1)
-		  (5 src-2)
-		  (11 (+ ,function-code (encode-fp-qualifier qualifier)))
-		  (5 dest)))))))
+      (sc-macro-transformer
+       (lambda (form environment)
+	 environment
+	 `(DEFINE-INSTRUCTION ,(cadr form)
+	    (((? src-1) (? src-2) (? dest))
+	     (LONG (6 #x15)		; Opcode
+		   (5 src-1)
+		   (5 src-2)
+		   (11 ,(caddr form))
+		   (5 dest)))
+	    ((/ (? qualifier) (? src-1) (? src-2) (? dest))
+	     (LONG (6 #x15)		; Opcode
+		   (5 src-1)
+		   (5 src-2)
+		   (11 (+ ,(caddr form) (encode-fp-qualifier qualifier)))
+		   (5 dest))))))))
   (vax ADDF #x80)
   (vax ADDG #xa0)
   (vax CMPGEQ #xa5)
@@ -133,4 +139,4 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
   (vax MULF #xb2)
   (vax MULG #x81)
   (vax SUBF #x81)
-  (vax SUBG #xa1))
+  (vax SUBG #xa1))
\ No newline at end of file
diff --git a/v7/src/compiler/machines/alpha/lapgen.scm b/v7/src/compiler/machines/alpha/lapgen.scm
index bf18b80cf..5c2a942d9 100644
--- a/v7/src/compiler/machines/alpha/lapgen.scm
+++ b/v7/src/compiler/machines/alpha/lapgen.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: lapgen.scm,v 1.8 2001/12/20 21:45:24 cph Exp $
+$Id: lapgen.scm,v 1.9 2002/02/22 03:06:43 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
@@ -837,16 +837,18 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 ;;;; Codes and Hooks
 
 (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
@@ -859,39 +861,30 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
     set! define lookup-apply))
 
 (let-syntax ((define-codes
-	       (lambda (start . names)
-		 (define (loop names offset)
-		   (if (null? names)
-		       '()
-		       (cons `(DEFINE-INTEGRABLE
-				,(symbol-append 'ASSEMBLY-HOOK:
-						(car names))
-				,offset)
-			     (loop (cdr names) (+ 16 offset)))))
-		 `(BEGIN ,@(loop names start)))))
+	       (sc-macro-transformer
+		(lambda (start . names)
+		  `(BEGIN
+		     ,@(let loop ((names (cddr form)) (offset (cadr form)))
+			 (if (pair? names)
+			     (cons `(DEFINE-INTEGRABLE
+				      ,(symbol-append 'ASSEMBLY-HOOK:
+						      (car names))
+				      ,offset)
+				   (loop (cdr names) (+ offset 16)))
+			     '())))))))
   (define-codes #x0
     long-jump
     allocate-closure))
 
 (define (invoke-assembly-hook which-hook)
-  (LAP (LDA ,regnum:assembler-temp
-	    (OFFSET ,which-hook ,regnum:closure-hook))
-       (JSR ,regnum:assembler-temp ,regnum:assembler-temp
-	    (@PCO ,which-hook))))
+  (LAP (LDA ,regnum:assembler-temp (OFFSET ,which-hook ,regnum:closure-hook))
+       (JSR ,regnum:assembler-temp ,regnum:assembler-temp (@PCO ,which-hook))))
 
 (define-integrable (link-to-interface code)
   ;; Jump, with link in regnum:first-arg, to link_to_interface
   (LAP (MOVEI ,regnum:interface-index (& ,code))
        (JMP ,regnum:first-arg ,regnum:scheme-to-interface-jsr)))
 
-#| ;; Not actually needed ...
-(define-integrable (link-to-trampoline code)
-  ;; Jump, with link in 31, to trampoline_to_interface
-  (LAP (LDA   ,regnum:assembler-temp (OFFSET -96xxx ,regnum:scheme-to-interface))
-       (MOVEI ,regnum:interface-index (& ,code))
-       (JMP   ,regnum:linkage ,regnum:assembler-temp)))
-|#
-
 (define-integrable (invoke-interface code)
   ;; Jump to scheme-to-interface
   (LAP (MOVEI ,regnum:interface-index (& ,code))
@@ -916,7 +909,6 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	   ,@load-regs
 	   ,@(clear-map!)))))
 
-
 (define (pre-lapgen-analysis rgraphs)
   rgraphs
   unspecific)
\ No newline at end of file
diff --git a/v7/src/compiler/machines/alpha/rules3.scm b/v7/src/compiler/machines/alpha/rules3.scm
index ffaae1d9f..92356e69e 100644
--- a/v7/src/compiler/machines/alpha/rules3.scm
+++ b/v7/src/compiler/machines/alpha/rules3.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: rules3.scm,v 1.9 2001/12/20 21:45:24 cph Exp $
+$Id: rules3.scm,v 1.10 2002/02/22 03:07: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
@@ -156,18 +156,21 @@ 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
-	    ,(list 'LAP
-		   (list 'UNQUOTE-SPLICING '(CLEAR-MAP!))
-		   (list 'UNQUOTE-SPLICING
-			 `(INVOKE-INTERFACE
-			   ,(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
+	     ,(list 'LAP
+		    (list 'UNQUOTE-SPLICING '(CLEAR-MAP!))
+		    (list 'UNQUOTE-SPLICING
+			  `(INVOKE-INTERFACE
+			    ,(close-syntax (symbol-append 'CODE:COMPILER-
+							  (cadr form))
+					   environment)))))))))
   (define-special-primitive-invocation &+)
   (define-special-primitive-invocation &-)
   (define-special-primitive-invocation &*)
diff --git a/v7/src/compiler/machines/alpha/rulflo.scm b/v7/src/compiler/machines/alpha/rulflo.scm
index e1020d384..63253cb99 100644
--- a/v7/src/compiler/machines/alpha/rulflo.scm
+++ b/v7/src/compiler/machines/alpha/rulflo.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: rulflo.scm,v 1.5 2001/12/20 21:45:24 cph Exp $
+$Id: rulflo.scm,v 1.6 2002/02/22 03:10:15 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
@@ -199,10 +199,12 @@ the vector length header are the same size.
 
 (let-syntax
     ((define-flonum-operation
-       (lambda (primitive-name opcode)
-	 `(define-arithmetic-method ',primitive-name flonum-methods/2-args
-	    (lambda (target source1 source2)
-	      (LAP (,opcode ,',source1 ,',source2 ,',target)))))))
+       (sc-macro-transformer
+	(lambda (form environment)
+	  environment
+	  `(DEFINE-ARITHMETIC-METHOD ',(cadr form) FLONUM-METHODS/2-ARGS
+	     (LAMBDA (TARGET SOURCE1 SOURCE2)
+	       (LAP (,(caddr form) ,',SOURCE1 ,',SOURCE2 ,',TARGET))))))))
   (define-flonum-operation flonum-add ADDT)
   (define-flonum-operation flonum-subtract SUBT)
   (define-flonum-operation flonum-multiply MULT)
diff --git a/v7/src/compiler/machines/bobcat/assmd.scm b/v7/src/compiler/machines/bobcat/assmd.scm
index ed393b9bc..23572cc0f 100644
--- a/v7/src/compiler/machines/bobcat/assmd.scm
+++ b/v7/src/compiler/machines/bobcat/assmd.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: assmd.scm,v 1.38 2001/12/20 21:45:24 cph Exp $
+$Id: assmd.scm,v 1.39 2002/02/22 03:11:37 cph Exp $
 
-Copyright (c) 1988, 1989, 1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1988-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
@@ -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 16 bits
diff --git a/v7/src/compiler/machines/bobcat/dassm1.scm b/v7/src/compiler/machines/bobcat/dassm1.scm
index a6c191f08..dc6f6ae0d 100644
--- a/v7/src/compiler/machines/bobcat/dassm1.scm
+++ b/v7/src/compiler/machines/bobcat/dassm1.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: dassm1.scm,v 4.21 2001/12/20 21:45:24 cph Exp $
+$Id: dassm1.scm,v 4.22 2002/02/22 03:12:39 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/bobcat/dassm2.scm b/v7/src/compiler/machines/bobcat/dassm2.scm
index c2a18890d..74a4f165d 100644
--- a/v7/src/compiler/machines/bobcat/dassm2.scm
+++ b/v7/src/compiler/machines/bobcat/dassm2.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: dassm2.scm,v 4.24 2001/12/20 21:45:24 cph Exp $
+$Id: dassm2.scm,v 4.25 2002/02/22 03:13:42 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))))
@@ -154,10 +159,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)
diff --git a/v7/src/compiler/machines/bobcat/flinstr1.scm b/v7/src/compiler/machines/bobcat/flinstr1.scm
index ca64a2afd..02ee1a236 100644
--- a/v7/src/compiler/machines/bobcat/flinstr1.scm
+++ b/v7/src/compiler/machines/bobcat/flinstr1.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: flinstr1.scm,v 1.3 2001/12/20 21:45:24 cph Exp $
+$Id: flinstr1.scm,v 1.4 2002/02/22 03:14:49 cph Exp $
 
-Copyright (c) 1988, 1989, 1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1988-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
@@ -138,41 +138,42 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (let-syntax
     ((define-unary-flop
-       (lambda (name bits)
-	 `(define-instruction ,name
-
-	    (((? type float-source-format)
-	      (? source ea-d)
-	      (? destination float-reg))
-	     (WORD (4 #b1111)
-		   (3 FPC)
-		   (3 #b000)
-		   (6 source SOURCE-EA 'L))
-	     (EXTENSION-WORD (3 #b010)
-			     (3 type)
-			     (3 destination)
-			     (7 ,bits)))
-
-	    (((? source float-reg) (? destination float-reg))
-	     (WORD (4 #b1111)
-		   (3 FPC)
-		   (3 #b000)
-		   (6 #b000000))
-	     (EXTENSION-WORD (3 #b000)
-			     (3 source)
-			     (3 destination)
-			     (7 ,bits)))
-
-	    (((? reg float-reg))
-	     (WORD (4 #b1111)
-		   (3 FPC)
-		   (3 #b000)
-		   (6 #b000000))
+       (sc-macro-transformer
+	(lambda (form environment)
+	  environment
+	  `(DEFINE-INSTRUCTION ,(cadr form)
+
+	     (((? type float-source-format)
+	       (? source ea-d)
+	       (? destination float-reg))
+	      (WORD (4 #b1111)
+		    (3 FPC)
+		    (3 #b000)
+		    (6 source SOURCE-EA 'L))
+	      (EXTENSION-WORD (3 #b010)
+			      (3 type)
+			      (3 destination)
+			      (7 ,(caddr form))))
+
+	     (((? source float-reg) (? destination float-reg))
+	      (WORD (4 #b1111)
+		    (3 FPC)
+		    (3 #b000)
+		    (6 #b000000))
+	      (EXTENSION-WORD (3 #b000)
+			      (3 source)
+			      (3 destination)
+			      (7 ,(caddr form))))
+
+	     (((? reg float-reg))
+	      (WORD (4 #b1111)
+		    (3 FPC)
+		    (3 #b000)
+		    (6 #b000000))
 	      (EXTENSION-WORD (3 #b000)
 			      (3 reg)
 			      (3 reg)
-			      (7 ,bits)))))))
-
+			      (7 ,(caddr form)))))))))
   (define-unary-flop FABS	#b0011000)
   (define-unary-flop FACOS	#b0011100)
   (define-unary-flop FASIN	#b0001100)
diff --git a/v7/src/compiler/machines/bobcat/flinstr2.scm b/v7/src/compiler/machines/bobcat/flinstr2.scm
index 2f0471a30..e931541e3 100644
--- a/v7/src/compiler/machines/bobcat/flinstr2.scm
+++ b/v7/src/compiler/machines/bobcat/flinstr2.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: flinstr2.scm,v 1.3 2001/12/20 21:45:24 cph Exp $
+$Id: flinstr2.scm,v 1.4 2002/02/22 03:15:47 cph Exp $
 
-Copyright (c) 1988, 1989, 1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1988-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
@@ -27,31 +27,32 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (let-syntax
     ((define-binary-flop
-       (lambda (name bits)
-	 `(define-instruction ,name
+       (sc-macro-transformer
+	(lambda (form environment)
+	  environment
+	  `(DEFINE-INSTRUCTION ,(cadr form)
 
-	    (((? type float-source-format)
-	      (? source ea-d)
-	      (? destination float-reg))
-	     (WORD (4 #b1111)
-		   (3 FPC)
-		   (3 #b000)
-		   (6 source SOURCE-EA 'L))
-	     (EXTENSION-WORD (3 #b010)
-			     (3 type)
-			     (3 destination)
-			     (7 ,bits)))
-
-	    (((? source float-reg) (? destination float-reg))
-	     (WORD (4 #b1111)
-		   (3 FPC)
-		   (3 #b000)
-		   (6 #b000000))
-	     (EXTENSION-WORD (3 #b000)
-			     (3 source)
-			     (3 destination)
-			     (7 ,bits)))))))
+	     (((? type float-source-format)
+	       (? source ea-d)
+	       (? destination float-reg))
+	      (WORD (4 #b1111)
+		    (3 FPC)
+		    (3 #b000)
+		    (6 source SOURCE-EA 'L))
+	      (EXTENSION-WORD (3 #b010)
+			      (3 type)
+			      (3 destination)
+			      (7 ,(caddr form))))
 
+	     (((? source float-reg) (? destination float-reg))
+	      (WORD (4 #b1111)
+		    (3 FPC)
+		    (3 #b000)
+		    (6 #b000000))
+	      (EXTENSION-WORD (3 #b000)
+			      (3 source)
+			      (3 destination)
+			      (7 ,(caddr form)))))))))
   (define-binary-flop FADD	#b0100010)
   (define-binary-flop FCMP	#b0111000)
   (define-binary-flop FDIV	#b0100000)