#| -*-Scheme-*-
-$Id: instr3.scm,v 1.19 2001/12/20 21:45:24 cph Exp $
+$Id: instr3.scm,v 1.20 2002/02/22 03:27:42 cph Exp $
-Copyright (c) 1988, 1990, 1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1988, 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
(let-syntax
((define-branch-instruction
- (lambda (opcode prefix field . fall-through)
- `(define-instruction ,opcode
- ((,@prefix B (@PCO (? o)))
- (WORD ,@field
- (8 o SIGNED)))
-
- ((,@prefix B (@PCR (? l)))
- (WORD ,@field
- (8 l SHORT-LABEL)))
-
- ((,@prefix W (@PCO (? o)))
- (WORD ,@field
- (8 #b00000000))
- (immediate-word o))
-
- ((,@prefix W (@PCR (? l)))
- (WORD ,@field
- (8 #b00000000))
- (relative-word l))
-
- ;; 68020 only
-
- ((,@prefix L (@PCO (? o)))
- (WORD ,@field
- (8 #b11111111))
- (immediate-long o))
-
- ((,@prefix L (@PCR (? l)))
- (WORD ,@field
- (8 #b11111111))
- (relative-long l))
-\f
- ((,@prefix (@PCO (? o)))
- (GROWING-WORD (disp o)
- ((0 0)
- ,@fall-through)
- ((-128 127)
- (WORD ,@field
- (8 disp SIGNED)))
- ((-32768 32767)
- (WORD ,@field
- (8 #b00000000)
- (16 disp SIGNED)))
- ((() ())
- (WORD ,@field
- (8 #b11111111)
- (32 disp SIGNED)))))
-
- ((,@prefix (@PCR (? l)))
- (GROWING-WORD (disp `(- ,l (+ *PC* 2)))
- ((0 0)
- ,@fall-through)
- ((-128 127)
- (WORD ,@field
- (8 disp SIGNED)))
- ((-32768 32767)
- (WORD ,@field
- (8 #b00000000)
- (16 disp SIGNED)))
- ((() ())
- (WORD ,@field
- (8 #b11111111)
- (32 disp SIGNED)))))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ `(DEFINE-INSTRUCTION ,(cadr form)
+ ((,@(caddr form) B (@PCO (? o)))
+ (WORD ,@(cadddr form)
+ (8 o SIGNED)))
+
+ ((,@(caddr form) B (@PCR (? l)))
+ (WORD ,@(cadddr form)
+ (8 l SHORT-LABEL)))
+
+ ((,@(caddr form) W (@PCO (? o)))
+ (WORD ,@(cadddr form)
+ (8 #b00000000))
+ (immediate-word o))
+
+ ((,@(caddr form) W (@PCR (? l)))
+ (WORD ,@(cadddr form)
+ (8 #b00000000))
+ (relative-word l))
+
+ ;; 68020 only
+
+ ((,@(caddr form) L (@PCO (? o)))
+ (WORD ,@(cadddr form)
+ (8 #b11111111))
+ (immediate-long o))
+
+ ((,@(caddr form) L (@PCR (? l)))
+ (WORD ,@(cadddr form)
+ (8 #b11111111))
+ (relative-long l))
+
+ ((,@(caddr form) (@PCO (? o)))
+ (GROWING-WORD (disp o)
+ ((0 0)
+ ,@(cddddr form))
+ ((-128 127)
+ (WORD ,@(cadddr form)
+ (8 disp SIGNED)))
+ ((-32768 32767)
+ (WORD ,@(cadddr form)
+ (8 #b00000000)
+ (16 disp SIGNED)))
+ ((() ())
+ (WORD ,@(cadddr form)
+ (8 #b11111111)
+ (32 disp SIGNED)))))
+
+ ((,@(caddr form) (@PCR (? l)))
+ (GROWING-WORD (disp `(- ,l (+ *PC* 2)))
+ ((0 0)
+ ,@(cddddr form))
+ ((-128 127)
+ (WORD ,@(cadddr form)
+ (8 disp SIGNED)))
+ ((-32768 32767)
+ (WORD ,@(cadddr form)
+ (8 #b00000000)
+ (16 disp SIGNED)))
+ ((() ())
+ (WORD ,@(cadddr form)
+ (8 #b11111111)
+ (32 disp SIGNED))))))))))
(define-branch-instruction B ((? c cc)) ((4 #b0110) (4 c))
(WORD (16 #b0100111001110001)))
#| -*-Scheme-*-
-$Id: instr4.scm,v 1.5 2001/12/20 21:45:24 cph Exp $
+$Id: instr4.scm,v 1.6 2002/02/22 03:30:17 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-bitfield-manipulation-1
- (lambda (keyword bits ea-mode)
- `(define-instruction ,keyword
- (((? ea ,ea-mode) (& (? offset)) (& (? width)) (D (? reg)))
- (WORD (4 #b1110)
- (4 ,bits)
- (2 #b11)
- (6 ea DESTINATION-EA))
- (EXTENSION-WORD (1 #b0)
- (3 reg)
- (1 #b0)
- (5 offset)
- (1 #b0)
- (5 width BFWIDTH)))
-
- (((? ea ,ea-mode) (& (? offset)) (D (? r-width)) (D (? reg)))
- (WORD (4 #b1110)
- (4 ,bits)
- (2 #b11)
- (6 ea DESTINATION-EA))
- (EXTENSION-WORD (1 #b0)
- (3 reg)
- (1 #b0)
- (5 offset)
- (3 #b100)
- (3 r-width)))
-
- (((? ea ,ea-mode) (D (? r-offset)) (& (? width)) (D (? reg)))
- (WORD (4 #b1110)
- (4 ,bits)
- (2 #b11)
- (6 ea DESTINATION-EA))
- (EXTENSION-WORD (1 #b0)
- (3 reg)
- (3 #b100)
- (3 r-offset)
- (1 #b0)
- (5 width BFWIDTH)))
-
- (((? ea ,ea-mode) (D (? r-offset)) (D (? r-width)) (D (? reg)))
- (WORD (4 #b1110)
- (4 ,bits)
- (2 #b11)
- (6 ea DESTINATION-EA))
- (EXTENSION-WORD (1 #b0)
- (3 reg)
- (3 #b100)
- (3 r-offset)
- (3 #b100)
- (3 r-width)))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ `(DEFINE-INSTRUCTION ,(cadr form)
+ (((? ea ,(cadddr form)) (& (? offset)) (& (? width)) (D (? reg)))
+ (WORD (4 #b1110)
+ (4 ,(caddr form))
+ (2 #b11)
+ (6 ea DESTINATION-EA))
+ (EXTENSION-WORD (1 #b0)
+ (3 reg)
+ (1 #b0)
+ (5 offset)
+ (1 #b0)
+ (5 width BFWIDTH)))
+
+ (((? ea ,(cadddr form)) (& (? offset))
+ (D (? r-width))
+ (D (? reg)))
+ (WORD (4 #b1110)
+ (4 ,(caddr form))
+ (2 #b11)
+ (6 ea DESTINATION-EA))
+ (EXTENSION-WORD (1 #b0)
+ (3 reg)
+ (1 #b0)
+ (5 offset)
+ (3 #b100)
+ (3 r-width)))
+
+ (((? ea ,(cadddr form)) (D (? r-offset))
+ (& (? width))
+ (D (? reg)))
+ (WORD (4 #b1110)
+ (4 ,(caddr form))
+ (2 #b11)
+ (6 ea DESTINATION-EA))
+ (EXTENSION-WORD (1 #b0)
+ (3 reg)
+ (3 #b100)
+ (3 r-offset)
+ (1 #b0)
+ (5 width BFWIDTH)))
+
+ (((? ea ,(cadddr form)) (D (? r-offset))
+ (D (? r-width))
+ (D (? reg)))
+ (WORD (4 #b1110)
+ (4 ,(caddr form))
+ (2 #b11)
+ (6 ea DESTINATION-EA))
+ (EXTENSION-WORD (1 #b0)
+ (3 reg)
+ (3 #b100)
+ (3 r-offset)
+ (3 #b100)
+ (3 r-width))))))))
(define-bitfield-manipulation-1 BFEXTS #b1011 ea-d/c)
(define-bitfield-manipulation-1 BFEXTU #b1001 ea-d/c)
(let-syntax
((define-bitfield-manipulation-2
- (lambda (keyword bits ea-mode)
- `(define-instruction ,keyword
- (((? ea ,ea-mode) (& (? offset)) (& (? width)))
- (WORD (4 #b1110)
- (4 ,bits)
- (2 #b11)
- (6 ea DESTINATION-EA))
- (EXTENSION-WORD (4 #b0000)
- (1 #b0)
- (5 offset)
- (1 #b0)
- (5 width BFWIDTH)))
-
- (((? ea ,ea-mode) (& (? offset)) (D (? r-width)))
- (WORD (4 #b1110)
- (4 ,bits)
- (2 #b11)
- (6 ea DESTINATION-EA))
- (EXTENSION-WORD (4 #b0000)
- (1 #b0)
- (5 offset)
- (3 #b100)
- (3 r-width)))
-
- (((? ea ,ea-mode) (D (? r-offset)) (& (? width)))
- (WORD (4 #b1110)
- (4 ,bits)
- (2 #b11)
- (6 ea DESTINATION-EA))
- (EXTENSION-WORD (4 #b0000)
- (3 #b100)
- (3 r-offset)
- (1 #b0)
- (5 width BFWIDTH)))
-
- (((? ea ,ea-mode) (D (? r-offset)) (D (? r-width)))
- (WORD (4 #b1110)
- (4 ,bits)
- (2 #b11)
- (6 ea DESTINATION-EA))
- (EXTENSION-WORD (4 #b0000)
- (3 #b100)
- (3 r-offset)
- (3 #b100)
- (3 r-width)))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ `(DEFINE-INSTRUCTION ,(cadr form)
+ (((? ea ,(cadddr form)) (& (? offset)) (& (? width)))
+ (WORD (4 #b1110)
+ (4 ,(caddr form))
+ (2 #b11)
+ (6 ea DESTINATION-EA))
+ (EXTENSION-WORD (4 #b0000)
+ (1 #b0)
+ (5 offset)
+ (1 #b0)
+ (5 width BFWIDTH)))
+
+ (((? ea ,(cadddr form)) (& (? offset)) (D (? r-width)))
+ (WORD (4 #b1110)
+ (4 ,(caddr form))
+ (2 #b11)
+ (6 ea DESTINATION-EA))
+ (EXTENSION-WORD (4 #b0000)
+ (1 #b0)
+ (5 offset)
+ (3 #b100)
+ (3 r-width)))
+
+ (((? ea ,(cadddr form)) (D (? r-offset)) (& (? width)))
+ (WORD (4 #b1110)
+ (4 ,(caddr form))
+ (2 #b11)
+ (6 ea DESTINATION-EA))
+ (EXTENSION-WORD (4 #b0000)
+ (3 #b100)
+ (3 r-offset)
+ (1 #b0)
+ (5 width BFWIDTH)))
+
+ (((? ea ,(cadddr form)) (D (? r-offset)) (D (? r-width)))
+ (WORD (4 #b1110)
+ (4 ,(caddr form))
+ (2 #b11)
+ (6 ea DESTINATION-EA))
+ (EXTENSION-WORD (4 #b0000)
+ (3 #b100)
+ (3 r-offset)
+ (3 #b100)
+ (3 r-width))))))))
(define-bitfield-manipulation-2 BFCHG #b1010 ea-d/c&a)
(define-bitfield-manipulation-2 BFCLR #b1100 ea-d/c&a)
#| -*-Scheme-*-
-$Id: lapgen.scm,v 4.52 2001/12/20 21:45:24 cph Exp $
+$Id: lapgen.scm,v 4.53 2002/02/22 03:35:12 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
(let-syntax
((binary-fixnum
- (lambda (name instr identity?)
- `(begin
- (define-fixnum-method ',name fixnum-methods/2-args
- (lambda (target source)
- (LAP (,instr L ,',source ,',target))))
- (define-fixnum-method ',name fixnum-methods/2-args-constant
- (lambda (target n)
- (if (,identity? n)
- (LAP)
- (LAP (,instr L (& ,',(* n fixnum-1)) ,',target)))))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ `(BEGIN
+ (DEFINE-FIXNUM-METHOD ',(cadr form) FIXNUM-METHODS/2-ARGS
+ (LAMBDA (TARGET SOURCE)
+ (LAP (,(caddr form) L ,',SOURCE ,',TARGET))))
+ (DEFINE-FIXNUM-METHOD ',(cadr form) FIXNUM-METHODS/2-ARGS-CONSTANT
+ (LAMBDA (TARGET N)
+ (IF (,(cadddr form) N)
+ (LAP)
+ (LAP (,(caddr form) L
+ (& ,',(* N FIXNUM-1))
+ ,',TARGET))))))))))
(binary-fixnum PLUS-FIXNUM ADD zero?)
(binary-fixnum FIXNUM-OR OR zero?)
(let-syntax
((define-flonum-operation
- (lambda (primitive-name instruction-name)
- `(DEFINE-FLONUM-METHOD ',primitive-name FLONUM-METHODS/1-ARG
- (LAMBDA (SOURCE TARGET)
- (IF (EFFECTIVE-ADDRESS/FLOAT-REGISTER? SOURCE)
- (LAP (,instruction-name ,',source ,',target))
- (LAP (,instruction-name D ,',source ,',target))))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ `(DEFINE-FLONUM-METHOD ',(cadr form) FLONUM-METHODS/1-ARG
+ (LAMBDA (SOURCE TARGET)
+ (IF (EFFECTIVE-ADDRESS/FLOAT-REGISTER? SOURCE)
+ (LAP (,(caddr form) ,',SOURCE ,',TARGET))
+ (LAP (,(caddr form) D ,',SOURCE ,',TARGET)))))))))
(define-flonum-operation flonum-negate fneg)
(define-flonum-operation flonum-abs fabs)
(define-flonum-operation flonum-sin fsin)
(let-syntax
((define-flonum-operation
- (lambda (primitive-name instruction-name)
- `(DEFINE-FLONUM-METHOD ',primitive-name FLONUM-METHODS/2-ARGS
- (LAMBDA (TARGET SOURCE)
- (IF (EFFECTIVE-ADDRESS/FLOAT-REGISTER? SOURCE)
- (LAP (,instruction-name ,',source ,',target))
- (LAP (,instruction-name D ,',source ,',target))))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ `(DEFINE-FLONUM-METHOD ',(cadr form) FLONUM-METHODS/2-ARGS
+ (LAMBDA (TARGET SOURCE)
+ (IF (EFFECTIVE-ADDRESS/FLOAT-REGISTER? SOURCE)
+ (LAP (,(caddr form) ,',SOURCE ,',TARGET))
+ (LAP (,(caddr form) D ,',SOURCE ,',TARGET)))))))))
(define-flonum-operation flonum-add fadd)
(define-flonum-operation flonum-subtract fsub)
(define-flonum-operation flonum-multiply fmul)
(define-integrable reg:stack-guard (INST-EA (@AO 6 #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
quotient remainder modulo))
\f
(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 (@AO 6 ,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 (@AO 6 ,index)))
+ (loop (cdr names) (+ index 8)))
+ '())))))))
(define-entries #x40
scheme-to-interface ; Main entry point (only one necessary)
scheme-to-interface-jsr ; Used by rules3&4, for convenience.
#| -*-Scheme-*-
-$Id: machin.scm,v 4.33 2001/12/20 21:45:24 cph Exp $
+$Id: machin.scm,v 4.34 2002/02/22 03:36:54 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
(define-integrable MC68K/closure-format 'MC68040) ; or MC68020
-(let-syntax ((define/format-dependent
- (lambda (name)
- `(define ,name
- (case MC68K/closure-format
- ((MC68020)
- ,(intern
- (string-append "MC68020/" (symbol->string name))))
- ((MC68040)
- ,(intern
- (string-append "MC68040/" (symbol->string name))))
- (else
- (error "Unknown closure format" closure-format)))))))
+(let-syntax
+ ((define/format-dependent
+ (sc-macro-transformer
+ (lambda (form environment)
+ (let ((name (cadr form)))
+ `(DEFINE ,name
+ (CASE MC68K/CLOSURE-FORMAT
+ ((MC68020)
+ ,(close-syntax (symbol-append 'MC68020/ name) environment))
+ ((MC68040)
+ ,(close-syntax (symbol-append 'MC68040/ name) environment))
+ (ELSE
+ (ERROR "Unknown closure format" CLOSURE-FORMAT)))))))))
;; Given: the number of entry points in a closure, and a particular
;; entry point number, compute the distance from that entry point to
#| -*-Scheme-*-
-$Id: rules3.scm,v 4.42 2001/12/20 21:45:24 cph Exp $
+$Id: rules3.scm,v 4.43 2002/02/22 03:40:24 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 'ENTRY: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 'ENTRY:COMPILER- (cadr form))
+ environment)))))))
(define-optimized-primitive-invocation &+)
(define-optimized-primitive-invocation &-)
(vector->list entries)))))
(let-syntax ((define/format-dependent
- (lambda (name1 name2)
- `(define ,name1
- (case MC68K/closure-format
- ((MC68020)
- ,(intern
- (string-append "MC68020/" (symbol->string name2))))
- ((MC68040)
- ,(intern
- (string-append "MC68040/" (symbol->string name2))))
- (else
- (error "Unknown closure format" closure-format)))))))
+ (sc-macro-transformer
+ (lambda (form environment)
+ `(DEFINE ,(cadr form)
+ (CASE MC68K/CLOSURE-FORMAT
+ ((MC68020)
+ ,(close-syntax (symbol-append 'MC68020/ (caddr form))
+ environment))
+ ((MC68040)
+ ,(close-syntax (symbol-append 'MC68040/ (caddr form))
+ environment))
+ (ELSE
+ (ERROR "Unknown closure format:" CLOSURE-FORMAT))))))))
(define/format-dependent generate/closure-header closure-header)
(define/format-dependent generate/cons-closure cons-closure)
#| -*-Scheme-*-
-$Id: assmd.scm,v 1.4 2001/12/20 21:45:25 cph Exp $
+$Id: assmd.scm,v 1.5 2002/02/22 03:41:32 cph Exp $
-Copyright (c) 1988-1990, 1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1988-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
(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
;; Instruction length is always a multiple of 32 bits
#| -*-Scheme-*-
-$Id: dassm1.scm,v 1.6 2001/12/20 21:45:25 cph Exp $
+$Id: dassm1.scm,v 1.7 2002/02/22 03:42:37 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
(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 1.6 2001/12/20 21:45:25 cph Exp $
+$Id: dassm2.scm,v 1.7 2002/02/22 03:42: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
\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)
projects / mit-scheme.git / commitdiff