From 7683ee79b3ee8ae7cffd18dbb554582ff6ca5c19 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 23 Dec 2001 17:21:00 +0000 Subject: [PATCH] Eliminate all references to SYNTAX-TABLE/DEFINE. Wrap all macros with new procedure NON-HYGIENIC-MACRO-TRANSFORMER; this will serve as a marker for identifying macros that need to be rewritten. --- v7/src/6001/arith.scm | 14 +- v7/src/compiler/back/asmmac.scm | 24 +- v7/src/compiler/back/lapgn3.scm | 34 +- v7/src/compiler/base/crsend.scm | 22 +- v7/src/compiler/base/lvalue.scm | 26 +- v7/src/compiler/base/macros.scm | 340 ++++++++++-------- v7/src/compiler/base/scode.scm | 5 +- v7/src/compiler/base/utils.scm | 5 +- v7/src/compiler/etc/comcmp.scm | 7 +- v7/src/compiler/fggen/canon.scm | 48 +-- v7/src/compiler/fggen/fggen.scm | 21 +- v7/src/compiler/machines/alpha/inerly.scm | 42 +-- v7/src/compiler/machines/alpha/insmac.scm | 31 +- v7/src/compiler/machines/bobcat/inerly.scm | 134 +++---- v7/src/compiler/machines/bobcat/insmac.scm | 166 ++++----- v7/src/compiler/machines/i386/assmd.scm | 7 +- v7/src/compiler/machines/i386/dassm1.scm | 5 +- v7/src/compiler/machines/i386/dassm2.scm | 18 +- v7/src/compiler/machines/i386/dassm3.scm | 10 +- v7/src/compiler/machines/i386/inerly.scm | 42 +-- v7/src/compiler/machines/i386/insmac.scm | 76 ++-- v7/src/compiler/machines/i386/instr1.scm | 45 ++- v7/src/compiler/machines/i386/instr2.scm | 31 +- v7/src/compiler/machines/i386/instrf.scm | 32 +- v7/src/compiler/machines/i386/lapgen.scm | 8 +- v7/src/compiler/machines/i386/rules3.scm | 28 +- v7/src/compiler/machines/i386/rulfix.scm | 19 +- v7/src/compiler/machines/i386/rulflo.scm | 8 +- v7/src/compiler/machines/mips/inerly.scm | 42 +-- v7/src/compiler/machines/mips/insmac.scm | 31 +- v7/src/compiler/machines/sparc/inerly.scm | 42 +-- v7/src/compiler/machines/sparc/insmac.scm | 31 +- v7/src/compiler/machines/spectrum/inerly.scm | 42 +-- v7/src/compiler/machines/spectrum/insmac.scm | 31 +- v7/src/compiler/machines/spectrum/instr2.scm | 34 +- v7/src/compiler/machines/vax/dsyn.scm | 15 +- v7/src/compiler/machines/vax/inerly.scm | 112 +++--- v7/src/compiler/machines/vax/insmac.scm | 73 ++-- v7/src/compiler/machines/vax/instr1.scm | 11 +- v7/src/compiler/machines/vax/instr2.scm | 11 +- v7/src/compiler/machines/vax/instr3.scm | 11 +- v7/src/compiler/rtlbase/rtlreg.scm | 5 +- v7/src/compiler/rtlbase/valclass.scm | 5 +- v7/src/edwin/buffer.scm | 9 +- v7/src/edwin/calias.scm | 7 +- v7/src/edwin/clsmac.scm | 81 +++-- v7/src/edwin/dosproc.scm | 5 +- v7/src/edwin/macros.scm | 198 +++++----- v7/src/edwin/regexp.scm | 41 ++- v7/src/edwin/search.scm | 38 +- v7/src/edwin/syntax.scm | 32 +- v7/src/edwin/tterm.scm | 8 +- v7/src/edwin/utils.scm | 23 +- v7/src/edwin/xcom.scm | 16 +- v7/src/microcode/os2pm.scm | 64 ++-- v7/src/microcode/utabmd.scm | 9 +- v7/src/runtime/apply.scm | 43 ++- v7/src/runtime/arith.scm | 237 ++++++------ v7/src/runtime/debug.scm | 17 +- v7/src/runtime/defstr.scm | 53 +-- v7/src/runtime/error.scm | 23 +- v7/src/runtime/graphics.scm | 5 +- v7/src/runtime/infstr.scm | 17 +- v7/src/runtime/list.scm | 99 ++--- v7/src/runtime/make.scm | 20 +- v7/src/runtime/os2winp.scm | 23 +- v7/src/runtime/parse.scm | 33 +- v7/src/runtime/parser-buffer.scm | 116 +++--- v7/src/runtime/port.scm | 9 +- v7/src/runtime/recslot.scm | 15 +- v7/src/runtime/rgxcmp.scm | 24 +- v7/src/runtime/runtime.pkg | 5 +- v7/src/runtime/scomb.scm | 41 +-- v7/src/runtime/starbase.scm | 5 +- v7/src/runtime/string.scm | 40 ++- v7/src/runtime/sysmac.scm | 44 +-- v7/src/runtime/vector.scm | 11 +- v7/src/sf/object.scm | 11 +- v7/src/sos/class.scm | 5 +- v7/src/sos/instance.scm | 295 +++++++-------- v7/src/sos/load.scm | 15 +- v7/src/sos/macros.scm | 244 ++++++------- v7/src/sos/sos.pkg | 16 +- v7/src/star-parser/matcher.scm | 58 +-- v7/src/star-parser/parser.pkg | 6 +- v7/src/star-parser/parser.scm | 49 +-- .../swat/scheme/control-floating-errors.scm | 13 +- v7/src/swat/scheme/load.scm | 82 +++-- v7/src/swat/scheme/mit-xhooks.scm | 14 +- v7/src/swat/scheme/scc-macros.scm | 30 +- v7/src/swat/scheme/uitk-macros.scm | 206 +++++------ v7/src/wabbit/test-wabbit.scm | 9 +- v7/src/win32/dib.scm | 9 +- v7/src/win32/ffimacro.scm | 273 +++++++------- v7/src/win32/make.scm | 3 +- v7/src/win32/win32.pkg | 16 +- v7/src/win32/win32.sf | 25 +- v7/src/win32/win_ffi.scm | 60 ++-- v7/src/win32/wingdi.scm | 9 +- v7/src/win32/winnt.scm | 11 +- v7/src/win32/winuser.scm | 9 +- v7/src/win32/wt_user.scm | 4 +- 102 files changed, 2418 insertions(+), 2209 deletions(-) diff --git a/v7/src/6001/arith.scm b/v7/src/6001/arith.scm index cdd9b4c6c..663a826c3 100644 --- a/v7/src/6001/arith.scm +++ b/v7/src/6001/arith.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: arith.scm,v 1.7 2001/12/20 21:29:22 cph Exp $ +$Id: arith.scm,v 1.8 2001/12/23 17:20:57 cph Exp $ Copyright (c) 1989-1999, 2001 Massachusetts Institute of Technology @@ -46,11 +46,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((define-standard-unary + (non-hygienic-macro-transformer (lambda (name flo:op int:op) `(DEFINE (,name X) (IF (FLONUM? X) (,flo:op X) - (,int:op X)))))) + (,int:op X))))))) (define-standard-unary rational? (lambda (x) x true) int:integer?) (define-standard-unary integer? flo:integer? int:integer?) (define-standard-unary exact? (lambda (x) x false) @@ -77,6 +78,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((define-standard-binary + (non-hygienic-macro-transformer (lambda (name flo:op int:op) `(DEFINE (,name X Y) (IF (FLONUM? X) @@ -85,7 +87,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (,flo:op X (INT:->FLONUM Y))) (IF (FLONUM? Y) (,flo:op (INT:->FLONUM X) Y) - (,int:op X Y))))))) + (,int:op X Y)))))))) (define-standard-binary real:+ flo:+ int:+) (define-standard-binary real:- flo:- int:-) (define-standard-binary rationalize @@ -184,6 +186,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((define-integer-binary + (non-hygienic-macro-transformer (lambda (name operator) `(DEFINE (,name N M) (IF (FLONUM? N) @@ -192,7 +195,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (IF (FLONUM? M) (FLO:->INTEGER M) M))) (IF (FLONUM? M) (INT:->FLONUM (,operator N (FLO:->INTEGER M))) - (,operator N M))))))) + (,operator N M)))))))) (define-integer-binary quotient int:quotient) (define-integer-binary remainder int:remainder) (define-integer-binary modulo int:modulo) @@ -215,11 +218,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((define-transcendental-unary + (non-hygienic-macro-transformer (lambda (name hole? hole-value function) `(DEFINE (,name X) (IF (,hole? X) ,hole-value - (,function (REAL:->FLONUM X))))))) + (,function (REAL:->FLONUM X)))))))) (define-transcendental-unary exp real:exact0= 1 flo:exp) (define-transcendental-unary log real:exact1= 0 flo:log) (define-transcendental-unary sin real:exact0= 0 flo:sin) diff --git a/v7/src/compiler/back/asmmac.scm b/v7/src/compiler/back/asmmac.scm index 08516ca22..2668e9445 100644 --- a/v7/src/compiler/back/asmmac.scm +++ b/v7/src/compiler/back/asmmac.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: asmmac.scm,v 1.9 2001/12/19 21:39:29 cph Exp $ +$Id: asmmac.scm,v 1.10 2001/12/23 17:20:57 cph Exp $ Copyright (c) 1988, 1990, 1999, 2001 Massachusetts Institute of Technology @@ -24,17 +24,17 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (declare (usual-integrations)) -(syntax-table/define (->environment '(COMPILER LAP-SYNTAXER)) - 'DEFINE-INSTRUCTION - (lambda (keyword . rules) - `(ADD-INSTRUCTION! - ',keyword - ,(compile-database rules - (lambda (pattern actions) - pattern - (if (null? actions) - (error "DEFINE-INSTRUCTION: Too few forms") - (parse-instruction (car actions) (cdr actions) false))))))) +(define-syntax define-instruction + (non-hygienic-macro-transformer + (lambda (keyword . rules) + `(ADD-INSTRUCTION! + ',keyword + ,(compile-database rules + (lambda (pattern actions) + pattern + (if (not (pair? actions)) + (error "DEFINE-INSTRUCTION: Too few forms.")) + (parse-instruction (car actions) (cdr actions) #f))))))) (define (compile-database cases procedure) `(LIST diff --git a/v7/src/compiler/back/lapgn3.scm b/v7/src/compiler/back/lapgn3.scm index fa03cdd9a..6c4a29878 100644 --- a/v7/src/compiler/back/lapgn3.scm +++ b/v7/src/compiler/back/lapgn3.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: lapgn3.scm,v 4.13 2001/12/20 21:45:23 cph Exp $ +$Id: lapgn3.scm,v 4.14 2001/12/23 17:20:57 cph Exp $ Copyright (c) 1987-1999, 2001 Massachusetts Institute of Technology @@ -70,21 +70,23 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (read))) label))))) -(let-syntax ((->label - (lambda (find var #!optional suffix) - `(object->label ,find - (lambda () ,var) - (lambda (new) - (declare (integrate new)) - (set! ,var new)) - ,(if (default-object? suffix) - `(lambda (object) - object ; ignore - (allocate-named-label "OBJECT-")) - `(lambda (object) - (allocate-named-label - (string-append (symbol->string object) - ,suffix)))))))) +(let-syntax + ((->label + (non-hygienic-macro-transformer + (lambda (find var #!optional suffix) + `(object->label ,find + (lambda () ,var) + (lambda (new) + (declare (integrate new)) + (set! ,var new)) + ,(if (default-object? suffix) + `(lambda (object) + object ; ignore + (allocate-named-label "OBJECT-")) + `(lambda (object) + (allocate-named-label + (string-append (symbol->string object) + ,suffix))))))))) (define constant->label (->label warning-assoc *interned-constants*)) diff --git a/v7/src/compiler/base/crsend.scm b/v7/src/compiler/base/crsend.scm index 7b659b0b8..5d17fb7d4 100644 --- a/v7/src/compiler/base/crsend.scm +++ b/v7/src/compiler/base/crsend.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: crsend.scm,v 1.11 2001/12/20 21:45:23 cph Exp $ +$Id: crsend.scm,v 1.12 2001/12/23 17:20:57 cph Exp $ Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology @@ -119,11 +119,13 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (with-absolutely-no-interrupts (lambda () (let-syntax ((ucode-primitive - (lambda (name) - (make-primitive-procedure name))) + (non-hygienic-macro-transformer + (lambda (name) + (make-primitive-procedure name)))) (ucode-type - (lambda (name) - (microcode-type name)))) + (non-hygienic-macro-transformer + (lambda (name) + (microcode-type name))))) ((ucode-primitive PRIMITIVE-OBJECT-SET-TYPE) (ucode-type COMPILED-ENTRY) (make-non-pointer-object @@ -144,11 +146,13 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define (cross-link/finish-assembly code-block objects scheme-object-width) (let-syntax ((ucode-primitive - (lambda (name) - (make-primitive-procedure name))) + (non-hygienic-macro-transformer + (lambda (name) + (make-primitive-procedure name)))) (ucode-type - (lambda (name) - (microcode-type name)))) + (non-hygienic-macro-transformer + (lambda (name) + (microcode-type name))))) (let* ((bl (quotient (bit-string-length code-block) scheme-object-width)) (non-pointer-length diff --git a/v7/src/compiler/base/lvalue.scm b/v7/src/compiler/base/lvalue.scm index 2ccbc8889..cb620507f 100644 --- a/v7/src/compiler/base/lvalue.scm +++ b/v7/src/compiler/base/lvalue.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: lvalue.scm,v 4.23 2001/12/20 21:45:23 cph Exp $ +$Id: lvalue.scm,v 4.24 2001/12/23 17:20:57 cph Exp $ Copyright (c) 1988-1990, 1999, 2001 Massachusetts Institute of Technology @@ -103,17 +103,19 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((define-named-variable - (lambda (name) - (let ((symbol (intern (string-append "#[" (symbol->string name) "]")))) - `(BEGIN (DEFINE-INTEGRABLE - (,(symbol-append 'MAKE- name '-VARIABLE) BLOCK) - (MAKE-VARIABLE BLOCK ',symbol)) - (DEFINE-INTEGRABLE - (,(symbol-append 'VARIABLE/ name '-VARIABLE?) LVALUE) - (EQ? (VARIABLE-NAME LVALUE) ',symbol)) - (DEFINE (,(symbol-append name '-VARIABLE?) LVALUE) - (AND (VARIABLE? LVALUE) - (EQ? (VARIABLE-NAME LVALUE) ',symbol)))))))) + (non-hygienic-macro-transformer + (lambda (name) + (let ((symbol + (intern (string-append "#[" (symbol->string name) "]")))) + `(BEGIN (DEFINE-INTEGRABLE + (,(symbol-append 'MAKE- name '-VARIABLE) BLOCK) + (MAKE-VARIABLE BLOCK ',symbol)) + (DEFINE-INTEGRABLE + (,(symbol-append 'VARIABLE/ name '-VARIABLE?) LVALUE) + (EQ? (VARIABLE-NAME LVALUE) ',symbol)) + (DEFINE (,(symbol-append name '-VARIABLE?) LVALUE) + (AND (VARIABLE? LVALUE) + (EQ? (VARIABLE-NAME LVALUE) ',symbol))))))))) (define-named-variable continuation) (define-named-variable value)) diff --git a/v7/src/compiler/base/macros.scm b/v7/src/compiler/base/macros.scm index cecab0b25..523e7bab5 100644 --- a/v7/src/compiler/base/macros.scm +++ b/v7/src/compiler/base/macros.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: macros.scm,v 4.21 2001/12/22 03:21:08 cph Exp $ +$Id: macros.scm,v 4.22 2001/12/23 17:20:57 cph Exp $ Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology @@ -26,109 +26,119 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (declare (usual-integrations)) (define-syntax last-reference - (lambda (name) - (let ((x (generate-uninterned-symbol))) - `(IF COMPILER:PRESERVE-DATA-STRUCTURES? - ,name - (LET ((,x ,name)) - (SET! ,name) - ,x))))) + (non-hygienic-macro-transformer + (lambda (name) + (let ((x (generate-uninterned-symbol))) + `(IF COMPILER:PRESERVE-DATA-STRUCTURES? + ,name + (LET ((,x ,name)) + (SET! ,name) + ,x)))))) (define-syntax package - (lambda (names . body) - (make-syntax-closure - (scode/make-sequence - `(,@(map (lambda (name) - (scode/make-definition name (make-unassigned-reference-trap))) - names) - ,(scode/make-combination - (let ((block (syntax* (append body (list unspecific))))) - (if (scode/open-block? block) - (scode/open-block-components block - (lambda (names* declarations body) - (scode/make-lambda lambda-tag:let '() '() #f - (list-transform-negative names* - (lambda (name) - (memq name names))) - declarations - body))) - (scode/make-lambda lambda-tag:let '() '() #f '() '() block))) - '())))))) + (non-hygienic-macro-transformer + (lambda (names . body) + (make-syntax-closure + (scode/make-sequence + `(,@(map (lambda (name) + (scode/make-definition name + (make-unassigned-reference-trap))) + names) + ,(scode/make-combination + (let ((block (syntax* (append body (list unspecific))))) + (if (scode/open-block? block) + (scode/open-block-components block + (lambda (names* declarations body) + (scode/make-lambda lambda-tag:let '() '() #f + (list-transform-negative names* + (lambda (name) + (memq name names))) + declarations + body))) + (scode/make-lambda lambda-tag:let '() '() #f '() '() block))) + '()))))))) (define-syntax define-export - (lambda (pattern . body) - (parse-define-syntax pattern body - (lambda (name body) - name - `(SET! ,pattern ,@body)) - (lambda (pattern body) - `(SET! ,(car pattern) - (NAMED-LAMBDA ,pattern ,@body)))))) + (non-hygienic-macro-transformer + (lambda (pattern . body) + (parse-define-syntax pattern body + (lambda (name body) + name + `(SET! ,pattern ,@body)) + (lambda (pattern body) + `(SET! ,(car pattern) + (NAMED-LAMBDA ,pattern ,@body))))))) (define-syntax define-vector-slots - (lambda (class index . slots) - (define (loop slots n) - (if (pair? slots) - (let ((make-defs - (lambda (slot) - (let ((ref-name (symbol-append class '- slot))) - `(BEGIN - (DEFINE-INTEGRABLE (,ref-name ,class) - (VECTOR-REF ,class ,n)) - (DEFINE-INTEGRABLE (,(symbol-append 'SET- ref-name '!) - ,class ,slot) - (VECTOR-SET! ,class ,n ,slot)))))) - (rest (loop (cdr slots) (1+ n)))) - (if (pair? (car slots)) - (map* rest make-defs (car slots)) - (cons (make-defs (car slots)) rest))) - '())) - (if (pair? slots) - `(BEGIN ,@(loop slots index)) - 'UNSPECIFIC))) + (non-hygienic-macro-transformer + (lambda (class index . slots) + (define (loop slots n) + (if (pair? slots) + (let ((make-defs + (lambda (slot) + (let ((ref-name (symbol-append class '- slot))) + `(BEGIN + (DEFINE-INTEGRABLE (,ref-name ,class) + (VECTOR-REF ,class ,n)) + (DEFINE-INTEGRABLE (,(symbol-append 'SET- ref-name '!) + ,class ,slot) + (VECTOR-SET! ,class ,n ,slot)))))) + (rest (loop (cdr slots) (1+ n)))) + (if (pair? (car slots)) + (map* rest make-defs (car slots)) + (cons (make-defs (car slots)) rest))) + '())) + (if (pair? slots) + `(BEGIN ,@(loop slots index)) + 'UNSPECIFIC)))) (define-syntax define-root-type - (lambda (type . slots) - (let ((tag-name (symbol-append type '-TAG))) - `(BEGIN (DEFINE ,tag-name - (MAKE-VECTOR-TAG #F ',type #F)) - (DEFINE ,(symbol-append type '?) - (TAGGED-VECTOR/SUBCLASS-PREDICATE ,tag-name)) - (DEFINE-VECTOR-SLOTS ,type 1 ,@slots) - (SET-VECTOR-TAG-DESCRIPTION! - ,tag-name - (LAMBDA (,type) - (DESCRIPTOR-LIST ,type ,@slots))))))) + (non-hygienic-macro-transformer + (lambda (type . slots) + (let ((tag-name (symbol-append type '-TAG))) + `(BEGIN (DEFINE ,tag-name + (MAKE-VECTOR-TAG #F ',type #F)) + (DEFINE ,(symbol-append type '?) + (TAGGED-VECTOR/SUBCLASS-PREDICATE ,tag-name)) + (DEFINE-VECTOR-SLOTS ,type 1 ,@slots) + (SET-VECTOR-TAG-DESCRIPTION! + ,tag-name + (LAMBDA (,type) + (DESCRIPTOR-LIST ,type ,@slots)))))))) (define-syntax descriptor-list - (lambda (type . slots) - (let ((ref-name (lambda (slot) (symbol-append type '- slot)))) - `(LIST ,@(map (lambda (slot) - (if (pair? slot) - (let ((ref-names (map ref-name slot))) - ``(,',ref-names ,(,(car ref-names) ,type))) - (let ((ref-name (ref-name slot))) - ``(,',ref-name ,(,ref-name ,type))))) - slots))))) + (non-hygienic-macro-transformer + (lambda (type . slots) + (let ((ref-name (lambda (slot) (symbol-append type '- slot)))) + `(LIST ,@(map (lambda (slot) + (if (pair? slot) + (let ((ref-names (map ref-name slot))) + ``(,',ref-names ,(,(car ref-names) ,type))) + (let ((ref-name (ref-name slot))) + ``(,',ref-name ,(,ref-name ,type))))) + slots)))))) (let-syntax ((define-type-definition - (lambda (name reserved enumeration) - (let ((parent (symbol-append name '-TAG))) - `(DEFINE-SYNTAX ,(symbol-append 'DEFINE- name) - (lambda (type . slots) - (let ((tag-name (symbol-append type '-TAG))) - `(BEGIN (DEFINE ,tag-name - (MAKE-VECTOR-TAG ,',parent ',type ,',enumeration)) - (DEFINE ,(symbol-append type '?) - (TAGGED-VECTOR/PREDICATE ,tag-name)) - (DEFINE-VECTOR-SLOTS ,type ,,reserved ,@slots) - (SET-VECTOR-TAG-DESCRIPTION! - ,tag-name - (LAMBDA (,type) - (APPEND! - ((VECTOR-TAG-DESCRIPTION ,',parent) ,type) - (DESCRIPTOR-LIST ,type ,@slots)))))))))))) + (non-hygienic-macro-transformer + (lambda (name reserved enumeration) + (let ((parent (symbol-append name '-TAG))) + `(define-syntax ,(symbol-append 'DEFINE- name) + (non-hygienic-macro-transformer + (lambda (type . slots) + (let ((tag-name (symbol-append type '-TAG))) + `(BEGIN + (DEFINE ,tag-name + (MAKE-VECTOR-TAG ,',parent ',type ,',enumeration)) + (DEFINE ,(symbol-append type '?) + (TAGGED-VECTOR/PREDICATE ,tag-name)) + (DEFINE-VECTOR-SLOTS ,type ,,reserved ,@slots) + (SET-VECTOR-TAG-DESCRIPTION! + ,tag-name + (LAMBDA (,type) + (APPEND! + ((VECTOR-TAG-DESCRIPTION ,',parent) ,type) + (DESCRIPTOR-LIST ,type ,@slots)))))))))))))) (define-type-definition snode 5 #f) (define-type-definition pnode 6 #f) (define-type-definition rvalue 2 rvalue-types) @@ -137,47 +147,54 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;;; Kludge to make these compile efficiently. (define-syntax make-snode - (lambda (tag . extra) - `((ACCESS VECTOR ,system-global-environment) - ,tag #F '() '() #F ,@extra))) + (non-hygienic-macro-transformer + (lambda (tag . extra) + `((ACCESS VECTOR ,system-global-environment) + ,tag #F '() '() #F ,@extra)))) (define-syntax make-pnode - (lambda (tag . extra) - `((ACCESS VECTOR ,system-global-environment) - ,tag #F '() '() #F #F ,@extra))) + (non-hygienic-macro-transformer + (lambda (tag . extra) + `((ACCESS VECTOR ,system-global-environment) + ,tag #F '() '() #F #F ,@extra)))) (define-syntax make-rvalue - (lambda (tag . extra) - `((ACCESS VECTOR ,system-global-environment) - ,tag #F ,@extra))) + (non-hygienic-macro-transformer + (lambda (tag . extra) + `((ACCESS VECTOR ,system-global-environment) + ,tag #F ,@extra)))) (define-syntax make-lvalue - (lambda (tag . extra) - (let ((result (generate-uninterned-symbol))) - `(let ((,result - ((ACCESS VECTOR ,system-global-environment) - ,tag #F '() '() '() '() '() '() 'NOT-CACHED - #F '() #F #F '() ,@extra))) - (SET! *LVALUES* (CONS ,result *LVALUES*)) - ,result)))) + (non-hygienic-macro-transformer + (lambda (tag . extra) + (let ((result (generate-uninterned-symbol))) + `(let ((,result + ((ACCESS VECTOR ,system-global-environment) + ,tag #F '() '() '() '() '() '() 'NOT-CACHED + #F '() #F #F '() ,@extra))) + (SET! *LVALUES* (CONS ,result *LVALUES*)) + ,result))))) (define-syntax define-rtl-expression - (lambda (type prefix . components) - (rtl-common type prefix components - identity-procedure - 'RTL:EXPRESSION-TYPES))) + (non-hygienic-macro-transformer + (lambda (type prefix . components) + (rtl-common type prefix components + identity-procedure + 'RTL:EXPRESSION-TYPES)))) (define-syntax define-rtl-statement - (lambda (type prefix . components) - (rtl-common type prefix components - (lambda (expression) `(STATEMENT->SRTL ,expression)) - 'RTL:STATEMENT-TYPES))) + (non-hygienic-macro-transformer + (lambda (type prefix . components) + (rtl-common type prefix components + (lambda (expression) `(STATEMENT->SRTL ,expression)) + 'RTL:STATEMENT-TYPES)))) (define-syntax define-rtl-predicate - (lambda (type prefix . components) - (rtl-common type prefix components - (lambda (expression) `(PREDICATE->PRTL ,expression)) - 'RTL:PREDICATE-TYPES))) + (non-hygienic-macro-transformer + (lambda (type prefix . components) + (rtl-common type prefix components + (lambda (expression) `(PREDICATE->PRTL ,expression)) + 'RTL:PREDICATE-TYPES)))) (define (rtl-common type prefix components wrap-constructor types) `(BEGIN @@ -209,37 +226,41 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA '())))) (define-syntax define-rule - (lambda (type pattern . body) - (parse-rule pattern body - (lambda (pattern variables qualifier actions) - `(,(case type - ((STATEMENT) 'ADD-STATEMENT-RULE!) - ((PREDICATE) 'ADD-STATEMENT-RULE!) - ((REWRITING) 'ADD-REWRITING-RULE!) - (else type)) - ',pattern - ,(rule-result-expression variables qualifier - `(BEGIN ,@actions))))))) + (non-hygienic-macro-transformer + (lambda (type pattern . body) + (parse-rule pattern body + (lambda (pattern variables qualifier actions) + `(,(case type + ((STATEMENT) 'ADD-STATEMENT-RULE!) + ((PREDICATE) 'ADD-STATEMENT-RULE!) + ((REWRITING) 'ADD-REWRITING-RULE!) + (else type)) + ',pattern + ,(rule-result-expression variables qualifier + `(BEGIN ,@actions)))))))) ;;;; LAP instruction sequences. (define-syntax lap - (lambda some-instructions - (list 'QUASIQUOTE some-instructions))) + (non-hygienic-macro-transformer + (lambda some-instructions + (list 'QUASIQUOTE some-instructions)))) (define-syntax inst-ea - (lambda (ea) - (list 'QUASIQUOTE ea))) + (non-hygienic-macro-transformer + (lambda (ea) + (list 'QUASIQUOTE ea)))) (define-syntax define-enumeration - (lambda (name elements) - (let ((enumeration (symbol-append name 'S))) - `(BEGIN (DEFINE ,enumeration - (MAKE-ENUMERATION ',elements)) - ,@(map (lambda (element) - `(DEFINE ,(symbol-append name '/ element) - (ENUMERATION/NAME->INDEX ,enumeration ',element))) - elements))))) + (non-hygienic-macro-transformer + (lambda (name elements) + (let ((enumeration (symbol-append name 'S))) + `(BEGIN (DEFINE ,enumeration + (MAKE-ENUMERATION ',elements)) + ,@(map (lambda (element) + `(DEFINE ,(symbol-append name '/ element) + (ENUMERATION/NAME->INDEX ,enumeration ',element))) + elements)))))) (define (macros/case-macro expression clauses predicate default) (let ((need-temp? (not (symbol? expression)))) @@ -268,20 +289,23 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA body))))) (define-syntax enumeration-case - (lambda (name expression . clauses) - (macros/case-macro expression - clauses - (lambda (expression element) - `(EQ? ,expression ,(symbol-append name '/ element))) - (lambda (expression) - expression - '())))) + (non-hygienic-macro-transformer + (lambda (name expression . clauses) + (macros/case-macro expression + clauses + (lambda (expression element) + `(EQ? ,expression ,(symbol-append name '/ element))) + (lambda (expression) + expression + '()))))) (define-syntax cfg-node-case - (lambda (expression . clauses) - (macros/case-macro expression - clauses - (lambda (expression element) - `(EQ? ,expression ,(symbol-append element '-TAG))) - (lambda (expression) - `((ELSE (ERROR "Unknown node type" ,expression))))))) \ No newline at end of file + (non-hygienic-macro-transformer + (lambda (expression . clauses) + (macros/case-macro expression + clauses + (lambda (expression element) + `(EQ? ,expression ,(symbol-append element '-TAG))) + (lambda (expression) + `((ELSE + (ERROR "Unknown node type" ,expression)))))))) \ No newline at end of file diff --git a/v7/src/compiler/base/scode.scm b/v7/src/compiler/base/scode.scm index 5bbd6e7b1..7ec7c092f 100644 --- a/v7/src/compiler/base/scode.scm +++ b/v7/src/compiler/base/scode.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: scode.scm,v 4.12 2001/12/20 21:45:23 cph Exp $ +$Id: scode.scm,v 4.13 2001/12/23 17:20:57 cph Exp $ Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology @@ -25,11 +25,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (declare (usual-integrations)) (let-syntax ((define-scode-operators + (non-hygienic-macro-transformer (lambda names `(BEGIN ,@(map (lambda (name) `(DEFINE ,(symbol-append 'SCODE/ name) (ACCESS ,name SYSTEM-GLOBAL-ENVIRONMENT))) - names))))) + names)))))) (define-scode-operators make-access access? access-components access-environment access-name diff --git a/v7/src/compiler/base/utils.scm b/v7/src/compiler/base/utils.scm index f0f3c28d7..6d202fd81 100644 --- a/v7/src/compiler/base/utils.scm +++ b/v7/src/compiler/base/utils.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: utils.scm,v 4.22 2001/12/20 21:45:23 cph Exp $ +$Id: utils.scm,v 4.23 2001/12/23 17:20:57 cph Exp $ Copyright (c) 1987-1999, 2001 Massachusetts Institute of Technology @@ -137,10 +137,11 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;;;; Type Codes (let-syntax ((define-type-code + (non-hygienic-macro-transformer (lambda (var-name #!optional type-name) (if (default-object? type-name) (set! type-name var-name)) `(DEFINE-INTEGRABLE ,(symbol-append 'TYPE-CODE: var-name) - ',(microcode-type type-name))))) + ',(microcode-type type-name)))))) (define-type-code lambda) (define-type-code extended-lambda) (define-type-code procedure) diff --git a/v7/src/compiler/etc/comcmp.scm b/v7/src/compiler/etc/comcmp.scm index 3e93a2b0b..9ee243d4d 100644 --- a/v7/src/compiler/etc/comcmp.scm +++ b/v7/src/compiler/etc/comcmp.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: comcmp.scm,v 1.8 2001/12/20 20:51:15 cph Exp $ +$Id: comcmp.scm,v 1.9 2001/12/23 17:20:57 cph Exp $ Copyright (c) 1989-1999, 2001 Massachusetts Institute of Technology @@ -28,8 +28,9 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (set! compiled-code-block/bytes-per-object 4)) (define-syntax ucode-type - (lambda (name) - (microcode-type name))) + (non-hygienic-macro-transformer + (lambda (name) + (microcode-type name)))) (define comcmp:ignore-debugging-info? #t) (define comcmp:show-differing-blocks? #f) diff --git a/v7/src/compiler/fggen/canon.scm b/v7/src/compiler/fggen/canon.scm index 854c50c6b..bd4c38e6e 100644 --- a/v7/src/compiler/fggen/canon.scm +++ b/v7/src/compiler/fggen/canon.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: canon.scm,v 1.19 2001/12/20 21:45:23 cph Exp $ +$Id: canon.scm,v 1.20 2001/12/23 17:20:57 cph Exp $ Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology @@ -504,11 +504,12 @@ ARBITRARY: The expression may be executed more than once. It ;;;; Hairier expressions (let-syntax ((is-operator? - (lambda (value name) - `(or (eq? ,value (ucode-primitive ,name)) - (and (scode/absolute-reference? ,value) - (eq? (scode/absolute-reference-name ,value) - ',name)))))) + (non-hygienic-macro-transformer + (lambda (value name) + `(or (eq? ,value (ucode-primitive ,name)) + (and (scode/absolute-reference? ,value) + (eq? (scode/absolute-reference-name ,value) + ',name))))))) (define (canonicalize/combination expr bound context) (scode/combination-components @@ -798,28 +799,33 @@ ARBITRARY: The expression may be executed more than once. It (let-syntax ((dispatch-entry - (lambda (type handler) - `(VECTOR-SET! DISPATCH-VECTOR ,(microcode-type type) ,handler))) + (non-hygienic-macro-transformer + (lambda (type handler) + `(VECTOR-SET! DISPATCH-VECTOR ,(microcode-type type) ,handler)))) (dispatch-entries - (lambda (types handler) - `(BEGIN ,@(map (lambda (type) - `(DISPATCH-ENTRY ,type ,handler)) - types)))) + (non-hygienic-macro-transformer + (lambda (types handler) + `(BEGIN ,@(map (lambda (type) + `(DISPATCH-ENTRY ,type ,handler)) + types))))) (standard-entry - (lambda (name) - `(DISPATCH-ENTRY ,name ,(symbol-append 'CANONICALIZE/ name)))) + (non-hygienic-macro-transformer + (lambda (name) + `(DISPATCH-ENTRY ,name ,(symbol-append 'CANONICALIZE/ name))))) (nary-entry - (lambda (nary name) - `(DISPATCH-ENTRY ,name - (,(symbol-append 'CANONICALIZE/ nary) - ,(symbol-append 'SCODE/ name '-COMPONENTS) - ,(symbol-append 'SCODE/MAKE- name))))) + (non-hygienic-macro-transformer + (lambda (nary name) + `(DISPATCH-ENTRY ,name + (,(symbol-append 'CANONICALIZE/ nary) + ,(symbol-append 'SCODE/ name '-COMPONENTS) + ,(symbol-append 'SCODE/MAKE- name)))))) (binary-entry - (lambda (name) - `(NARY-ENTRY binary ,name)))) + (non-hygienic-macro-transformer + (lambda (name) + `(NARY-ENTRY binary ,name))))) ;; quotations are treated as constants. (binary-entry access) diff --git a/v7/src/compiler/fggen/fggen.scm b/v7/src/compiler/fggen/fggen.scm index 2cc8d2347..27fb4ce8e 100644 --- a/v7/src/compiler/fggen/fggen.scm +++ b/v7/src/compiler/fggen/fggen.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: fggen.scm,v 4.34 2001/12/20 21:45:23 cph Exp $ +$Id: fggen.scm,v 4.35 2001/12/23 17:20:57 cph Exp $ Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology @@ -955,16 +955,19 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((dispatch-entry - (lambda (type handler) - `(VECTOR-SET! DISPATCH-VECTOR ,(microcode-type type) ,handler))) + (non-hygienic-macro-transformer + (lambda (type handler) + `(VECTOR-SET! DISPATCH-VECTOR ,(microcode-type type) ,handler)))) (dispatch-entries - (lambda (types handler) - `(BEGIN ,@(map (lambda (type) - `(DISPATCH-ENTRY ,type ,handler)) - types)))) + (non-hygienic-macro-transformer + (lambda (types handler) + `(BEGIN ,@(map (lambda (type) + `(DISPATCH-ENTRY ,type ,handler)) + types))))) (standard-entry - (lambda (name) - `(DISPATCH-ENTRY ,name ,(symbol-append 'GENERATE/ name))))) + (non-hygienic-macro-transformer + (lambda (name) + `(DISPATCH-ENTRY ,name ,(symbol-append 'GENERATE/ name)))))) (standard-entry access) (standard-entry assignment) (standard-entry conditional) diff --git a/v7/src/compiler/machines/alpha/inerly.scm b/v7/src/compiler/machines/alpha/inerly.scm index c8d366e15..2ed52de05 100644 --- a/v7/src/compiler/machines/alpha/inerly.scm +++ b/v7/src/compiler/machines/alpha/inerly.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: inerly.scm,v 1.5 2001/12/20 02:37:21 cph Exp $ +$Id: inerly.scm,v 1.6 2001/12/23 17:20:57 cph Exp $ Copyright (c) 1992-1999, 2001 Massachusetts Institute of Technology @@ -25,23 +25,23 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (declare (usual-integrations)) -(syntax-table/define (->environment '(COMPILER)) - 'DEFINE-INSTRUCTION - (lambda (opcode . patterns) - `(SET! EARLY-INSTRUCTIONS - (CONS - (LIST ',opcode - ,@(map (lambda (pattern) - `(early-parse-rule - ',(car pattern) - (lambda (pat vars) - (early-make-rule - pat - vars - (scode-quote - (instruction->instruction-sequence - ,(parse-instruction (cadr pattern) - (cddr pattern) - true))))))) - patterns)) - EARLY-INSTRUCTIONS)))) \ No newline at end of file +(define-syntax define-instruction + (non-hygienic-macro-transformer + (lambda (opcode . patterns) + `(SET! EARLY-INSTRUCTIONS + (CONS + (LIST ',opcode + ,@(map (lambda (pattern) + `(early-parse-rule + ',(car pattern) + (lambda (pat vars) + (early-make-rule + pat + vars + (scode-quote + (instruction->instruction-sequence + ,(parse-instruction (cadr pattern) + (cddr pattern) + #t))))))) + patterns)) + EARLY-INSTRUCTIONS))))) \ No newline at end of file diff --git a/v7/src/compiler/machines/alpha/insmac.scm b/v7/src/compiler/machines/alpha/insmac.scm index d4cdf560d..6c7bc7223 100644 --- a/v7/src/compiler/machines/alpha/insmac.scm +++ b/v7/src/compiler/machines/alpha/insmac.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: insmac.scm,v 1.3 2001/12/19 21:39:29 cph Exp $ +$Id: insmac.scm,v 1.4 2001/12/23 17:20:57 cph Exp $ Copyright (c) 1992-1999, 2001 Massachusetts Institute of Technology @@ -27,22 +27,19 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;;;; Definition macros -(syntax-table/define (->environment '(COMPILER LAP-SYNTAXER)) - 'DEFINE-SYMBOL-TRANSFORMER - (lambda (name . alist) - `(BEGIN - (DECLARE (INTEGRATE-OPERATOR ,name)) - (DEFINE (,name SYMBOL) - (DECLARE (INTEGRATE SYMBOL)) - (LET ((PLACE (ASSQ SYMBOL ',alist))) - (IF (NULL? PLACE) - #F - (CDR PLACE))))))) - -(syntax-table/define (->environment '(COMPILER LAP-SYNTAXER)) - 'DEFINE-TRANSFORMER - (lambda (name value) - `(DEFINE ,name ,value))) +(define-syntax define-symbol-transformer + (non-hygienic-macro-transformer + (lambda (name . alist) + `(DEFINE-INTEGRABLE (,name SYMBOL) + (LET ((PLACE (ASSQ SYMBOL ',alist))) + (IF (PAIR? PLACE) + (CDR PLACE) + #F)))))) + +(define-syntax define-transformer + (non-hygienic-macro-transformer + (lambda (name value) + `(DEFINE ,name ,value)))) ;;;; Fixed width instruction parsing diff --git a/v7/src/compiler/machines/bobcat/inerly.scm b/v7/src/compiler/machines/bobcat/inerly.scm index f73d0df78..afc226a6d 100644 --- a/v7/src/compiler/machines/bobcat/inerly.scm +++ b/v7/src/compiler/machines/bobcat/inerly.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: inerly.scm,v 1.10 2001/12/20 02:37:21 cph Exp $ +$Id: inerly.scm,v 1.11 2001/12/23 17:20:57 cph Exp $ Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology @@ -53,82 +53,84 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (and (memq (car s1) s2) (eq-subset? (cdr s1) s2)))) -(syntax-table/define (->environment '(COMPILER)) - 'DEFINE-EA-TRANSFORMER - (lambda (name . restrictions) - `(DEFINE-EARLY-TRANSFORMER ',name - (APPLY MAKE-EA-TRANSFORMER ',restrictions)))) - -(syntax-table/define (->environment '(COMPILER)) - 'DEFINE-SYMBOL-TRANSFORMER - (lambda (name . assoc) - `(DEFINE-EARLY-TRANSFORMER ',name (MAKE-SYMBOL-TRANSFORMER ',assoc)))) - -(syntax-table/define (->environment '(COMPILER)) - 'DEFINE-REG-LIST-TRANSFORMER - (lambda (name . assoc) - `(DEFINE-EARLY-TRANSFORMER ',name (MAKE-BIT-MASK-TRANSFORMER 16 ',assoc)))) +(define-syntax define-ea-transformer + (non-hygienic-macro-transformer + (lambda (name . restrictions) + `(DEFINE-EARLY-TRANSFORMER ',name + (APPLY MAKE-EA-TRANSFORMER ',restrictions))))) + +(define-syntax define-symbol-transformer + (non-hygienic-macro-transformer + (lambda (name . assoc) + `(DEFINE-EARLY-TRANSFORMER ',name (MAKE-SYMBOL-TRANSFORMER ',assoc))))) + +(define-syntax define-reg-list-transformer + (non-hygienic-macro-transformer + (lambda (name . assoc) + `(DEFINE-EARLY-TRANSFORMER ',name + (MAKE-BIT-MASK-TRANSFORMER 16 ',assoc))))) ;;;; Instruction and addressing mode macros -(syntax-table/define (->environment '(COMPILER)) - 'DEFINE-INSTRUCTION - (lambda (opcode . patterns) - `(SET! EARLY-INSTRUCTIONS - (CONS - (LIST ',opcode - ,@(map (lambda (pattern) - `(early-parse-rule - ',(car pattern) - (lambda (pat vars) - (early-make-rule - pat - vars - (scode-quote - (instruction->instruction-sequence - ,(parse-instruction (cadr pattern) - (cddr pattern) - true))))))) - patterns)) - EARLY-INSTRUCTIONS)))) - -(syntax-table/define (->environment '(COMPILER)) - 'EXTENSION-WORD - (lambda descriptors - (expand-descriptors descriptors - (lambda (instruction size source destination) - (if (or source destination) - (error "EXTENSION-WORD: Source or destination used")) - (if (not (zero? (remainder size 16))) - (error "EXTENSION-WORD: Extensions must be 16 bit multiples" size)) - (optimize-group-syntax instruction true))))) - -(syntax-table/define (->environment '(COMPILER)) - 'VARIABLE-EXTENSION - (lambda (binding . clauses) - (variable-width-expression-syntaxer - (car binding) - (cadr binding) - (map (lambda (clause) +(define-syntax define-instruction + (non-hygienic-macro-transformer + (lambda (opcode . patterns) + `(SET! EARLY-INSTRUCTIONS + (CONS + (LIST ',opcode + ,@(map (lambda (pattern) + `(early-parse-rule + ',(car pattern) + (lambda (pat vars) + (early-make-rule + pat + vars + (scode-quote + (instruction->instruction-sequence + ,(parse-instruction (cadr pattern) + (cddr pattern) + #t))))))) + patterns)) + EARLY-INSTRUCTIONS))))) + +(define-syntax extension-word + (non-hygienic-macro-transformer + (lambda descriptors + (expand-descriptors descriptors + (lambda (instruction size source destination) + (if (or source destination) + (error "EXTENSION-WORD: Source or destination used")) + (if (not (zero? (remainder size 16))) + (error "EXTENSION-WORD: Extensions must be 16 bit multiples" + size)) + (optimize-group-syntax instruction true)))))) + +(define-syntax variable-extension + (non-hygienic-macro-transformer + (lambda (binding . clauses) + (variable-width-expression-syntaxer + (car binding) + (cadr binding) + (map (lambda (clause) `((LIST ,(caddr clause)) ,(cadr clause) ; Size ,@(car clause))) ; Range - clauses)))) + clauses))))) ;;;; Early effective address assembly. ;;; *** NOTE: If this format changes, insutl.scm must also be changed! *** -(syntax-table/define (->environment '(COMPILER)) - 'DEFINE-EA-DATABASE - (lambda rules - `(SET! EARLY-EA-DATABASE - (LIST - ,@(map (lambda (rule) - (if (null? (cdddr rule)) - (apply make-position-dependent-early rule) - (apply make-position-independent-early rule))) - rules))))) +(define-syntax define-ea-database + (non-hygienic-macro-transformer + (lambda rules + `(SET! EARLY-EA-DATABASE + (LIST + ,@(map (lambda (rule) + (if (null? (cdddr rule)) + (apply make-position-dependent-early rule) + (apply make-position-independent-early rule))) + rules)))))) (define (make-ea-selector-expander late-name index) (scode->scode-expander diff --git a/v7/src/compiler/machines/bobcat/insmac.scm b/v7/src/compiler/machines/bobcat/insmac.scm index 8749a5cca..572f16446 100644 --- a/v7/src/compiler/machines/bobcat/insmac.scm +++ b/v7/src/compiler/machines/bobcat/insmac.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: insmac.scm,v 1.128 2001/12/19 21:39:30 cph Exp $ +$Id: insmac.scm,v 1.129 2001/12/23 17:20:57 cph Exp $ Copyright (c) 1988, 1990, 1999, 2001 Massachusetts Institute of Technology @@ -29,39 +29,39 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define ea-database-name 'EA-DATABASE) -(syntax-table/define (->environment '(COMPILER LAP-SYNTAXER)) - 'DEFINE-EA-DATABASE - (lambda rules - `(DEFINE ,ea-database-name - ,(compile-database rules - (lambda (pattern actions) - (if (null? (cddr actions)) - (make-position-dependent pattern actions) - (make-position-independent pattern actions))))))) +(define-syntax define-ea-database + (non-hygienic-macro-transformer + (lambda rules + `(DEFINE ,ea-database-name + ,(compile-database rules + (lambda (pattern actions) + (if (null? (cddr actions)) + (make-position-dependent pattern actions) + (make-position-independent pattern actions)))))))) -(syntax-table/define (->environment '(COMPILER LAP-SYNTAXER)) - 'EXTENSION-WORD - (lambda descriptors - (expand-descriptors descriptors - (lambda (instruction size source destination) - (if (or source destination) - (error "Source or destination used" 'EXTENSION-WORD) - (if (zero? (remainder size 16)) - (optimize-group-syntax instruction false) - (error "EXTENSION-WORD: Extensions must be 16 bit multiples" - size))))))) +(define-syntax extension-word + (non-hygienic-macro-transformer + (lambda descriptors + (expand-descriptors descriptors + (lambda (instruction size source destination) + (if (or source destination) + (error "Source or destination used" 'EXTENSION-WORD) + (if (zero? (remainder size 16)) + (optimize-group-syntax instruction false) + (error "EXTENSION-WORD: Extensions must be 16 bit multiples" + size)))))))) -(syntax-table/define (->environment '(COMPILER LAP-SYNTAXER)) - 'VARIABLE-EXTENSION - (lambda (binding . clauses) - (variable-width-expression-syntaxer - (car binding) - (cadr binding) - (map (lambda (clause) - `((LIST ,(caddr clause)) - ,(cadr clause) - ,@(car clause))) - clauses)))) +(define-syntax variable-extension + (non-hygienic-macro-transformer + (lambda (binding . clauses) + (variable-width-expression-syntaxer + (car binding) + (cadr binding) + (map (lambda (clause) + `((LIST ,(caddr clause)) + ,(cadr clause) + ,@(car clause))) + clauses))))) (define (make-position-independent pattern actions) (let ((keyword (car pattern)) @@ -118,61 +118,61 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;;;; Transformers -(syntax-table/define (->environment '(COMPILER LAP-SYNTAXER)) - 'DEFINE-EA-TRANSFORMER - (lambda (name #!optional categories keywords) - (define (filter special generator extraction) - (define (multiple rem) - (if (null? rem) - `() - `(,(generator (car rem) 'temp) - ,@(multiple (cdr rem))))) +(define-syntax define-ea-transformer + (non-hygienic-macro-transformer + (lambda (name #!optional categories keywords) + (define (filter special generator extraction) + (define (multiple rem) + (if (null? rem) + `() + `(,(generator (car rem) 'temp) + ,@(multiple (cdr rem))))) - (cond ((null? special) - `()) - ((null? (cdr special)) - `(,(generator (car special) extraction))) - (else - `((let ((temp ,extraction)) - (and ,@(multiple special))))))) + (cond ((null? special) + `()) + ((null? (cdr special)) + `(,(generator (car special) extraction))) + (else + `((let ((temp ,extraction)) + (and ,@(multiple special))))))) - `(define (,name expression) - (let ((match-result (pattern-lookup ,ea-database-name expression))) - (and match-result - ,(if (default-object? categories) - `(match-result) - `(let ((ea (match-result))) - (and ,@(filter categories - (lambda (cat exp) `(memq ',cat ,exp)) - `(ea-categories ea)) - ,@(if (default-object? keywords) - `() - (filter keywords - (lambda (key exp) - `(not (eq? ',key ,exp))) - `(ea-keyword ea))) - ea)))))))) + `(define (,name expression) + (let ((match-result (pattern-lookup ,ea-database-name expression))) + (and match-result + ,(if (default-object? categories) + `(match-result) + `(let ((ea (match-result))) + (and ,@(filter categories + (lambda (cat exp) `(memq ',cat ,exp)) + `(ea-categories ea)) + ,@(if (default-object? keywords) + `() + (filter keywords + (lambda (key exp) + `(not (eq? ',key ,exp))) + `(ea-keyword ea))) + ea))))))))) -(syntax-table/define (->environment '(COMPILER LAP-SYNTAXER)) - 'DEFINE-SYMBOL-TRANSFORMER - (lambda (name . alist) - `(begin - (declare (integrate-operator ,name)) - (define (,name symbol) - (declare (integrate symbol)) - (let ((place (assq symbol ',alist))) - (if (null? place) - #F - (cdr place))))))) +(define-syntax define-symbol-transformer + (non-hygienic-macro-transformer + (lambda (name . alist) + `(begin + (declare (integrate-operator ,name)) + (define (,name symbol) + (declare (integrate symbol)) + (let ((place (assq symbol ',alist))) + (if (null? place) + #F + (cdr place)))))))) -(syntax-table/define (->environment '(COMPILER LAP-SYNTAXER)) - 'DEFINE-REG-LIST-TRANSFORMER - (lambda (name . alist) - `(begin - (declare (integrate-operator ,name)) - (define (,name reg-list) - (declare (integrate reg-list)) - (encode-register-list reg-list ',alist))))) +(define-syntax define-reg-list-transformer + (non-hygienic-macro-transformer + (lambda (name . alist) + `(begin + (declare (integrate-operator ,name)) + (define (,name reg-list) + (declare (integrate reg-list)) + (encode-register-list reg-list ',alist)))))) ;;;; Utility procedures diff --git a/v7/src/compiler/machines/i386/assmd.scm b/v7/src/compiler/machines/i386/assmd.scm index f3060f5dd..e974f1d43 100644 --- a/v7/src/compiler/machines/i386/assmd.scm +++ b/v7/src/compiler/machines/i386/assmd.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: assmd.scm,v 1.4 2001/12/20 21:45:24 cph Exp $ +$Id: assmd.scm,v 1.5 2001/12/23 17:20:57 cph Exp $ Copyright (c) 1992, 1999, 2001 Massachusetts Institute of Technology @@ -24,7 +24,10 @@ 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 + (non-hygienic-macro-transformer + (lambda (name) `',(microcode-type name))))) (define-integrable maximum-padding-length ;; Instructions can be any number of bytes long. diff --git a/v7/src/compiler/machines/i386/dassm1.scm b/v7/src/compiler/machines/i386/dassm1.scm index b75513332..ddc110f23 100644 --- a/v7/src/compiler/machines/i386/dassm1.scm +++ b/v7/src/compiler/machines/i386/dassm1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: dassm1.scm,v 1.11 2001/12/20 21:45:24 cph Exp $ +$Id: dassm1.scm,v 1.12 2001/12/23 17:20:57 cph Exp $ Copyright (c) 1992-1999, 2001 Massachusetts Institute of Technology @@ -145,7 +145,8 @@ 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)))) + (non-hygienic-macro-transformer + (lambda (name) (microcode-type name))))) (ucode-type linkage-section)) (system-vector-ref block index)) (loop (disassembler/write-linkage-section block diff --git a/v7/src/compiler/machines/i386/dassm2.scm b/v7/src/compiler/machines/i386/dassm2.scm index 49ebeb944..c2c03a2f4 100644 --- a/v7/src/compiler/machines/i386/dassm2.scm +++ b/v7/src/compiler/machines/i386/dassm2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: dassm2.scm,v 1.10 2001/12/20 21:45:24 cph Exp $ +$Id: dassm2.scm,v 1.11 2001/12/23 17:20:58 cph Exp $ Copyright (c) 1992-1999, 2001 Massachusetts Institute of Technology @@ -27,10 +27,12 @@ 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))) + (non-hygienic-macro-transformer + (lambda (name) (microcode-type name)))) (ucode-primitive - (lambda (name arity) - (make-primitive-procedure name arity)))) + (non-hygienic-macro-transformer + (lambda (name arity) + (make-primitive-procedure name arity))))) ((ucode-primitive primitive-object-set-type 2) (ucode-type quad) (system-vector-ref block index)))) @@ -185,10 +187,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (with-absolutely-no-interrupts (lambda () (let-syntax ((ucode-type - (lambda (name) (microcode-type name))) + (non-hygienic-macro-transformer + (lambda (name) (microcode-type name)))) (ucode-primitive - (lambda (name arity) - (make-primitive-procedure name arity)))) + (non-hygienic-macro-transformer + (lambda (name arity) + (make-primitive-procedure name arity))))) ((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/i386/dassm3.scm b/v7/src/compiler/machines/i386/dassm3.scm index b5986ad32..3365a8706 100644 --- a/v7/src/compiler/machines/i386/dassm3.scm +++ b/v7/src/compiler/machines/i386/dassm3.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: dassm3.scm,v 1.8 2001/12/20 21:45:24 cph Exp $ +$Id: dassm3.scm,v 1.9 2001/12/23 17:20:58 cph Exp $ Copyright (c) 1992, 1999, 2001 Massachusetts Institute of Technology @@ -438,9 +438,11 @@ USA. next))))) (define decode-fp - (let-syntax ((IN (lambda (body . bindings) - `(LET ,bindings - ,body)))) + (let-syntax + ((IN + (non-hygienic-macro-transformer + (lambda (body . bindings) + `(LET ,bindings ,body))))) (IN (lambda (opcode-byte) (let* ((next (next-unsigned-byte)) diff --git a/v7/src/compiler/machines/i386/inerly.scm b/v7/src/compiler/machines/i386/inerly.scm index 0bbc81560..56767f99b 100644 --- a/v7/src/compiler/machines/i386/inerly.scm +++ b/v7/src/compiler/machines/i386/inerly.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: inerly.scm,v 1.6 2001/12/20 02:37:21 cph Exp $ +$Id: inerly.scm,v 1.7 2001/12/23 17:20:58 cph Exp $ Copyright (c) 1992, 1999, 2001 Massachusetts Institute of Technology @@ -25,23 +25,23 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (declare (usual-integrations)) -(syntax-table/define (->environment '(COMPILER LAP-SYNTAXER)) - 'DEFINE-INSTRUCTION - (lambda (opcode . patterns) - `(SET! EARLY-INSTRUCTIONS - (CONS - (LIST ',opcode - ,@(map (lambda (pattern) - `(early-parse-rule - ',(car pattern) - (lambda (pat vars) - (early-make-rule - pat - vars - (scode-quote - (instruction->instruction-sequence - ,(parse-instruction (cadr pattern) - (cddr pattern) - true))))))) - patterns)) - EARLY-INSTRUCTIONS)))) \ No newline at end of file +(define-syntax define-instruction + (non-hygienic-macro-transformer + (lambda (opcode . patterns) + `(SET! EARLY-INSTRUCTIONS + (CONS + (LIST ',opcode + ,@(map (lambda (pattern) + `(early-parse-rule + ',(car pattern) + (lambda (pat vars) + (early-make-rule + pat + vars + (scode-quote + (instruction->instruction-sequence + ,(parse-instruction (cadr pattern) + (cddr pattern) + #t))))))) + patterns)) + EARLY-INSTRUCTIONS))))) \ No newline at end of file diff --git a/v7/src/compiler/machines/i386/insmac.scm b/v7/src/compiler/machines/i386/insmac.scm index 5f8849196..28d5458bc 100644 --- a/v7/src/compiler/machines/i386/insmac.scm +++ b/v7/src/compiler/machines/i386/insmac.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: insmac.scm,v 1.12 2001/12/19 21:39:30 cph Exp $ +$Id: insmac.scm,v 1.13 2001/12/23 17:20:58 cph Exp $ Copyright (c) 1992, 1999, 2001 Massachusetts Institute of Technology @@ -24,29 +24,39 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (declare (usual-integrations)) +(define-syntax define-trivial-instruction + (non-hygienic-macro-transformer + (lambda (mnemonic opcode . extra) + `(DEFINE-INSTRUCTION ,mnemonic + (() + (BYTE (8 ,opcode)) + ,@(map (lambda (extra) + `(BYTE (8 ,extra))) + extra)))))) + ;;;; Effective addressing (define ea-database-name 'EA-DATABASE) -(syntax-table/define (->environment '(COMPILER LAP-SYNTAXER)) - 'DEFINE-EA-DATABASE - (lambda rules - `(DEFINE ,ea-database-name - ,(compile-database rules - (lambda (pattern actions) - (let ((keyword (car pattern)) - (categories (car actions)) - (mode (cadr actions)) - (register (caddr actions)) - (tail (cdddr actions))) - (declare (integrate keyword value)) - `(MAKE-EFFECTIVE-ADDRESS - ',keyword - ',categories - ,(integer-syntaxer mode 'UNSIGNED 2) - ,(integer-syntaxer register 'UNSIGNED 3) - ,(process-tail tail false)))))))) +(define-syntax define-ea-database + (non-hygienic-macro-transformer + (lambda rules + `(DEFINE ,ea-database-name + ,(compile-database rules + (lambda (pattern actions) + (let ((keyword (car pattern)) + (categories (car actions)) + (mode (cadr actions)) + (register (caddr actions)) + (tail (cdddr actions))) + (declare (integrate keyword value)) + `(MAKE-EFFECTIVE-ADDRESS + ',keyword + ',categories + ,(integer-syntaxer mode 'UNSIGNED 2) + ,(integer-syntaxer register 'UNSIGNED 3) + ,(process-tail tail false))))))))) (define (process-tail tail early?) (if (null? tail) @@ -55,20 +65,20 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;; This one is necessary to distinguish between r/mW mW, etc. -(syntax-table/define (->environment '(COMPILER LAP-SYNTAXER)) - 'DEFINE-EA-TRANSFORMER - (lambda (name #!optional restriction) - (if (default-object? restriction) - `(define (,name expression) - (let ((match-result (pattern-lookup ,ea-database-name expression))) - (and match-result - (match-result)))) - `(define (,name expression) - (let ((match-result (pattern-lookup ,ea-database-name expression))) - (and match-result - (let ((ea (match-result))) - (and (memq ',restriction (ea/categories ea)) - ea)))))))) +(define-syntax define-ea-transformer + (non-hygienic-macro-transformer + (lambda (name #!optional restriction) + (if (default-object? restriction) + `(DEFINE (,name EXPRESSION) + (LET ((MATCH-RESULT (PATTERN-LOOKUP ,ea-database-name EXPRESSION))) + (AND MATCH-RESULT + (MATCH-RESULT)))) + `(DEFINE (,name EXPRESSION) + (LET ((MATCH-RESULT (PATTERN-LOOKUP ,ea-database-name EXPRESSION))) + (AND MATCH-RESULT + (LET ((EA (MATCH-RESULT))) + (AND (MEMQ ',restriction (EA/CATEGORIES EA)) + EA))))))))) ;; *** We can't really handle switching these right now. *** diff --git a/v7/src/compiler/machines/i386/instr1.scm b/v7/src/compiler/machines/i386/instr1.scm index 12ec2d8a3..bd3c85896 100644 --- a/v7/src/compiler/machines/i386/instr1.scm +++ b/v7/src/compiler/machines/i386/instr1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: instr1.scm,v 1.14 2001/12/20 21:45:24 cph Exp $ +$Id: instr1.scm,v 1.15 2001/12/23 17:20:58 cph Exp $ Copyright (c) 1992, 1999, 2001 Massachusetts Institute of Technology @@ -28,17 +28,6 @@ USA. (declare (usual-integrations)) -;; Utility - -(define-syntax define-trivial-instruction - (lambda (mnemonic opcode . extra) - `(define-instruction ,mnemonic - (() - (BYTE (8 ,opcode)) - ,@(map (lambda (extra) - `(BYTE (8 ,extra))) - extra))))) - ;;;; Pseudo ops (define-instruction BYTE @@ -58,16 +47,17 @@ USA. (BYTE (32 value SIGNED))) ((U (? value)) (BYTE (32 value UNSIGNED)))) - + ;;;; Actual instructions (define-trivial-instruction AAA #x37) (define-trivial-instruction AAD #xd5 #x0a) (define-trivial-instruction AAM #xd4 #x0a) (define-trivial-instruction AAS #x3f) - + (let-syntax ((define-arithmetic-instruction + (non-hygienic-macro-transformer (lambda (mnemonic opcode digit) `(define-instruction ,mnemonic ((W (? target r/mW) (R (? source))) @@ -126,11 +116,11 @@ USA. (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))))))) + (BYTE (8 value UNSIGNED)))))))) (define-arithmetic-instruction ADC #x10 2) (define-arithmetic-instruction ADD #x00 0) @@ -140,7 +130,7 @@ USA. (define-arithmetic-instruction SBB #x18 3) (define-arithmetic-instruction SUB #x28 5) (define-arithmetic-instruction XOR #x30 6)) - + (define-instruction ARPL (((? target r/mW) (R (? source))) (BYTE (8 #x63)) @@ -170,6 +160,7 @@ USA. (let-syntax ((define-bit-test-instruction + (non-hygienic-macro-transformer (lambda (mnemonic opcode digit) `(define-instruction ,mnemonic (((? target r/mW) (& (? posn))) @@ -181,7 +172,7 @@ USA. (((? target r/mW) (R (? posn))) (BYTE (8 #x0f) (8 ,opcode)) - (ModR/M posn target)))))) + (ModR/M posn target))))))) (define-bit-test-instruction BT #xa3 4) (define-bit-test-instruction BTC #xbb 7) @@ -224,13 +215,14 @@ USA. (let-syntax ((define-string-instruction + (non-hygienic-macro-transformer (lambda (mnemonic opcode) `(define-instruction ,mnemonic ((W) (BYTE (8 ,(1+ opcode)))) ((B) - (BYTE (8 ,opcode))))))) + (BYTE (8 ,opcode)))))))) (define-string-instruction CMPS #xa6) (define-string-instruction LODS #xac) @@ -260,6 +252,7 @@ USA. (let-syntax ((define-inc/dec + (non-hygienic-macro-transformer (lambda (mnemonic digit opcode) `(define-instruction ,mnemonic ((W (R (? reg))) @@ -271,13 +264,14 @@ USA. ((B (? target r/mB)) (BYTE (8 #xfe)) - (ModR/M ,digit target)))))) + (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)) @@ -286,7 +280,7 @@ USA. ((B (R 0) (? operand r/mB)) (BYTE (8 #xf6)) - (ModR/M ,digit operand)))))) + (ModR/M ,digit operand))))))) (define-mul/div DIV 6) (define-mul/div IDIV 7) @@ -363,6 +357,7 @@ USA. (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) @@ -393,7 +388,7 @@ USA. ((W (@PCO (? displ))) (BYTE (8 #x0f) (8 ,opcode2)) - (IMMEDIATE displ ADDRESS)))))) + (IMMEDIATE displ ADDRESS))))))) (define-jump-instruction JA #x77 #x87) (define-jump-instruction JAE #x73 #x83) @@ -428,6 +423,7 @@ USA. (let-syntax ((define-loop-instruction + (non-hygienic-macro-transformer (lambda (mnemonic opcode) `(define-instruction ,mnemonic ((B (@PCR (? dest))) @@ -436,7 +432,7 @@ USA. ((B (@PCO (? displ))) (BYTE (8 ,opcode) - (8 displ SIGNED))))))) + (8 displ SIGNED)))))))) (define-loop-instruction JCXZ #xe3) (define-loop-instruction JECXZ #xe3) @@ -514,12 +510,13 @@ USA. (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)))))) + (ModR/M ,digit operand))))))) (define-load/store-state INVLPG #x01 7) ; 486 only (define-load/store-state LGDT #x01 2) diff --git a/v7/src/compiler/machines/i386/instr2.scm b/v7/src/compiler/machines/i386/instr2.scm index d5d80dac1..660b6afb1 100644 --- a/v7/src/compiler/machines/i386/instr2.scm +++ b/v7/src/compiler/machines/i386/instr2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: instr2.scm,v 1.8 2001/12/20 21:45:24 cph Exp $ +$Id: instr2.scm,v 1.9 2001/12/23 17:20:58 cph Exp $ Copyright (c) 1992, 1999, 2001 Massachusetts Institute of Technology @@ -27,29 +27,19 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;; i486 book. Check against the appendices or the i386 book. (declare (usual-integrations)) - -;; Utility - -(define-syntax define-trivial-instruction - (lambda (mnemonic opcode . extra) - `(define-instruction ,mnemonic - (() - (BYTE (8 ,opcode)) - ,@(map (lambda (extra) - `(BYTE (8 ,extra))) - extra))))) ;;;; Actual instructions (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)))))) + (ModR/M reg pointer))))))) (define-load-segment LDS #xc5) (define-load-segment LSS #x0f #xb2) @@ -65,6 +55,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((define-data-extension + (non-hygienic-macro-transformer (lambda (mnemonic opcode) `(define-instruction ,mnemonic ((B (R (? target)) (? source r/mB)) @@ -75,13 +66,14 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ((H (R (? target)) (? source r/mW)) (BYTE (8 #x0f) (8 ,(1+ opcode))) - (ModR/M target source)))))) + (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)) @@ -90,7 +82,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ((B (? operand r/mB)) (BYTE (8 #xf6)) - (ModR/M ,digit operand)))))) + (ModR/M ,digit operand))))))) (define-unary NEG 3) (define-unary NOT 2)) @@ -337,6 +329,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((define-rotate/shift + (non-hygienic-macro-transformer (lambda (mnemonic digit) `(define-instruction ,mnemonic ((W (? operand r/mW) (& 1)) @@ -363,7 +356,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ((B (? operand r/mB) (R 1)) (BYTE (8 #xd2)) - (ModR/M ,digit operand)))))) + (ModR/M ,digit operand))))))) (define-rotate/shift RCL 2) (define-rotate/shift RCR 3) @@ -376,6 +369,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((define-double-shift + (non-hygienic-macro-transformer (lambda (mnemonic opcode) `(define-instruction ,mnemonic ((W (? target r/mW) (R (? source)) (& (? count))) @@ -387,7 +381,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ((W (? target r/mW) (R (? source)) (R 1)) (BYTE (8 #x0f) (8 ,(1+ opcode))) - (ModR/M target source)))))) + (ModR/M target source))))))) (define-double-shift SHLD #xa4) (define-double-shift SHRD #xac)) @@ -411,12 +405,13 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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? + (ModR/M 0 target))))))) ; 0? (define-setcc-instruction SETA #x97) (define-setcc-instruction SETAE #x93) diff --git a/v7/src/compiler/machines/i386/instrf.scm b/v7/src/compiler/machines/i386/instrf.scm index 08116c0a0..cd88b838f 100644 --- a/v7/src/compiler/machines/i386/instrf.scm +++ b/v7/src/compiler/machines/i386/instrf.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: instrf.scm,v 1.16 2001/12/20 21:45:24 cph Exp $ +$Id: instrf.scm,v 1.17 2001/12/23 17:20:58 cph Exp $ Copyright (c) 1992, 1999, 2001 Massachusetts Institute of Technology @@ -25,6 +25,7 @@ along with this program; if not, write to the Free Software (let-syntax ((define-binary-flonum + (non-hygienic-macro-transformer (lambda (mnemonic pmnemonic imnemonic digit opcode1 opcode2) `(begin (define-instruction ,mnemonic @@ -60,7 +61,7 @@ along with this program; if not, write to the Free Software ((H (? source mW)) (BYTE (8 #xde)) - (ModR/M ,digit source))))))) + (ModR/M ,digit source)))))))) ;; The i486 book (and 387, etc.) has inconsistent instruction ;; descriptions and opcode assignments for FSUB and siblings, @@ -87,15 +88,6 @@ along with this program; if not, write to the Free Software (define-binary-flonum FSUB FSUBP FISUB 4 #xe0 #xe8) (define-binary-flonum FSUBR FSUBPR FISUBR 5 #xe8 #xe0)) -(define-syntax define-trivial-instruction - (lambda (mnemonic opcode . extra) - `(define-instruction ,mnemonic - (() - (BYTE (8 ,opcode)) - ,@(map (lambda (extra) - `(BYTE (8 ,extra))) - extra))))) - (define-trivial-instruction F2XM1 #xd9 #xf0) (define-trivial-instruction FABS #xd9 #xe1) @@ -115,6 +107,7 @@ along with this program; if not, write to the Free Software (let-syntax ((define-flonum-comparison + (non-hygienic-macro-transformer (lambda (mnemonic digit opcode) `(define-instruction ,mnemonic (((ST 0) (ST (? i))) @@ -131,7 +124,7 @@ along with this program; if not, write to the Free Software ((S (? source mW)) (BYTE (8 #xd8)) - (ModR/M ,digit source)))))) + (ModR/M ,digit source))))))) (define-flonum-comparison FCOM 2 #xd0) (define-flonum-comparison FCOMP 3 #xd8)) @@ -147,6 +140,7 @@ along with this program; if not, write to the Free Software (let-syntax ((define-flonum-integer-comparison + (non-hygienic-macro-transformer (lambda (mnemonic digit) `(define-instruction ,mnemonic ((L (? source mW)) @@ -155,13 +149,14 @@ along with this program; if not, write to the Free Software ((H (? source mW)) (BYTE (8 #xde)) - (ModR/M ,digit source)))))) + (ModR/M ,digit source))))))) (define-flonum-integer-comparison FICOM 2) (define-flonum-integer-comparison FICOMP 3)) (let-syntax ((define-flonum-integer-memory + (non-hygienic-macro-transformer (lambda (mnemonic digit1 digit2) `(define-instruction ,mnemonic ,@(if (not digit2) @@ -176,7 +171,7 @@ along with this program; if not, write to the Free Software ((H (? source mW)) (BYTE (8 #xdf)) - (ModR/M ,digit1 source)))))) + (ModR/M ,digit1 source))))))) (define-flonum-integer-memory FILD 0 5) (define-flonum-integer-memory FIST 2 #f) @@ -188,6 +183,7 @@ along with this program; if not, write to the Free Software (let-syntax ((define-flonum-memory + (non-hygienic-macro-transformer (lambda (mnemonic digit1 digit2 opcode1 opcode2) `(define-instruction ,mnemonic (((ST (? i))) @@ -206,7 +202,7 @@ along with this program; if not, write to the Free Software `() `(((X (? operand mW)) (BYTE (8 #xdb)) - (ModR/M ,digit2 operand)))))))) + (ModR/M ,digit2 operand))))))))) (define-flonum-memory FLD 0 5 #xd9 #xc0) (define-flonum-memory FST 2 #f #xdd #xd0) @@ -222,6 +218,7 @@ along with this program; if not, write to the Free Software (let-syntax ((define-flonum-state + (non-hygienic-macro-transformer (lambda (mnemonic opcode digit mnemonic2) `(begin ,@(if (not mnemonic2) @@ -235,7 +232,7 @@ along with this program; if not, write to the Free Software (define-instruction ,mnemonic (((? source mW)) (BYTE (8 ,opcode)) - (ModR/M ,digit source))))))) + (ModR/M ,digit source)))))))) (define-flonum-state FNLDCW #xd9 5 FLDCW) (define-flonum-state FLDENV #xd9 4 #f) @@ -279,6 +276,7 @@ along with this program; if not, write to the Free Software (let-syntax ((define-binary-flonum + (non-hygienic-macro-transformer (lambda (mnemonic opcode1 opcode2) `(define-instruction ,mnemonic (((ST 0) (ST (? i))) @@ -287,7 +285,7 @@ along with this program; if not, write to the Free Software (() (BYTE (8 ,opcode1) - (8 (+ ,opcode2 1)))))))) + (8 (+ ,opcode2 1))))))))) (define-binary-flonum FUCOM #xdd #xe0) (define-binary-flonum FUCOMP #xdd #xe8) diff --git a/v7/src/compiler/machines/i386/lapgen.scm b/v7/src/compiler/machines/i386/lapgen.scm index 0cd2e5925..30eb0320e 100644 --- a/v7/src/compiler/machines/i386/lapgen.scm +++ b/v7/src/compiler/machines/i386/lapgen.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: lapgen.scm,v 1.29 2001/12/20 21:45:24 cph Exp $ +$Id: lapgen.scm,v 1.30 2001/12/23 17:20:58 cph Exp $ Copyright (c) 1992-1999, 2001 Massachusetts Institute of Technology @@ -568,6 +568,7 @@ USA. (let-syntax ((define-codes + (non-hygienic-macro-transformer (lambda (start . names) (define (loop names index) (if (null? names) @@ -577,7 +578,7 @@ USA. (car names)) ,index) (loop (cdr names) (1+ index))))) - `(BEGIN ,@(loop names start))))) + `(BEGIN ,@(loop names start)))))) (define-codes #x012 primitive-apply primitive-lexpr-apply apply error lexpr-apply link @@ -605,6 +606,7 @@ USA. ,@(invoke-hook/call entry:compiler-scheme-to-interface/call))) (let-syntax ((define-entries + (non-hygienic-macro-transformer (lambda (start high . names) (define (loop names index high) (cond ((null? names) @@ -619,7 +621,7 @@ USA. (byte-offset-reference regnum:regs-pointer ,index)) (loop (cdr names) (+ index 4) high))))) - `(BEGIN ,@(loop names start high))))) + `(BEGIN ,@(loop names start high)))))) (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. diff --git a/v7/src/compiler/machines/i386/rules3.scm b/v7/src/compiler/machines/i386/rules3.scm index f9b37740f..ac6ce6ae9 100644 --- a/v7/src/compiler/machines/i386/rules3.scm +++ b/v7/src/compiler/machines/i386/rules3.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: rules3.scm,v 1.36 2001/12/20 21:45:24 cph Exp $ +$Id: rules3.scm,v 1.37 2001/12/23 17:20:58 cph Exp $ Copyright (c) 1992-1999, 2001 Massachusetts Institute of Technology @@ -171,14 +171,15 @@ USA. continuation ; ignored ;; (let-syntax ((invoke - #| - (lambda (code entry) - entry ; ignored (for now) - `(invoke-interface ,code)) - |# - (lambda (code entry) - code ; ignored - `(invoke-hook ,entry)))) + (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!) @@ -221,6 +222,7 @@ USA. (let-syntax ((define-special-primitive-invocation + (non-hygienic-macro-transformer (lambda (name) `(define-rule statement (INVOCATION:SPECIAL-PRIMITIVE @@ -230,9 +232,10 @@ USA. frame-size continuation (expect-no-exit-interrupt-checks) (special-primitive-invocation - ,(symbol-append 'CODE:COMPILER- name))))) + ,(symbol-append 'CODE:COMPILER- name)))))) (define-optimized-primitive-invocation + (non-hygienic-macro-transformer (lambda (name) `(define-rule statement (INVOCATION:SPECIAL-PRIMITIVE @@ -242,14 +245,15 @@ USA. frame-size continuation (expect-no-exit-interrupt-checks) (optimized-primitive-invocation - ,(symbol-append 'ENTRY:COMPILER- name)))))) + ,(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-optimized-primitive-invocation ,name))))) (define-primitive-invocation &+) (define-primitive-invocation &-) diff --git a/v7/src/compiler/machines/i386/rulfix.scm b/v7/src/compiler/machines/i386/rulfix.scm index a3e72d8fc..7550599b8 100644 --- a/v7/src/compiler/machines/i386/rulfix.scm +++ b/v7/src/compiler/machines/i386/rulfix.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: rulfix.scm,v 1.32 2001/12/20 21:45:25 cph Exp $ +$Id: rulfix.scm,v 1.33 2001/12/23 17:20:58 cph Exp $ Copyright (c) 1992-1999, 2001 Massachusetts Institute of Technology @@ -403,14 +403,15 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((binary-operation - (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))))))))) + (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) diff --git a/v7/src/compiler/machines/i386/rulflo.scm b/v7/src/compiler/machines/i386/rulflo.scm index 290fc1e19..04019397a 100644 --- a/v7/src/compiler/machines/i386/rulflo.scm +++ b/v7/src/compiler/machines/i386/rulflo.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: rulflo.scm,v 1.23 2001/12/20 21:45:25 cph Exp $ +$Id: rulflo.scm,v 1.24 2001/12/23 17:20:58 cph Exp $ Copyright (c) 1992-1999, 2001 Massachusetts Institute of Technology @@ -244,6 +244,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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 @@ -252,7 +253,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (LAP (,opcode)) (LAP (FLD (ST ,', source)) (,opcode) - (FSTP (ST ,',(1+ target))))))))))) + (FSTP (ST ,',(1+ target)))))))))))) (define-flonum-operation FLONUM-NEGATE FCHS) (define-flonum-operation FLONUM-ABS FABS) (define-flonum-operation FLONUM-SIN FSIN) @@ -490,6 +491,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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 @@ -534,7 +536,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (,op2%1p (ST ,',(1+ target)) (ST 0))) (LAP (FLD1) (,op2%1 (ST 0) (ST ,',(1+ source))) - (FSTP (ST ,',(1+ target)))))))))))) + (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) diff --git a/v7/src/compiler/machines/mips/inerly.scm b/v7/src/compiler/machines/mips/inerly.scm index 5da4a43ed..42ef6ab6d 100644 --- a/v7/src/compiler/machines/mips/inerly.scm +++ b/v7/src/compiler/machines/mips/inerly.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: inerly.scm,v 1.5 2001/12/20 02:37:21 cph Exp $ +$Id: inerly.scm,v 1.6 2001/12/23 17:20:58 cph Exp $ Copyright (c) 1988, 1989, 1990, 1999, 2001 Massachusetts Institute of Technology @@ -25,23 +25,23 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (declare (usual-integrations)) -(syntax-table/define (->environment '(COMPILER)) - 'DEFINE-INSTRUCTION - (lambda (opcode . patterns) - `(SET! EARLY-INSTRUCTIONS - (CONS - (LIST ',opcode - ,@(map (lambda (pattern) - `(early-parse-rule - ',(car pattern) - (lambda (pat vars) - (early-make-rule - pat - vars - (scode-quote - (instruction->instruction-sequence - ,(parse-instruction (cadr pattern) - (cddr pattern) - true))))))) - patterns)) - EARLY-INSTRUCTIONS)))) \ No newline at end of file +(define-syntax define-instruction + (non-hygienic-macro-transformer + (lambda (opcode . patterns) + `(SET! EARLY-INSTRUCTIONS + (CONS + (LIST ',opcode + ,@(map (lambda (pattern) + `(early-parse-rule + ',(car pattern) + (lambda (pat vars) + (early-make-rule + pat + vars + (scode-quote + (instruction->instruction-sequence + ,(parse-instruction (cadr pattern) + (cddr pattern) + #t))))))) + patterns)) + EARLY-INSTRUCTIONS))))) \ No newline at end of file diff --git a/v7/src/compiler/machines/mips/insmac.scm b/v7/src/compiler/machines/mips/insmac.scm index 61611a8dd..fae2d92cb 100644 --- a/v7/src/compiler/machines/mips/insmac.scm +++ b/v7/src/compiler/machines/mips/insmac.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: insmac.scm,v 1.4 2001/12/19 21:39:30 cph Exp $ +$Id: insmac.scm,v 1.5 2001/12/23 17:20:58 cph Exp $ Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology @@ -26,22 +26,19 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;;;; Definition macros -(syntax-table/define (->environment '(COMPILER LAP-SYNTAXER)) - 'DEFINE-SYMBOL-TRANSFORMER - (lambda (name . alist) - `(BEGIN - (DECLARE (INTEGRATE-OPERATOR ,name)) - (DEFINE (,name SYMBOL) - (DECLARE (INTEGRATE SYMBOL)) - (LET ((PLACE (ASSQ SYMBOL ',alist))) - (IF (NULL? PLACE) - #F - (CDR PLACE))))))) - -(syntax-table/define (->environment '(COMPILER LAP-SYNTAXER)) - 'DEFINE-TRANSFORMER - (lambda (name value) - `(DEFINE ,name ,value))) +(define-syntax define-symbol-transformer + (non-hygienic-macro-transformer + (lambda (name . alist) + `(DEFINE-INTEGRABLE (,name SYMBOL) + (LET ((PLACE (ASSQ SYMBOL ',alist))) + (IF (PAIR? PLACE) + (CDR PLACE) + #F)))))) + +(define-syntax define-transformer + (non-hygienic-macro-transformer + (lambda (name value) + `(DEFINE ,name ,value)))) ;;;; Fixed width instruction parsing diff --git a/v7/src/compiler/machines/sparc/inerly.scm b/v7/src/compiler/machines/sparc/inerly.scm index 837916398..71bee7d2e 100644 --- a/v7/src/compiler/machines/sparc/inerly.scm +++ b/v7/src/compiler/machines/sparc/inerly.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: inerly.scm,v 1.5 2001/12/20 02:37:21 cph Exp $ +$Id: inerly.scm,v 1.6 2001/12/23 17:20:58 cph Exp $ Copyright (c) 1988, 1989, 1990, 1999, 2001 Massachusetts Institute of Technology @@ -25,23 +25,23 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (declare (usual-integrations)) -(syntax-table/define (->environment '(COMPILER)) - 'DEFINE-INSTRUCTION - (lambda (opcode . patterns) - `(SET! EARLY-INSTRUCTIONS - (CONS - (LIST ',opcode - ,@(map (lambda (pattern) - `(early-parse-rule - ',(car pattern) - (lambda (pat vars) - (early-make-rule - pat - vars - (scode-quote - (instruction->instruction-sequence - ,(parse-instruction (cadr pattern) - (cddr pattern) - true))))))) - patterns)) - EARLY-INSTRUCTIONS)))) \ No newline at end of file +(define-syntax define-instruction + (non-hygienic-macro-transformer + (lambda (opcode . patterns) + `(SET! EARLY-INSTRUCTIONS + (CONS + (LIST ',opcode + ,@(map (lambda (pattern) + `(early-parse-rule + ',(car pattern) + (lambda (pat vars) + (early-make-rule + pat + vars + (scode-quote + (instruction->instruction-sequence + ,(parse-instruction (cadr pattern) + (cddr pattern) + #t))))))) + patterns)) + EARLY-INSTRUCTIONS))))) \ No newline at end of file diff --git a/v7/src/compiler/machines/sparc/insmac.scm b/v7/src/compiler/machines/sparc/insmac.scm index d695125e4..e17576830 100644 --- a/v7/src/compiler/machines/sparc/insmac.scm +++ b/v7/src/compiler/machines/sparc/insmac.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: insmac.scm,v 1.3 2001/12/19 21:39:30 cph Exp $ +$Id: insmac.scm,v 1.4 2001/12/23 17:20:58 cph Exp $ Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology @@ -26,22 +26,19 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;;;; Definition macros -(syntax-table/define (->environment '(COMPILER LAP-SYNTAXER)) - 'DEFINE-SYMBOL-TRANSFORMER - (lambda (name . alist) - `(BEGIN - (DECLARE (INTEGRATE-OPERATOR ,name)) - (DEFINE (,name SYMBOL) - (DECLARE (INTEGRATE SYMBOL)) - (LET ((PLACE (ASSQ SYMBOL ',alist))) - (IF (NULL? PLACE) - #F - (CDR PLACE))))))) - -(syntax-table/define (->environment '(COMPILER LAP-SYNTAXER)) - 'DEFINE-TRANSFORMER - (lambda (name value) - `(DEFINE ,name ,value))) +(define-syntax define-symbol-transformer + (non-hygienic-macro-transformer + (lambda (name . alist) + `(DEFINE-INTEGRABLE (,name SYMBOL) + (LET ((PLACE (ASSQ SYMBOL ',alist))) + (IF (PAIR? PLACE) + (CDR PLACE) + #F)))))) + +(define-syntax define-transformer + (non-hygienic-macro-transformer + (lambda (name value) + `(DEFINE ,name ,value)))) ;;;; Fixed width instruction parsing diff --git a/v7/src/compiler/machines/spectrum/inerly.scm b/v7/src/compiler/machines/spectrum/inerly.scm index 675434a56..7c632143c 100644 --- a/v7/src/compiler/machines/spectrum/inerly.scm +++ b/v7/src/compiler/machines/spectrum/inerly.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: inerly.scm,v 1.5 2001/12/20 02:37:21 cph Exp $ +$Id: inerly.scm,v 1.6 2001/12/23 17:20:58 cph Exp $ Copyright (c) 1988, 1989, 1990, 1999, 2001 Massachusetts Institute of Technology @@ -25,23 +25,23 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (declare (usual-integrations)) -(syntax-table/define (->environment '(COMPILER)) - 'DEFINE-INSTRUCTION - (lambda (opcode . patterns) - `(SET! EARLY-INSTRUCTIONS - (CONS - (LIST ',opcode - ,@(map (lambda (pattern) - `(early-parse-rule - ',(car pattern) - (lambda (pat vars) - (early-make-rule - pat - vars - (scode-quote - (instruction->instruction-sequence - ,(parse-instruction (cadr pattern) - (cddr pattern) - true))))))) - patterns)) - EARLY-INSTRUCTIONS)))) \ No newline at end of file +(define-syntax define-instruction + (non-hygienic-macro-transformer + (lambda (opcode . patterns) + `(SET! EARLY-INSTRUCTIONS + (CONS + (LIST ',opcode + ,@(map (lambda (pattern) + `(early-parse-rule + ',(car pattern) + (lambda (pat vars) + (early-make-rule + pat + vars + (scode-quote + (instruction->instruction-sequence + ,(parse-instruction (cadr pattern) + (cddr pattern) + #t))))))) + patterns)) + EARLY-INSTRUCTIONS))))) \ No newline at end of file diff --git a/v7/src/compiler/machines/spectrum/insmac.scm b/v7/src/compiler/machines/spectrum/insmac.scm index cc4873bd9..f86f829cf 100644 --- a/v7/src/compiler/machines/spectrum/insmac.scm +++ b/v7/src/compiler/machines/spectrum/insmac.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: insmac.scm,v 1.4 2001/12/19 21:39:30 cph Exp $ +$Id: insmac.scm,v 1.5 2001/12/23 17:20:58 cph Exp $ Copyright (c) 1988, 1989, 1990, 1999, 2001 Massachusetts Institute of Technology @@ -26,22 +26,19 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;;;; Definition macros -(syntax-table/define (->environment '(COMPILER LAP-SYNTAXER)) - 'DEFINE-SYMBOL-TRANSFORMER - (lambda (name . alist) - `(begin - (declare (integrate-operator ,name)) - (define (,name symbol) - (declare (integrate symbol)) - (let ((place (assq symbol ',alist))) - (if (null? place) - #F - (cdr place))))))) - -(syntax-table/define (->environment '(COMPILER LAP-SYNTAXER)) - 'DEFINE-TRANSFORMER - (lambda (name value) - `(define ,name ,value))) +(define-syntax define-symbol-transformer + (non-hygienic-macro-transformer + (lambda (name . alist) + `(DEFINE-INTEGRABLE (,name SYMBOL) + (LET ((PLACE (ASSQ SYMBOL ',alist))) + (IF (PAIR? PLACE) + (CDR PLACE) + #F)))))) + +(define-syntax define-transformer + (non-hygienic-macro-transformer + (lambda (name value) + `(DEFINE ,name ,value)))) ;;;; Fixed width instruction parsing diff --git a/v7/src/compiler/machines/spectrum/instr2.scm b/v7/src/compiler/machines/spectrum/instr2.scm index a2a9d88dd..8727c69c2 100644 --- a/v7/src/compiler/machines/spectrum/instr2.scm +++ b/v7/src/compiler/machines/spectrum/instr2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: instr2.scm,v 1.9 2001/12/20 21:45:25 cph Exp $ +$Id: instr2.scm,v 1.10 2001/12/23 17:20:58 cph Exp $ Copyright (c) 1987-1999, 2001 Massachusetts Institute of Technology @@ -536,15 +536,17 @@ branch-extend-nullify in instr1. (1 (branch-extend-disp disp) ASSEMBLE17:Z))))))))) (define-syntax defcond - (lambda (name opcode1 opcode2 opr1) - `(defccbranch ,name complaltfb ,opcode1 ,opcode2 ,opr1))) + (non-hygienic-macro-transformer + (lambda (name opcode1 opcode2 opr1) + `(defccbranch ,name complaltfb ,opcode1 ,opcode2 ,opr1)))) (define-syntax defpseudo - (lambda (name opcode opr1) - `(defccbranch ,name complalb - (TF-adjust ,opcode (cdr compl)) - (TF-adjust-inverted ,opcode (cdr compl)) - ,opr1))) + (non-hygienic-macro-transformer + (lambda (name opcode opr1) + `(defccbranch ,name complalb + (TF-adjust ,opcode (cdr compl)) + (TF-adjust-inverted ,opcode (cdr compl)) + ,opr1)))) (defcond COMBT #x20 #x22 (reg-1)) (defcond COMBF #x22 #x20 (reg-1)) @@ -648,15 +650,17 @@ Note: Only those currently used by the code generator are implemented. (1 (branch-extend-disp disp) ASSEMBLE17:Z))))))))) (define-syntax defcond - (lambda (name opcode1 opcode2 opr1) - `(defccbranch ,name complaltf ,opcode1 ,opcode2 ,opr1))) + (non-hygienic-macro-transformer + (lambda (name opcode1 opcode2 opr1) + `(defccbranch ,name complaltf ,opcode1 ,opcode2 ,opr1)))) (define-syntax defpseudo - (lambda (name opcode opr1) - `(defccbranch ,name complal - (TF-adjust ,opcode compl) - (TF-adjust-inverted ,opcode compl) - ,opr1))) + (non-hygienic-macro-transformer + (lambda (name opcode opr1) + `(defccbranch ,name complal + (TF-adjust ,opcode compl) + (TF-adjust-inverted ,opcode compl) + ,opr1)))) (defcond COMIBTN #X21 #x23 (immed-5 right-signed)) (defcond COMIBFN #X23 #x21 (immed-5 right-signed)) diff --git a/v7/src/compiler/machines/vax/dsyn.scm b/v7/src/compiler/machines/vax/dsyn.scm index 4db52d7d0..13acadc20 100644 --- a/v7/src/compiler/machines/vax/dsyn.scm +++ b/v7/src/compiler/machines/vax/dsyn.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: dsyn.scm,v 1.10 2001/12/21 18:28:31 cph Exp $ +$Id: dsyn.scm,v 1.11 2001/12/23 17:20:58 cph Exp $ Copyright (c) 1987, 1989, 1999, 2001 Massachusetts Institute of Technology @@ -35,12 +35,13 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. '(BYTE WORD LONG BUG B BR BSB)) (define-syntax define-instruction - (lambda (name . patterns) - (if (memq name instructions-disassembled-specially) - ''() - `(begin ,@(map (lambda (pattern) - (process-instruction-definition name pattern)) - patterns))))) + (non-hygienic-macro-transformer + (lambda (name . patterns) + (if (memq name instructions-disassembled-specially) + ''() + `(begin ,@(map (lambda (pattern) + (process-instruction-definition name pattern)) + patterns)))))) (define (process-instruction-definition name pattern) (let ((prefix (cons name (find-pattern-prefix (car pattern)))) diff --git a/v7/src/compiler/machines/vax/inerly.scm b/v7/src/compiler/machines/vax/inerly.scm index a9458736a..174ee873e 100644 --- a/v7/src/compiler/machines/vax/inerly.scm +++ b/v7/src/compiler/machines/vax/inerly.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: inerly.scm,v 1.9 2001/12/20 02:37:21 cph Exp $ +$Id: inerly.scm,v 1.10 2001/12/23 17:20:58 cph Exp $ Copyright (c) 1987-1999, 2001 Massachusetts Institute of Technology @@ -28,26 +28,26 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define early-ea-database '()) -(syntax-table/define (->environment '(COMPILER)) - 'DEFINE-INSTRUCTION - (lambda (opcode . patterns) - `(SET! EARLY-INSTRUCTIONS - (CONS - (LIST ',opcode - ,@(map (lambda (pattern) - `(EARLY-PARSE-RULE - ',(car pattern) - (LAMBDA (PAT VARS) - (EARLY-MAKE-RULE - PAT - VARS - (SCODE-QUOTE - (instruction->instruction-sequence - ,(parse-instruction (cadr pattern) - (cddr pattern) - true))))))) - patterns)) - EARLY-INSTRUCTIONS)))) +(define-syntax define-instruction + (non-hygienic-macro-transformer + (lambda (opcode . patterns) + `(SET! EARLY-INSTRUCTIONS + (CONS + (LIST ',opcode + ,@(map (lambda (pattern) + `(EARLY-PARSE-RULE + ',(car pattern) + (LAMBDA (PAT VARS) + (EARLY-MAKE-RULE + PAT + VARS + (SCODE-QUOTE + (instruction->instruction-sequence + ,(parse-instruction (cadr pattern) + (cddr pattern) + #t))))))) + patterns)) + EARLY-INSTRUCTIONS))))) ;;;; Transformers and utilities @@ -56,23 +56,23 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (cons (cons name transformer) early-transformers))) -(syntax-table/define (->environment '(COMPILER)) - 'DEFINE-SYMBOL-TRANSFORMER - (lambda (name . assoc) - `(DEFINE-EARLY-TRANSFORMER ',name (MAKE-SYMBOL-TRANSFORMER ',assoc)))) +(define-syntax define-symbol-transformer + (non-hygienic-macro-transformer + (lambda (name . assoc) + `(DEFINE-EARLY-TRANSFORMER ',name (MAKE-SYMBOL-TRANSFORMER ',assoc))))) ;; *** Is this right? *** -(syntax-table/define (->environment '(COMPILER)) - 'DEFINE-TRANSFORMER - (lambda (name value) - `(DEFINE-EARLY-TRANSFORMER ',name ,value))) +(define-syntax define-transformer + (non-hygienic-macro-transformer + (lambda (name value) + `(DEFINE-EARLY-TRANSFORMER ',name ,value)))) -(syntax-table/define (->environment '(COMPILER)) - 'DEFINE-EA-TRANSFORMER - (lambda (name category type) - `(DEFINE-EARLY-TRANSFORMER ',name - (MAKE-EA-TRANSFORMER ',category ',type)))) +(define-syntax define-ea-transformer + (non-hygienic-macro-transformer + (lambda (name category type) + `(DEFINE-EARLY-TRANSFORMER ',name + (MAKE-EA-TRANSFORMER ',category ',type))))) (define (make-ea-transformer category type) type ; ignored @@ -90,28 +90,28 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;;; *** NOTE: If this format changes, insutl.scm must also be changed! *** -(syntax-table/define (->environment '(COMPILER)) - 'DEFINE-EA-DATABASE - (lambda rules - `(SET! EARLY-EA-DATABASE - (LIST - ,@(map (lambda (rule) - (apply - (lambda (pattern categories . fields) - (let ((keyword (car pattern))) - `(EARLY-PARSE-RULE - ',pattern - (LAMBDA (PAT VARS) - (LIST PAT - VARS - ',categories - (SCODE-QUOTE - (MAKE-EFFECTIVE-ADDRESS - ',keyword - ',categories - ,(process-fields fields true)))))))) - rule)) - rules))))) +(define-syntax define-ea-database + (non-hygienic-macro-transformer + (lambda rules + `(SET! EARLY-EA-DATABASE + (LIST + ,@(map (lambda (rule) + (apply + (lambda (pattern categories . fields) + (let ((keyword (car pattern))) + `(EARLY-PARSE-RULE + ',pattern + (LAMBDA (PAT VARS) + (LIST PAT + VARS + ',categories + (SCODE-QUOTE + (MAKE-EFFECTIVE-ADDRESS + ',keyword + ',categories + ,(process-fields fields true)))))))) + rule)) + rules)))))) ;; This is super hairy because of immediate operands! ;; The index 2 here is the argument number to MAKE-EFFECTIVE-ADDRESS. diff --git a/v7/src/compiler/machines/vax/insmac.scm b/v7/src/compiler/machines/vax/insmac.scm index 8fc9fbf77..0fa772135 100644 --- a/v7/src/compiler/machines/vax/insmac.scm +++ b/v7/src/compiler/machines/vax/insmac.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: insmac.scm,v 1.14 2001/12/19 21:39:30 cph Exp $ +$Id: insmac.scm,v 1.15 2001/12/23 17:20:58 cph Exp $ Copyright (c) 1987, 1989, 1999, 2001 Massachusetts Institute of Technology @@ -29,46 +29,43 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define ea-database-name 'EA-DATABASE) -(syntax-table/define (->environment '(COMPILER LAP-SYNTAXER)) - 'DEFINE-EA-DATABASE - (lambda rules - `(DEFINE ,ea-database-name - ,(compile-database rules - (lambda (pattern actions) - (let ((keyword (car pattern)) - (categories (car actions)) - (value (cdr actions))) - (declare (integrate keyword categories value)) - `(MAKE-EFFECTIVE-ADDRESS - ',keyword - ',categories - ,(process-fields value false)))))))) +(define-syntax define-ea-database + (non-hygienic-macro-transformer + (lambda rules + `(DEFINE ,ea-database-name + ,(compile-database rules + (lambda (pattern actions) + (let ((keyword (car pattern)) + (categories (car actions)) + (value (cdr actions))) + (declare (integrate keyword categories value)) + `(MAKE-EFFECTIVE-ADDRESS + ',keyword + ',categories + ,(process-fields value false))))))))) -(syntax-table/define (->environment '(COMPILER LAP-SYNTAXER)) - 'DEFINE-EA-TRANSFORMER - (lambda (name category type) - `(define (,name expression) - (let ((ea (process-ea expression ',type))) - (and ea - (memq ',category (ea-categories ea)) - ea))))) +(define-syntax define-ea-transformer + (non-hygienic-macro-transformer + (lambda (name category type) + `(DEFINE (,name EXPRESSION) + (LET ((EA (PROCESS-EA EXPRESSION ',type))) + (AND EA + (MEMQ ',category (EA-CATEGORIES EA)) + EA)))))) -(syntax-table/define (->environment '(COMPILER LAP-SYNTAXER)) - 'DEFINE-SYMBOL-TRANSFORMER - (lambda (name . alist) - `(begin - (declare (integrate-operator ,name)) - (define (,name symbol) - (declare (integrate symbol)) - (let ((place (assq symbol ',alist))) - (if (null? place) - #F - (cdr place))))))) +(define-syntax define-symbol-transformer + (non-hygienic-macro-transformer + (lambda (name . alist) + `(DEFINE-INTEGRABLE (,name SYMBOL) + (LET ((PLACE (ASSQ SYMBOL ',alist))) + (IF (PAIR? PLACE) + (CDR PLACE) + #F)))))) -(syntax-table/define (->environment '(COMPILER LAP-SYNTAXER)) - 'DEFINE-TRANSFORMER - (lambda (name value) - `(define ,name ,value))) +(define-syntax define-transformer + (non-hygienic-macro-transformer + (lambda (name value) + `(DEFINE ,name ,value)))) (define (parse-instruction opcode tail early?) (process-fields (cons opcode tail) early?)) diff --git a/v7/src/compiler/machines/vax/instr1.scm b/v7/src/compiler/machines/vax/instr1.scm index 1139614f8..d049876ef 100644 --- a/v7/src/compiler/machines/vax/instr1.scm +++ b/v7/src/compiler/machines/vax/instr1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: instr1.scm,v 1.8 2001/12/20 20:51:16 cph Exp $ +$Id: instr1.scm,v 1.9 2001/12/23 17:20:58 cph Exp $ Copyright (c) 1987, 1989, 1999, 2001 Massachusetts Institute of Technology @@ -59,10 +59,11 @@ opcodes are ;; Utility (define-syntax define-trivial-instruction - (lambda (mnemonic opcode) - `(define-instruction ,mnemonic - (() - (BYTE (8 ,opcode)))))) + (non-hygienic-macro-transformer + (lambda (mnemonic opcode) + `(DEFINE-INSTRUCTION ,mnemonic + (() + (BYTE (8 ,opcode))))))) ;; Pseudo ops diff --git a/v7/src/compiler/machines/vax/instr2.scm b/v7/src/compiler/machines/vax/instr2.scm index c33b5e985..890110734 100644 --- a/v7/src/compiler/machines/vax/instr2.scm +++ b/v7/src/compiler/machines/vax/instr2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: instr2.scm,v 1.8 2001/12/20 21:45:25 cph Exp $ +$Id: instr2.scm,v 1.9 2001/12/23 17:20:58 cph Exp $ Copyright (c) 1987, 1989, 1999, 2001 Massachusetts Institute of Technology @@ -27,10 +27,11 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (declare (usual-integrations)) (define-syntax define-trivial-instruction - (lambda (mnemonic opcode) - `(define-instruction ,mnemonic - (() - (BYTE (8 ,opcode)))))) + (non-hygienic-macro-transformer + (lambda (mnemonic opcode) + `(DEFINE-INSTRUCTION ,mnemonic + (() + (BYTE (8 ,opcode))))))) (define-instruction CVT ((B W (? src ea-r-b) (? dst ea-w-w)) diff --git a/v7/src/compiler/machines/vax/instr3.scm b/v7/src/compiler/machines/vax/instr3.scm index 7aec89d30..509a9e720 100644 --- a/v7/src/compiler/machines/vax/instr3.scm +++ b/v7/src/compiler/machines/vax/instr3.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: instr3.scm,v 1.12 2001/12/20 21:45:25 cph Exp $ +$Id: instr3.scm,v 1.13 2001/12/23 17:20:58 cph Exp $ Copyright (c) 1987, 1989, 1991, 1999, 2001 Massachusetts Institute of Technology @@ -27,10 +27,11 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (declare (usual-integrations)) (define-syntax define-trivial-instruction - (lambda (mnemonic opcode) - `(define-instruction ,mnemonic - (() - (BYTE (8 ,opcode)))))) + (non-hygienic-macro-transformer + (lambda (mnemonic opcode) + `(DEFINE-INSTRUCTION ,mnemonic + (() + (BYTE (8 ,opcode))))))) (define-instruction ASH ((L (? cnt ea-r-b) (? src ea-r-l) (? dst ea-w-l)) diff --git a/v7/src/compiler/rtlbase/rtlreg.scm b/v7/src/compiler/rtlbase/rtlreg.scm index e1806ee6a..850383254 100644 --- a/v7/src/compiler/rtlbase/rtlreg.scm +++ b/v7/src/compiler/rtlbase/rtlreg.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: rtlreg.scm,v 4.7 2001/12/20 21:45:26 cph Exp $ +$Id: rtlreg.scm,v 4.8 2001/12/23 17:20:58 cph Exp $ Copyright (c) 1987, 1988, 1990, 1999, 2001 Massachusetts Institute of Technology @@ -67,6 +67,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((define-register-references + (non-hygienic-macro-transformer (lambda (slot) (let ((name (symbol-append 'REGISTER- slot))) (let ((vector `(,(symbol-append 'RGRAPH- name) *CURRENT-RGRAPH*))) @@ -74,7 +75,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (VECTOR-REF ,vector REGISTER)) (DEFINE-INTEGRABLE (,(symbol-append 'SET- name '!) REGISTER VALUE) - (VECTOR-SET! ,vector REGISTER VALUE)))))))) + (VECTOR-SET! ,vector REGISTER VALUE))))))))) (define-register-references bblock) (define-register-references n-refs) (define-register-references n-deaths) diff --git a/v7/src/compiler/rtlbase/valclass.scm b/v7/src/compiler/rtlbase/valclass.scm index 85d0e639c..c70a017f3 100644 --- a/v7/src/compiler/rtlbase/valclass.scm +++ b/v7/src/compiler/rtlbase/valclass.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: valclass.scm,v 1.3 1999/01/02 06:06:43 cph Exp $ +$Id: valclass.scm,v 1.4 2001/12/23 17:20:58 cph Exp $ Copyright (c) 1989, 1990, 1999 Massachusetts Institute of Technology @@ -75,6 +75,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (let-syntax ((define-value-class + (non-hygienic-macro-transformer (lambda (name parent-name) (let* ((name->variable (lambda (name) (symbol-append 'VALUE-CLASS= name))) @@ -90,7 +91,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (DEFINE (,(symbol-append 'REGISTER- variable '?) REGISTER) (VALUE-CLASS/ANCESTOR-OR-SELF? (REGISTER-VALUE-CLASS REGISTER) - ,variable))))))) + ,variable)))))))) (define-value-class value #f) (define-value-class float value) diff --git a/v7/src/edwin/buffer.scm b/v7/src/edwin/buffer.scm index f999a382d..553d38b36 100644 --- a/v7/src/edwin/buffer.scm +++ b/v7/src/edwin/buffer.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: buffer.scm,v 1.183 2001/12/20 21:27:52 cph Exp $ +;;; $Id: buffer.scm,v 1.184 2001/12/23 17:20:58 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology ;;; @@ -46,9 +46,10 @@ (let-syntax ((rename - (lambda (slot-name) - `(DEFINE-INTEGRABLE ,(symbol-append 'BUFFER- slot-name) - ,(symbol-append 'BUFFER-% slot-name))))) + (non-hygienic-macro-transformer + (lambda (slot-name) + `(DEFINE-INTEGRABLE ,(symbol-append 'BUFFER- slot-name) + ,(symbol-append 'BUFFER-% slot-name)))))) (rename name) (rename default-directory) (rename pathname) diff --git a/v7/src/edwin/calias.scm b/v7/src/edwin/calias.scm index 41c1a5613..e7dedbdd9 100644 --- a/v7/src/edwin/calias.scm +++ b/v7/src/edwin/calias.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: calias.scm,v 1.22 2001/12/20 21:27:55 cph Exp $ +;;; $Id: calias.scm,v 1.23 2001/12/23 17:20:58 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology ;;; @@ -256,8 +256,9 @@ ;; Predefined special keys (let-syntax ((make-key - (lambda (name) - `(DEFINE ,name (INTERN-SPECIAL-KEY ',name 0))))) + (non-hygienic-macro-transformer + (lambda (name) + `(DEFINE ,name (INTERN-SPECIAL-KEY ',name 0)))))) (make-key backspace) (make-key stop) (make-key f1) diff --git a/v7/src/edwin/clsmac.scm b/v7/src/edwin/clsmac.scm index 33b839a5d..60f45010d 100644 --- a/v7/src/edwin/clsmac.scm +++ b/v7/src/edwin/clsmac.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;;$Id: clsmac.scm,v 1.6 2001/12/21 18:41:10 cph Exp $ +;;;$Id: clsmac.scm,v 1.7 2001/12/23 17:20:58 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989, 1999, 2001 Massachusetts Institute of Technology ;;; @@ -30,51 +30,56 @@ ;;; ****************************************************************** (define-syntax define-class - (lambda (name superclass variables) - (guarantee-symbol "Class name" name) - (if (not (null? superclass)) - (guarantee-symbol "Class name" superclass)) - ;; Compile-time definition. - (make-class name - (if (null? superclass) false (name->class superclass)) - variables) - ;; Load-time definition. - `(DEFINE ,name - (MAKE-CLASS ',name - ,(if (null? superclass) false superclass) - ',variables)))) + (non-hygienic-macro-transformer + (lambda (name superclass variables) + (guarantee-symbol "Class name" name) + (if (not (null? superclass)) + (guarantee-symbol "Class name" superclass)) + ;; Compile-time definition. + (make-class name + (if (null? superclass) false (name->class superclass)) + variables) + ;; Load-time definition. + `(DEFINE ,name + (MAKE-CLASS ',name + ,(if (null? superclass) false superclass) + ',variables))))) (define-syntax define-method - (lambda (class bvl . body) - (syntax-class-definition class bvl body - (lambda (name expression) - (make-syntax-closure - (make-method-definition class name expression)))))) + (non-hygienic-macro-transformer + (lambda (class bvl . body) + (syntax-class-definition class bvl body + (lambda (name expression) + (make-syntax-closure + (make-method-definition class name expression))))))) (define-syntax with-instance-variables - (lambda (class self free-names . body) - (guarantee-symbol "Self name" self) - (make-syntax-closure - (syntax-class-expression class self free-names body)))) + (non-hygienic-macro-transformer + (lambda (class self free-names . body) + (guarantee-symbol "Self name" self) + (make-syntax-closure + (syntax-class-expression class self free-names body))))) (define-syntax => - (lambda (object operation . arguments) - (guarantee-symbol "Operation name" operation) - (let ((obname (string->uninterned-symbol "object"))) - `(LET ((,obname ,object)) - ((CLASS-METHODS/REF (OBJECT-METHODS ,obname) ',operation) - ,obname - ,@arguments))))) + (non-hygienic-macro-transformer + (lambda (object operation . arguments) + (guarantee-symbol "Operation name" operation) + (let ((obname (string->uninterned-symbol "object"))) + `(LET ((,obname ,object)) + ((CLASS-METHODS/REF (OBJECT-METHODS ,obname) ',operation) + ,obname + ,@arguments)))))) (define-syntax usual=> - (lambda (object operation . arguments) - (guarantee-symbol "Operation name" operation) - (if (not *class-name*) - (error "Not inside class expression: USUAL=>" operation)) - `((CLASS-METHODS/REF (CLASS-METHODS (CLASS-SUPERCLASS ,*class-name*)) - ',operation) - ,object - ,@arguments))) + (non-hygienic-macro-transformer + (lambda (object operation . arguments) + (guarantee-symbol "Operation name" operation) + (if (not *class-name*) + (error "Not inside class expression: USUAL=>" operation)) + `((CLASS-METHODS/REF (CLASS-METHODS (CLASS-SUPERCLASS ,*class-name*)) + ',operation) + ,object + ,@arguments)))) (define (syntax-class-definition class bvl body receiver) (parse-definition bvl body diff --git a/v7/src/edwin/dosproc.scm b/v7/src/edwin/dosproc.scm index fe0a2a18a..d6319c95c 100644 --- a/v7/src/edwin/dosproc.scm +++ b/v7/src/edwin/dosproc.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: dosproc.scm,v 1.6 2001/12/20 21:27:57 cph Exp $ +;;; $Id: dosproc.scm,v 1.7 2001/12/23 17:20:58 cph Exp $ ;;; ;;; Copyright (c) 1992-2001 Massachusetts Institute of Technology ;;; @@ -42,8 +42,9 @@ (editor-error "Processes not implemented" name process))) (let-syntax ((define-process-operation + (non-hygienic-macro-transformer (lambda (name) - `(define ,name (process-operation ',name))))) + `(define ,name (process-operation ',name)))))) (define-process-operation delete-process)) diff --git a/v7/src/edwin/macros.scm b/v7/src/edwin/macros.scm index 5f0f20bf4..4623a6294 100644 --- a/v7/src/edwin/macros.scm +++ b/v7/src/edwin/macros.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: macros.scm,v 1.69 2001/12/22 04:00:39 cph Exp $ +;;; $Id: macros.scm,v 1.70 2001/12/23 17:20:58 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-1999, 2001 Massachusetts Institute of Technology ;;; @@ -26,49 +26,56 @@ (define edwin-syntax-table (->environment '(EDWIN))) ;upwards compatibility (define-syntax define-command - (lambda (name description interactive procedure) - (let ((name (canonicalize-name name))) - (let ((scheme-name (command-name->scheme-name name))) - `(DEFINE ,scheme-name - (MAKE-COMMAND ',name - ,description - ,(if (null? interactive) - `'() - interactive) - ,(if (and (pair? procedure) - (eq? 'LAMBDA (car procedure)) - (pair? (cdr procedure))) - `(NAMED-LAMBDA (,scheme-name - ,@(cadr procedure)) - ,@(cddr procedure)) - procedure))))))) + (non-hygienic-macro-transformer + (lambda (name description interactive procedure) + (let ((name (canonicalize-name name))) + (let ((scheme-name (command-name->scheme-name name))) + `(DEFINE ,scheme-name + (MAKE-COMMAND ',name + ,description + ,(if (null? interactive) + `'() + interactive) + ,(if (and (pair? procedure) + (eq? 'LAMBDA (car procedure)) + (pair? (cdr procedure))) + `(NAMED-LAMBDA (,scheme-name + ,@(cadr procedure)) + ,@(cddr procedure)) + procedure)))))))) (define-syntax ref-command-object - (lambda (name) - (command-name->scheme-name (canonicalize-name name)))) + (non-hygienic-macro-transformer + (lambda (name) + (command-name->scheme-name (canonicalize-name name))))) (define-syntax ref-command - (lambda (name) - `(COMMAND-PROCEDURE - ,(command-name->scheme-name (canonicalize-name name))))) + (non-hygienic-macro-transformer + (lambda (name) + `(COMMAND-PROCEDURE + ,(command-name->scheme-name (canonicalize-name name)))))) (define-syntax command-defined? - (lambda (name) - (let ((variable-name (command-name->scheme-name (canonicalize-name name)))) - `(LET ((_ENV (->ENVIRONMENT '(EDWIN)))) - (AND (ENVIRONMENT-BOUND? _ENV ',variable-name) - (ENVIRONMENT-ASSIGNED? _ENV ',variable-name)))))) + (non-hygienic-macro-transformer + (lambda (name) + (let ((variable-name + (command-name->scheme-name (canonicalize-name name)))) + `(LET ((_ENV (->ENVIRONMENT '(EDWIN)))) + (AND (ENVIRONMENT-BOUND? _ENV ',variable-name) + (ENVIRONMENT-ASSIGNED? _ENV ',variable-name))))))) (define (command-name->scheme-name name) (symbol-append 'EDWIN-COMMAND$ name)) (define-syntax define-variable - (lambda args - (apply (variable-definition #f) args))) + (non-hygienic-macro-transformer + (lambda args + (apply (variable-definition #f) args)))) (define-syntax define-variable-per-buffer - (lambda args - (apply (variable-definition #t) args))) + (non-hygienic-macro-transformer + (lambda args + (apply (variable-definition #t) args)))) (define (variable-definition buffer-local?) (lambda (name description #!optional value test normalization) @@ -91,81 +98,90 @@ ,normalization)))))))) (define-syntax ref-variable-object - (lambda (name) - (variable-name->scheme-name (canonicalize-name name)))) + (non-hygienic-macro-transformer + (lambda (name) + (variable-name->scheme-name (canonicalize-name name))))) (define-syntax ref-variable - (lambda (name #!optional buffer) - (let ((name (variable-name->scheme-name (canonicalize-name name)))) - (if (default-object? buffer) - `(VARIABLE-VALUE ,name) - `(VARIABLE-LOCAL-VALUE ,buffer ,name))))) + (non-hygienic-macro-transformer + (lambda (name #!optional buffer) + (let ((name (variable-name->scheme-name (canonicalize-name name)))) + (if (default-object? buffer) + `(VARIABLE-VALUE ,name) + `(VARIABLE-LOCAL-VALUE ,buffer ,name)))))) (define-syntax set-variable! - (lambda (name #!optional value buffer) - (let ((name (variable-name->scheme-name (canonicalize-name name))) - (value (if (default-object? value) '#F value))) - (if (default-object? buffer) - `(SET-VARIABLE-VALUE! ,name ,value) - `(SET-VARIABLE-LOCAL-VALUE! ,buffer ,name ,value))))) + (non-hygienic-macro-transformer + (lambda (name #!optional value buffer) + (let ((name (variable-name->scheme-name (canonicalize-name name))) + (value (if (default-object? value) '#F value))) + (if (default-object? buffer) + `(SET-VARIABLE-VALUE! ,name ,value) + `(SET-VARIABLE-LOCAL-VALUE! ,buffer ,name ,value)))))) (define-syntax local-set-variable! - (lambda (name #!optional value buffer) - `(DEFINE-VARIABLE-LOCAL-VALUE! - ,(if (default-object? buffer) '(CURRENT-BUFFER) buffer) - ,(variable-name->scheme-name (canonicalize-name name)) - ,(if (default-object? value) '#F value)))) + (non-hygienic-macro-transformer + (lambda (name #!optional value buffer) + `(DEFINE-VARIABLE-LOCAL-VALUE! + ,(if (default-object? buffer) '(CURRENT-BUFFER) buffer) + ,(variable-name->scheme-name (canonicalize-name name)) + ,(if (default-object? value) '#F value))))) (define (variable-name->scheme-name name) (symbol-append 'EDWIN-VARIABLE$ name)) (define-syntax define-major-mode - (lambda (name super-mode-name display-name description - #!optional initialization) - (let ((name (canonicalize-name name)) - (super-mode-name - (and super-mode-name (canonicalize-name super-mode-name)))) - `(DEFINE ,(mode-name->scheme-name name) - (MAKE-MODE ',name - #T - ',(or display-name (symbol->string name)) - ,(if super-mode-name - `(->MODE ',super-mode-name) - `#F) - ,description - ,(let ((super-initialization - (and super-mode-name - `(MODE-INITIALIZATION - ,(mode-name->scheme-name super-mode-name)))) - (initialization - (and (not (default-object? initialization)) - initialization))) - (cond (super-initialization - `(LAMBDA (BUFFER) - (,super-initialization BUFFER) - ,@(if initialization - `((,initialization BUFFER)) - `()))) - (initialization) - (else `(LAMBDA (BUFFER) BUFFER UNSPECIFIC))))))))) + (non-hygienic-macro-transformer + (lambda (name super-mode-name display-name description + #!optional initialization) + (let ((name (canonicalize-name name)) + (super-mode-name + (and super-mode-name (canonicalize-name super-mode-name)))) + `(DEFINE ,(mode-name->scheme-name name) + (MAKE-MODE ',name + #T + ',(or display-name (symbol->string name)) + ,(if super-mode-name + `(->MODE ',super-mode-name) + `#F) + ,description + ,(let ((super-initialization + (and super-mode-name + `(MODE-INITIALIZATION + ,(mode-name->scheme-name + super-mode-name)))) + (initialization + (and (not (default-object? initialization)) + initialization))) + (cond (super-initialization + `(LAMBDA (BUFFER) + (,super-initialization BUFFER) + ,@(if initialization + `((,initialization BUFFER)) + `()))) + (initialization) + (else + `(LAMBDA (BUFFER) BUFFER UNSPECIFIC)))))))))) (define-syntax define-minor-mode - (lambda (name display-name description #!optional initialization) - (let ((name (canonicalize-name name))) - `(DEFINE ,(mode-name->scheme-name name) - (MAKE-MODE ',name - #F - ',(or display-name (symbol->string name)) - #F - ,description - ,(if (and (not (default-object? initialization)) - initialization) - initialization - `(LAMBDA (BUFFER) BUFFER UNSPECIFIC))))))) + (non-hygienic-macro-transformer + (lambda (name display-name description #!optional initialization) + (let ((name (canonicalize-name name))) + `(DEFINE ,(mode-name->scheme-name name) + (MAKE-MODE ',name + #F + ',(or display-name (symbol->string name)) + #F + ,description + ,(if (and (not (default-object? initialization)) + initialization) + initialization + `(LAMBDA (BUFFER) BUFFER UNSPECIFIC)))))))) (define-syntax ref-mode-object - (lambda (name) - (mode-name->scheme-name (canonicalize-name name)))) + (non-hygienic-macro-transformer + (lambda (name) + (mode-name->scheme-name (canonicalize-name name))))) (define (mode-name->scheme-name name) (symbol-append 'EDWIN-MODE$ name)) diff --git a/v7/src/edwin/regexp.scm b/v7/src/edwin/regexp.scm index fe086e548..45b4f1299 100644 --- a/v7/src/edwin/regexp.scm +++ b/v7/src/edwin/regexp.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: regexp.scm,v 1.76 2001/12/20 20:51:16 cph Exp $ +;;; $Id: regexp.scm,v 1.77 2001/12/23 17:20:58 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology ;;; @@ -155,28 +155,31 @@ (make-mark group start))) (define-syntax default-end-mark - (lambda (start end) - `(IF (DEFAULT-OBJECT? ,end) - (GROUP-END ,start) - (BEGIN - (IF (NOT (MARK<= ,start ,end)) - (ERROR "Marks incorrectly related:" ,start ,end)) - ,end)))) + (non-hygienic-macro-transformer + (lambda (start end) + `(IF (DEFAULT-OBJECT? ,end) + (GROUP-END ,start) + (BEGIN + (IF (NOT (MARK<= ,start ,end)) + (ERROR "Marks incorrectly related:" ,start ,end)) + ,end))))) (define-syntax default-start-mark - (lambda (start end) - `(IF (DEFAULT-OBJECT? ,start) - (GROUP-START ,end) - (BEGIN - (IF (NOT (MARK<= ,start ,end)) - (ERROR "Marks incorrectly related:" ,start ,end)) - ,start)))) + (non-hygienic-macro-transformer + (lambda (start end) + `(IF (DEFAULT-OBJECT? ,start) + (GROUP-START ,end) + (BEGIN + (IF (NOT (MARK<= ,start ,end)) + (ERROR "Marks incorrectly related:" ,start ,end)) + ,start))))) (define-syntax default-case-fold-search - (lambda (case-fold-search mark) - `(IF (DEFAULT-OBJECT? ,case-fold-search) - (GROUP-CASE-FOLD-SEARCH (MARK-GROUP ,mark)) - ,case-fold-search))) + (non-hygienic-macro-transformer + (lambda (case-fold-search mark) + `(IF (DEFAULT-OBJECT? ,case-fold-search) + (GROUP-CASE-FOLD-SEARCH (MARK-GROUP ,mark)) + ,case-fold-search)))) (define (search-forward string start #!optional end case-fold-search) (%re-search string start (default-end-mark start end) diff --git a/v7/src/edwin/search.scm b/v7/src/edwin/search.scm index b8ba514ba..8d0d477e7 100644 --- a/v7/src/edwin/search.scm +++ b/v7/src/edwin/search.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;;$Id: search.scm,v 1.152 2001/12/20 21:28:02 cph Exp $ +;;;$Id: search.scm,v 1.153 2001/12/23 17:20:58 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-1999, 2001 Massachusetts Institute of Technology ;;; @@ -25,6 +25,7 @@ (let-syntax ((define-forward-search + (non-hygienic-macro-transformer (lambda (name find-next) `(DEFINE (,name GROUP START END CHAR) ;; Assume (FIX:<= START END) @@ -52,7 +53,7 @@ CHAR))) (AND POSITION (FIX:- POSITION - (GROUP-GAP-LENGTH GROUP))))))))))) + (GROUP-GAP-LENGTH GROUP)))))))))))) (define-forward-search group-find-next-char substring-find-next-char) (define-forward-search group-find-next-char-ci substring-find-next-char-ci) (define-forward-search group-find-next-char-in-set @@ -60,6 +61,7 @@ (let-syntax ((define-backward-search + (non-hygienic-macro-transformer (lambda (name find-previous) `(DEFINE (,name GROUP START END CHAR) ;; Assume (FIX:<= START END) @@ -85,7 +87,7 @@ (,find-previous (GROUP-TEXT GROUP) START (GROUP-GAP-START GROUP) - CHAR)))))))) + CHAR))))))))) (define-backward-search group-find-previous-char substring-find-previous-char) (define-backward-search group-find-previous-char-ci substring-find-previous-char-ci) @@ -266,22 +268,24 @@ (make-mark group index))))) (define-syntax default-end-mark - (lambda (start end) - `(IF (DEFAULT-OBJECT? ,end) - (GROUP-END ,start) - (BEGIN - (IF (NOT (MARK<= ,start ,end)) - (ERROR "Marks incorrectly related:" ,start ,end)) - ,end)))) + (non-hygienic-macro-transformer + (lambda (start end) + `(IF (DEFAULT-OBJECT? ,end) + (GROUP-END ,start) + (BEGIN + (IF (NOT (MARK<= ,start ,end)) + (ERROR "Marks incorrectly related:" ,start ,end)) + ,end))))) (define-syntax default-start-mark - (lambda (start end) - `(IF (DEFAULT-OBJECT? ,start) - (GROUP-START ,end) - (BEGIN - (IF (NOT (MARK<= ,start ,end)) - (ERROR "Marks incorrectly related:" ,start ,end)) - ,start)))) + (non-hygienic-macro-transformer + (lambda (start end) + `(IF (DEFAULT-OBJECT? ,start) + (GROUP-START ,end) + (BEGIN + (IF (NOT (MARK<= ,start ,end)) + (ERROR "Marks incorrectly related:" ,start ,end)) + ,start))))) (define (char-match-forward char start #!optional end case-fold-search) (and (mark< start (default-end-mark start end)) diff --git a/v7/src/edwin/syntax.scm b/v7/src/edwin/syntax.scm index f6fc0982c..840e3a96f 100644 --- a/v7/src/edwin/syntax.scm +++ b/v7/src/edwin/syntax.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: syntax.scm,v 1.87 2001/12/20 20:51:16 cph Exp $ +;;; $Id: syntax.scm,v 1.88 2001/12/23 17:20:58 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology ;;; @@ -192,22 +192,24 @@ a comment ending." ;;;; Lisp Parsing (define-syntax default-end/forward - (lambda (start end) - `(COND ((DEFAULT-OBJECT? ,end) - (GROUP-END ,start)) - ((MARK<= ,start ,end) - ,end) - (ELSE - (ERROR "Marks incorrectly related:" ,start ,end))))) + (non-hygienic-macro-transformer + (lambda (start end) + `(COND ((DEFAULT-OBJECT? ,end) + (GROUP-END ,start)) + ((MARK<= ,start ,end) + ,end) + (ELSE + (ERROR "Marks incorrectly related:" ,start ,end)))))) (define-syntax default-end/backward - (lambda (start end) - `(COND ((DEFAULT-OBJECT? ,end) - (GROUP-START ,start)) - ((MARK>= ,start ,end) - ,end) - (ELSE - (ERROR "Marks incorrectly related:" ,start ,end))))) + (non-hygienic-macro-transformer + (lambda (start end) + `(COND ((DEFAULT-OBJECT? ,end) + (GROUP-START ,start)) + ((MARK>= ,start ,end) + ,end) + (ELSE + (ERROR "Marks incorrectly related:" ,start ,end)))))) (define (forward-prefix-chars start #!optional end) (let ((group (mark-group start)) diff --git a/v7/src/edwin/tterm.scm b/v7/src/edwin/tterm.scm index d612c99e7..82dfb288b 100644 --- a/v7/src/edwin/tterm.scm +++ b/v7/src/edwin/tterm.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: tterm.scm,v 1.31 2001/12/20 21:28:04 cph Exp $ +$Id: tterm.scm,v 1.32 2001/12/23 17:20:58 cph Exp $ Copyright (c) 1990-1999, 2001 Massachusetts Institute of Technology @@ -442,17 +442,19 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (key-table false)) (let-syntax ((define-accessor + (non-hygienic-macro-transformer (lambda (name) `(DEFINE-INTEGRABLE (,(symbol-append 'SCREEN- name) SCREEN) (,(symbol-append 'TERMINAL-STATE/ name) - (SCREEN-STATE SCREEN))))) + (SCREEN-STATE SCREEN)))))) (define-updater + (non-hygienic-macro-transformer (lambda (name) `(DEFINE-INTEGRABLE (,(symbol-append 'SET-SCREEN- name '!) SCREEN ,name) (,(symbol-append 'SET-TERMINAL-STATE/ name '!) (SCREEN-STATE SCREEN) - ,name))))) + ,name)))))) (define-accessor description) (define-accessor baud-rate-index) (define-accessor baud-rate) diff --git a/v7/src/edwin/utils.scm b/v7/src/edwin/utils.scm index 127e02b21..4536ff43d 100644 --- a/v7/src/edwin/utils.scm +++ b/v7/src/edwin/utils.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: utils.scm,v 1.49 2001/12/20 20:51:16 cph Exp $ +;;; $Id: utils.scm,v 1.50 2001/12/23 17:20:58 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology ;;; @@ -55,16 +55,17 @@ standard-error-handler)) (define-syntax chars-to-words-shift - (lambda () - ;; This is written as a macro so that the shift will be a constant - ;; in the compiled code. - ;; It does not work when cross-compiled! - (let ((chars-per-word - (vector-ref ((ucode-primitive gc-space-status 0)) 0))) - (case chars-per-word - ((4) -2) - ((8) -3) - (else (error "Can't support this word size:" chars-per-word)))))) + (non-hygienic-macro-transformer + (lambda () + ;; This is written as a macro so that the shift will be a constant + ;; in the compiled code. + ;; It does not work when cross-compiled! + (let ((chars-per-word + (vector-ref ((ucode-primitive gc-space-status 0)) 0))) + (case chars-per-word + ((4) -2) + ((8) -3) + (else (error "Can't support this word size:" chars-per-word))))))) (define (edwin-string-allocate n-chars) (if (not (fix:fixnum? n-chars)) diff --git a/v7/src/edwin/xcom.scm b/v7/src/edwin/xcom.scm index e8582c136..080ad736c 100644 --- a/v7/src/edwin/xcom.scm +++ b/v7/src/edwin/xcom.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: xcom.scm,v 1.18 2001/07/02 01:45:27 cph Exp $ +;;; $Id: xcom.scm,v 1.19 2001/12/23 17:20:58 cph Exp $ ;;; ;;; Copyright (c) 1989-2001 Massachusetts Institute of Technology ;;; @@ -310,9 +310,10 @@ When called interactively, completion is available on the input." (let-syntax ((copy - (lambda (name) - `(DEFINE ,(symbol-append 'EDWIN-COMMAND$X- name) - ,(symbol-append 'EDWIN-COMMAND$ name))))) + (non-hygienic-macro-transformer + (lambda (name) + `(DEFINE ,(symbol-append 'EDWIN-COMMAND$X- name) + ,(symbol-append 'EDWIN-COMMAND$ name)))))) (copy set-foreground-color) (copy set-background-color) (copy set-border-color) @@ -339,9 +340,10 @@ When called interactively, completion is available on the input." (let-syntax ((copy - (lambda (name) - `(DEFINE ,(symbol-append 'EDWIN-VARIABLE$X-SCREEN- name) - ,(symbol-append 'EDWIN-VARIABLE$FRAME- name))))) + (non-hygienic-macro-transformer + (lambda (name) + `(DEFINE ,(symbol-append 'EDWIN-VARIABLE$X-SCREEN- name) + ,(symbol-append 'EDWIN-VARIABLE$FRAME- name)))))) (copy icon-name-format) (copy icon-name-length)) diff --git a/v7/src/microcode/os2pm.scm b/v7/src/microcode/os2pm.scm index b8101c94b..242ca667b 100644 --- a/v7/src/microcode/os2pm.scm +++ b/v7/src/microcode/os2pm.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: os2pm.scm,v 1.9 2001/12/20 20:51:16 cph Exp $ +$Id: os2pm.scm,v 1.10 2001/12/23 17:20:59 cph Exp $ Copyright (c) 1995-1999, 2001 Massachusetts Institute of Technology @@ -52,36 +52,38 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;;;; Syntax (define-syntax define-pm-procedure - (lambda (name . clauses) - (let ((external-name (if (pair? name) (car name) name)) - (internal-name (if (pair? name) (cadr name) name))) - `(BEGIN - (HASH-TABLE/PUT! PM-PROCEDURES ',external-name - (MAKE-PMP (TRANSLATE-NAME ',external-name) - (TRANSLATE-NAME ',internal-name) - ,(let ((clause (assq 'VALUE clauses))) - (if clause - (let ((val (cadr clause))) - (if (symbol? val) - (if (eq? val 'SYNC) - `',val - `(TRANSLATE-TYPE/NAME - ',`((ID ,val) ,val))) - `(TRANSLATE-TYPE/NAME ',val))) - '#F)) - ,(let ((args - (let ((clause (assq 'ARGUMENTS clauses))) - (if (not clause) - (error "ARGUMENTS clause is required:" name)) - (cdr clause)))) - `(CONS (TRANSLATE-TYPE/NAME - ',(if (symbol? (car args)) - `((ID ,(car args)) ,(car args)) - (car args))) - (LIST ,@(map (lambda (arg) - `(TRANSLATE-TYPE/NAME ',arg)) - (cdr args))))))) - ',external-name)))) + (non-hygienic-macro-transformer + (lambda (name . clauses) + (let ((external-name (if (pair? name) (car name) name)) + (internal-name (if (pair? name) (cadr name) name))) + `(BEGIN + (HASH-TABLE/PUT! PM-PROCEDURES ',external-name + (MAKE-PMP (TRANSLATE-NAME ',external-name) + (TRANSLATE-NAME ',internal-name) + ,(let ((clause (assq 'VALUE clauses))) + (if clause + (let ((val (cadr clause))) + (if (symbol? val) + (if (eq? val 'SYNC) + `',val + `(TRANSLATE-TYPE/NAME + ',`((ID ,val) ,val))) + `(TRANSLATE-TYPE/NAME ',val))) + '#F)) + ,(let ((args + (let ((clause (assq 'ARGUMENTS clauses))) + (if (not clause) + (error "ARGUMENTS clause is required:" + name)) + (cdr clause)))) + `(CONS (TRANSLATE-TYPE/NAME + ',(if (symbol? (car args)) + `((ID ,(car args)) ,(car args)) + (car args))) + (LIST ,@(map (lambda (arg) + `(TRANSLATE-TYPE/NAME ',arg)) + (cdr args))))))) + ',external-name))))) (define (translate-type/name tn) (cond ((and (pair? tn) diff --git a/v7/src/microcode/utabmd.scm b/v7/src/microcode/utabmd.scm index 60896637e..10b3cc006 100644 --- a/v7/src/microcode/utabmd.scm +++ b/v7/src/microcode/utabmd.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: utabmd.scm,v 9.81 2001/12/21 04:36:19 cph Exp $ +;;; $Id: utabmd.scm,v 9.82 2001/12/23 17:20:59 cph Exp $ ;;; ;;; Copyright (c) 1987-2001 Massachusetts Institute of Technology ;;; @@ -575,8 +575,9 @@ ;;; [] System-call names (define-syntax ucode-primitive - (lambda args - (apply make-primitive-procedure args))) + (non-hygienic-macro-transformer + (lambda args + (apply make-primitive-procedure args)))) (vector-set! (get-fixed-objects-vector) #x09 ;(fixed-objects-vector-slot 'SYSTEM-CALL-NAMES) @@ -607,4 +608,4 @@ ;;; This identification string is saved by the system. -"$Id: utabmd.scm,v 9.81 2001/12/21 04:36:19 cph Exp $" +"$Id: utabmd.scm,v 9.82 2001/12/23 17:20:59 cph Exp $" diff --git a/v7/src/runtime/apply.scm b/v7/src/runtime/apply.scm index 3845c652a..cda18e9db 100644 --- a/v7/src/runtime/apply.scm +++ b/v7/src/runtime/apply.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: apply.scm,v 1.3 2001/12/20 21:22:05 cph Exp $ +$Id: apply.scm,v 1.4 2001/12/23 17:20:59 cph Exp $ Copyright (c) 1992, 1999, 2001 Massachusetts Institute of Technology @@ -34,25 +34,25 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (error "apply: Improper argument list" a0)) (let-syntax ((apply-dispatch&bind - (lambda (var clause . clauses) - (if (null? clauses) - (cadr clause) - (let walk ((lv var) - (clause clause) - (clauses clauses)) - `(if (not (pair? ,lv)) - (if (null? ,lv) - ,(cadr clause) - (fail)) - ,(if (null? (cdr clauses)) - (cadr (car clauses)) - (let ((lv* (generate-uninterned-symbol)) - (av* (car clause))) - `(let ((,lv* (cdr ,lv)) - (,av* (car ,lv))) - ,(walk lv* (car clauses) - (cdr clauses))))))))))) - + (non-hygienic-macro-transformer + (lambda (var clause . clauses) + (if (null? clauses) + (cadr clause) + (let walk ((lv var) + (clause clause) + (clauses clauses)) + `(if (not (pair? ,lv)) + (if (null? ,lv) + ,(cadr clause) + (fail)) + ,(if (null? (cdr clauses)) + (cadr (car clauses)) + (let ((lv* (generate-uninterned-symbol)) + (av* (car clause))) + `(let ((,lv* (cdr ,lv)) + (,av* (car ,lv))) + ,(walk lv* (car clauses) + (cdr clauses)))))))))))) (apply-dispatch&bind a0 (v0 (f)) (v1 (f v0)) @@ -64,8 +64,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (v6 (f v0 v1 v2 v3 v4 v5)) (v7 (f v0 v1 v2 v3 v4 v5 v6)) |# - (else - ((ucode-primitive apply) f a0))))) + (else ((ucode-primitive apply) f a0))))) (define (apply-entity-procedure self f . args) ;; This is safe because args is a newly-consed list diff --git a/v7/src/runtime/arith.scm b/v7/src/runtime/arith.scm index 31a726c50..48695201c 100644 --- a/v7/src/runtime/arith.scm +++ b/v7/src/runtime/arith.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: arith.scm,v 1.47 2001/12/20 21:22:31 cph Exp $ +$Id: arith.scm,v 1.48 2001/12/23 17:20:59 cph Exp $ Copyright (c) 1989-1999, 2001 Massachusetts Institute of Technology @@ -28,8 +28,9 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;;;; Utilities (define-syntax copy - (lambda (x) - `(LOCAL-DECLARE ((INTEGRATE ,x)) ,x))) + (non-hygienic-macro-transformer + (lambda (x) + `(LOCAL-DECLARE ((INTEGRATE ,x)) ,x)))) ;;;; Primitives @@ -141,63 +142,69 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((commutative - (lambda (name generic-binary identity primitive-binary) - `(SET! ,name - (MAKE-ENTITY - (NAMED-LAMBDA (,name SELF . ZS) - SELF ; ignored - (REDUCE ,generic-binary ,identity ZS)) - (VECTOR (FIXED-OBJECTS-ITEM 'arity-dispatcher-tag) - (NAMED-LAMBDA (,(symbol-append 'NULLARY- name)) - ,identity) - (NAMED-LAMBDA (,(symbol-append 'UNARY- name) Z) - (IF (NOT (COMPLEX:COMPLEX? Z)) - (ERROR:WRONG-TYPE-ARGUMENT Z FALSE ',name)) - Z) - (NAMED-LAMBDA (,(symbol-append 'BINARY- name) Z1 Z2) - ((UCODE-PRIMITIVE ,primitive-binary) Z1 Z2)))))))) + (non-hygienic-macro-transformer + (lambda (name generic-binary identity primitive-binary) + `(SET! ,name + (MAKE-ENTITY + (NAMED-LAMBDA (,name SELF . ZS) + SELF ; ignored + (REDUCE ,generic-binary ,identity ZS)) + (VECTOR + (FIXED-OBJECTS-ITEM 'arity-dispatcher-tag) + (NAMED-LAMBDA (,(symbol-append 'NULLARY- name)) + ,identity) + (NAMED-LAMBDA (,(symbol-append 'UNARY- name) Z) + (IF (NOT (COMPLEX:COMPLEX? Z)) + (ERROR:WRONG-TYPE-ARGUMENT Z FALSE ',name)) + Z) + (NAMED-LAMBDA (,(symbol-append 'BINARY- name) Z1 Z2) + ((UCODE-PRIMITIVE ,primitive-binary) Z1 Z2))))))))) (commutative + complex:+ 0 &+) (commutative * complex:* 1 &*)) (let-syntax ((non-commutative - (lambda (name generic-unary generic-binary - generic-inverse inverse-identity primitive-binary) - `(SET! ,name - (MAKE-ENTITY - (NAMED-LAMBDA (,name SELF Z1 . ZS) - SELF ; ignored - (,generic-binary - Z1 - (REDUCE ,generic-inverse ,inverse-identity ZS))) - (VECTOR (FIXED-OBJECTS-ITEM 'arity-dispatcher-tag) - #F - ,generic-unary - (NAMED-LAMBDA (,(symbol-append 'BINARY- name) Z1 Z2) - ((UCODE-PRIMITIVE ,primitive-binary) Z1 Z2)))))))) + (non-hygienic-macro-transformer + (lambda (name generic-unary generic-binary + generic-inverse inverse-identity primitive-binary) + `(SET! ,name + (MAKE-ENTITY + (NAMED-LAMBDA (,name SELF Z1 . ZS) + SELF ; ignored + (,generic-binary + Z1 + (REDUCE ,generic-inverse ,inverse-identity ZS))) + (VECTOR + (FIXED-OBJECTS-ITEM 'arity-dispatcher-tag) + #F + ,generic-unary + (NAMED-LAMBDA (,(symbol-append 'BINARY- name) Z1 Z2) + ((UCODE-PRIMITIVE ,primitive-binary) Z1 Z2))))))))) (non-commutative - complex:negate complex:- complex:+ 0 &-) (non-commutative / complex:invert complex:/ complex:* 1 &/)) (let-syntax ((relational - (lambda (name generic-binary primitive-binary correct-type? negated?) - `(SET! ,name - (MAKE-ENTITY - (NAMED-LAMBDA (,name SELF . ZS) - SELF ; ignored - (REDUCE-COMPARATOR ,generic-binary ZS ',name)) - (VECTOR - (FIXED-OBJECTS-ITEM 'arity-dispatcher-tag) - (NAMED-LAMBDA (,(symbol-append 'NULLARY- name)) #T) - (NAMED-LAMBDA (,(symbol-append 'UNARY- name) Z) - (IF (NOT (,correct-type? Z)) - (ERROR:WRONG-TYPE-ARGUMENT Z FALSE ',name)) - #T) - ,(if negated? - `(NAMED-LAMBDA (,(symbol-append 'BINARY- name) Z1 Z2) - (NOT ((UCODE-PRIMITIVE ,primitive-binary) Z1 Z2))) - `(NAMED-LAMBDA (,(symbol-append 'BINARY- name) Z1 Z2) - ((UCODE-PRIMITIVE ,primitive-binary) Z1 Z2))))))))) + (non-hygienic-macro-transformer + (lambda (name generic-binary primitive-binary correct-type? negated?) + `(SET! ,name + (MAKE-ENTITY + (NAMED-LAMBDA (,name SELF . ZS) + SELF ; ignored + (REDUCE-COMPARATOR ,generic-binary ZS ',name)) + (VECTOR + (FIXED-OBJECTS-ITEM 'arity-dispatcher-tag) + (NAMED-LAMBDA (,(symbol-append 'NULLARY- name)) #T) + (NAMED-LAMBDA (,(symbol-append 'UNARY- name) Z) + (IF (NOT (,correct-type? Z)) + (ERROR:WRONG-TYPE-ARGUMENT Z FALSE ',name)) + #T) + ,(if negated? + `(NAMED-LAMBDA (,(symbol-append 'BINARY- name) Z1 Z2) + (NOT ((UCODE-PRIMITIVE ,primitive-binary) Z1 Z2))) + `(NAMED-LAMBDA (,(symbol-append 'BINARY- name) Z1 Z2) + ((UCODE-PRIMITIVE ,primitive-binary) + Z1 Z2)))))))))) (relational = complex:= &= complex:complex? #F) (relational < complex:< &< complex:real? #F) (relational > complex:> &> complex:real? #F) @@ -206,20 +213,21 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((max/min - (lambda (name generic-binary) - `(SET! ,name - (MAKE-ENTITY - (NAMED-LAMBDA (,name SELF X . XS) - SELF ; ignored - (REDUCE-MAX/MIN ,generic-binary X XS ',name)) - (VECTOR - (FIXED-OBJECTS-ITEM 'arity-dispatcher-tag) - #F - (NAMED-LAMBDA (,(symbol-append 'UNARY- name) X) - (IF (NOT (COMPLEX:REAL? X)) - (ERROR:WRONG-TYPE-ARGUMENT X FALSE ',name)) - X) - ,generic-binary)))))) + (non-hygienic-macro-transformer + (lambda (name generic-binary) + `(SET! ,name + (MAKE-ENTITY + (NAMED-LAMBDA (,name SELF X . XS) + SELF ; ignored + (REDUCE-MAX/MIN ,generic-binary X XS ',name)) + (VECTOR + (FIXED-OBJECTS-ITEM 'arity-dispatcher-tag) + #F + (NAMED-LAMBDA (,(symbol-append 'UNARY- name) X) + (IF (NOT (COMPLEX:REAL? X)) + (ERROR:WRONG-TYPE-ARGUMENT X FALSE ',name)) + X) + ,generic-binary))))))) (max/min max complex:max) (max/min min complex:min)) @@ -510,29 +518,30 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((define-addition-operator - (lambda (name int:op) - `(define (,name u/u* v/v*) - (rat:binary-operator u/u* v/v* - ,int:op - (lambda (u v v*) - (make-rational (,int:op (int:* u v*) v) v*)) - (lambda (u u* v) - (make-rational (,int:op u (int:* v u*)) u*)) - (lambda (u u* v v*) - (let ((d1 (int:gcd u* v*))) - (if (int:= d1 1) - (make-rational (,int:op (int:* u v*) (int:* v u*)) - (int:* u* v*)) - (let* ((u*/d1 (int:quotient u* d1)) - (t - (,int:op (int:* u (int:quotient v* d1)) - (int:* v u*/d1)))) - (if (int:zero? t) - 0 ;(make-rational 0 1) - (let ((d2 (int:gcd t d1))) - (make-rational - (int:quotient t d2) - (int:* u*/d1 (int:quotient v* d2)))))))))))))) + (non-hygienic-macro-transformer + (lambda (name int:op) + `(define (,name u/u* v/v*) + (rat:binary-operator u/u* v/v* + ,int:op + (lambda (u v v*) + (make-rational (,int:op (int:* u v*) v) v*)) + (lambda (u u* v) + (make-rational (,int:op u (int:* v u*)) u*)) + (lambda (u u* v v*) + (let ((d1 (int:gcd u* v*))) + (if (int:= d1 1) + (make-rational (,int:op (int:* u v*) (int:* v u*)) + (int:* u* v*)) + (let* ((u*/d1 (int:quotient u* d1)) + (t + (,int:op (int:* u (int:quotient v* d1)) + (int:* v u*/d1)))) + (if (int:zero? t) + 0 ;(make-rational 0 1) + (let ((d2 (int:gcd t d1))) + (make-rational + (int:quotient t d2) + (int:* u*/d1 (int:quotient v* d2))))))))))))))) (define-addition-operator rat:+ int:+) (define-addition-operator rat:- int:-)) @@ -669,13 +678,14 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((define-integer-coercion - (lambda (name operation-name coercion) - `(DEFINE (,name Q) - (COND ((RATNUM? Q) - (,coercion (RATNUM-NUMERATOR Q) (RATNUM-DENOMINATOR Q))) - ((INT:INTEGER? Q) Q) - (ELSE - (ERROR:WRONG-TYPE-ARGUMENT Q FALSE ',operation-name))))))) + (non-hygienic-macro-transformer + (lambda (name operation-name coercion) + `(DEFINE (,name Q) + (COND ((RATNUM? Q) + (,coercion (RATNUM-NUMERATOR Q) (RATNUM-DENOMINATOR Q))) + ((INT:INTEGER? Q) Q) + (ELSE + (ERROR:WRONG-TYPE-ARGUMENT Q FALSE ',operation-name)))))))) (define-integer-coercion rat:floor floor int:floor) (define-integer-coercion rat:ceiling ceiling int:ceiling) (define-integer-coercion rat:truncate truncate int:quotient) @@ -920,11 +930,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((define-standard-unary - (lambda (name flo:op rat:op) - `(DEFINE (,name X) - (IF (FLONUM? X) - (,flo:op X) - (,rat:op X)))))) + (non-hygienic-macro-transformer + (lambda (name flo:op rat:op) + `(DEFINE (,name X) + (IF (FLONUM? X) + (,flo:op X) + (,rat:op X))))))) (define-standard-unary real:1+ (lambda (x) (flo:+ x flo:1)) (copy rat:1+)) (define-standard-unary real:-1+ (lambda (x) (flo:- x flo:1)) (copy rat:-1+)) (define-standard-unary real:negate flo:negate (copy rat:negate)) @@ -948,15 +959,16 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((define-standard-binary - (lambda (name flo:op rat:op) - `(DEFINE (,name X Y) - (IF (FLONUM? X) - (IF (FLONUM? Y) - (,flo:op X Y) - (,flo:op X (RAT:->INEXACT Y))) - (IF (FLONUM? Y) - (,flo:op (RAT:->INEXACT X) Y) - (,rat:op X Y))))))) + (non-hygienic-macro-transformer + (lambda (name flo:op rat:op) + `(DEFINE (,name X Y) + (IF (FLONUM? X) + (IF (FLONUM? Y) + (,flo:op X Y) + (,flo:op X (RAT:->INEXACT Y))) + (IF (FLONUM? Y) + (,flo:op (RAT:->INEXACT X) Y) + (,rat:op X Y)))))))) (define-standard-binary real:+ flo:+ (copy rat:+)) (define-standard-binary real:- flo:- (copy rat:-)) (define-standard-binary real:rationalize @@ -1032,6 +1044,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((define-integer-binary + (non-hygienic-macro-transformer (lambda (name operator-name operator) (let ((flo->int (lambda (n) @@ -1047,7 +1060,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA M))) (IF (FLONUM? M) (INT:->INEXACT (,operator N ,(flo->int 'M))) - (,operator N M)))))))) + (,operator N M))))))))) (define-integer-binary real:quotient quotient int:quotient) (define-integer-binary real:remainder remainder int:remainder) (define-integer-binary real:modulo modulo int:modulo) @@ -1060,21 +1073,23 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((define-rational-unary + (non-hygienic-macro-transformer (lambda (name operator) `(DEFINE (,name Q) (IF (FLONUM? Q) (RAT:->INEXACT (,operator (FLO:->RATIONAL Q))) - (,operator Q)))))) + (,operator Q))))))) (define-rational-unary real:numerator rat:numerator) (define-rational-unary real:denominator rat:denominator)) (let-syntax ((define-transcendental-unary + (non-hygienic-macro-transformer (lambda (name hole? hole-value function) `(DEFINE (,name X) (IF (,hole? X) ,hole-value - (,function (REAL:->INEXACT X))))))) + (,function (REAL:->INEXACT X)))))))) (define-transcendental-unary real:exp real:exact0= 1 flo:exp) (define-transcendental-unary real:log real:exact1= 0 flo:log) (define-transcendental-unary real:sin real:exact0= 0 flo:sin) diff --git a/v7/src/runtime/debug.scm b/v7/src/runtime/debug.scm index 63d78d782..c0b581d73 100644 --- a/v7/src/runtime/debug.scm +++ b/v7/src/runtime/debug.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: debug.scm,v 14.41 2001/12/20 20:51:16 cph Exp $ +$Id: debug.scm,v 14.42 2001/12/23 17:20:59 cph Exp $ Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology @@ -207,13 +207,14 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define command-set) (define-syntax define-command - (lambda (bvl . body) - (let ((dstate (cadr bvl)) - (port (caddr bvl))) - `(DEFINE (,(car bvl) #!OPTIONAL ,dstate ,port) - (LET ((,dstate (IF (DEFAULT-OBJECT? ,dstate) *DSTATE* ,dstate)) - (,port (IF (DEFAULT-OBJECT? ,port) *PORT* ,port))) - ,@body))))) + (non-hygienic-macro-transformer + (lambda (bvl . body) + (let ((dstate (cadr bvl)) + (port (caddr bvl))) + `(DEFINE (,(car bvl) #!OPTIONAL ,dstate ,port) + (LET ((,dstate (IF (DEFAULT-OBJECT? ,dstate) *DSTATE* ,dstate)) + (,port (IF (DEFAULT-OBJECT? ,port) *PORT* ,port))) + ,@body)))))) ;;;; Display commands diff --git a/v7/src/runtime/defstr.scm b/v7/src/runtime/defstr.scm index 6fa928a66..cf83a725b 100644 --- a/v7/src/runtime/defstr.scm +++ b/v7/src/runtime/defstr.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: defstr.scm,v 14.35 2001/12/21 18:37:18 cph Exp $ +$Id: defstr.scm,v 14.36 2001/12/23 17:20:59 cph Exp $ Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology @@ -71,31 +71,32 @@ differences: |# (define-syntax define-structure - (lambda (name-and-options . slot-descriptions) - (let ((structure - (with-values - (lambda () - (if (pair? name-and-options) - (values (car name-and-options) (cdr name-and-options)) - (values name-and-options '()))) - (lambda (name options) - (parse/options name - options - (map parse/slot-description - slot-descriptions)))))) - (do ((slots (structure/slots structure) (cdr slots)) - (index (if (structure/named? structure) - (+ (structure/offset structure) 1) - (structure/offset structure)) - (+ index 1))) - ((null? slots)) - (set-slot/index! (car slots) index)) - `(BEGIN ,@(type-definitions structure) - ,@(constructor-definitions structure) - ,@(accessor-definitions structure) - ,@(modifier-definitions structure) - ,@(predicate-definitions structure) - ,@(copier-definitions structure))))) + (non-hygienic-macro-transformer + (lambda (name-and-options . slot-descriptions) + (let ((structure + (with-values + (lambda () + (if (pair? name-and-options) + (values (car name-and-options) (cdr name-and-options)) + (values name-and-options '()))) + (lambda (name options) + (parse/options name + options + (map parse/slot-description + slot-descriptions)))))) + (do ((slots (structure/slots structure) (cdr slots)) + (index (if (structure/named? structure) + (+ (structure/offset structure) 1) + (structure/offset structure)) + (+ index 1))) + ((null? slots)) + (set-slot/index! (car slots) index)) + `(BEGIN ,@(type-definitions structure) + ,@(constructor-definitions structure) + ,@(accessor-definitions structure) + ,@(modifier-definitions structure) + ,@(predicate-definitions structure) + ,@(copier-definitions structure)))))) ;;;; Parse Options diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm index 313474877..cc9b7cc38 100644 --- a/v7/src/runtime/error.scm +++ b/v7/src/runtime/error.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: error.scm,v 14.54 2001/12/21 04:37:29 cph Exp $ +$Id: error.scm,v 14.55 2001/12/23 17:20:59 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -412,16 +412,17 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (loop (cdr restarts)))))) (define-syntax restarts-default - (lambda (restarts name) - ;; This is a macro because DEFAULT-OBJECT? is. - `(COND ((OR (DEFAULT-OBJECT? ,restarts) - (EQ? 'BOUND-RESTARTS ,restarts)) - *BOUND-RESTARTS*) - ((CONDITION? ,restarts) - (%CONDITION/RESTARTS ,restarts)) - (ELSE - (GUARANTEE-RESTARTS ,restarts ',name) - ,restarts)))) + (non-hygienic-macro-transformer + (lambda (restarts name) + ;; This is a macro because DEFAULT-OBJECT? is. + `(COND ((OR (DEFAULT-OBJECT? ,restarts) + (EQ? 'BOUND-RESTARTS ,restarts)) + *BOUND-RESTARTS*) + ((CONDITION? ,restarts) + (%CONDITION/RESTARTS ,restarts)) + (ELSE + (GUARANTEE-RESTARTS ,restarts ',name) + ,restarts))))) (define (find-restart name #!optional restarts) (guarantee-symbol name 'FIND-RESTART) diff --git a/v7/src/runtime/graphics.scm b/v7/src/runtime/graphics.scm index 0933b7c09..35bf71cfd 100644 --- a/v7/src/runtime/graphics.scm +++ b/v7/src/runtime/graphics.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: graphics.scm,v 1.18 2001/12/20 21:22:55 cph Exp $ +$Id: graphics.scm,v 1.19 2001/12/23 17:20:59 cph Exp $ Copyright (c) 1989-1999, 2001 Massachusetts Institute of Technology @@ -253,11 +253,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((define-graphics-operation + (non-hygienic-macro-transformer (lambda (name) `(DEFINE-INTEGRABLE (,(symbol-append 'GRAPHICS-DEVICE/OPERATION/ name) DEVICE) (,(symbol-append 'GRAPHICS-DEVICE-TYPE/OPERATION/ name) - (GRAPHICS-DEVICE/TYPE DEVICE)))))) + (GRAPHICS-DEVICE/TYPE DEVICE))))))) (define-graphics-operation clear) (define-graphics-operation close) (define-graphics-operation coordinate-limits) diff --git a/v7/src/runtime/infstr.scm b/v7/src/runtime/infstr.scm index 2f97dfc3a..fc109d020 100644 --- a/v7/src/runtime/infstr.scm +++ b/v7/src/runtime/infstr.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: infstr.scm,v 1.12 2001/12/20 21:23:14 cph Exp $ +$Id: infstr.scm,v 1.13 2001/12/23 17:20:59 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -152,13 +152,14 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((dbg-block-name - (lambda (name) - (let ((symbol (symbol-append 'DBG-BLOCK-NAME/ name))) - `(DEFINE-INTEGRABLE ,symbol - ',((ucode-primitive string->symbol) - (string-append "#[(runtime compiler-info)" - (string-downcase (symbol-name symbol)) - "]"))))))) + (non-hygienic-macro-transformer + (lambda (name) + (let ((symbol (symbol-append 'DBG-BLOCK-NAME/ name))) + `(DEFINE-INTEGRABLE ,symbol + ',((ucode-primitive string->symbol) + (string-append "#[(runtime compiler-info)" + (string-downcase (symbol-name symbol)) + "]")))))))) ;; Various names used in `layout' to identify things that wouldn't ;; otherwise have names. (dbg-block-name dynamic-link) diff --git a/v7/src/runtime/list.scm b/v7/src/runtime/list.scm index 56e7c12a5..d509471fc 100644 --- a/v7/src/runtime/list.scm +++ b/v7/src/runtime/list.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: list.scm,v 14.28 2001/12/20 21:23:31 cph Exp $ +$Id: list.scm,v 14.29 2001/12/23 17:20:59 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -547,54 +547,55 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((mapping-procedure - (lambda (name combiner initial-value procedure first rest) - `(BEGIN - (DEFINE (MAP-1 L) - (COND ((PAIR? L) - (,combiner (,procedure (CAR L)) - (MAP-1 (CDR L)))) - ((NULL? L) ,initial-value) - (ELSE (BAD-END)))) - - (DEFINE (MAP-2 L1 L2) - (COND ((AND (PAIR? L1) (PAIR? L2)) - (,combiner (,procedure (CAR L1) (CAR L2)) - (MAP-2 (CDR L1) (CDR L2)))) - ((AND (NULL? L1) (NULL? L2)) ,initial-value) - (ELSE (BAD-END)))) - - (DEFINE (MAP-N LISTS) - (LET N-LOOP ((LISTS LISTS)) - (IF (PAIR? (CAR LISTS)) - (DO ((LISTS LISTS (CDR LISTS)) - (CARS '() (CONS (CAAR LISTS) CARS)) - (CDRS '() (CONS (CDAR LISTS) CDRS))) - ((NOT (PAIR? LISTS)) - (,combiner (APPLY ,procedure (REVERSE! CARS)) - (N-LOOP (REVERSE! CDRS)))) - (IF (NOT (PAIR? (CAR LISTS))) - (BAD-END))) - (DO ((LISTS LISTS (CDR LISTS))) - ((NOT (PAIR? LISTS)) ,initial-value) - (IF (NOT (NULL? (CAR LISTS))) - (BAD-END)))))) - - (DEFINE (BAD-END) - (DO ((LISTS (CONS ,first ,rest) (CDR LISTS))) - ((NOT (PAIR? LISTS))) - (IF (NOT (LIST? (CAR LISTS))) - (ERROR:WRONG-TYPE-ARGUMENT (CAR LISTS) "list" ',name))) - (LET ((N (LENGTH ,first))) - (DO ((LISTS ,rest (CDR LISTS))) - ((NOT (PAIR? LISTS))) - (IF (NOT (= N (LENGTH (CAR LISTS)))) - (ERROR:BAD-RANGE-ARGUMENT (CAR LISTS) ',name))))) - - (IF (PAIR? ,rest) - (IF (PAIR? (CDR ,rest)) - (MAP-N (CONS ,first ,rest)) - (MAP-2 ,first (CAR ,rest))) - (MAP-1 ,first)))))) + (non-hygienic-macro-transformer + (lambda (name combiner initial-value procedure first rest) + `(BEGIN + (DEFINE (MAP-1 L) + (COND ((PAIR? L) + (,combiner (,procedure (CAR L)) + (MAP-1 (CDR L)))) + ((NULL? L) ,initial-value) + (ELSE (BAD-END)))) + + (DEFINE (MAP-2 L1 L2) + (COND ((AND (PAIR? L1) (PAIR? L2)) + (,combiner (,procedure (CAR L1) (CAR L2)) + (MAP-2 (CDR L1) (CDR L2)))) + ((AND (NULL? L1) (NULL? L2)) ,initial-value) + (ELSE (BAD-END)))) + + (DEFINE (MAP-N LISTS) + (LET N-LOOP ((LISTS LISTS)) + (IF (PAIR? (CAR LISTS)) + (DO ((LISTS LISTS (CDR LISTS)) + (CARS '() (CONS (CAAR LISTS) CARS)) + (CDRS '() (CONS (CDAR LISTS) CDRS))) + ((NOT (PAIR? LISTS)) + (,combiner (APPLY ,procedure (REVERSE! CARS)) + (N-LOOP (REVERSE! CDRS)))) + (IF (NOT (PAIR? (CAR LISTS))) + (BAD-END))) + (DO ((LISTS LISTS (CDR LISTS))) + ((NOT (PAIR? LISTS)) ,initial-value) + (IF (NOT (NULL? (CAR LISTS))) + (BAD-END)))))) + + (DEFINE (BAD-END) + (DO ((LISTS (CONS ,first ,rest) (CDR LISTS))) + ((NOT (PAIR? LISTS))) + (IF (NOT (LIST? (CAR LISTS))) + (ERROR:WRONG-TYPE-ARGUMENT (CAR LISTS) "list" ',name))) + (LET ((N (LENGTH ,first))) + (DO ((LISTS ,rest (CDR LISTS))) + ((NOT (PAIR? LISTS))) + (IF (NOT (= N (LENGTH (CAR LISTS)))) + (ERROR:BAD-RANGE-ARGUMENT (CAR LISTS) ',name))))) + + (IF (PAIR? ,rest) + (IF (PAIR? (CDR ,rest)) + (MAP-N (CONS ,first ,rest)) + (MAP-2 ,first (CAR ,rest))) + (MAP-1 ,first))))))) (define (for-each procedure first . rest) (mapping-procedure for-each begin unspecific procedure first rest)) diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm index f3b8bb89b..ff583c257 100644 --- a/v7/src/runtime/make.scm +++ b/v7/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: make.scm,v 14.81 2001/12/21 18:37:23 cph Exp $ +$Id: make.scm,v 14.82 2001/12/23 17:20:59 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -50,10 +50,16 @@ USA. (define system-global-environment #f) +(define (non-hygienic-macro-transformer transformer) + transformer) + ;; *MAKE-ENVIRONMENT is referred to by compiled code. It must go ;; before the uses of the-environment later, and after apply above. (define (*make-environment parent names . values) - (let-syntax ((ucode-type (lambda (name) (microcode-type name)))) + (let-syntax + ((ucode-type + (non-hygienic-macro-transformer + (lambda (name) (microcode-type name))))) (system-list->vector (ucode-type environment) (cons (system-pair-cons (ucode-type procedure) @@ -68,12 +74,14 @@ USA. (vector lambda-tag:unnamed)))) (define-syntax ucode-primitive - (lambda arguments - (apply make-primitive-procedure arguments))) + (non-hygienic-macro-transformer + (lambda arguments + (apply make-primitive-procedure arguments)))) (define-syntax ucode-type - (lambda (name) - (microcode-type name))) + (non-hygienic-macro-transformer + (lambda (name) + (microcode-type name)))) (define-integrable + (ucode-primitive integer-add)) (define-integrable - (ucode-primitive integer-subtract)) diff --git a/v7/src/runtime/os2winp.scm b/v7/src/runtime/os2winp.scm index 1a82c5235..e6915a091 100644 --- a/v7/src/runtime/os2winp.scm +++ b/v7/src/runtime/os2winp.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: os2winp.scm,v 1.16 2001/12/20 20:51:16 cph Exp $ +$Id: os2winp.scm,v 1.17 2001/12/23 17:20:59 cph Exp $ Copyright (c) 1995-1999, 2001 Massachusetts Institute of Technology @@ -113,16 +113,17 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-integrable (set-event-wid! event wid) (vector-set! event 1 wid)) (define-syntax define-event - (lambda (name type . slots) - `(BEGIN - (DEFINE-INTEGRABLE ,(symbol-append 'EVENT-TYPE: name) ,type) - ,@(let loop ((slots slots) (index 2)) - (if (null? slots) - '() - (cons `(DEFINE-INTEGRABLE - (,(symbol-append name '-EVENT/ (car slots)) EVENT) - (VECTOR-REF EVENT ,index)) - (loop (cdr slots) (+ index 1)))))))) + (non-hygienic-macro-transformer + (lambda (name type . slots) + `(BEGIN + (DEFINE-INTEGRABLE ,(symbol-append 'EVENT-TYPE: name) ,type) + ,@(let loop ((slots slots) (index 2)) + (if (null? slots) + '() + (cons `(DEFINE-INTEGRABLE + (,(symbol-append name '-EVENT/ (car slots)) EVENT) + (VECTOR-REF EVENT ,index)) + (loop (cdr slots) (+ index 1))))))))) ;; These must match "microcode/pros2pm.c" (define-event button 0 number type x y flags) diff --git a/v7/src/runtime/parse.scm b/v7/src/runtime/parse.scm index a8f240f1b..7dea8f196 100644 --- a/v7/src/runtime/parse.scm +++ b/v7/src/runtime/parse.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: parse.scm,v 14.34 2001/12/20 20:51:16 cph Exp $ +$Id: parse.scm,v 14.35 2001/12/23 17:20:59 cph Exp $ Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology @@ -276,21 +276,22 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define *parser-current-position*) (define-syntax define-accretor - (lambda (param-list-1 param-list-2 . body) - (let ((real-param-list (if (number? param-list-1) - param-list-2 - param-list-1)) - (real-body (if (number? param-list-1) - body - (cons param-list-2 body))) - (offset (if (number? param-list-1) - param-list-1 - 0))) - `(DEFINE ,real-param-list - (LET ((CORE (LAMBDA () ,@real-body))) - (IF *PARSER-ASSOCIATE-POSITIONS?* - (RECORDING-OBJECT-POSITION ,offset CORE) - (CORE))))))) + (non-hygienic-macro-transformer + (lambda (param-list-1 param-list-2 . body) + (let ((real-param-list (if (number? param-list-1) + param-list-2 + param-list-1)) + (real-body (if (number? param-list-1) + body + (cons param-list-2 body))) + (offset (if (number? param-list-1) + param-list-1 + 0))) + `(DEFINE ,real-param-list + (LET ((CORE (LAMBDA () ,@real-body))) + (IF *PARSER-ASSOCIATE-POSITIONS?* + (RECORDING-OBJECT-POSITION ,offset CORE) + (CORE)))))))) (define (current-position-getter port) (cond ((input-port/operation port 'POSITION) diff --git a/v7/src/runtime/parser-buffer.scm b/v7/src/runtime/parser-buffer.scm index b4a64df73..bf3707177 100644 --- a/v7/src/runtime/parser-buffer.scm +++ b/v7/src/runtime/parser-buffer.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: parser-buffer.scm,v 1.1 2001/11/11 05:51:13 cph Exp $ +;;; $Id: parser-buffer.scm,v 1.2 2001/12/23 17:20:59 cph Exp $ ;;; ;;; Copyright (c) 2001 Massachusetts Institute of Technology ;;; @@ -143,26 +143,27 @@ (let-syntax ((char-matcher - (lambda (name test) - `(BEGIN - (DEFINE (,(symbol-append 'MATCH-PARSER-BUFFER- name '-NO-ADVANCE) - BUFFER REFERENCE) - (AND (GUARANTEE-BUFFER-CHARS BUFFER 1) - (LET ((CHAR - (STRING-REF (PARSER-BUFFER-STRING BUFFER) - (PARSER-BUFFER-INDEX BUFFER)))) - (DECLARE (INTEGRATE CHAR)) - ,test))) - (DEFINE (,(symbol-append 'MATCH-PARSER-BUFFER- name) - BUFFER REFERENCE) - (AND (GUARANTEE-BUFFER-CHARS BUFFER 1) - (LET ((CHAR - (STRING-REF (PARSER-BUFFER-STRING BUFFER) - (PARSER-BUFFER-INDEX BUFFER)))) - (AND ,test - (BEGIN - (INCREMENT-BUFFER-INDEX! BUFFER CHAR) - #T))))))))) + (non-hygienic-macro-transformer + (lambda (name test) + `(BEGIN + (DEFINE (,(symbol-append 'MATCH-PARSER-BUFFER- name '-NO-ADVANCE) + BUFFER REFERENCE) + (AND (GUARANTEE-BUFFER-CHARS BUFFER 1) + (LET ((CHAR + (STRING-REF (PARSER-BUFFER-STRING BUFFER) + (PARSER-BUFFER-INDEX BUFFER)))) + (DECLARE (INTEGRATE CHAR)) + ,test))) + (DEFINE (,(symbol-append 'MATCH-PARSER-BUFFER- name) + BUFFER REFERENCE) + (AND (GUARANTEE-BUFFER-CHARS BUFFER 1) + (LET ((CHAR + (STRING-REF (PARSER-BUFFER-STRING BUFFER) + (PARSER-BUFFER-INDEX BUFFER)))) + (AND ,test + (BEGIN + (INCREMENT-BUFFER-INDEX! BUFFER CHAR) + #T)))))))))) (char-matcher char (char=? char reference)) (char-matcher char-ci (char-ci=? char reference)) (char-matcher not-char (not (char=? char reference))) @@ -184,14 +185,15 @@ (let-syntax ((string-matcher - (lambda (suffix) - (let ((name - (intern (string-append "match-parser-buffer-string" suffix))) - (match-substring - (intern - (string-append "match-parser-buffer-substring" suffix)))) - `(DEFINE (,name BUFFER STRING) - (,match-substring BUFFER STRING 0 (STRING-LENGTH STRING))))))) + (non-hygienic-macro-transformer + (lambda (suffix) + (let ((name + (intern (string-append "match-parser-buffer-string" suffix))) + (match-substring + (intern + (string-append "match-parser-buffer-substring" suffix)))) + `(DEFINE (,name BUFFER STRING) + (,match-substring BUFFER STRING 0 (STRING-LENGTH STRING)))))))) (string-matcher "") (string-matcher "-ci") (string-matcher "-no-advance") @@ -199,38 +201,40 @@ (let-syntax ((substring-matcher - (lambda (suffix) - `(DEFINE (,(intern - (string-append "match-parser-buffer-substring" suffix)) - BUFFER STRING START END) - (LET ((N (FIX:- END START))) - (AND (GUARANTEE-BUFFER-CHARS BUFFER N) - (,(intern (string-append "substring" suffix "=?")) - STRING START END - (PARSER-BUFFER-STRING BUFFER) - (PARSER-BUFFER-INDEX BUFFER) - (FIX:+ (PARSER-BUFFER-INDEX BUFFER) N)) - (BEGIN - (BUFFER-INDEX+N! BUFFER N) - #T))))))) + (non-hygienic-macro-transformer + (lambda (suffix) + `(DEFINE (,(intern + (string-append "match-parser-buffer-substring" suffix)) + BUFFER STRING START END) + (LET ((N (FIX:- END START))) + (AND (GUARANTEE-BUFFER-CHARS BUFFER N) + (,(intern (string-append "substring" suffix "=?")) + STRING START END + (PARSER-BUFFER-STRING BUFFER) + (PARSER-BUFFER-INDEX BUFFER) + (FIX:+ (PARSER-BUFFER-INDEX BUFFER) N)) + (BEGIN + (BUFFER-INDEX+N! BUFFER N) + #T)))))))) (substring-matcher "") (substring-matcher "-ci")) (let-syntax ((substring-matcher - (lambda (suffix) - `(DEFINE (,(intern - (string-append "match-parser-buffer-substring" - suffix - "-no-advance")) - BUFFER STRING START END) - (LET ((N (FIX:- END START))) - (AND (GUARANTEE-BUFFER-CHARS BUFFER N) - (,(intern (string-append "substring" suffix "=?")) - STRING START END - (PARSER-BUFFER-STRING BUFFER) - (PARSER-BUFFER-INDEX BUFFER) - (FIX:+ (PARSER-BUFFER-INDEX BUFFER) N)))))))) + (non-hygienic-macro-transformer + (lambda (suffix) + `(DEFINE (,(intern + (string-append "match-parser-buffer-substring" + suffix + "-no-advance")) + BUFFER STRING START END) + (LET ((N (FIX:- END START))) + (AND (GUARANTEE-BUFFER-CHARS BUFFER N) + (,(intern (string-append "substring" suffix "=?")) + STRING START END + (PARSER-BUFFER-STRING BUFFER) + (PARSER-BUFFER-INDEX BUFFER) + (FIX:+ (PARSER-BUFFER-INDEX BUFFER) N))))))))) (substring-matcher "") (substring-matcher "-ci")) diff --git a/v7/src/runtime/port.scm b/v7/src/runtime/port.scm index be4df45f9..e1c096772 100644 --- a/v7/src/runtime/port.scm +++ b/v7/src/runtime/port.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: port.scm,v 1.20 2001/02/27 17:20:35 cph Exp $ +$Id: port.scm,v 1.21 2001/12/23 17:20:59 cph Exp $ Copyright (c) 1991-2001 Massachusetts Institute of Technology @@ -189,9 +189,10 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (port-type/operation-names (port/type port))) (let-syntax ((define-port-operation - (lambda (dir name) - `(DEFINE (,(symbol-append dir '-PORT/OPERATION/ name) PORT) - (,(symbol-append 'PORT-TYPE/ name) (PORT/TYPE PORT)))))) + (non-hygienic-macro-transformer + (lambda (dir name) + `(DEFINE (,(symbol-append dir '-PORT/OPERATION/ name) PORT) + (,(symbol-append 'PORT-TYPE/ name) (PORT/TYPE PORT))))))) (define-port-operation input char-ready?) (define-port-operation input peek-char) (define-port-operation input read-char) diff --git a/v7/src/runtime/recslot.scm b/v7/src/runtime/recslot.scm index b4612dbf2..a74163ccb 100644 --- a/v7/src/runtime/recslot.scm +++ b/v7/src/runtime/recslot.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: recslot.scm,v 1.5 2001/12/20 20:51:16 cph Exp $ +;;; $Id: recslot.scm,v 1.6 2001/12/23 17:20:59 cph Exp $ ;;; ;;; Copyright (c) 1995-1999, 2001 Massachusetts Institute of Technology ;;; @@ -45,12 +45,13 @@ (%record-initpred index))))) (define-syntax generate-index-cases - (lambda (index limit expand-case) - `(CASE ,index - ,@(let loop ((i 1)) - (if (= i limit) - `((ELSE (,expand-case ,index))) - `(((,i) (,expand-case ,i)) ,@(loop (+ i 1)))))))) + (non-hygienic-macro-transformer + (lambda (index limit expand-case) + `(CASE ,index + ,@(let loop ((i 1)) + (if (= i limit) + `((ELSE (,expand-case ,index))) + `(((,i) (,expand-case ,i)) ,@(loop (+ i 1))))))))) (define (%record-accessor index) (generate-index-cases index 16 diff --git a/v7/src/runtime/rgxcmp.scm b/v7/src/runtime/rgxcmp.scm index 93ae6cd8b..8f99ffb10 100644 --- a/v7/src/runtime/rgxcmp.scm +++ b/v7/src/runtime/rgxcmp.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: rgxcmp.scm,v 1.117 2001/12/20 20:51:16 cph Exp $ +;;; $Id: rgxcmp.scm,v 1.118 2001/12/23 17:20:59 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology ;;; @@ -27,16 +27,18 @@ ;;;; Compiled Opcodes (define-syntax define-enumeration - (lambda (name prefix . suffixes) - `(BEGIN - ,@(let loop ((n 0) (suffixes suffixes)) - (if (null? suffixes) - '() - (cons `(DEFINE-INTEGRABLE ,(symbol-append prefix (car suffixes)) - ,n) - (loop (1+ n) (cdr suffixes))))) - (DEFINE ,name - (VECTOR ,@(map (lambda (suffix) `',suffix) suffixes)))))) + (non-hygienic-macro-transformer + (lambda (name prefix . suffixes) + `(BEGIN + ,@(let loop ((n 0) (suffixes suffixes)) + (if (pair? suffixes) + (cons `(DEFINE-INTEGRABLE + ,(symbol-append prefix (car suffixes)) + ,n) + (loop (+ n 1) (cdr suffixes))) + '())) + (DEFINE ,name + (VECTOR ,@(map (lambda (suffix) `',suffix) suffixes))))))) (define-enumeration re-codes re-code: diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 2a23aaa02..327827c11 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.402 2001/12/22 03:19:19 cph Exp $ +$Id: runtime.pkg,v 14.403 2001/12/23 17:20:59 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -3759,11 +3759,10 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime syntax-table) (files "syntab") (parent (runtime)) - (export () - syntax-table/define) (export (runtime syntaxer) guarantee-syntax-table make-syntax-table + syntax-table/define syntax-table/environment syntax-table/extend syntax-table/ref)) diff --git a/v7/src/runtime/scomb.scm b/v7/src/runtime/scomb.scm index 12f356545..b9080bf19 100644 --- a/v7/src/runtime/scomb.scm +++ b/v7/src/runtime/scomb.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: scomb.scm,v 14.17 2001/12/20 21:24:08 cph Exp $ +$Id: scomb.scm,v 14.18 2001/12/23 17:20:59 cph Exp $ Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology @@ -281,25 +281,26 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((combination-dispatch - (lambda (name combination case-0 case-1 case-2 case-n) - `(COND ((OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-0) - ,combination) - ,case-0) - ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION-1) ,combination) - (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-1) - ,combination)) - ,case-1) - ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION-2) ,combination) - (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-2) - ,combination)) - ,case-2) - ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION) ,combination) - (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-3) - ,combination)) - ,case-n) - (ELSE - (ERROR:WRONG-TYPE-ARGUMENT ,combination "SCode combination" - ',name)))))) + (non-hygienic-macro-transformer + (lambda (name combination case-0 case-1 case-2 case-n) + `(COND ((OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-0) + ,combination) + ,case-0) + ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION-1) ,combination) + (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-1) + ,combination)) + ,case-1) + ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION-2) ,combination) + (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-2) + ,combination)) + ,case-2) + ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION) ,combination) + (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-3) + ,combination)) + ,case-n) + (ELSE + (ERROR:WRONG-TYPE-ARGUMENT ,combination "SCode combination" + ',name))))))) (define (combination-size combination) (combination-dispatch combination-size combination diff --git a/v7/src/runtime/starbase.scm b/v7/src/runtime/starbase.scm index d9ea5c243..42acb0478 100644 --- a/v7/src/runtime/starbase.scm +++ b/v7/src/runtime/starbase.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: starbase.scm,v 1.14 2001/12/20 21:24:28 cph Exp $ +$Id: starbase.scm,v 1.15 2001/12/23 17:20:59 cph Exp $ Copyright (c) 1989-1999, 2001 Massachusetts Institute of Technology @@ -106,6 +106,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((define-accessors-and-mutators + (non-hygienic-macro-transformer (lambda (name) `(BEGIN (DEFINE (,(symbol-append 'STARBASE-DEVICE/ name) DEVICE) @@ -115,7 +116,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA DEVICE VALUE) (,(symbol-append 'SET-STARBASE-GRAPHICS-DESCRIPTOR/ name '!) (GRAPHICS-DEVICE/DESCRIPTOR DEVICE) - VALUE)))))) + VALUE))))))) (define-accessors-and-mutators x-left) (define-accessors-and-mutators y-bottom) (define-accessors-and-mutators x-right) diff --git a/v7/src/runtime/string.scm b/v7/src/runtime/string.scm index b457722f2..9056e2612 100644 --- a/v7/src/runtime/string.scm +++ b/v7/src/runtime/string.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: string.scm,v 14.45 2001/09/25 05:29:57 cph Exp $ +$Id: string.scm,v 14.46 2001/12/23 17:20:59 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -203,25 +203,27 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;; Calling the primitive is expensive, so avoid it for small copies. (let-syntax ((unrolled-move-left - (lambda (n) - `(BEGIN - (STRING-SET! STRING2 START2 (STRING-REF STRING1 START1)) - ,@(let loop ((i 1)) - (if (< i n) - `((STRING-SET! STRING2 (FIX:+ START2 ,i) - (STRING-REF STRING1 (FIX:+ START1 ,i))) - ,@(loop (+ i 1))) - '()))))) + (non-hygienic-macro-transformer + (lambda (n) + `(BEGIN + (STRING-SET! STRING2 START2 (STRING-REF STRING1 START1)) + ,@(let loop ((i 1)) + (if (< i n) + `((STRING-SET! STRING2 (FIX:+ START2 ,i) + (STRING-REF STRING1 (FIX:+ START1 ,i))) + ,@(loop (+ i 1))) + '())))))) (unrolled-move-right - (lambda (n) - `(BEGIN - ,@(let loop ((i 1)) - (if (< i n) - `(,@(loop (+ i 1)) - (STRING-SET! STRING2 (FIX:+ START2 ,i) - (STRING-REF STRING1 (FIX:+ START1 ,i)))) - '())) - (STRING-SET! STRING2 START2 (STRING-REF STRING1 START1)))))) + (non-hygienic-macro-transformer + (lambda (n) + `(BEGIN + ,@(let loop ((i 1)) + (if (< i n) + `(,@(loop (+ i 1)) + (STRING-SET! STRING2 (FIX:+ START2 ,i) + (STRING-REF STRING1 (FIX:+ START1 ,i)))) + '())) + (STRING-SET! STRING2 START2 (STRING-REF STRING1 START1))))))) (let ((n (fix:- end1 start1))) (if (or (not (eq? string2 string1)) (fix:< start2 start1)) (cond ((fix:> n 4) diff --git a/v7/src/runtime/sysmac.scm b/v7/src/runtime/sysmac.scm index 1fba90ba6..669fcebbb 100644 --- a/v7/src/runtime/sysmac.scm +++ b/v7/src/runtime/sysmac.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: sysmac.scm,v 14.6 2001/12/21 18:22:44 cph Exp $ +$Id: sysmac.scm,v 14.7 2001/12/23 17:20:59 cph Exp $ Copyright (c) 1988, 1999, 2001 Massachusetts Institute of Technology @@ -26,28 +26,32 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (declare (usual-integrations)) (define-syntax define-primitives - (let ((primitive-definition - (lambda (variable-name primitive-args) - `(DEFINE-INTEGRABLE ,variable-name - ,(apply make-primitive-procedure primitive-args))))) - (lambda names - `(BEGIN ,@(map (lambda (name) - (cond ((not (pair? name)) - (primitive-definition name (list name))) - ((not (symbol? (cadr name))) - (primitive-definition (car name) name)) - (else - (primitive-definition (car name) (cdr name))))) - names))))) + (non-hygienic-macro-transformer + (let ((primitive-definition + (lambda (variable-name primitive-args) + `(DEFINE-INTEGRABLE ,variable-name + ,(apply make-primitive-procedure primitive-args))))) + (lambda names + `(BEGIN ,@(map (lambda (name) + (cond ((not (pair? name)) + (primitive-definition name (list name))) + ((not (symbol? (cadr name))) + (primitive-definition (car name) name)) + (else + (primitive-definition (car name) (cdr name))))) + names)))))) (define-syntax ucode-type - (lambda arguments - (apply microcode-type arguments))) + (non-hygienic-macro-transformer + (lambda arguments + (apply microcode-type arguments)))) (define-syntax ucode-primitive - (lambda arguments - (apply make-primitive-procedure arguments))) + (non-hygienic-macro-transformer + (lambda arguments + (apply make-primitive-procedure arguments)))) (define-syntax ucode-return-address - (lambda arguments - (make-return-address (apply microcode-return arguments)))) \ No newline at end of file + (non-hygienic-macro-transformer + (lambda arguments + (make-return-address (apply microcode-return arguments))))) \ No newline at end of file diff --git a/v7/src/runtime/vector.scm b/v7/src/runtime/vector.scm index 920c10b48..4a2477ffd 100644 --- a/v7/src/runtime/vector.scm +++ b/v7/src/runtime/vector.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: vector.scm,v 14.18 2001/12/20 21:23:45 cph Exp $ +$Id: vector.scm,v 14.19 2001/12/23 17:20:59 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -204,10 +204,11 @@ USA. (let-syntax ((iref - (lambda (name index) - `(DEFINE-INTEGRABLE (,name VECTOR) - (GUARANTEE-VECTOR VECTOR 'SAFE-VECTOR-REF) - (VECTOR-REF VECTOR ,index))))) + (non-hygienic-macro-transformer + (lambda (name index) + `(DEFINE-INTEGRABLE (,name VECTOR) + (GUARANTEE-VECTOR VECTOR 'SAFE-VECTOR-REF) + (VECTOR-REF VECTOR ,index)))))) (iref vector-first 0) (iref vector-second 1) (iref vector-third 2) diff --git a/v7/src/sf/object.scm b/v7/src/sf/object.scm index 902875fce..8c238dbf5 100644 --- a/v7/src/sf/object.scm +++ b/v7/src/sf/object.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: object.scm,v 4.11 2001/12/20 21:24:54 cph Exp $ +$Id: object.scm,v 4.12 2001/12/23 17:20:59 cph Exp $ Copyright (c) 1987-1999, 2001 Massachusetts Institute of Technology @@ -65,6 +65,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((define-enumeration + (non-hygienic-macro-transformer (lambda (enumeration-name enumerand-names) `(BEGIN (DEFINE ,enumeration-name @@ -73,7 +74,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA `(DEFINE ,(symbol-append enumerand-name '/ENUMERAND) (ENUMERATION/NAME->ENUMERAND ,enumeration-name ',enumerand-name))) - enumerand-names))))) + enumerand-names)))))) (define-enumeration enumeration/random (block delayed-integration @@ -120,6 +121,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((define-simple-type + (non-hygienic-macro-transformer (lambda (name slots #!optional scode?) `(DEFINE-STRUCTURE (,name (TYPE VECTOR) (NAMED ,(symbol-append name '/ENUMERAND)) @@ -128,7 +130,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ,@(if (or (default-object? scode?) scode?) `((scode #f read-only #t)) `()) - ,@slots)))) + ,@slots))))) (define-simple-type variable (block name flags) #F) (define-simple-type access (environment name)) (define-simple-type assignment (block variable value)) @@ -165,6 +167,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let-syntax ((define-flag + (non-hygienic-macro-transformer (lambda (name tester setter) `(BEGIN (DEFINE (,tester VARIABLE) @@ -173,7 +176,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (IF (NOT (MEMQ ',name (VARIABLE/FLAGS VARIABLE))) (SET-VARIABLE/FLAGS! VARIABLE (CONS ',name - (VARIABLE/FLAGS VARIABLE))))))))) + (VARIABLE/FLAGS VARIABLE)))))))))) (define-flag SIDE-EFFECTED variable/side-effected variable/side-effect!) (define-flag REFERENCED variable/referenced variable/reference!) (define-flag INTEGRATED variable/integrated variable/integrated!) diff --git a/v7/src/sos/class.scm b/v7/src/sos/class.scm index 7536978d7..9ec8c5ff3 100644 --- a/v7/src/sos/class.scm +++ b/v7/src/sos/class.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: class.scm,v 1.10 2001/12/20 21:25:19 cph Exp $ +;;; $Id: class.scm,v 1.11 2001/12/23 17:20:59 cph Exp $ ;;; ;;; Copyright (c) 1995-1999, 2001 Massachusetts Institute of Technology ;;; @@ -273,8 +273,9 @@ (let-syntax ((define-primitive-class + (non-hygienic-macro-transformer (lambda (name . superclasses) - `(DEFINE ,name (MAKE-CLASS ',name (LIST ,@superclasses) '()))))) + `(DEFINE ,name (MAKE-CLASS ',name (LIST ,@superclasses) '())))))) (define-primitive-class ) (define-primitive-class ) diff --git a/v7/src/sos/instance.scm b/v7/src/sos/instance.scm index fd1f47e81..3bbf8b326 100644 --- a/v7/src/sos/instance.scm +++ b/v7/src/sos/instance.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: instance.scm,v 1.12 2001/12/20 20:51:16 cph Exp $ +;;; $Id: instance.scm,v 1.13 2001/12/23 17:20:59 cph Exp $ ;;; ;;; Copyright (c) 1995-2001 Massachusetts Institute of Technology ;;; @@ -29,99 +29,106 @@ ;;; requires them to appear before their first reference. (define-syntax constructor-case - (lambda (n low high generator . generator-args) - ;; Assumes that (< LOW HIGH). - (let loop ((low low) (high high)) - (let ((mid (quotient (+ high low) 2))) - (if (= mid low) - `(,generator ,@generator-args ,low) - `(IF (< ,n ,mid) - ,(loop low mid) - ,(loop mid high))))))) + (non-hygienic-macro-transformer + (lambda (n low high generator . generator-args) + ;; Assumes that (< LOW HIGH). + (let loop ((low low) (high high)) + (let ((mid (quotient (+ high low) 2))) + (if (= mid low) + `(,generator ,@generator-args ,low) + `(IF (< ,n ,mid) + ,(loop low mid) + ,(loop mid high)))))))) (define-syntax instance-constructor-1 - (lambda (n-slots) - `(IF N-INIT-ARGS - (IF (< N-INIT-ARGS 4) - (CONSTRUCTOR-CASE N-INIT-ARGS 0 4 INSTANCE-CONSTRUCTOR-2 ,n-slots) - (INSTANCE-CONSTRUCTOR-2 ,n-slots #F)) - (INSTANCE-CONSTRUCTOR-2 ,n-slots NO-INITIALIZE-INSTANCE)))) - + (non-hygienic-macro-transformer + (lambda (n-slots) + `(IF N-INIT-ARGS + (IF (< N-INIT-ARGS 4) + (CONSTRUCTOR-CASE N-INIT-ARGS 0 4 INSTANCE-CONSTRUCTOR-2 + ,n-slots) + (INSTANCE-CONSTRUCTOR-2 ,n-slots #F)) + (INSTANCE-CONSTRUCTOR-2 ,n-slots NO-INITIALIZE-INSTANCE))))) + (define-syntax instance-constructor-2 - (lambda (n-slots n-init-args) - (let ((make-names - (lambda (n prefix) - (make-initialized-list n - (lambda (index) - (intern (string-append prefix (number->string index)))))))) - (call-with-values - (lambda () - (cond ((eq? 'NO-INITIALIZE-INSTANCE n-init-args) - (values '() '())) - (n-init-args - (let ((ivs (make-names n-init-args "iv"))) - (values ivs `((INITIALIZE-INSTANCE INSTANCE ,@ivs))))) - (else - (values 'IVS `((APPLY INITIALIZE-INSTANCE INSTANCE IVS)))))) - (lambda (ivs ixs) - (let ((generator - (lambda (initialization) - (let ((sis (make-names n-slots "si")) - (svs (make-names n-slots "sv"))) - (let ((l - `(LAMBDA (,@svs . ,ivs) - (LET ((INSTANCE - (OBJECT-NEW-TYPE - (UCODE-TYPE RECORD) - (MAKE-VECTOR - INSTANCE-LENGTH - RECORD-SLOT-UNINITIALIZED)))) - (%RECORD-SET! INSTANCE 0 INSTANCE-TAG) - ,@(map (lambda (index value) - `(%RECORD-SET! INSTANCE - ,index - ,value)) - sis - svs) - ,@initialization - ,@ixs - INSTANCE)))) - (if (null? sis) - l - `(LET (,@(make-initialized-list n-slots - (lambda (i) - `(,(list-ref sis i) - (LIST-REF INDEXES ,i))))) - ,l))))))) - `(IF INITIALIZATION - ,(generator '((INITIALIZATION INSTANCE))) - ,(generator '())))))))) + (non-hygienic-macro-transformer + (lambda (n-slots n-init-args) + (let ((make-names + (lambda (n prefix) + (make-initialized-list n + (lambda (index) + (intern (string-append prefix (number->string index)))))))) + (call-with-values + (lambda () + (cond ((eq? 'NO-INITIALIZE-INSTANCE n-init-args) + (values '() '())) + (n-init-args + (let ((ivs (make-names n-init-args "iv"))) + (values ivs `((INITIALIZE-INSTANCE INSTANCE ,@ivs))))) + (else + (values 'IVS + `((APPLY INITIALIZE-INSTANCE INSTANCE IVS)))))) + (lambda (ivs ixs) + (let ((generator + (lambda (initialization) + (let ((sis (make-names n-slots "si")) + (svs (make-names n-slots "sv"))) + (let ((l + `(LAMBDA (,@svs . ,ivs) + (LET ((INSTANCE + (OBJECT-NEW-TYPE + (UCODE-TYPE RECORD) + (MAKE-VECTOR + INSTANCE-LENGTH + RECORD-SLOT-UNINITIALIZED)))) + (%RECORD-SET! INSTANCE 0 INSTANCE-TAG) + ,@(map (lambda (index value) + `(%RECORD-SET! INSTANCE + ,index + ,value)) + sis + svs) + ,@initialization + ,@ixs + INSTANCE)))) + (if (null? sis) + l + `(LET (,@(make-initialized-list n-slots + (lambda (i) + `(,(list-ref sis i) + (LIST-REF INDEXES ,i))))) + ,l))))))) + `(IF INITIALIZATION + ,(generator '((INITIALIZATION INSTANCE))) + ,(generator '()))))))))) (define-syntax ucode-type - (lambda arguments - (apply microcode-type arguments))) + (non-hygienic-macro-transformer + (lambda arguments + (apply microcode-type arguments)))) (define-syntax instance-constructor-3 - (lambda (test arity initialization ixs) - `(LETREC - ((PROCEDURE - (LAMBDA ARGS - (IF (NOT (,@test (LENGTH ARGS))) - (ERROR:WRONG-NUMBER-OF-ARGUMENTS PROCEDURE ,arity ARGS)) - (LET ((INSTANCE - (OBJECT-NEW-TYPE - (UCODE-TYPE RECORD) - (MAKE-VECTOR INSTANCE-LENGTH - RECORD-SLOT-UNINITIALIZED)))) - (%RECORD-SET! INSTANCE 0 INSTANCE-TAG) - (DO ((INDEXES INDEXES (CDR INDEXES)) - (ARGS ARGS (CDR ARGS))) - ((NULL? INDEXES) - ,@initialization - ,@ixs) - (%RECORD-SET! INSTANCE (CAR INDEXES) (CAR ARGS))) - INSTANCE)))) - PROCEDURE))) + (non-hygienic-macro-transformer + (lambda (test arity initialization ixs) + `(LETREC + ((PROCEDURE + (LAMBDA ARGS + (IF (NOT (,@test (LENGTH ARGS))) + (ERROR:WRONG-NUMBER-OF-ARGUMENTS PROCEDURE ,arity ARGS)) + (LET ((INSTANCE + (OBJECT-NEW-TYPE + (UCODE-TYPE RECORD) + (MAKE-VECTOR INSTANCE-LENGTH + RECORD-SLOT-UNINITIALIZED)))) + (%RECORD-SET! INSTANCE 0 INSTANCE-TAG) + (DO ((INDEXES INDEXES (CDR INDEXES)) + (ARGS ARGS (CDR ARGS))) + ((NULL? INDEXES) + ,@initialization + ,@ixs) + (%RECORD-SET! INSTANCE (CAR INDEXES) (CAR ARGS))) + INSTANCE)))) + PROCEDURE)))) (define (instance-constructor class slot-names #!optional init-arg-names) (if (not (subclass? class )) @@ -178,64 +185,66 @@ (instance-constructor-3 (fix:= n-slots) n-slots () ())))))) (define-syntax make-initialization-1 - (lambda (if-n) - `(IF (< IV-N 8) - (CONSTRUCTOR-CASE IV-N 0 8 MAKE-INITIALIZATION-2 ,if-n) - (MAKE-INITIALIZATION-2 ,if-n #F)))) + (non-hygienic-macro-transformer + (lambda (if-n) + `(IF (< IV-N 8) + (CONSTRUCTOR-CASE IV-N 0 8 MAKE-INITIALIZATION-2 ,if-n) + (MAKE-INITIALIZATION-2 ,if-n #F))))) (define-syntax make-initialization-2 - (lambda (if-n iv-n) - (if (and if-n iv-n) - (let ((generate - (let ((make-names - (lambda (n prefix) - (make-initialized-list n - (lambda (index) - (intern - (string-append prefix - (number->string index)))))))) - (lambda (n prefix isn vsn fv) - (let ((is (make-names n (string-append prefix "i"))) - (vs (make-names n (string-append prefix "v")))) - (values - (append (make-initialized-list n - (lambda (i) - `(,(list-ref is i) (LIST-REF ,isn ,i)))) - (make-initialized-list n - (lambda (i) - `(,(list-ref vs i) (LIST-REF ,vsn ,i))))) - (make-initialized-list n - (lambda (i) - `(%RECORD-SET! INSTANCE - ,(list-ref is i) - ,(fv (list-ref vs i))))))))))) - - (call-with-values - (lambda () - (generate if-n "f" 'IF-INDEXES 'INITIALIZERS - (lambda (expr) `(,expr)))) - (lambda (if-bindings if-body) - (call-with-values - (lambda () - (generate iv-n "v" 'IV-INDEXES 'INITIAL-VALUES - (lambda (expr) expr))) - (lambda (iv-bindings iv-body) - (if (and (null? if-bindings) (null? iv-bindings)) - '#F - `(LET (,@if-bindings ,@iv-bindings) - (LAMBDA (INSTANCE) - ,@if-body - ,@iv-body)))))))) - `(LAMBDA (INSTANCE) - (DO ((IS IF-INDEXES (CDR IS)) - (VS INITIALIZERS (CDR VS))) - ((NULL? IS) UNSPECIFIC) - (%RECORD-SET! INSTANCE (CAR IS) ((CAR VS)))) - (DO ((IS IV-INDEXES (CDR IS)) - (VS INITIAL-VALUES (CDR VS))) - ((NULL? IS) UNSPECIFIC) - (%RECORD-SET! INSTANCE (CAR IS) (CAR VS))))))) + (non-hygienic-macro-transformer + (lambda (if-n iv-n) + (if (and if-n iv-n) + (let ((generate + (let ((make-names + (lambda (n prefix) + (make-initialized-list n + (lambda (index) + (intern + (string-append prefix + (number->string index)))))))) + (lambda (n prefix isn vsn fv) + (let ((is (make-names n (string-append prefix "i"))) + (vs (make-names n (string-append prefix "v")))) + (values + (append (make-initialized-list n + (lambda (i) + `(,(list-ref is i) (LIST-REF ,isn ,i)))) + (make-initialized-list n + (lambda (i) + `(,(list-ref vs i) (LIST-REF ,vsn ,i))))) + (make-initialized-list n + (lambda (i) + `(%RECORD-SET! INSTANCE + ,(list-ref is i) + ,(fv (list-ref vs i))))))))))) + (call-with-values + (lambda () + (generate if-n "f" 'IF-INDEXES 'INITIALIZERS + (lambda (expr) `(,expr)))) + (lambda (if-bindings if-body) + (call-with-values + (lambda () + (generate iv-n "v" 'IV-INDEXES 'INITIAL-VALUES + (lambda (expr) expr))) + (lambda (iv-bindings iv-body) + (if (and (null? if-bindings) (null? iv-bindings)) + '#F + `(LET (,@if-bindings ,@iv-bindings) + (LAMBDA (INSTANCE) + ,@if-body + ,@iv-body)))))))) + `(LAMBDA (INSTANCE) + (DO ((IS IF-INDEXES (CDR IS)) + (VS INITIALIZERS (CDR VS))) + ((NULL? IS) UNSPECIFIC) + (%RECORD-SET! INSTANCE (CAR IS) ((CAR VS)))) + (DO ((IS IV-INDEXES (CDR IS)) + (VS INITIAL-VALUES (CDR VS))) + ((NULL? IS) UNSPECIFIC) + (%RECORD-SET! INSTANCE (CAR IS) (CAR VS)))))))) + (define (make-initialization class arg-slots) (let ((if-slots (list-transform-positive (class-slots class) @@ -256,7 +265,7 @@ (if (< if-n 4) (constructor-case if-n 0 4 make-initialization-1) (make-initialization-1 #f))))) - + (define initialize-instance (make-generic-procedure '(1 . #F) 'INITIALIZE-INSTANCE)) diff --git a/v7/src/sos/load.scm b/v7/src/sos/load.scm index 4c6e44a58..d14714031 100644 --- a/v7/src/sos/load.scm +++ b/v7/src/sos/load.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: load.scm,v 1.9 2001/12/20 06:38:18 cph Exp $ +;;; $Id: load.scm,v 1.10 2001/12/23 17:21:00 cph Exp $ ;;; ;;; Copyright (c) 1995-1999, 2001 Massachusetts Institute of Technology ;;; @@ -23,17 +23,4 @@ (with-working-directory-pathname (directory-pathname (current-load-pathname)) (lambda () (load-package-set "sos"))) -(let ((install - (let ((environment (package/environment (find-package '(SOS MACROS))))) - (lambda (mname tname) - (syntax-table/define system-global-environment - mname - (environment-lookup environment tname)))))) - (install 'DEFINE-CLASS 'TRANSFORM:DEFINE-CLASS) - (install 'DEFINE-GENERIC 'TRANSFORM:DEFINE-GENERIC) - (install 'DEFINE-METHOD 'TRANSFORM:DEFINE-METHOD) - (install 'DEFINE-COMPUTED-METHOD 'TRANSFORM:DEFINE-COMPUTED-METHOD) - (install 'DEFINE-COMPUTED-EMP 'TRANSFORM:DEFINE-COMPUTED-EMP) - ;;(install 'METHOD 'TRANSFORM:METHOD) - ) (add-identification! "SOS" 1 6) \ No newline at end of file diff --git a/v7/src/sos/macros.scm b/v7/src/sos/macros.scm index d953f1fdc..ad64a5510 100644 --- a/v7/src/sos/macros.scm +++ b/v7/src/sos/macros.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: macros.scm,v 1.11 2001/12/20 16:28:23 cph Exp $ +;;; $Id: macros.scm,v 1.12 2001/12/23 17:21:00 cph Exp $ ;;; ;;; Copyright (c) 1993-2001 Massachusetts Institute of Technology ;;; @@ -23,47 +23,49 @@ (declare (usual-integrations)) -(define (transform:define-class name superclasses . slot-arguments) - (let ((lose - (lambda (s a) - (serror 'DEFINE-CLASS (string-append "Malformed " s ":") a)))) - (call-with-values (lambda () (parse-define-class-name name lose)) - (lambda (name post-definitions separator) - (if (not (list? superclasses)) - (lose "superclasses" superclasses)) - (let ((pre-definitions - (extract-generic-definitions! slot-arguments name separator - lose))) - `(BEGIN - ,@pre-definitions - (DEFINE ,name - (,(make-absolute-reference 'MAKE-CLASS) - ',name - (,(make-absolute-reference 'LIST) ,@superclasses) - (,(make-absolute-reference 'LIST) - ,@(map - (lambda (arg) - (cond ((symbol? arg) - `',arg) - ((and (pair? arg) - (symbol? (car arg)) - (list? (cdr arg))) - `(,(make-absolute-reference 'LIST) - ',(car arg) - ,@(let loop ((plist (cdr arg))) - (cond ((null? plist) - '()) - ((and (symbol? (car plist)) - (pair? (cdr plist))) - (cons* `',(car plist) - (cadr plist) - (loop (cddr plist)))) - (else - (lose "slot argument" arg)))))) - (else - (lose "slot argument" arg)))) - slot-arguments)))) - ,@post-definitions)))))) +(define-syntax define-class + (non-hygienic-macro-transformer + (lambda (name superclasses . slot-arguments) + (let ((lose + (lambda (s a) + (error (string-append "Malformed " s ":") a)))) + (call-with-values (lambda () (parse-define-class-name name lose)) + (lambda (name post-definitions separator) + (if (not (list? superclasses)) + (lose "superclasses" superclasses)) + (let ((pre-definitions + (extract-generic-definitions! slot-arguments name separator + lose))) + `(BEGIN + ,@pre-definitions + (DEFINE ,name + (,(make-absolute-reference 'MAKE-CLASS) + ',name + (,(make-absolute-reference 'LIST) ,@superclasses) + (,(make-absolute-reference 'LIST) + ,@(map + (lambda (arg) + (cond ((symbol? arg) + `',arg) + ((and (pair? arg) + (symbol? (car arg)) + (list? (cdr arg))) + `(,(make-absolute-reference 'LIST) + ',(car arg) + ,@(let loop ((plist (cdr arg))) + (cond ((null? plist) + '()) + ((and (symbol? (car plist)) + (pair? (cdr plist))) + (cons* `',(car plist) + (cadr plist) + (loop (cddr plist)))) + (else + (lose "slot argument" arg)))))) + (else + (lose "slot argument" arg)))) + slot-arguments)))) + ,@post-definitions)))))))) (define (parse-define-class-name name lose) (call-with-values (lambda () (parse-define-class-name-1 name lose)) @@ -144,7 +146,7 @@ (lose "class option" option)))) (define (list-of-symbols? x) - (and (list? x) (for-all? x symbol?))) + (list-of-type? x symbol?)) (define (optional? x) (or (null? x) (and (pair? x) (null? (cdr x))))) @@ -154,6 +156,20 @@ (define (default-constructor-name class-name) (intern (string-append "make-" (strip-angle-brackets class-name)))) + +(define (make-named-lambda name required optional rest body) + (let ((bvl + (append required + (if (null? optional) + '() + `(#!OPTIONAL ,@optional)) + (or rest '())))) + (if name + `(NAMED-LAMBDA (,name ,@bvl) ,@body) + `(LAMBDA ,bvl ,@body)))) + +(define (make-absolute-reference name) + `(ACCESS ,name #F)) (define (extract-generic-definitions! slot-arguments name separator lose) (let ((definitions '())) @@ -231,72 +247,76 @@ (substring s 1 (fix:- (string-length s) 1)) s))) -(define (transform:define-generic name lambda-list) - (let ((mname 'DEFINE-GENERIC)) - (if (not (symbol? name)) - (serror mname "Malformed generic procedure name:" name)) - (call-with-values (lambda () (parse-lambda-list lambda-list #f mname)) - (lambda (required optional rest) - `(DEFINE ,name - (,(make-absolute-reference 'MAKE-GENERIC-PROCEDURE) - ',(let ((low (length required))) - (cond (rest (cons low #f)) - ((null? optional) low) - (else (cons low (+ low (length optional)))))) - ',name)))))) +(define-syntax define-generic + (non-hygienic-macro-transformer + (lambda (name lambda-list) + (if (not (symbol? name)) + (error "Malformed generic procedure name:" name)) + (call-with-values (lambda () (parse-lambda-list lambda-list #f)) + (lambda (required optional rest) + `(DEFINE ,name + (,(make-absolute-reference 'MAKE-GENERIC-PROCEDURE) + ',(let ((low (length required))) + (cond (rest (cons low #f)) + ((null? optional) low) + (else (cons low (+ low (length optional)))))) + ',name))))))) -(define (transform:define-method name lambda-list . body) - (%transform:define-method name lambda-list body 'DEFINE-METHOD - generate-method-definition)) +(define-syntax define-method + (non-hygienic-macro-transformer + (lambda (name lambda-list . body) + (transform-define-method name lambda-list body + (lambda (name required specializers optional rest body) + `(,(make-absolute-reference 'ADD-METHOD) + ,name + ,(make-method-sexp name required optional rest specializers + body))))))) -(define (transform:define-computed-method name lambda-list . body) - (%transform:define-method name lambda-list body 'DEFINE-COMPUTED-METHOD - generate-computed-method-definition)) +(define-syntax define-computed-method + (non-hygienic-macro-transformer + (lambda (name lambda-list . body) + (transform-define-method name lambda-list body + (lambda (name required specializers optional rest body) + `(,(make-absolute-reference 'ADD-METHOD) + ,name + (,(make-absolute-reference 'MAKE-COMPUTED-METHOD) + (,(make-absolute-reference 'LIST) ,@specializers) + ,(make-named-lambda name required optional rest body)))))))) -(define (%transform:define-method name lambda-list body mname generator) +(define (transform-define-method name lambda-list body generator) (if (not (symbol? name)) - (serror mname "Malformed generic procedure name:" name)) - (call-with-values (lambda () (parse-lambda-list lambda-list #t mname)) + (error "Malformed generic procedure name:" name)) + (call-with-values (lambda () (parse-lambda-list lambda-list #t)) (lambda (required optional rest) (call-with-values (lambda () (extract-required-specializers required)) (lambda (required specializers) (generator name required specializers optional rest body)))))) -(define (generate-method-definition name required specializers optional rest - body) - `(,(make-absolute-reference 'ADD-METHOD) - ,name - ,(make-method-sexp name required optional rest specializers body))) - -(define (generate-computed-method-definition name required specializers - optional rest body) - `(,(make-absolute-reference 'ADD-METHOD) - ,name - (,(make-absolute-reference 'MAKE-COMPUTED-METHOD) - (,(make-absolute-reference 'LIST) ,@specializers) - ,(make-named-lambda name required optional rest body)))) +(define-syntax define-computed-emp + (non-hygienic-macro-transformer + (lambda (name key lambda-list . body) + (if (not (symbol? name)) + (error "Malformed generic procedure name:" name)) + (call-with-values (lambda () (parse-lambda-list lambda-list #t)) + (lambda (required optional rest) + (call-with-values (lambda () (extract-required-specializers required)) + (lambda (required specializers) + `(,(make-absolute-reference 'ADD-METHOD) + ,name + (,(make-absolute-reference 'MAKE-COMPUTED-EMP) + ,key + (,(make-absolute-reference 'LIST) ,@specializers) + ,(make-named-lambda name required optional rest body)))))))))) -(define (transform:define-computed-emp name key lambda-list . body) - (let ((mname 'DEFINE-COMPUTED-EMP)) - (if (not (symbol? name)) - (serror mname "Malformed generic procedure name:" name)) - (call-with-values (lambda () (parse-lambda-list lambda-list #t mname)) - (lambda (required optional rest) - (call-with-values (lambda () (extract-required-specializers required)) - (lambda (required specializers) - `(,(make-absolute-reference 'ADD-METHOD) - ,name - (,(make-absolute-reference 'MAKE-COMPUTED-EMP) - ,key - (,(make-absolute-reference 'LIST) ,@specializers) - ,(make-named-lambda name required optional rest body))))))))) - -(define (transform:method lambda-list . body) - (call-with-values (lambda () (parse-lambda-list lambda-list #t 'METHOD)) - (lambda (required optional rest) - (call-with-values (lambda () (extract-required-specializers required)) - (lambda (required specializers) - (make-method-sexp #f required optional rest specializers body)))))) +(define-syntax method + (non-hygienic-macro-transformer + (lambda (lambda-list . body) + (call-with-values (lambda () (parse-lambda-list lambda-list #t)) + (lambda (required optional rest) + (call-with-values (lambda () (extract-required-specializers required)) + (lambda (required specializers) + (make-method-sexp #f required optional rest specializers + body)))))))) (define (extract-required-specializers required) (let loop ((required required) (names '()) (specializers '())) @@ -379,8 +399,7 @@ (else (cons (car body) (loop (cdr body)))))))) (values body - (free-variable? 'CALL-NEXT-METHOD - (syntax* body)))))) + (free-variable? 'CALL-NEXT-METHOD (syntax* body)))))) (define free-variable? (letrec @@ -445,8 +464,7 @@ (illegal (lambda (expr) (error "Illegal expression:" expr)))) do-expr)) -(define (parse-lambda-list lambda-list allow-specializers? specform) - specform +(define (parse-lambda-list lambda-list allow-specializers?) (let ((required '()) (optional '()) (rest #f)) @@ -520,22 +538,4 @@ (illegal-element (lambda (lambda-list) (error "Illegal parameter list element:" (car lambda-list))))) - (parse-required lambda-list)))) - -(define (make-named-lambda name required optional rest body) - (let ((bvl - (append required - (if (null? optional) - '() - `(#!OPTIONAL ,@optional)) - (or rest '())))) - (if name - `(NAMED-LAMBDA (,name ,@bvl) ,@body) - `(LAMBDA ,bvl ,@body)))) - -(define (make-absolute-reference name) - `(ACCESS ,name #F)) - -(define (serror procedure message . objects) - procedure - (apply error message objects)) \ No newline at end of file + (parse-required lambda-list)))) \ No newline at end of file diff --git a/v7/src/sos/sos.pkg b/v7/src/sos/sos.pkg index 9fdc4952f..72b20f3af 100644 --- a/v7/src/sos/sos.pkg +++ b/v7/src/sos/sos.pkg @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: sos.pkg,v 1.10 2001/12/19 20:50:08 cph Exp $ +$Id: sos.pkg,v 1.11 2001/12/23 17:21:00 cph Exp $ -Copyright (c) 1995-2000 Massachusetts Institute of Technology +Copyright (c) 1995-2001 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 @@ -16,7 +16,8 @@ General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software -Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. |# ;;;; Packaging for Scheme Object System @@ -24,7 +25,6 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (global-definitions "../runtime/runtime") (define-package (sos) - (files) (parent ())) (define-package (sos slot) @@ -169,4 +169,10 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (define-package (sos macros) (files "macros") - (parent (sos))) \ No newline at end of file + (parent (sos)) + (export () + define-class + define-computed-emp + define-computed-method + define-generic + define-method)) \ No newline at end of file diff --git a/v7/src/star-parser/matcher.scm b/v7/src/star-parser/matcher.scm index fe1795ebc..be830b22b 100644 --- a/v7/src/star-parser/matcher.scm +++ b/v7/src/star-parser/matcher.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: matcher.scm,v 1.27 2001/12/20 20:51:16 cph Exp $ +;;; $Id: matcher.scm,v 1.28 2001/12/23 17:21:00 cph Exp $ ;;; ;;; Copyright (c) 2001 Massachusetts Institute of Technology ;;; @@ -74,18 +74,19 @@ (hash-table/put! matcher-preprocessors name procedure)) name) -(syntax-table/define system-global-environment 'DEFINE-*MATCHER-MACRO - (lambda (bvl expression) - (cond ((symbol? bvl) - `(DEFINE-*MATCHER-EXPANDER ',bvl - (LAMBDA () - ,expression))) - ((named-lambda-bvl? bvl) - `(DEFINE-*MATCHER-EXPANDER ',(car bvl) - (LAMBDA ,(cdr bvl) - ,expression))) - (else - (error "Malformed bound-variable list:" bvl))))) +(define-syntax define-*matcher-macro + (non-hygienic-macro-transformer + (lambda (bvl expression) + (cond ((symbol? bvl) + `(DEFINE-*MATCHER-EXPANDER ',bvl + (LAMBDA () + ,expression))) + ((named-lambda-bvl? bvl) + `(DEFINE-*MATCHER-EXPANDER ',(car bvl) + (LAMBDA ,(cdr bvl) + ,expression))) + (else + (error "Malformed bound-variable list:" bvl)))))) (define (define-*matcher-expander name procedure) (define-matcher-macro name @@ -184,9 +185,10 @@ ;;;; Compiler -(syntax-table/define system-global-environment '*MATCHER - (lambda (expression) - (generate-matcher-code expression))) +(define-syntax *matcher + (non-hygienic-macro-transformer + (lambda (expression) + (generate-matcher-code expression)))) (define (generate-matcher-code expression) (generate-external-procedure expression preprocess-matcher-expression @@ -226,13 +228,14 @@ ,(delay-call kf))) (define-syntax define-matcher - (lambda (form . compiler-body) - (let ((name (car form)) - (parameters (cdr form))) - `(DEFINE-MATCHER-COMPILER ',name - ,(if (symbol? parameters) `#F (length parameters)) - (LAMBDA (POINTER KS KF . ,parameters) - ,@compiler-body))))) + (non-hygienic-macro-transformer + (lambda (form . compiler-body) + (let ((name (car form)) + (parameters (cdr form))) + `(DEFINE-MATCHER-COMPILER ',name + ,(if (symbol? parameters) `#F (length parameters)) + (LAMBDA (POINTER KS KF . ,parameters) + ,@compiler-body)))))) (define (define-matcher-compiler keyword arity compiler) (hash-table/put! matcher-compilers keyword (cons arity compiler)) @@ -242,10 +245,11 @@ (make-eq-hash-table)) (define-syntax define-atomic-matcher - (lambda (form test-expression) - `(DEFINE-MATCHER ,form - POINTER - (WRAP-EXTERNAL-MATCHER ,test-expression KS KF)))) + (non-hygienic-macro-transformer + (lambda (form test-expression) + `(DEFINE-MATCHER ,form + POINTER + (WRAP-EXTERNAL-MATCHER ,test-expression KS KF))))) (define-atomic-matcher (char char) `(MATCH-PARSER-BUFFER-CHAR ,*buffer-name* (PROTECT ,char))) diff --git a/v7/src/star-parser/parser.pkg b/v7/src/star-parser/parser.pkg index 59574be6a..db9cbdb0f 100644 --- a/v7/src/star-parser/parser.pkg +++ b/v7/src/star-parser/parser.pkg @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: parser.pkg,v 1.16 2001/12/20 06:39:03 cph Exp $ +;;; $Id: parser.pkg,v 1.17 2001/12/23 17:21:00 cph Exp $ ;;; ;;; Copyright (c) 2001 Massachusetts Institute of Technology ;;; @@ -27,9 +27,13 @@ (files "synchk" "shared" "matcher" "parser") (parent (runtime)) (export () + *matcher + *parser current-parser-macros define-*matcher-expander + define-*matcher-macro define-*parser-expander + define-*parser-macro global-parser-macros make-parser-macros parser-macros? diff --git a/v7/src/star-parser/parser.scm b/v7/src/star-parser/parser.scm index f6eabf431..e0cfe6afb 100644 --- a/v7/src/star-parser/parser.scm +++ b/v7/src/star-parser/parser.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: parser.scm,v 1.30 2001/12/20 20:51:16 cph Exp $ +;;; $Id: parser.scm,v 1.31 2001/12/23 17:21:00 cph Exp $ ;;; ;;; Copyright (c) 2001 Massachusetts Institute of Technology ;;; @@ -71,18 +71,19 @@ (hash-table/put! parser-preprocessors name procedure)) name) -(syntax-table/define system-global-environment 'DEFINE-*PARSER-MACRO - (lambda (bvl expression) - (cond ((symbol? bvl) - `(DEFINE-*PARSER-EXPANDER ',bvl - (LAMBDA () - ,expression))) - ((named-lambda-bvl? bvl) - `(DEFINE-*PARSER-EXPANDER ',(car bvl) - (LAMBDA ,(cdr bvl) - ,expression))) - (else - (error "Malformed bound-variable list:" bvl))))) +(define-syntax define-*parser-macro + (non-hygienic-macro-transformer + (lambda (bvl expression) + (cond ((symbol? bvl) + `(DEFINE-*PARSER-EXPANDER ',bvl + (LAMBDA () + ,expression))) + ((named-lambda-bvl? bvl) + `(DEFINE-*PARSER-EXPANDER ',(car bvl) + (LAMBDA ,(cdr bvl) + ,expression))) + (else + (error "Malformed bound-variable list:" bvl)))))) (define (define-*parser-expander name procedure) (define-parser-macro name @@ -173,9 +174,10 @@ ;;;; Compiler -(syntax-table/define system-global-environment '*PARSER - (lambda (expression) - (generate-parser-code expression))) +(define-syntax *parser + (non-hygienic-macro-transformer + (lambda (expression) + (generate-parser-code expression)))) (define (generate-parser-code expression) (generate-external-procedure expression preprocess-parser-expression @@ -217,13 +219,14 @@ ,(delay-call kf))))) (define-syntax define-parser - (lambda (form . compiler-body) - (let ((name (car form)) - (parameters (cdr form))) - `(DEFINE-PARSER-COMPILER ',name - ,(if (symbol? parameters) `#F (length parameters)) - (LAMBDA (POINTER KS KF . ,parameters) - ,@compiler-body))))) + (non-hygienic-macro-transformer + (lambda (form . compiler-body) + (let ((name (car form)) + (parameters (cdr form))) + `(DEFINE-PARSER-COMPILER ',name + ,(if (symbol? parameters) `#F (length parameters)) + (LAMBDA (POINTER KS KF . ,parameters) + ,@compiler-body)))))) (define (define-parser-compiler keyword arity compiler) (hash-table/put! parser-compilers keyword (cons arity compiler)) diff --git a/v7/src/swat/scheme/control-floating-errors.scm b/v7/src/swat/scheme/control-floating-errors.scm index 683955c8a..7ad15d3f8 100644 --- a/v7/src/swat/scheme/control-floating-errors.scm +++ b/v7/src/swat/scheme/control-floating-errors.scm @@ -20,13 +20,12 @@ (declare (usual-integrations)) (define-syntax deflap - (lambda (name . lap) - `(define ,name - (scode-eval - ',((access lap->code (->environment '(compiler top-level))) - name - lap) - system-global-environment)))) + (non-hygienic-macro-transformer + (lambda (name . lap) + `(DEFINE ,name + (SCODE-EVAL + ',((access lap->code (->environment '(COMPILER TOP-LEVEL))) name lap) + SYSTEM-GLOBAL-ENVIRONMENT))))) (define set-floating-error-mask! (let () diff --git a/v7/src/swat/scheme/load.scm b/v7/src/swat/scheme/load.scm index 9338147fe..c410ff5df 100644 --- a/v7/src/swat/scheme/load.scm +++ b/v7/src/swat/scheme/load.scm @@ -21,14 +21,15 @@ (let ((swat-env (extend-interpreter-environment system-global-environment))) - (package/add-child! (find-package '()) 'SWAT swat-env) + (package/add-child! (find-package '()) 'SWAT swat-env) - (for-each (lambda (export) - (environment-define swat-env export 'UNASSIGNED) - (link-variables (package/environment (find-package '())) export - swat-env export)) + (for-each (lambda (name) + (environment-define swat-env name 'UNASSIGNED) + (link-variables system-global-environment name + swat-env name)) ;; All of SWAT's exported names. This list need pruning - '(*-alert-structure-size-* + '( + *-alert-structure-size-* *-alert.function-* *-alert.reason-* *-canvasitem-structure-size-* @@ -163,6 +164,37 @@ ->xpixel ->xregion ->xwindow + ;;add-to-protection-list! + ;;canvas-flush-protect-list! + ;;canvas-protect-from-gc! + ;;canvas-unprotect-from-gc! + ;;clean-lost-protected-objects + ;;del-assq! + ;;del-assv! + ;;del-op! + ;;dequeue! + ;;display-protection-list + ;;enqueue! + ;;find-in-protection-list + ;;find-tk-protection-list + ;;find-tk-protection-list-from-number + ;;make-protection-list + ;;make-queue + ;;make-weak-del-op! + ;;make-weak-lookup + ;;protection-list-all-elements + ;;protection-list-referenced-elements + ;;queue? + ;;region-protection-list + ;;remove-from-protection-list! + ;;search-protection-list + ;;text-flush-protect-list! + ;;text-protect-from-gc! + ;;text-unprotect-from-gc! + ;;uiobj-protect-from-gc! + ;;uiobj-unprotect-from-gc! + ;;uitk-protection-list + ;;weak-delq! active-variable-value add-child! add-event-handler! @@ -171,7 +203,6 @@ add-to-agenda! add-to-canvas-item-group add-to-menu - ;;add-to-protection-list! add-vectors add-widget-list-for-display-number! after-delay @@ -218,10 +249,7 @@ box:event-propagator box:rearrange button-stretch - ;;canvas-flush-protect-list! - ;;canvas-protect-from-gc! canvas-stretch - ;;canvas-unprotect-from-gc! canvasitem-add-event-handler! canvasitem-ask-widget canvasitem.add-event-handler!-procedure @@ -246,7 +274,6 @@ choose-maximum-glue choose-minimum-glue clean-lost-celled-objects - ;;clean-lost-protected-objects cleanup-vanished-objects-for-display clear-counters! cleararea @@ -290,18 +317,15 @@ decode-unknown-event decode-window-attributes defer - ;;del-assq! - ;;del-assv! - ;;del-op! + define-constant ;macro + define-in-line ;macro delete-! delete-menuitem! - ;;dequeue! destroy-all-sensitive-surfaces-from-display destroy-associated-tk-widgets destroy-registration destroy-sensitive-surface display->tk-widgets - ;;display-protection-list display/colormap-list display/default-root-window display/display @@ -325,7 +349,6 @@ empty-agenda? empty-queue? empty-segments? - ;;enqueue! ensure-graphics-context entry-height-stretch event! @@ -346,13 +369,10 @@ fillrectangle finalize-uitk-objects finalize-uitk-objects-later - ;;find-in-protection-list find-menu-record find-real-array-box-children find-sensitivity find-ss - ;;find-tk-protection-list - ;;find-tk-protection-list-from-number first-segment flush-display-hook flush-queued-output @@ -483,8 +503,6 @@ make-point make-point-event make-polygon-on-canvas - ;;make-protection-list - ;;make-queue make-radiobutton make-rect make-rectangle-event @@ -528,8 +546,6 @@ make-unfilled-rectangle make-unknown-event make-vbox - ;;make-weak-del-op! - ;;make-weak-lookup make-widget-on-canvas makexregion maybe-defer @@ -572,10 +588,7 @@ point= point? proc-with-transformed-args - ;;protection-list-all-elements - ;;protection-list-referenced-elements queue/pp - ;;queue? read-and-empty-agenda! read-and-empty-queue! read-queue-trace @@ -587,11 +600,9 @@ rectangle-overlaps-rectangle? rectangle-overlaps? rectangle= - ;;region-protection-list region/region remember-on-canvas! remove-child! - ;;remove-from-protection-list! reset-sensitivity! rest-segments restart-uitk @@ -599,6 +610,8 @@ rigid-glue? row-lists->col-lists run-queue-trace + scc-define-structure ;macro + scc-define-syntax ;macro screen-area= scrollable-canvas-canvas scrollable-canvas-hscroll @@ -618,7 +631,6 @@ scxl-wrapper.wrapped-object scxl-wrapper/pp scxl-wrapper? - ;;search-protection-list segment-queue segment-time segments @@ -770,9 +782,6 @@ swat-open-in-application swat:number->string tcl-global-eval - ;;text-flush-protect-list! - ;;text-protect-from-gc! - ;;text-unprotect-from-gc! texttag-add-event-handler! texttag-ask-widget texttag.add-event-handler!-procedure @@ -860,12 +869,10 @@ uiobj-get-desired-size uiobj-handle-event uiobj-point-within? - ;;uiobj-protect-from-gc! uiobj-rectangle-overlaps? uiobj-set-assigned-screen-area! uiobj-set-context! uiobj-set-used-screen-area! - ;;uiobj-unprotect-from-gc! uiobj-used-screen-area uiobjinternals uiobjinternals-index @@ -891,7 +898,6 @@ uiobjinternals.used-screen-area-procedure uiobjinternals/pp uiobjinternals? - ;;uitk-protection-list uitk-queue uitk-thread uitk-thread-main-loop @@ -918,7 +924,6 @@ valid-color-for-application? valid-color? valid-non-widget? - ;;weak-delq! when-idle! when-unreferenced widget->screen-area @@ -999,7 +1004,8 @@ xtranslatecoordinates xunionrectspecswithregion! xunionregion! - xunloadfont))) + xunloadfont + ))) (with-working-directory-pathname diff --git a/v7/src/swat/scheme/mit-xhooks.scm b/v7/src/swat/scheme/mit-xhooks.scm index 921518eeb..6951a8d9a 100644 --- a/v7/src/swat/scheme/mit-xhooks.scm +++ b/v7/src/swat/scheme/mit-xhooks.scm @@ -122,8 +122,9 @@ This is some debugging stuff for probing the space usage. (define (record-free-pointer trace) (if allow-free-trace? (let-syntax ((ucode-primitive - (lambda arguments - (apply make-primitive-procedure arguments)))) + (non-hygienic-macro-transformer + (lambda arguments + (apply make-primitive-procedure arguments))))) (vector-set! (cdr trace) (car trace) ((ucode-primitive primitive-get-free 1) 26)) @@ -155,10 +156,11 @@ end of debugging stuff (restart-thread uitk-thread #T (lambda () (initial-thread-state 'go)))) (let-syntax ((last-reference - (lambda (variable) - `(let ((foo ,variable)) - (set! ,variable #F) - foo)))) + (non-hygienic-macro-transformer + (lambda (variable) + `(let ((foo ,variable)) + (set! ,variable #F) + foo))))) (define (uitk-thread-main-loop) (define (flush-all-displays) diff --git a/v7/src/swat/scheme/scc-macros.scm b/v7/src/swat/scheme/scc-macros.scm index c692a7384..3805ce149 100644 --- a/v7/src/swat/scheme/scc-macros.scm +++ b/v7/src/swat/scheme/scc-macros.scm @@ -1,19 +1,23 @@ ;;;; -*-Scheme-*- -;;; $Id: scc-macros.scm,v 1.2 2001/12/20 06:43:25 cph Exp $ +;;; $Id: scc-macros.scm,v 1.3 2001/12/23 17:21:00 cph Exp $ -(syntax-table/define system-global-environment 'DEFINE-CONSTANT - (lambda (name value) - `(DEFINE-INTEGRABLE ,name ,value))) +(define-syntax define-constant + (non-hygienic-macro-transformer + (lambda (name value) + `(DEFINE-INTEGRABLE ,name ,value)))) -(syntax-table/define system-global-environment 'DEFINE-IN-LINE - (lambda (arg-list . body) - `(DEFINE-INTEGRABLE ,arg-list . ,body))) +(define-syntax define-in-line + (non-hygienic-macro-transformer + (lambda (arg-list . body) + `(DEFINE-INTEGRABLE ,arg-list . ,body)))) -(syntax-table/define system-global-environment 'SCC-DEFINE-SYNTAX - (lambda (name-and-arglist . body) - (let ((name (car name-and-arglist)) - (arglist (cdr name-and-arglist))) - `(SYNTAX-TABLE/DEFINE SYSTEM-GLOBAL-ENVIRONMENT ',name - (LAMBDA ,arglist ,@body))))) +(define-syntax scc-define-syntax + (non-hygienic-macro-transformer + (lambda (name-and-arglist . body) + (let ((name (car name-and-arglist)) + (arglist (cdr name-and-arglist))) + `(DEFINE-SYNTAX ,name + (NON-HYGIENIC-MACRO-TRANSFORMER + (LAMBDA ,arglist ,@body))))))) (define-integrable *running-in-mit-scheme* #t) \ No newline at end of file diff --git a/v7/src/swat/scheme/uitk-macros.scm b/v7/src/swat/scheme/uitk-macros.scm index 43af32cfd..bf0101258 100644 --- a/v7/src/swat/scheme/uitk-macros.scm +++ b/v7/src/swat/scheme/uitk-macros.scm @@ -1,5 +1,5 @@ ;;;; -*-Scheme-*- -;;; $Id: uitk-macros.scm,v 1.1 1995/08/02 21:26:49 adams Exp $ +;;; $Id: uitk-macros.scm,v 1.2 2001/12/23 17:21:00 cph Exp $ ;;; derived from macros.sc,v 1.1 1993/02/16 14:04:09 jmiller Exp $ ;;; Primitive X toolkit for Scheme->C. ;;; RHH, September, 1989. @@ -32,111 +32,113 @@ ;;;; (set-dot.color! a-dot 'green) ;;;; (list (dot.x a-dot) (dot.color a-dot)) -> (3 green) -(scc-define-syntax (scc-define-structure name . components) - (define (symbol-format . args) - (string->symbol - (apply string-append - (map (lambda (object) - (cond ((string? object) object) - ((symbol? object) (symbol->string object)) - (else (error - 'SYMBOL-FORMAT - "Neither symbol nor string ~A" - object)))) - args)))) - (let ((size-name (symbol-format "*-" name '-STRUCTURE-SIZE "-*")) - (self-varname (lambda (fn-name) - (symbol-format 'SELF "/" name "/" fn-name))) - (predicate-name (symbol-format name "?"))) +(define-syntax scc-define-structure + (non-hygienic-macro-transformer + (lambda (name . components) + (define (symbol-format . args) + (string->symbol + (apply string-append + (map (lambda (object) + (cond ((string? object) object) + ((symbol? object) (symbol->string object)) + (else (error + 'SYMBOL-FORMAT + "Neither symbol nor string ~A" + object)))) + args)))) + (let ((size-name (symbol-format "*-" name '-STRUCTURE-SIZE "-*")) + (self-varname (lambda (fn-name) + (symbol-format 'SELF "/" name "/" fn-name))) + (predicate-name (symbol-format name "?"))) - (define (component-name component) - (if (pair? component) (car component) component)) + (define (component-name component) + (if (pair? component) (car component) component)) - (define (accessor-name component) - (symbol-format name "." (component-name component))) + (define (accessor-name component) + (symbol-format name "." (component-name component))) - (define (set-symbol component) - (symbol-format 'SET "-" name "." (component-name component) "!")) + (define (set-symbol component) + (symbol-format 'SET "-" name "." (component-name component) "!")) - (define (gen-accessors components counter) - (if (null? components) - `((DEFINE-CONSTANT ,size-name ,counter)) - (let ((cname (component-name (car components)))) - (let ((offset-name (symbol-format "*-" name "." cname "-*")) - (self (self-varname cname))) - `((DEFINE-CONSTANT ,offset-name ,counter) - (DEFINE-IN-LINE (,(accessor-name cname) ,self) - (IF (,predicate-name ,self) - (VECTOR-REF ,self ,offset-name) - (ERROR ',(accessor-name cname) - "Object not correct type ~A" ,self))) - (DEFINE-IN-LINE (,(set-symbol cname) ,self NEW-VALUE) - (IF (,predicate-name ,self) - (BEGIN - (VECTOR-SET! ,self ,offset-name NEW-VALUE) - 'MODIFIED!) - (ERROR ',(set-symbol cname) - "Object not correct type ~A" ,self))) - ,@(if *running-in-mit-scheme* - '() - `((DEFINE (,(accessor-name cname) ,self) - (IF (,predicate-name ,self) - (VECTOR-REF ,self ,offset-name) - (ERROR ',(accessor-name cname) - "Object not correct type ~A" ,self))) - (DEFINE (,(set-symbol cname) ,self NEW-VALUE) - (IF (,predicate-name ,self) - (BEGIN - (VECTOR-SET! ,self ,offset-name NEW-VALUE) - 'MODIFIED!) - (ERROR ',(set-symbol cname) - "Object not correct type ~A" ,self))))) - ,@(gen-accessors (cdr components) (+ counter 1))))))) + (define (gen-accessors components counter) + (if (null? components) + `((DEFINE-CONSTANT ,size-name ,counter)) + (let ((cname (component-name (car components)))) + (let ((offset-name (symbol-format "*-" name "." cname "-*")) + (self (self-varname cname))) + `((DEFINE-CONSTANT ,offset-name ,counter) + (DEFINE-IN-LINE (,(accessor-name cname) ,self) + (IF (,predicate-name ,self) + (VECTOR-REF ,self ,offset-name) + (ERROR ',(accessor-name cname) + "Object not correct type ~A" ,self))) + (DEFINE-IN-LINE (,(set-symbol cname) ,self NEW-VALUE) + (IF (,predicate-name ,self) + (BEGIN + (VECTOR-SET! ,self ,offset-name NEW-VALUE) + 'MODIFIED!) + (ERROR ',(set-symbol cname) + "Object not correct type ~A" ,self))) + ,@(if *running-in-mit-scheme* + '() + `((DEFINE (,(accessor-name cname) ,self) + (IF (,predicate-name ,self) + (VECTOR-REF ,self ,offset-name) + (ERROR ',(accessor-name cname) + "Object not correct type ~A" ,self))) + (DEFINE (,(set-symbol cname) ,self NEW-VALUE) + (IF (,predicate-name ,self) + (BEGIN + (VECTOR-SET! ,self ,offset-name NEW-VALUE) + 'MODIFIED!) + (ERROR ',(set-symbol cname) + "Object not correct type ~A" ,self))))) + ,@(gen-accessors (cdr components) (+ counter 1))))))) - (define (make-bvl components) - (cond ((null? components) '()) - ((pair? (car components)) (make-bvl (cdr components))) - (else (cons (car components) (make-bvl (cdr components)))))) + (define (make-bvl components) + (cond ((null? components) '()) + ((pair? (car components)) (make-bvl (cdr components))) + (else (cons (car components) (make-bvl (cdr components)))))) - (define (gen-structure-initialization self-name components) - (if (null? components) - '() - `((,(set-symbol (car components)) - ,self-name - ,@(if (pair? (car components)) - (cdar components) - (list (car components)))) - ,@(gen-structure-initialization self-name (cdr components))))) + (define (gen-structure-initialization self-name components) + (if (null? components) + '() + `((,(set-symbol (car components)) + ,self-name + ,@(if (pair? (car components)) + (cdar components) + (list (car components)))) + ,@(gen-structure-initialization self-name (cdr components))))) - (let ((init-name (symbol-format 'INIT "-" name)) - (init-self-name (self-varname 'INIT)) - (init-bvl (make-bvl components)) - (accessors (gen-accessors components 1)) - (tag (symbol-format "#[" name "]"))) - `(begin - (if ,*running-in-mit-scheme* - (ADD-UNPARSER-SPECIAL-OBJECT! - ',tag - (lambda (obj) - (display "#[scc-object ") - (display ',name) - (display " ") - (display (hash obj)) - (display "]")))) - ,@accessors - (DEFINE (,(symbol-format name '/pp) OBJ) - (IF (NUMBER? OBJ) (SET! OBJ (UNHASH OBJ))) - (FOR-EACH (LAMBDA (FIELD-NAME ACCESSOR) - (PP (LIST FIELD-NAME (ACCESSOR OBJ)))) - ',(map component-name components) - (LIST ,@(map accessor-name components)))) - (DEFINE (,predicate-name OBJ) - (AND (VECTOR? OBJ) - (= (VECTOR-LENGTH OBJ) ,size-name) - (EQ? (VECTOR-REF OBJ 0) ',tag))) - (DEFINE (,init-name ,init-self-name ,@init-bvl) - (VECTOR-SET! ,init-self-name 0 ',tag) - ,@(gen-structure-initialization init-self-name components) - ,init-self-name) - (DEFINE (,(symbol-format 'MAKE "-" name) ,@init-bvl) - (,init-name (make-vector ,size-name) ,@init-bvl)))))) + (let ((init-name (symbol-format 'INIT "-" name)) + (init-self-name (self-varname 'INIT)) + (init-bvl (make-bvl components)) + (accessors (gen-accessors components 1)) + (tag (symbol-format "#[" name "]"))) + `(begin + (if ,*running-in-mit-scheme* + (ADD-UNPARSER-SPECIAL-OBJECT! + ',tag + (lambda (obj) + (display "#[scc-object ") + (display ',name) + (display " ") + (display (hash obj)) + (display "]")))) + ,@accessors + (DEFINE (,(symbol-format name '/pp) OBJ) + (IF (NUMBER? OBJ) (SET! OBJ (UNHASH OBJ))) + (FOR-EACH (LAMBDA (FIELD-NAME ACCESSOR) + (PP (LIST FIELD-NAME (ACCESSOR OBJ)))) + ',(map component-name components) + (LIST ,@(map accessor-name components)))) + (DEFINE (,predicate-name OBJ) + (AND (VECTOR? OBJ) + (= (VECTOR-LENGTH OBJ) ,size-name) + (EQ? (VECTOR-REF OBJ 0) ',tag))) + (DEFINE (,init-name ,init-self-name ,@init-bvl) + (VECTOR-SET! ,init-self-name 0 ',tag) + ,@(gen-structure-initialization init-self-name components) + ,init-self-name) + (DEFINE (,(symbol-format 'MAKE "-" name) ,@init-bvl) + (,init-name (make-vector ,size-name) ,@init-bvl)))))))) diff --git a/v7/src/wabbit/test-wabbit.scm b/v7/src/wabbit/test-wabbit.scm index d498cbf4c..815569d26 100644 --- a/v7/src/wabbit/test-wabbit.scm +++ b/v7/src/wabbit/test-wabbit.scm @@ -2,7 +2,7 @@ (DECLARE (USUAL-INTEGRATIONS)) ; MIT Scheme-ism: promise not to redefine prims -;;; $Id: test-wabbit.scm,v 1.2 2001/12/20 21:26:00 cph Exp $ +;;; $Id: test-wabbit.scm,v 1.3 2001/12/23 17:21:00 cph Exp $ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; @@ -22,7 +22,7 @@ ;; - Document dependencies ;; - [SCREWS] see last page -;;; $Id: test-wabbit.scm,v 1.2 2001/12/20 21:26:00 cph Exp $ +;;; $Id: test-wabbit.scm,v 1.3 2001/12/23 17:21:00 cph Exp $ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; @@ -204,7 +204,10 @@ (access %entity-extra/apply-hook? (->environment '(runtime procedure)))) |# -(let-syntax ((ucode-type (lambda (name) (microcode-type name)))) +(let-syntax + ((ucode-type + (non-hygienic-macro-transformer + (lambda (name) (microcode-type name))))) (define apply-hook-tag (access apply-hook-tag (->environment '(runtime procedure)))) diff --git a/v7/src/win32/dib.scm b/v7/src/win32/dib.scm index ab1f681c9..e21c43755 100644 --- a/v7/src/win32/dib.scm +++ b/v7/src/win32/dib.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: dib.scm,v 1.4 2000/04/13 03:12:09 cph Exp $ +$Id: dib.scm,v 1.5 2001/12/23 17:21:00 cph Exp $ -Copyright (c) 1993, 1999, 2000 Massachusetts Institute of Technology +Copyright (c) 1993, 1999-2001 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 @@ -16,11 +16,14 @@ General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software -Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. |# ;;;; Device-independent bitmaps (dibutils.dll) ;;; package: (win32 dib) + +(declare (usual-integrations)) (define-structure (dib (constructor %make-dib)) handle) diff --git a/v7/src/win32/ffimacro.scm b/v7/src/win32/ffimacro.scm index 3df3c25d7..28fb4559f 100644 --- a/v7/src/win32/ffimacro.scm +++ b/v7/src/win32/ffimacro.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: ffimacro.scm,v 1.4 2001/12/20 06:45:48 cph Exp $ +$Id: ffimacro.scm,v 1.5 2001/12/23 17:21:00 cph Exp $ Copyright (c) 1993, 1999, 2001 Massachusetts Institute of Technology @@ -20,6 +20,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |# +(declare (usual-integrations)) + #| WINDOWS PROCEDURE TYPE SYSTEM @@ -89,143 +91,136 @@ after the type checking but before the type conversion. This allows extra consistency checks to be placed, especially checks that several arguments are mutualy consistent (e.g. an index into a buffer indexes to inside a string that is being used as the buffer). - |# - - -(let () - - (define ffi-module-entry-variable (string->symbol "[ffi entry]")) - (define ffi-result-variable (string->symbol "[ffi result]")) - - - (define (type->checker type) - (string->symbol (string-append (symbol-name type) ":check"))) - - (define (type->converter type) - (string->symbol (string-append (symbol-name type) ":convert"))) - - (define (type->check&converter type) - (string->symbol (string-append (symbol-name type) ":check&convert"))) - - (define (type->return-converter type) - (string->symbol (string-append (symbol-name type) ":return-convert"))) - - (define (type->reverter type) - (string->symbol (string-append (symbol-name type) ":revert"))) - - - (define (expand/windows-procedure args return-type module entry-name - . additional-specifications) - - (define (make-converted-name sym) - (string->symbol (string-append "[converted " (symbol-name sym) "]"))) - - (define (make-check type arg) - `(if (not (,(type->checker type) ,arg)) - (windows-procedure-argument-type-check-error ',type ,arg))) - - (define (make-conversion type arg) - `(,(type->converter type) ,arg)) - - (define (make-reversion type sym representation) - `(,(type->reverter type) ,sym ,representation)) - - (define (make-return-conversion type expr) - `(,(type->return-converter type) ,expr)) - - (if additional-specifications - ;; expanded version: - (let* ((procedure-name (car args)) - (arg-names (map car (cdr args))) - (arg-types (map cadr (cdr args))) - (cvt-names (map make-converted-name arg-names)) - (checks (map make-check arg-types arg-names)) - (conversions (map (lambda (cvt-name arg-type arg-name) - `(,cvt-name - ,(make-conversion arg-type arg-name))) - cvt-names arg-types arg-names)) - (reversions (map make-reversion arg-types arg-names cvt-names)) - (additional-checks - (if (and (pair? additional-specifications) - (symbol? (car additional-specifications))) - (cdr additional-specifications) - additional-specifications)) - ) - - `((access parameterize-with-module-entry ()) - (lambda (,ffi-module-entry-variable) - (named-lambda (,procedure-name . ,arg-names) - ,@checks - ,@additional-checks - (let ,conversions - (let ((,ffi-result-variable - (%call-foreign-function - (module-entry/machine-address - ,ffi-module-entry-variable) + +(define ffi-module-entry-variable (string->symbol "[ffi entry]")) +(define ffi-result-variable (string->symbol "[ffi result]")) + +(define (type->checker type) + (string->symbol (string-append (symbol-name type) ":check"))) + +(define (type->converter type) + (string->symbol (string-append (symbol-name type) ":convert"))) + +(define (type->check&converter type) + (string->symbol (string-append (symbol-name type) ":check&convert"))) + +(define (type->return-converter type) + (string->symbol (string-append (symbol-name type) ":return-convert"))) + +(define (type->reverter type) + (string->symbol (string-append (symbol-name type) ":revert"))) + +(define-syntax windows-procedure + (non-hygienic-macro-transformer + (lambda (args return-type module entry-name . additional-specifications) + + (define (make-converted-name sym) + (string->symbol (string-append "[converted " (symbol-name sym) "]"))) + + (define (make-check type arg) + `(if (not (,(type->checker type) ,arg)) + (windows-procedure-argument-type-check-error ',type ,arg))) + + (define (make-conversion type arg) + `(,(type->converter type) ,arg)) + + (define (make-reversion type sym representation) + `(,(type->reverter type) ,sym ,representation)) + + (define (make-return-conversion type expr) + `(,(type->return-converter type) ,expr)) + + (if additional-specifications + ;; expanded version: + (let* ((procedure-name (car args)) + (arg-names (map car (cdr args))) + (arg-types (map cadr (cdr args))) + (cvt-names (map make-converted-name arg-names)) + (checks (map make-check arg-types arg-names)) + (conversions (map (lambda (cvt-name arg-type arg-name) + `(,cvt-name + ,(make-conversion arg-type arg-name))) + cvt-names arg-types arg-names)) + (reversions + (map make-reversion arg-types arg-names cvt-names)) + (additional-checks + (if (and (pair? additional-specifications) + (symbol? (car additional-specifications))) + (cdr additional-specifications) + additional-specifications))) + + `((access parameterize-with-module-entry ()) + (lambda (,ffi-module-entry-variable) + (named-lambda (,procedure-name . ,arg-names) + ,@checks + ,@additional-checks + (let ,conversions + (let ((,ffi-result-variable + (%call-foreign-function + (module-entry/machine-address + ,ffi-module-entry-variable) . ,cvt-names))) - ,@reversions - ,(make-return-conversion return-type - ffi-result-variable))))) - ,module ,entry-name)) - - ;; closure version: - (let* ((arg-types (map cadr (cdr args)))) - `(make-windows-procedure ,module ,entry-name - ,(type->return-converter return-type) - ,@(map type->check&converter arg-types))))) - - - (define (expand/define-windows-type name - #!optional check convert return revert) - (let ((check (if (default-object? check) #f check)) - (convert (if (default-object? convert) #f convert)) - (return (if (default-object? return) #f return)) - (revert (if (default-object? revert) #f revert))) - (let ((check (or check '(lambda (x) x #t))) - (convert (or convert '(lambda (x) x))) - (return (or return '(lambda (x) x))) - (revert (or revert '(lambda (x y) x y unspecific)))) - `(begin - (define-integrable (,(type->checker name) x) (,check x)) - (define-integrable (,(type->converter name) x) (,convert x)) - (define-integrable (,(type->check&converter name) x) - (if (,(type->checker name) x) - (,(type->converter name) x) - (windows-procedure-argument-type-check-error ',name x))) - (define-integrable (,(type->return-converter name) x) (,return x)) - (define-integrable (,(type->reverter name) x y) (,revert x y)))))) - - - (define (expand/define-similar-windows-type - name model - #!optional check convert return revert) - (let ((check (if (default-object? check) #f check)) - (convert (if (default-object? convert) #f convert)) - (return (if (default-object? return) #f return)) - (revert (if (default-object? revert) #f revert))) - ;; eta conversion below are deliberate to persuade integration to chain - (let ((check (or check (type->checker model))) - (convert (or convert (type->converter model))) - (return (or return (type->return-converter model))) - (revert (or revert (type->reverter model)))) - `(begin - (define-integrable (,(type->checker name) x) (,check x)) - (define-integrable (,(type->converter name) x) (,convert x)) - (define-integrable (,(type->check&converter name) x) - (if (,(type->checker name) x) - (,(type->converter name) x) - (windows-procedure-argument-type-check-error ',name x))) - (define-integrable (,(type->return-converter name) x) (,return x)) - (define-integrable (,(type->reverter name) x y) (,revert x y)))))) - - (syntax-table/define system-global-environment 'WINDOWS-PROCEDURE - expand/windows-procedure) - - (syntax-table/define system-global-environment 'DEFINE-WINDOWS-TYPE - expand/define-windows-type) - - (syntax-table/define system-global-environment 'DEFINE-SIMILAR-WINDOWS-TYPE - expand/define-similar-windows-type) - -) \ No newline at end of file + ,@reversions + ,(make-return-conversion return-type + ffi-result-variable))))) + ,module ,entry-name)) + + ;; closure version: + (let* ((arg-types (map cadr (cdr args)))) + `(make-windows-procedure ,module ,entry-name + ,(type->return-converter return-type) + ,@(map type->check&converter + arg-types))))))) + +(define-syntax define-windows-type + (non-hygienic-macro-transformer + (lambda (name #!optional check convert return revert) + (let ((check (if (default-object? check) #f check)) + (convert (if (default-object? convert) #f convert)) + (return (if (default-object? return) #f return)) + (revert (if (default-object? revert) #f revert))) + (let ((check (or check '(lambda (x) x #t))) + (convert (or convert '(lambda (x) x))) + (return (or return '(lambda (x) x))) + (revert (or revert '(lambda (x y) x y unspecific)))) + `(begin + (define-integrable (,(type->checker name) x) + (,check x)) + (define-integrable (,(type->converter name) x) + (,convert x)) + (define-integrable (,(type->check&converter name) x) + (if (,(type->checker name) x) + (,(type->converter name) x) + (windows-procedure-argument-type-check-error ',name x))) + (define-integrable (,(type->return-converter name) x) + (,return x)) + (define-integrable (,(type->reverter name) x y) + (,revert x y)))))))) + + +(define-syntax define-similar-windows-type + (non-hygienic-macro-transformer + (lambda (name model #!optional check convert return revert) + (let ((check (if (default-object? check) #f check)) + (convert (if (default-object? convert) #f convert)) + (return (if (default-object? return) #f return)) + (revert (if (default-object? revert) #f revert))) + ;; eta conversion below are deliberate to persuade integration to chain + (let ((check (or check (type->checker model))) + (convert (or convert (type->converter model))) + (return (or return (type->return-converter model))) + (revert (or revert (type->reverter model)))) + `(begin + (define-integrable (,(type->checker name) x) + (,check x)) + (define-integrable (,(type->converter name) x) + (,convert x)) + (define-integrable (,(type->check&converter name) x) + (if (,(type->checker name) x) + (,(type->converter name) x) + (windows-procedure-argument-type-check-error ',name x))) + (define-integrable (,(type->return-converter name) x) + (,return x)) + (define-integrable (,(type->reverter name) x y) + (,revert x y)))))))) \ No newline at end of file diff --git a/v7/src/win32/make.scm b/v7/src/win32/make.scm index 8be59c913..16c354eae 100644 --- a/v7/src/win32/make.scm +++ b/v7/src/win32/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: make.scm,v 1.8 2001/08/18 04:52:08 cph Exp $ +$Id: make.scm,v 1.9 2001/12/23 17:21:00 cph Exp $ Copyright (c) 1993-1999, 2001 Massachusetts Institute of Technology @@ -31,6 +31,5 @@ USA. (working-directory-pathname) (pathname-as-directory "win32") (lambda () - (load "ffimacro") (load-package-set "win32"))))) (add-identification! "Win32" 1 5) \ No newline at end of file diff --git a/v7/src/win32/win32.pkg b/v7/src/win32/win32.pkg index c98e97d2c..9a04d8f98 100644 --- a/v7/src/win32/win32.pkg +++ b/v7/src/win32/win32.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: win32.pkg,v 1.14 2001/12/20 03:27:54 cph Exp $ +$Id: win32.pkg,v 1.15 2001/12/23 17:21:00 cph Exp $ Copyright (c) 1993-2001 Massachusetts Institute of Technology @@ -25,7 +25,7 @@ USA. (global-definitions "../runtime/runtime") (define-package (win32) - (parent (runtime)) + (parent ()) (files "winuser" "wt_user" "wf_user" @@ -33,8 +33,7 @@ USA. "win_ffi" "module" "protect" - "clipbrd" - ) + "clipbrd") (export () %call-foreign-function parameterize-with-module-entry @@ -45,6 +44,8 @@ USA. win32-clipboard-write-text win32-screen-height win32-screen-width) + (import (runtime) + ucode-primitive) (initialization (begin (initialize-protection-list-package!) @@ -52,6 +53,13 @@ USA. (initialize-package!) (init-wf_user!)))) +(define-package (win32 ffi-macro) + (files "ffimacro") + (parent (win32)) + (export () + define-similar-windows-type + define-windows-type + windows-procedure)) (define-package (win32 scheme-graphics) (files "graphics") diff --git a/v7/src/win32/win32.sf b/v7/src/win32/win32.sf index a07ffea1e..f6d18f85b 100644 --- a/v7/src/win32/win32.sf +++ b/v7/src/win32/win32.sf @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: win32.sf,v 1.7 2001/12/19 21:55:37 cph Exp $ +$Id: win32.sf,v 1.8 2001/12/23 17:21:00 cph Exp $ Copyright (c) 1993-1999, 2001 Massachusetts Institute of Technology @@ -20,21 +20,29 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |# -(fluid-let ((sf/default-syntax-table (->environment '(RUNTIME)))) +(load-option 'CREF) + +(if (not (name->package '(WIN32))) + (let ((package-set (package-set-pathname "win32"))) + (if (not (file-exists? package-set)) + (cref/generate-trivial-constructor "win32")) + (construct-packages-from-file (fasload package-set)))) + +(fluid-let ((sf/default-syntax-table (->environment '(WIN32)))) (for-each (lambda (names) (sf/add-file-declarations! (car names) `((integrate-external . ,(cdr names))))) - '(("module" "winuser" "wingdi" "wt_user") - ("graphics" "winuser" "wingdi" "wt_user") - ("win_ffi" "winuser" "wingdi" "wt_user") - ("wf_user" "win_ffi" "wt_user") - ("dib" "win_ffi"))) + '(("module" "winuser" "wingdi" "wt_user") + ("graphics" "winuser" "wingdi" "wt_user") + ("win_ffi" "winuser" "wingdi" "wt_user") + ("wf_user" "win_ffi" "wt_user") + ("dib" "win_ffi"))) (sf-conditionally "ffimacro") (if (not (file-modification-timestring thing) - (cond ((string? thing) thing) - ((symbol? thing) (symbol-name thing)) - ((number? thing) (number->string thing)))) - (define (concat . things) - (string->symbol (apply string-append (map ->string things)))) - - (let* ((arg-names (map-index (lambda (i) (concat "arg" i)) 1 n)) - (type-names (map-index (lambda (i) (concat "arg" i "-type")) 1 n)) - (indexes (map-index identity-procedure 1 n)) - (type-binds (map (lambda (type-name index) - `(,type-name (list-ref arg-types ,(- index 1)))) - type-names indexes)) - (conversions (map list type-names arg-names))) - - `(lambda (module-entry) - (let ,type-binds - (lambda ,arg-names - (result-type (%call-foreign-function - (module-entry/machine-address module-entry) - . ,conversions)))))))) + (define (map-index f i n) + (if (<= i n) + (cons (f i) (map-index f (1+ i) n)) + '())) + (define (->string thing) + (cond ((string? thing) thing) + ((symbol? thing) (symbol-name thing)) + ((number? thing) (number->string thing)))) + (define (concat . things) + (string->symbol (apply string-append (map ->string things)))) + + (let* ((arg-names (map-index (lambda (i) (concat "arg" i)) 1 n)) + (type-names (map-index (lambda (i) (concat "arg" i "-type")) 1 n)) + (indexes (map-index identity-procedure 1 n)) + (type-binds (map (lambda (type-name index) + `(,type-name (list-ref arg-types ,(- index 1)))) + type-names indexes)) + (conversions (map list type-names arg-names))) + + `(lambda (module-entry) + (let ,type-binds + (lambda ,arg-names + (result-type (%call-foreign-function + (module-entry/machine-address module-entry) + . ,conversions))))))))) (define (make-windows-procedure lib name result-type . arg-types) diff --git a/v7/src/win32/wingdi.scm b/v7/src/win32/wingdi.scm index 9599d612e..9d2c3ce3e 100644 --- a/v7/src/win32/wingdi.scm +++ b/v7/src/win32/wingdi.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: wingdi.scm,v 1.2 1999/01/09 03:37:18 cph Exp $ +$Id: wingdi.scm,v 1.3 2001/12/23 17:21:00 cph Exp $ -Copyright (c) 1993, 1999 Massachusetts Institute of Technology +Copyright (c) 1993, 1999, 2001 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 @@ -16,9 +16,12 @@ General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software -Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. |# +(declare (usual-integrations)) + ;;Binary raster ops (define-integrable R2_BLACK 1 ) ;0 (define-integrable R2_NOTMERGEPEN 2 ) ;DPon diff --git a/v7/src/win32/winnt.scm b/v7/src/win32/winnt.scm index 47fe80eb9..af4f6f10b 100644 --- a/v7/src/win32/winnt.scm +++ b/v7/src/win32/winnt.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: winnt.scm,v 1.2 1999/01/09 03:37:25 cph Exp $ +$Id: winnt.scm,v 1.3 2001/12/23 17:21:00 cph Exp $ -Copyright (c) 1993, 1999 Massachusetts Institute of Technology +Copyright (c) 1993, 1999, 2001 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 @@ -16,7 +16,10 @@ General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software -Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. |# -(define-integrable APPLICATION_ERROR_MASK #x20000000) \ No newline at end of file +(declare (usual-integrations)) + +(define-integrable APPLICATION_ERROR_MASK #x20000000) \ No newline at end of file diff --git a/v7/src/win32/winuser.scm b/v7/src/win32/winuser.scm index 569f7bdfb..a7c6f152d 100644 --- a/v7/src/win32/winuser.scm +++ b/v7/src/win32/winuser.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: winuser.scm,v 1.2 1999/01/09 03:37:06 cph Exp $ +$Id: winuser.scm,v 1.3 2001/12/23 17:21:00 cph Exp $ -Copyright (c) 1993, 1999 Massachusetts Institute of Technology +Copyright (c) 1993, 1999, 2001 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 @@ -16,9 +16,12 @@ General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software -Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. |# +(declare (usual-integrations)) + ;;Predefined Resource Types (define-integrable RT_CURSOR 1) (define-integrable RT_BITMAP 2) diff --git a/v7/src/win32/wt_user.scm b/v7/src/win32/wt_user.scm index 50ccafcc1..198957384 100644 --- a/v7/src/win32/wt_user.scm +++ b/v7/src/win32/wt_user.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: wt_user.scm,v 1.5 2001/12/20 16:13:19 cph Exp $ +$Id: wt_user.scm,v 1.6 2001/12/23 17:21:00 cph Exp $ Copyright (c) 1993, 1999, 2001 Massachusetts Institute of Technology @@ -20,6 +20,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |# +(declare (usual-integrations)) + ;; ;; common win32 types -- 2.25.1