From 8c9654150dfe8a1aabcad30f8dc5f603c8981280 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 22 Feb 2002 05:07:18 +0000 Subject: [PATCH] Eliminate non-hygienic macros. --- v7/src/compiler/machines/spectrum/instr3.scm | 339 ++++++++++--------- v7/src/compiler/machines/spectrum/lapgen.scm | 48 +-- v7/src/compiler/machines/spectrum/rules3.scm | 69 ++-- v7/src/compiler/machines/spectrum/rulfix.scm | 49 +-- v7/src/compiler/machines/spectrum/rulflo.scm | 34 +- v7/src/compiler/machines/vax/assmd.scm | 10 +- v7/src/compiler/machines/vax/dassm1.scm | 9 +- v7/src/compiler/machines/vax/dassm2.scm | 26 +- v7/src/compiler/machines/vax/lapgen.scm | 48 +-- v7/src/compiler/machines/vax/rules3.scm | 43 +-- 10 files changed, 379 insertions(+), 296 deletions(-) diff --git a/v7/src/compiler/machines/spectrum/instr3.scm b/v7/src/compiler/machines/spectrum/instr3.scm index 4f4d10919..99f8397b1 100644 --- a/v7/src/compiler/machines/spectrum/instr3.scm +++ b/v7/src/compiler/machines/spectrum/instr3.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: instr3.scm,v 1.4 2001/12/20 21:45:25 cph Exp $ +$Id: instr3.scm,v 1.5 2002/02/22 04:45:53 cph Exp $ -Copyright (c) 1987, 1989, 1990, 1999, 2001 Massachusetts Institute of Technology +Copyright (c) 1987, 1989, 1990, 1999, 2001, 2002 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -28,17 +28,19 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;;;; Computation instructions (let-syntax ((arith-logical - (lambda (keyword extn) - `(define-instruction ,keyword - (((? compl complal) (? source-reg1) (? source-reg2) - (? target-reg)) - (LONG (6 #x02) - (5 source-reg2) - (5 source-reg1) - (3 (car compl)) - (1 (cadr compl)) - (7 ,extn) - (5 target-reg))))))) + (sc-macro-transformer + (lambda (form environment) + environment + `(DEFINE-INSTRUCTION ,(cadr form) + (((? compl complal) (? source-reg1) (? source-reg2) + (? target-reg)) + (LONG (6 #x02) + (5 source-reg2) + (5 source-reg1) + (3 (car compl)) + (1 (cadr compl)) + (7 ,(caddr form)) + (5 target-reg)))))))) (arith-logical ANDCM #x00) (arith-logical AND #x10) @@ -104,17 +106,19 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (5 #b00000)))) (let-syntax ((immed-arith - (lambda (keyword opcode extn) - `(define-instruction ,keyword - (((? compl complal) (? immed-11) (? source-reg) - (? target-reg)) - (LONG (6 ,opcode) - (5 source-reg) - (5 target-reg) - (3 (car compl)) - (1 (cadr compl)) - (1 ,extn) - (11 immed-11 RIGHT-SIGNED))))))) + (sc-macro-transformer + (lambda (form environment) + environment + `(DEFINE-INSTRUCTION ,(cadr form) + (((? compl complal) (? immed-11) (? source-reg) + (? target-reg)) + (LONG (6 ,(caddr form)) + (5 source-reg) + (5 target-reg) + (3 (car compl)) + (1 (cadr compl)) + (1 ,(cadddr form)) + (11 immed-11 RIGHT-SIGNED)))))))) (immed-arith ADDI #x2d 0) (immed-arith ADDIO #x2d 1) (immed-arith ADDIT #x2c 0) @@ -145,82 +149,95 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (5 (- 31 pos)) (5 target-reg)))) -(let-syntax ((extr (lambda (keyword extn) - `(define-instruction ,keyword - (((? compl compled) (? source-reg) (? pos) (? len) - (? target-reg)) - (LONG (6 #x34) - (5 source-reg) - (5 target-reg) - (3 compl) - (3 ,extn) - (5 pos) - (5 (- 32 len))))))) - (vextr (lambda (keyword extn) - `(define-instruction ,keyword - (((? compl compled) (? source-reg) (? len) - (? target-reg)) - (LONG (6 #x34) - (5 source-reg) - (5 target-reg) - (3 compl) - (3 ,extn) - (5 #b00000) - (5 (- 32 len)))))))) +(let-syntax ((extr + (sc-macro-transformer + (lambda (form environment) + environment + `(DEFINE-INSTRUCTION ,(cadr form) + (((? compl compled) (? source-reg) (? pos) (? len) + (? target-reg)) + (LONG (6 #x34) + (5 source-reg) + (5 target-reg) + (3 compl) + (3 ,(caddr form)) + (5 pos) + (5 (- 32 len)))))))) + (vextr + (sc-macro-transformer + (lambda (form environment) + environment + `(DEFINE-INSTRUCTION ,(cadr form) + (((? compl compled) (? source-reg) (? len) + (? target-reg)) + (LONG (6 #x34) + (5 source-reg) + (5 target-reg) + (3 compl) + (3 ,(caddr form)) + (5 #b00000) + (5 (- 32 len))))))))) (extr EXTRU 6) (extr EXTRS 7) (vextr VEXTRU 4) (vextr VEXTRS 5)) (let-syntax ((depos - (lambda (keyword extn) - `(define-instruction ,keyword - (((? compl compled) (? source-reg) (? pos) (? len) - (? target-reg)) - (LONG (6 #x35) - (5 target-reg) - (5 source-reg) - (3 compl) - (3 ,extn) - (5 (- 31 pos)) - (5 (- 32 len))))))) + (sc-macro-transformer + (lambda (form environment) + environment + `(DEFINE-INSTRUCTION ,(cadr form) + (((? compl compled) (? source-reg) (? pos) (? len) + (? target-reg)) + (LONG (6 #x35) + (5 target-reg) + (5 source-reg) + (3 compl) + (3 ,(caddr form)) + (5 (- 31 pos)) + (5 (- 32 len)))))))) (vdepos - (lambda (keyword extn) - `(define-instruction ,keyword - (((? compl compled) (? source-reg) (? len) - (? target-reg)) - (LONG (6 #x35) - (5 target-reg) - (5 source-reg) - (3 compl) - (3 ,extn) - (5 #b00000) - (5 (- 32 len))))))) + (sc-macro-transformer + (lambda (form environment) + environment + `(DEFINE-INSTRUCTION ,(cadr form) + (((? compl compled) (? source-reg) (? len) + (? target-reg)) + (LONG (6 #x35) + (5 target-reg) + (5 source-reg) + (3 compl) + (3 ,(caddr form)) + (5 #b00000) + (5 (- 32 len)))))))) (idepos - (lambda (keyword extn) - `(define-instruction ,keyword - (((? compl compled) (? immed) (? pos) (? len) - (? target-reg)) - (LONG (6 #x35) - (5 target-reg) - (5 immed RIGHT-SIGNED) - (3 compl) - (3 ,extn) - (5 (- 31 pos)) - (5 (- 32 len))))))) - + (sc-macro-transformer + (lambda (form environment) + environment + `(DEFINE-INSTRUCTION ,(cadr form) + (((? compl compled) (? immed) (? pos) (? len) + (? target-reg)) + (LONG (6 #x35) + (5 target-reg) + (5 immed RIGHT-SIGNED) + (3 compl) + (3 ,(caddr form)) + (5 (- 31 pos)) + (5 (- 32 len)))))))) (videpos - (lambda (keyword extn) - `(define-instruction ,keyword - (((? compl compled) (? immed) (? len) - (? target-reg)) - (LONG (6 #x35) - (5 target-reg) - (5 immed RIGHT-SIGNED) - (3 compl) - (3 ,extn) - (5 #b00000) - (5 (- 32 len)))))))) + (sc-macro-transformer + (lambda (form environment) + environment + `(DEFINE-INSTRUCTION ,(cadr form) + (((? compl compled) (? immed) (? len) + (? target-reg)) + (LONG (6 #x35) + (5 target-reg) + (5 immed RIGHT-SIGNED) + (3 compl) + (3 ,(caddr form)) + (5 #b00000) + (5 (- 32 len))))))))) (idepos DEPI 7) (idepos ZDEPI 6) @@ -232,17 +249,19 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (vdepos ZVDEP 0)) (let-syntax ((Probe-Read-Write - (lambda (keyword extn) - `(define-instruction ,keyword - ((() (OFFSET 0 (? space) (? base)) (? priv-reg) - (? target-reg)) - (LONG (6 1) - (5 base) - (5 priv-reg) - (2 space) - (8 ,extn) - (1 #b0) - (5 target-reg))))))) + (sc-macro-transformer + (lambda (form environment) + environment + `(DEFINE-INSTRUCTION ,(cadr form) + ((() (OFFSET 0 (? space) (? base)) (? priv-reg) + (? target-reg)) + (LONG (6 1) + (5 base) + (5 priv-reg) + (2 space) + (8 ,(caddr form)) + (1 #b0) + (5 target-reg)))))))) (Probe-Read-Write PROBER #x46) (Probe-Read-Write PROBEW #x47) (Probe-Read-Write PROBERI #xc6) @@ -333,30 +352,34 @@ DIAG |# (let-syntax ((floatarith-1 - (lambda (keyword extn-a extn-b) - `(define-instruction ,keyword - ((((? fmt fpformat)) (? source-reg) (? target-reg)) - (LONG (6 #x0c) - (5 source-reg) - (5 #b00000) - (3 ,extn-a) - (2 fmt) - (2 ,extn-b) - (4 #b0000) - (5 target-reg)))))) + (sc-macro-transformer + (lambda (form environment) + environment + `(DEFINE-INSTRUCTION ,(cadr form) + ((((? fmt fpformat)) (? source-reg) (? target-reg)) + (LONG (6 #x0c) + (5 source-reg) + (5 #b00000) + (3 ,(caddr form)) + (2 fmt) + (2 ,(cadddr form)) + (4 #b0000) + (5 target-reg))))))) (floatarith-2 - (lambda (keyword extn-a extn-b) - `(define-instruction ,keyword - ((((? fmt fpformat)) (? source-reg1) (? source-reg2) - (? target-reg)) - (LONG (6 #x0c) - (5 source-reg1) - (5 source-reg2) - (3 ,extn-a) - (2 fmt) - (2 ,extn-b) - (4 #b0000) - (5 target-reg))))))) + (sc-macro-transformer + (lambda (form environment) + environment + `(DEFINE-INSTRUCTION ,(cadr form) + ((((? fmt fpformat)) (? source-reg1) (? source-reg2) + (? target-reg)) + (LONG (6 #x0c) + (5 source-reg1) + (5 source-reg2) + (3 ,(caddr form)) + (2 fmt) + (2 ,(cadddr form)) + (4 #b0000) + (5 target-reg)))))))) (floatarith-2 FADD 0 3) (floatarith-2 FSUB 1 3) @@ -379,19 +402,21 @@ DIAG (5 condition)))) (let-syntax ((fpconvert - (lambda (keyword extn) - `(define-instruction ,keyword - ((((? sf fpformat) (? df fpformat)) - (? source-reg1) - (? reg-t)) - (LONG (6 #x0c) - (5 source-reg1) - (4 #b0000) - (2 ,extn) - (2 df) - (2 sf) - (6 #b010000) - (5 reg-t))))))) + (sc-macro-transformer + (lambda (form environment) + environment + `(DEFINE-INSTRUCTION ,(cadr form) + ((((? sf fpformat) (? df fpformat)) + (? source-reg1) + (? reg-t)) + (LONG (6 #x0c) + (5 source-reg1) + (4 #b0000) + (2 ,(caddr form)) + (2 df) + (2 sf) + (6 #b010000) + (5 reg-t)))))))) (fpconvert FCNVFF 0) (fpconvert FCNVFX 1) (fpconvert FCNVXF 2) @@ -410,14 +435,16 @@ DIAG ;; tested before use. WLH 11/18/86 (let-syntax ((multdiv - (lambda (keyword extn) - `(define-instruction ,keyword - ((() (? reg-1) (? reg-2)) - (LONG (6 #x04) - (5 reg-2) - (5 reg-1) - (5 ,extn) - (11 #b11000000000))))))) + (sc-macro-transformer + (lambda (form environment) + environment + `(DEFINE-INSTRUCTION ,(cadr form) + ((() (? reg-1) (? reg-2)) + (LONG (6 #x04) + (5 reg-2) + (5 reg-1) + (5 ,(caddr form)) + (11 #b11000000000)))))))) (multdiv MPYS #x08) (multdiv MPYU #x0a) (multdiv MPYSCV #x0c) @@ -440,15 +467,17 @@ DIAG (16 #b1000000000000000)))) (let-syntax ((multdivresult - (lambda (keyword extn-a extn-b) - `(define-instruction ,keyword - ((() (? reg-t)) - (LONG (6 #x04) - (10 #b0000000000) - (5 ,extn-a) - (5 #b01000) - (1 ,extn-b) - (5 reg-t))))))) + (sc-macro-transformer + (lambda (form environment) + environment + `(DEFINE-INSTRUCTION ,(cadr form) + ((() (? reg-t)) + (LONG (6 #x04) + (10 #b0000000000) + (5 ,(caddr form)) + (5 #b01000) + (1 ,(cadddr form)) + (5 reg-t)))))))) (multdivresult MDLO 4 0) (multdivresult MDLNV 4 1) (multdivresult MDLV 5 1) diff --git a/v7/src/compiler/machines/spectrum/lapgen.scm b/v7/src/compiler/machines/spectrum/lapgen.scm index 3f3b3d2a4..af12f273e 100644 --- a/v7/src/compiler/machines/spectrum/lapgen.scm +++ b/v7/src/compiler/machines/spectrum/lapgen.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: lapgen.scm,v 4.49 2001/12/20 21:45:25 cph Exp $ +$Id: lapgen.scm,v 4.50 2002/02/22 04:48:52 cph Exp $ -Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology +Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -592,16 +592,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 @@ -629,16 +631,18 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (LDI () ,code 28))) (let-syntax ((define-hooks - (lambda (start . names) - (define (loop names index) - (if (null? names) - '() - (cons `(DEFINE-INTEGRABLE - ,(symbol-append 'HOOK:COMPILER- - (car names)) - ,index) - (loop (cdr names) (+ 8 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 'HOOK:COMPILER- + (car names)) + ,index) + (loop (cdr names) (+ index 8))) + '()))))))) (define-hooks 100 store-closure-code store-closure-entry ; newer version of store-closure-code. diff --git a/v7/src/compiler/machines/spectrum/rules3.scm b/v7/src/compiler/machines/spectrum/rules3.scm index 5596b2691..f26ab1f15 100644 --- a/v7/src/compiler/machines/spectrum/rules3.scm +++ b/v7/src/compiler/machines/spectrum/rules3.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: rules3.scm,v 4.43 2001/12/20 21:45:25 cph Exp $ +$Id: rules3.scm,v 4.44 2002/02/22 04:52:22 cph Exp $ -Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology +Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -170,38 +170,47 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((define-special-primitive-invocation - (lambda (name) - `(define-rule statement - (INVOCATION:SPECIAL-PRIMITIVE - (? frame-size) - (? continuation) - ,(make-primitive-procedure name true)) - frame-size continuation - (special-primitive-invocation - ,(symbol-append 'CODE:COMPILER- name))))) + (sc-macro-transformer + (lambda (form environment) + `(DEFINE-RULE STATEMENT + (INVOCATION:SPECIAL-PRIMITIVE + (? frame-size) + (? continuation) + ,(make-primitive-procedure (cadr form) #t)) + FRAME-SIZE CONTINUATION + (SPECIAL-PRIMITIVE-INVOCATION + ,(close-syntax (symbol-append 'CODE:COMPILER- (cadr form)) + environment)))))) (define-optimized-primitive-invocation - (lambda (name) - `(define-rule statement - (INVOCATION:SPECIAL-PRIMITIVE - (? frame-size) - (? continuation) - ,(make-primitive-procedure name true)) - frame-size continuation - (optimized-primitive-invocation - ,(symbol-append 'HOOK:COMPILER- name))))) + (sc-macro-transformer + (lambda (form environment) + `(DEFINE-RULE STATEMENT + (INVOCATION:SPECIAL-PRIMITIVE + (? frame-size) + (? continuation) + ,(make-primitive-procedure (cadr form) #t)) + FRAME-SIZE CONTINUATION + (OPTIMIZED-PRIMITIVE-INVOCATION + ,(close-syntax (symbol-append 'HOOK:COMPILER- (cadr form)) + environment)))))) (define-allocation-primitive - (lambda (name) - (let ((prim (make-primitive-procedure name true))) - `(define-rule statement - (INVOCATION:SPECIAL-PRIMITIVE - (? frame-size) - (? continuation) - ,prim) - (open-code-block-allocation ',name ',prim - ,(symbol-append 'HOOK:COMPILER- name) - frame-size continuation)))))) + (sc-macro-transformer + (lambda (form environment) + (let ((prim (make-primitive-procedure (cadr form) #t))) + `(DEFINE-RULE STATEMENT + (INVOCATION:SPECIAL-PRIMITIVE + (? frame-size) + (? continuation) + ,prim) + (OPEN-CODE-BLOCK-ALLOCATION + ',(cadr form) + ',prim + ,(close-syntax (symbol-append 'HOOK:COMPILER- (cadr form)) + environment) + FRAME-SIZE + CONTINUATION))))))) (define-optimized-primitive-invocation &+) (define-optimized-primitive-invocation &-) diff --git a/v7/src/compiler/machines/spectrum/rulfix.scm b/v7/src/compiler/machines/spectrum/rulfix.scm index e38171462..7f0dc4c88 100644 --- a/v7/src/compiler/machines/spectrum/rulfix.scm +++ b/v7/src/compiler/machines/spectrum/rulfix.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: rulfix.scm,v 4.49 2001/12/20 21:45:25 cph Exp $ +$Id: rulfix.scm,v 4.50 2002/02/22 04:56:28 cph Exp $ -Copyright (c) 1989-1999, 2001 Massachusetts Institute of Technology +Copyright (c) 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 @@ -189,29 +189,36 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((unary-fixnum - (lambda (name instr nsv fixed-operand) - `(define-arithmetic-method ',name fixnum-methods/1-arg - (lambda (tgt src overflow?) - (if overflow? - (LAP (,instr (,nsv) ,fixed-operand ,',src ,',tgt)) - (LAP (,instr () ,fixed-operand ,',src ,',tgt))))))) + (sc-macro-transformer + (lambda (form environment) + environment + `(DEFINE-ARITHMETIC-METHOD ',(cadr form) FIXNUM-METHODS/1-ARG + (LAMBDA (TGT SRC OVERFLOW?) + (IF OVERFLOW? + (LAP (,(caddr form) (,(cadddr form)) + ,(list-ref form 4) ,',SRC ,',TGT)) + (LAP (,(caddr form) () ,fixed-operand ,',SRC ,',TGT)))))))) (binary-fixnum - (lambda (name instr nsv) - `(define-arithmetic-method ',name fixnum-methods/2-args - (lambda (tgt src1 src2 overflow?) - (if overflow? - (LAP (,instr (,nsv) ,',src1 ,',src2 ,',tgt)) - (LAP (,instr () ,',src1 ,',src2 ,',tgt))))))) + (sc-macro-transformer + (lambda (form environment) + environment + `(DEFINE-ARITHMETIC-METHOD ',(cadr form) FIXNUM-METHODS/2-ARGS + (LAMBDA (TGT SRC1 SRC2 OVERFLOW?) + (IF OVERFLOW? + (LAP (,(caddr form) (,(cadddr form)) ,',SRC1 ,',SRC2 ,',TGT)) + (LAP (,(caddr form) () ,',SRC1 ,',SRC2 ,',TGT)))))))) (binary-out-of-line - (lambda (name . regs) - `(define-arithmetic-method ',name fixnum-methods/2-args/special - (cons ,(symbol-append 'HOOK:COMPILER- name) - (lambda () - ,(if (null? regs) - `(LAP) - `(require-registers! ,@regs)))))))) + (sc-macro-transformer + (lambda (form environment) + environment + `(DEFINE-ARITHMETIC-METHOD ',(cadr form) FIXNUM-METHODS/2-ARGS/SPECIAL + (CONS ,(symbol-append 'HOOK:COMPILER- (cadr form)) + (LAMBDA () + ,(if (null? (cddr form)) + `(LAP) + `(REQUIRE-REGISTERS! ,@(cddr form)))))))))) (unary-fixnum ONE-PLUS-FIXNUM ADDI NSV ,fixnum-1) (unary-fixnum MINUS-ONE-PLUS-FIXNUM ADDI NSV ,(- fixnum-1)) diff --git a/v7/src/compiler/machines/spectrum/rulflo.scm b/v7/src/compiler/machines/spectrum/rulflo.scm index 0f96231bb..6dca42458 100644 --- a/v7/src/compiler/machines/spectrum/rulflo.scm +++ b/v7/src/compiler/machines/spectrum/rulflo.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: rulflo.scm,v 4.41 2001/12/20 21:45:25 cph Exp $ +$Id: rulflo.scm,v 4.42 2002/02/22 04:58:51 cph Exp $ -Copyright (c) 1989-1999, 2001 Massachusetts Institute of Technology +Copyright (c) 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 @@ -361,10 +361,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((define-flonum-operation - (lambda (primitive-name opcode) - `(define-arithmetic-method ',primitive-name flonum-methods/1-arg - (lambda (target source) - (LAP (,opcode (DBL) ,',source ,',target))))))) + (sc-macro-transformer + (lambda (form environment) + environment + `(DEFINE-ARITHMETIC-METHOD ',(cadr form) FLONUM-METHODS/1-ARG + (LAMBDA (TARGET SOURCE) + (LAP (,(caddr form) (DBL) ,',SOURCE ,',TARGET)))))))) (define-flonum-operation FLONUM-ABS FABS) (define-flonum-operation FLONUM-SQRT FSQRT) (define-flonum-operation FLONUM-ROUND FRND)) @@ -387,9 +389,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (list 'FLONUM-METHODS/1-ARG/SPECIAL)) (let-syntax ((define-out-of-line - (lambda (name) - `(define-arithmetic-method ',name flonum-methods/1-arg/special - ,(symbol-append 'HOOK:COMPILER- name))))) + (sc-macro-transformer + (lambda (form environment) + `(DEFINE-ARITHMETIC-METHOD ',(cadr form) + FLONUM-METHODS/1-ARG/SPECIAL + ,(close-syntax (symbol-append 'HOOK:COMPILER- (cadr form)) + environment)))))) (define-out-of-line FLONUM-SIN) (define-out-of-line FLONUM-COS) (define-out-of-line FLONUM-TAN) @@ -475,10 +480,13 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((define-flonum-operation - (lambda (primitive-name opcode) - `(define-arithmetic-method ',primitive-name flonum-methods/2-args - (lambda (target source1 source2) - (LAP (,opcode (DBL) ,',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) (DBL) + ,',SOURCE1 ,',SOURCE2 ,',TARGET)))))))) (define-flonum-operation flonum-add fadd) (define-flonum-operation flonum-subtract fsub) (define-flonum-operation flonum-multiply fmpy) diff --git a/v7/src/compiler/machines/vax/assmd.scm b/v7/src/compiler/machines/vax/assmd.scm index c99c53c0d..290c42ad0 100644 --- a/v7/src/compiler/machines/vax/assmd.scm +++ b/v7/src/compiler/machines/vax/assmd.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: assmd.scm,v 4.8 2001/12/20 21:45:25 cph Exp $ +$Id: assmd.scm,v 4.9 2002/02/22 05:01:07 cph Exp $ -Copyright (c) 1987, 1989, 1991, 1999, 2001 Massachusetts Institute of Technology +Copyright (c) 1987, 1989, 1991, 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 ;; Instructions can be any number of bytes long. diff --git a/v7/src/compiler/machines/vax/dassm1.scm b/v7/src/compiler/machines/vax/dassm1.scm index 2812d1ef9..79b789888 100644 --- a/v7/src/compiler/machines/vax/dassm1.scm +++ b/v7/src/compiler/machines/vax/dassm1.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: dassm1.scm,v 4.8 2001/12/20 21:45:25 cph Exp $ +$Id: dassm1.scm,v 4.9 2002/02/22 05:01:36 cph Exp $ -Copyright (c) 1987-1999, 2001 Massachusetts Institute of Technology +Copyright (c) 1987-1999, 2001, 2002 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -123,7 +123,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/vax/dassm2.scm b/v7/src/compiler/machines/vax/dassm2.scm index 452f19ad1..1ec80c94b 100644 --- a/v7/src/compiler/machines/vax/dassm2.scm +++ b/v7/src/compiler/machines/vax/dassm2.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: dassm2.scm,v 4.14 2001/12/20 21:45:25 cph Exp $ +$Id: dassm2.scm,v 4.15 2002/02/22 05:03:14 cph Exp $ -Copyright (c) 1987-1999, 2001 Massachusetts Institute of Technology +Copyright (c) 1987-1999, 2001, 2002 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -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)))) @@ -187,10 +192,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/vax/lapgen.scm b/v7/src/compiler/machines/vax/lapgen.scm index 4f209782f..d6d9120ff 100644 --- a/v7/src/compiler/machines/vax/lapgen.scm +++ b/v7/src/compiler/machines/vax/lapgen.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: lapgen.scm,v 4.17 2001/12/20 21:45:25 cph Exp $ +$Id: lapgen.scm,v 4.18 2002/02/22 05:04:57 cph Exp $ -Copyright (c) 1987-1999, 2001 Massachusetts Institute of Technology +Copyright (c) 1987-1999, 2001, 2002 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -535,16 +535,18 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-integrable reg:stack-guard (INST-EA (@RO B 10 #x002C))) (let-syntax ((define-codes - (lambda (start . names) - (define (loop names index) - (if (null? names) - '() - (cons `(DEFINE-INTEGRABLE - ,(symbol-append 'CODE:COMPILER- - (car names)) - ,index) - (loop (cdr names) (1+ index))))) - `(BEGIN ,@(loop names start))))) + (sc-macro-transformer + (lambda (form environment) + environment + `(BEGIN + ,@(let loop ((names (cddr form)) (index (cadr form))) + (if (pair? names) + (cons `(DEFINE-INTEGRABLE + ,(symbol-append 'CODE:COMPILER- + (car names)) + ,index) + (loop (cdr names) (+ index 1))) + '()))))))) (define-codes #x012 primitive-apply primitive-lexpr-apply apply error lexpr-apply link @@ -557,16 +559,18 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA set! define lookup-apply)) (let-syntax ((define-entries - (lambda (start . names) - (define (loop names index) - (if (null? names) - '() - (cons `(DEFINE-INTEGRABLE - ,(symbol-append 'ENTRY:COMPILER- - (car names)) - (INST-EA (@RO B 10 ,index))) - (loop (cdr names) (+ index 8))))) - `(BEGIN ,@(loop names start))))) + (sc-macro-transformer + (lambda (form environment) + environment + `(BEGIN + ,@(let loop ((names (cddr form)) (index (cadr form))) + (if (pair? names) + (cons `(DEFINE-INTEGRABLE + ,(symbol-append 'ENTRY:COMPILER- + (car names)) + (INST-EA (@RO B 10 ,index))) + (loop (cdr names) (+ index 8))) + '()))))))) (define-entries #x40 scheme-to-interface ; Main entry point (only one necessary) scheme-to-interface-jsb ; Used by rules3&4, for convenience. diff --git a/v7/src/compiler/machines/vax/rules3.scm b/v7/src/compiler/machines/vax/rules3.scm index 55be738a3..a090090cb 100644 --- a/v7/src/compiler/machines/vax/rules3.scm +++ b/v7/src/compiler/machines/vax/rules3.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: rules3.scm,v 4.13 2001/12/20 21:45:26 cph Exp $ +$Id: rules3.scm,v 4.14 2002/02/22 05:07:18 cph Exp $ -Copyright (c) 1987-1999, 2001 Massachusetts Institute of Technology +Copyright (c) 1987-1999, 2001, 2002 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -164,23 +164,28 @@ 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 ; ignored - ,(list 'LAP - (list 'UNQUOTE-SPLICING '(clear-map!)) - #| - (list 'JMP - (list 'UNQUOTE - (symbol-append 'ENTRY:COMPILER- name))) - |# - (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 ; ignored + ,(list 'LAP + (list 'UNQUOTE-SPLICING '(CLEAR-MAP!)) + #| + (list 'JMP + (list 'UNQUOTE + (close-syntax (symbol-append 'ENTRY:COMPILER- + (cadr form)) + environment))) + |# + (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 &*) -- 2.25.1