#| -*-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
;;;; 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)
(5 #b00000))))
\f
(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)
(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))
\f
(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)
(vdepos ZVDEP 0))
\f
(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)
|#
\f
(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)
(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)
;; 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)
(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)
#| -*-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
;;;; 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
(LDI () ,code 28)))
\f
(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.
#| -*-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
\f
(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 &-)
#| -*-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
(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))
#| -*-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
(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))
(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)
(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)
#| -*-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
(declare (usual-integrations))
\f
-(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.
#| -*-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
(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
#| -*-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
\f
(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))))
(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)
#| -*-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
(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
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.
#| -*-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
(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 &*)
projects / mit-scheme.git / commitdiff