#| -*-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
\f
(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)
(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)
(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)
\f
(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)
(define-trivial-instruction INTO #xce)
(define-trivial-instruction INVD #x0f #x08) ; 486 only
(define-trivial-instruction IRET #xcf)
-
+\f
(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)))))))
-\f
+ (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)
(define-jump-instruction JPO #x7b #x8b)
(define-jump-instruction JS #x78 #x88)
(define-jump-instruction JZ #x74 #x84))
-
+\f
(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)
(((? dest r/mW))
(BYTE (8 #xff))
(ModR/M 4 dest))
-\f
+
((B (@PCR (? dest)))
(BYTE (8 #xeb)
(8 `(- ,dest (+ *PC* 1)) SIGNED)))
(BYTE (8 #xea))
(BYTE (16 seg))
(IMMEDIATE off ADDRESS)))
-
+\f
(define-trivial-instruction LAHF #x9f)
(define-instruction LAR
(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)
#| -*-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
(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)
(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))
\f
(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)
(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))
(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)
#| -*-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
\f
(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,
(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))
(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))
-
+\f
(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)
(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)
(define-trivial-instruction FLDLG2 #xd9 #xec)
(define-trivial-instruction FLDLN2 #xd9 #xed)
(define-trivial-instruction FLDZ #xd9 #xee)
-
+\f
(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)
(((R 0))
(BYTE (8 #xdf)
(8 #xe0))))
-
+\f
(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)
#| -*-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
(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
(LAP (MOV B (R ,eax) (& ,code))
,@(invoke-hook/call entry:compiler-scheme-to-interface/call)))
\f
-(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.
shortcircuit-apply-size-8
interrupt-continuation-2
conditionally-serialize))
-
+\f
;; Operation tables
(define (define-arithmetic-method operator methods method)
(for-each (lambda (edge)
(determine-interrupt-checks (edge-right-node edge)))
(rgraph-entry-edges rgraph)))
- rgraphs))
+ rgraphs))
\ No newline at end of file
#| -*-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
(POP (R ,eax))
(AND W (R ,eax) (R ,regnum:datum-mask)) ;clear type code
(JMP (R ,eax))))
-
+\f
(define-rule statement
(INVOCATION:LEXPR (? number-pushed) (? continuation) (? label))
continuation
(expect-no-exit-interrupt-checks)
(LAP ,@(clear-map!)
(JMP (@PCRO ,(free-uuo-link-label name frame-size) 3))))
-\f
+
(define-rule statement
(INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name))
continuation
(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))))))))
\f
(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!)
(define (optimized-primitive-invocation entry)
(LAP ,@(clear-map!)
,@(invoke-hook entry)))
-
+\f
;;; Invocation Prefixes
(define-rule statement
(INVOCATION-PREFIX:DYNAMIC-LINK 0 (REGISTER 4) (? any))
any ; ignored
(LAP))
-\f
+
(define-rule statement
(INVOCATION-PREFIX:MOVE-FRAME-UP
(? frame-size)
(expect-no-entry-interrupt-checks)
(make-external-label (continuation-code-word internal-label)
internal-label))
-
+\f
(define-rule statement
(CONTINUATION-HEADER (? internal-label))
#|
(define (make-closure-code-longword frame/min frame/max pc-offset)
(make-closure-longword (make-procedure-code-word frame/min frame/max)
pc-offset))
-
+\f
(define-rule statement
(CLOSURE-HEADER (? internal-label) (? nentries) (? entry))
(generate/closure-header internal-label nentries entry))
#| -*-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
#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))
#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))
(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))))))
(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)
(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?
\f
(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)
(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))
overflow? ; ignored
(require-register! ecx)
(two-arg-register-operation operate
- false
+ #f
target
source1
source2))))
(LAP))
(else
(LAP (AND W ,target (& ,(* n fixnum-1))))))))
-\f
+
(define-arithmetic-method 'FIXNUM-ANDC fixnum-methods/2-args-constant
(lambda (target n overflow?)
overflow? ; ignored
(else
(LAP (SHR W ,target (& ,(- 0 n)))
,@(word->fixnum target))))))
-
+\f
(define-rule statement
(ASSIGN (REGISTER (? target))
(FIXNUM->OBJECT
#| -*-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
(define flonum-methods/1-arg
(list 'FLONUM-METHODS/1-ARG))
-
+\f
;;; 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)
(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))
\f
(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))
-
+\f
(define-arithmetic-method 'FLONUM-ATAN2 flonum-methods/2-args
(lambda (target source1 source2)
(if (and (not (machine-register? source1))
(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)))))))
-\f
+
(define-arithmetic-method 'FLONUM-REMAINDER flonum-methods/2-args
(flonum-binary-operation
(lambda (target source1 source2)
0
target))))
(FXCH (ST 0) (ST ,source2)))))))
-
+\f
(define-rule statement
(ASSIGN (REGISTER (? target))
(FLONUM-2-ARGS FLONUM-SUBTRACT
projects / mit-scheme.git / commitdiff