From: Chris Hanson Date: Sat, 16 Feb 2002 06:43:11 +0000 (+0000) Subject: Eliminate non-hygienic macros. X-Git-Tag: 20090517-FFI~2235 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a19efe91cd84022595580880f420666df2510d40;p=mit-scheme.git Eliminate non-hygienic macros. --- diff --git a/v7/src/compiler/machines/C/lapgen.scm b/v7/src/compiler/machines/C/lapgen.scm index e502984ac..f848ed4bb 100644 --- a/v7/src/compiler/machines/C/lapgen.scm +++ b/v7/src/compiler/machines/C/lapgen.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: lapgen.scm,v 1.13 2001/12/20 21:45:24 cph Exp $ +$Id: lapgen.scm,v 1.14 2002/02/16 06:32:42 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 @@ -579,16 +579,18 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA operator)))) (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) (1+ index))) + `()))))))) (define-codes #x012 primitive-apply primitive-lexpr-apply apply error lexpr-apply link diff --git a/v7/src/compiler/machines/C/rules3.scm b/v7/src/compiler/machines/C/rules3.scm index e93da6c48..edc08fb64 100644 --- a/v7/src/compiler/machines/C/rules3.scm +++ b/v7/src/compiler/machines/C/rules3.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: rules3.scm,v 1.10 2001/12/20 21:45:24 cph Exp $ +$Id: rules3.scm,v 1.11 2002/02/16 06:34:31 cph Exp $ -Copyright (c) 1992-1999, 2001 Massachusetts Institute of Technology +Copyright (c) 1992-1999, 2001, 2002 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -166,15 +166,18 @@ 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 - (invoke-special-primitive - ,(symbol-append 'CODE:COMPILER- name)))))) + (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 + (INVOKE-SPECIAL-PRIMITIVE + ,(close-syntax (symbol-append 'CODE:COMPILER- name) + environment)))))))) (define-special-primitive-invocation &+) (define-special-primitive-invocation &-) (define-special-primitive-invocation &*) diff --git a/v7/src/compiler/machines/C/rulfix.scm b/v7/src/compiler/machines/C/rulfix.scm index 470565979..60213b5f5 100644 --- a/v7/src/compiler/machines/C/rulfix.scm +++ b/v7/src/compiler/machines/C/rulfix.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: rulfix.scm,v 1.4 2001/12/20 21:45:24 cph Exp $ +$Id: rulfix.scm,v 1.5 2002/02/16 06:37:29 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 @@ -165,12 +165,15 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((binary-fixnum - (lambda (name instr) - `(define-arithmetic-method ',name fixnum-methods/2-args - (lambda (tgt src1 src2 overflow?) - (if overflow? (no-overflow-branches!)) - (LAP ,',tgt " = (" ,',src1 ,instr ,',src2 ");\n\t")))))) - + (sc-macro-transformer + (lambda (form environment) + environment + (let ((name (cadr form)) + (instr (caddr form))) + `(DEFINE-ARITHMETIC-METHOD ',name FIXNUM-METHODS/2-ARGS + (LAMBDA (TGT SRC1 SRC2 OVERFLOW?) + (IF OVERFLOW? (NO-OVERFLOW-BRANCHES!)) + (LAP ,',tgt " = (" ,',src1 ,instr ,',src2 ");\n\t")))))))) (binary-fixnum FIXNUM-AND " & ") (binary-fixnum FIXNUM-OR " | ") (binary-fixnum FIXNUM-XOR " ^ ") @@ -178,13 +181,16 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((binary-fixnum - (lambda (name instr) - `(define-arithmetic-method ',name fixnum-methods/2-args - (lambda (tgt src1 src2 overflow?) - (if overflow? (no-overflow-branches!)) - (LAP ,',tgt - " = (" ,instr " (" ,',src1 ", " ,',src2 "));\n\t")))))) - + (sc-macro-transformer + (lambda (form environment) + environment + (let ((name (cadr form)) + (instr (caddr form))) + `(DEFINE-ARITHMETIC-METHOD ',name FIXNUM-METHODS/2-ARGS + (LAMBDA (TGT SRC1 SRC2 OVERFLOW?) + (IF OVERFLOW? (NO-OVERFLOW-BRANCHES!)) + (LAP ,',tgt + " = (" ,instr " (" ,',src1 ", " ,',src2 "));\n\t")))))))) (binary-fixnum FIXNUM-REMAINDER "FIXNUM_REMAINDER") (binary-fixnum FIXNUM-LSH "FIXNUM_LSH")) @@ -410,14 +416,17 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((binary-fixnum - (lambda (name instr) - `(define-arithmetic-method ',name - fixnum-methods/2-args/register*constant - (lambda (tgt src1 constant overflow?) - (if overflow? (no-overflow-branches!)) - (LAP ,',tgt " = (" ,',src1 ,instr ,',(longify constant) - ");\n\t")))))) - + (sc-macro-transformer + (lambda (form environment) + environment + (let ((name (cadr form)) + (instr (caddr form))) + `(DEFINE-ARITHMETIC-METHOD ',name + FIXNUM-METHODS/2-ARGS/REGISTER*CONSTANT + (LAMBDA (TGT SRC1 CONSTANT OVERFLOW?) + (IF OVERFLOW? (NO-OVERFLOW-BRANCHES!)) + (LAP ,',tgt " = (" ,',src1 ,instr ,',(longify constant) + ");\n\t")))))))) (binary-fixnum FIXNUM-AND " & ") (binary-fixnum FIXNUM-OR " | ") (binary-fixnum FIXNUM-XOR " ^ ") diff --git a/v7/src/compiler/machines/C/rulflo.scm b/v7/src/compiler/machines/C/rulflo.scm index d45300126..9fac0b98f 100644 --- a/v7/src/compiler/machines/C/rulflo.scm +++ b/v7/src/compiler/machines/C/rulflo.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: rulflo.scm,v 1.6 2001/12/20 21:45:24 cph Exp $ +$Id: rulflo.scm,v 1.7 2002/02/16 06:38:35 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 @@ -191,11 +191,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 ,',target " = (" ,',source1 ,opcode ,',source2 - ");\n\t")))))) + (sc-macro-transformer + (lambda (form environment) + environment + `(DEFINE-ARITHMETIC-METHOD ',(cadr form) FLONUM-METHODS/2-ARGS + (LAMBDA (TARGET SOURCE1 SOURCE2) + (LAP ,',target " = (" ,',source1 ,(caddr form) ,',source2 + ");\n\t"))))))) (define-flonum-operation flonum-add " + ") (define-flonum-operation flonum-subtract " - ") (define-flonum-operation flonum-multiply " * ") diff --git a/v7/src/compiler/machines/alpha/assmd.scm b/v7/src/compiler/machines/alpha/assmd.scm index 8aa6f6a0d..6a0decca9 100644 --- a/v7/src/compiler/machines/alpha/assmd.scm +++ b/v7/src/compiler/machines/alpha/assmd.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: assmd.scm,v 1.3 2001/12/20 21:46:10 cph Exp $ +$Id: assmd.scm,v 1.4 2002/02/16 06:39:42 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 @@ -25,7 +25,11 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (declare (usual-integrations)) -(let-syntax ((ucode-type (lambda (name) `',(microcode-type name)))) +(let-syntax ((ucode-type + (sc-macro-transformer + (lambda (form environment) + environment + (apply microcode-type (cdr form)))))) (define-integrable maximum-padding-length ;; Instruction length is always a multiple of 32 bits diff --git a/v7/src/compiler/machines/alpha/dassm1.scm b/v7/src/compiler/machines/alpha/dassm1.scm index 30676ded0..bad5b21a8 100644 --- a/v7/src/compiler/machines/alpha/dassm1.scm +++ b/v7/src/compiler/machines/alpha/dassm1.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: dassm1.scm,v 1.3 2001/12/20 21:45:24 cph Exp $ +$Id: dassm1.scm,v 1.4 2002/02/16 06:42: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 @@ -148,9 +148,11 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let loop ((index (compiled-code-block/constants-start block))) (cond ((not (< index end)) 'DONE) ((object-type? - (let-syntax ((ucode-type - (lambda (name) (microcode-type name)))) - (ucode-type linkage-section)) + ((sc-macro-transformer + (lambda (form environment) + environment + (apply microcode-type (cdr form)))) + linkage-section) (system-vector-ref block index)) (loop (disassembler/write-linkage-section block symbol-table diff --git a/v7/src/compiler/machines/alpha/dassm2.scm b/v7/src/compiler/machines/alpha/dassm2.scm index f6d960ed0..424b22fec 100644 --- a/v7/src/compiler/machines/alpha/dassm2.scm +++ b/v7/src/compiler/machines/alpha/dassm2.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: dassm2.scm,v 1.3 2001/12/20 21:45:24 cph Exp $ +$Id: dassm2.scm,v 1.4 2002/02/16 06:43:11 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 @@ -32,10 +32,15 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (set! disassembler/read-variable-cache (lambda (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)))))