#| -*-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
(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)
\f
(let-syntax
((define-standard-binary
+ (non-hygienic-macro-transformer
(lambda (name flo:op int:op)
`(DEFINE (,name X Y)
(IF (FLONUM? X)
(,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
(let-syntax
((define-integer-binary
+ (non-hygienic-macro-transformer
(lambda (name operator)
`(DEFINE (,name N M)
(IF (FLONUM? N)
(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)
(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)
#| -*-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
(declare (usual-integrations))
\f
-(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
#| -*-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
(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*))
#| -*-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
(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
\f
(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
#| -*-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
(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))
#| -*-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
(declare (usual-integrations))
\f
(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)))))))
\f
(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))))))
\f
(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)
;;; 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)))))
\f
(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
'()))))
(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))))))))
\f
;;;; 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))))
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
#| -*-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
(declare (usual-integrations))
\f
(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
#| -*-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
;;;; 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)
#| -*-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
(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)
#| -*-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
;;;; 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
(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)
#| -*-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
\f
(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)
#| -*-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
(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
#| -*-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
\f
;;;; 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
#| -*-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
(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)))))
\f
;;;; 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)))))
\f
;;;; 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
#| -*-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
(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)))))
\f
(define (make-position-independent pattern actions)
(let ((keyword (car pattern))
\f
;;;; 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))))))
\f
;;;; Utility procedures
#| -*-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
(declare (usual-integrations))
\f
-(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.
#| -*-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
(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
#| -*-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
\f
(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))))
(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)
#| -*-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
next)))))
\f
(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))
#| -*-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
(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
#| -*-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
(declare (usual-integrations))
\f
+(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)
;; 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)))))))))
\f
;; *** We can't really handle switching these right now. ***
#| -*-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
(declare (usual-integrations))
\f
-;; 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
(BYTE (32 value SIGNED)))
((U (? value))
(BYTE (32 value UNSIGNED))))
-\f
+
;;;; Actual instructions
(define-trivial-instruction AAA #x37)
(define-trivial-instruction AAD #xd5 #x0a)
(define-trivial-instruction AAM #xd4 #x0a)
(define-trivial-instruction AAS #x3f)
-
+\f
(let-syntax
((define-arithmetic-instruction
+ (non-hygienic-macro-transformer
(lambda (mnemonic opcode digit)
`(define-instruction ,mnemonic
((W (? target r/mW) (R (? source)))
(BYTE (8 #x80))
(ModR/M ,digit target)
(BYTE (8 value SIGNED)))
-\f
+
((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)
(define-arithmetic-instruction SBB #x18 3)
(define-arithmetic-instruction SUB #x28 5)
(define-arithmetic-instruction XOR #x30 6))
-
+\f
(define-instruction ARPL
(((? target r/mW) (R (? source)))
(BYTE (8 #x63))
(let-syntax
((define-bit-test-instruction
+ (non-hygienic-macro-transformer
(lambda (mnemonic opcode digit)
`(define-instruction ,mnemonic
(((? target r/mW) (& (? posn)))
(((? 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)
(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)
\f
(let-syntax
((define-inc/dec
+ (non-hygienic-macro-transformer
(lambda (mnemonic digit opcode)
`(define-instruction ,mnemonic
((W (R (? reg)))
((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))
((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)
(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)
((W (@PCO (? displ)))
(BYTE (8 #x0f)
(8 ,opcode2))
- (IMMEDIATE displ ADDRESS))))))
+ (IMMEDIATE displ ADDRESS)))))))
\f
(define-jump-instruction JA #x77 #x87)
(define-jump-instruction JAE #x73 #x83)
(let-syntax
((define-loop-instruction
+ (non-hygienic-macro-transformer
(lambda (mnemonic opcode)
`(define-instruction ,mnemonic
((B (@PCR (? dest)))
((B (@PCO (? displ)))
(BYTE (8 ,opcode)
- (8 displ SIGNED)))))))
+ (8 displ SIGNED))))))))
(define-loop-instruction JCXZ #xe3)
(define-loop-instruction JECXZ #xe3)
(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)
#| -*-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
;; 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)))))
\f
;;;; 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)
(let-syntax
((define-data-extension
+ (non-hygienic-macro-transformer
(lambda (mnemonic opcode)
`(define-instruction ,mnemonic
((B (R (? target)) (? source r/mB))
((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))
((B (? operand r/mB))
(BYTE (8 #xf6))
- (ModR/M ,digit operand))))))
+ (ModR/M ,digit operand)))))))
(define-unary NEG 3)
(define-unary NOT 2))
\f
(let-syntax
((define-rotate/shift
+ (non-hygienic-macro-transformer
(lambda (mnemonic digit)
`(define-instruction ,mnemonic
((W (? operand r/mW) (& 1))
((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)
(let-syntax
((define-double-shift
+ (non-hygienic-macro-transformer
(lambda (mnemonic opcode)
`(define-instruction ,mnemonic
((W (? target r/mW) (R (? source)) (& (? count)))
((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))
(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)
#| -*-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
\f
(let-syntax
((define-binary-flonum
+ (non-hygienic-macro-transformer
(lambda (mnemonic pmnemonic imnemonic digit opcode1 opcode2)
`(begin
(define-instruction ,mnemonic
((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,
(define-binary-flonum FSUB FSUBP FISUB 4 #xe0 #xe8)
(define-binary-flonum FSUBR FSUBPR FISUBR 5 #xe8 #xe0))
\f
-(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)
(let-syntax
((define-flonum-comparison
+ (non-hygienic-macro-transformer
(lambda (mnemonic digit opcode)
`(define-instruction ,mnemonic
(((ST 0) (ST (? i)))
((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))
(let-syntax
((define-flonum-integer-comparison
+ (non-hygienic-macro-transformer
(lambda (mnemonic digit)
`(define-instruction ,mnemonic
((L (? source mW))
((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)
((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)
(let-syntax
((define-flonum-memory
+ (non-hygienic-macro-transformer
(lambda (mnemonic digit1 digit2 opcode1 opcode2)
`(define-instruction ,mnemonic
(((ST (? i)))
`()
`(((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)
(let-syntax
((define-flonum-state
+ (non-hygienic-macro-transformer
(lambda (mnemonic opcode digit mnemonic2)
`(begin
,@(if (not mnemonic2)
(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)
(let-syntax
((define-binary-flonum
+ (non-hygienic-macro-transformer
(lambda (mnemonic opcode1 opcode2)
`(define-instruction ,mnemonic
(((ST 0) (ST (? i)))
(()
(BYTE (8 ,opcode1)
- (8 (+ ,opcode2 1))))))))
+ (8 (+ ,opcode2 1)))))))))
(define-binary-flonum FUCOM #xdd #xe0)
(define-binary-flonum FUCOMP #xdd #xe8)
#| -*-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
(let-syntax ((define-codes
+ (non-hygienic-macro-transformer
(lambda (start . names)
(define (loop names index)
(if (null? names)
(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
,@(invoke-hook/call entry:compiler-scheme-to-interface/call)))
\f
(let-syntax ((define-entries
+ (non-hygienic-macro-transformer
(lambda (start high . names)
(define (loop names index high)
(cond ((null? names)
(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.
#| -*-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
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!)
\f
(let-syntax
((define-special-primitive-invocation
+ (non-hygienic-macro-transformer
(lambda (name)
`(define-rule statement
(INVOCATION:SPECIAL-PRIMITIVE
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
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 &-)
#| -*-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
(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)
#| -*-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
(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
(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)
\f
(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
(,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)
#| -*-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
(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
#| -*-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
\f
;;;; 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
#| -*-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
(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
#| -*-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
\f
;;;; 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
#| -*-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
(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
#| -*-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
\f
;;;; 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))))
\f
;;;; Fixed width instruction parsing
#| -*-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
(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))
(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))
#| -*-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
'(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))))
#| -*-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
(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)))))
\f
;;;; Transformers and utilities
(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
;;; *** 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))))))
\f
;; This is super hairy because of immediate operands!
;; The index 2 here is the argument number to MAKE-EFFECTIVE-ADDRESS.
#| -*-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
(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))))
\f
(define (parse-instruction opcode tail early?)
(process-fields (cons opcode tail) early?))
#| -*-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
;; 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
#| -*-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
(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)))))))
\f
(define-instruction CVT
((B W (? src ea-r-b) (? dst ea-w-w))
#| -*-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
(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)))))))
\f
(define-instruction ASH
((L (? cnt ea-r-b) (? src ea-r-l) (? dst ea-w-l))
#| -*-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
\f
(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*)))
(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)
#| -*-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
\f
(let-syntax
((define-value-class
+ (non-hygienic-macro-transformer
(lambda (name parent-name)
(let* ((name->variable
(lambda (name) (symbol-append 'VALUE-CLASS= name)))
(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)
;;; -*-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
;;;
(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)
;;; -*-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
;;;
;; 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)
;;; -*-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
;;;
;;; ******************************************************************
\f
(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))))
\f
(define (syntax-class-definition class bvl body receiver)
(parse-definition bvl body
;;; -*-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
;;;
(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))
;;; -*-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
;;;
(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))
\f
(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)
,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))
\f
(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))
;;; -*-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
;;;
(make-mark group start)))
\f
(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)
;;; -*-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
;;;
\f
(let-syntax
((define-forward-search
+ (non-hygienic-macro-transformer
(lambda (name find-next)
`(DEFINE (,name GROUP START END CHAR)
;; Assume (FIX:<= START END)
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
(let-syntax
((define-backward-search
+ (non-hygienic-macro-transformer
(lambda (name find-previous)
`(DEFINE (,name GROUP START END CHAR)
;; Assume (FIX:<= START END)
(,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)
(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))
;;; -*-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
;;;
;;;; 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))
#| -*-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
(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)
;;; -*-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
;;;
standard-error-handler))
\f
(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))
;;; -*-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
;;;
(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)
(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))
#| -*-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
;;;; 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)
;;; -*-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
;;;
;;; [] 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)
;;; 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 $"
#| -*-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
(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))
(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
#| -*-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
;;;; Utilities
(define-syntax copy
- (lambda (x)
- `(LOCAL-DECLARE ((INTEGRATE ,x)) ,x)))
+ (non-hygienic-macro-transformer
+ (lambda (x)
+ `(LOCAL-DECLARE ((INTEGRATE ,x)) ,x))))
;;;; Primitives
(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 &/))
\f
(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)
(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))
(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:-))
(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)
(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))
\f
(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
(let-syntax
((define-integer-binary
+ (non-hygienic-macro-transformer
(lambda (name operator-name operator)
(let ((flo->int
(lambda (n)
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)
(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))
\f
(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)
#| -*-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
(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))))))
\f
;;;; Display commands
#| -*-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
|#
\f
(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))))))
\f
;;;; Parse Options
#| -*-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
(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)))))
\f
(define (find-restart name #!optional restarts)
(guarantee-symbol name 'FIND-RESTART)
#| -*-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
(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)
#| -*-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
(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)
#| -*-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
\f
(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))
#| -*-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
(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)
(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))
#| -*-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
(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)
#| -*-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
(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)
;;; -*-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
;;;
\f
(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)))
\f
(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")
(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"))
\f
#| -*-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
(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)
;;; -*-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
;;;
(%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
;;; -*-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
;;;
;;;; 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:
#| -*-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
(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))
#| -*-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
\f
(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
#| -*-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
(let-syntax
((define-accessors-and-mutators
+ (non-hygienic-macro-transformer
(lambda (name)
`(BEGIN
(DEFINE (,(symbol-append 'STARBASE-DEVICE/ name) DEVICE)
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)
#| -*-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
;; 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)
#| -*-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
(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
#| -*-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
(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)
#| -*-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
(let-syntax
((define-enumeration
+ (non-hygienic-macro-transformer
(lambda (enumeration-name enumerand-names)
`(BEGIN
(DEFINE ,enumeration-name
`(DEFINE ,(symbol-append enumerand-name '/ENUMERAND)
(ENUMERATION/NAME->ENUMERAND ,enumeration-name
',enumerand-name)))
- enumerand-names)))))
+ enumerand-names))))))
(define-enumeration enumeration/random
(block
delayed-integration
(let-syntax
((define-simple-type
+ (non-hygienic-macro-transformer
(lambda (name slots #!optional scode?)
`(DEFINE-STRUCTURE (,name (TYPE VECTOR)
(NAMED ,(symbol-append name '/ENUMERAND))
,@(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))
(let-syntax
((define-flag
+ (non-hygienic-macro-transformer
(lambda (name tester setter)
`(BEGIN
(DEFINE (,tester VARIABLE)
(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!)
;;; -*-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
;;;
(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 <boolean> <object>)
(define-primitive-class <char> <object>)
;;; -*-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
;;;
;;; 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)))))
+\f
(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))))
\f
(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 <instance>))
(instance-constructor-3 (fix:= n-slots) n-slots () ()))))))
\f
(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))))))))
+\f
(define (make-initialization class arg-slots)
(let ((if-slots
(list-transform-positive (class-slots class)
(if (< if-n 4)
(constructor-case if-n 0 4 make-initialization-1)
(make-initialization-1 #f)))))
-\f
+
(define initialize-instance
(make-generic-procedure '(1 . #F) 'INITIALIZE-INSTANCE))
;;; -*-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
;;;
(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
;;; -*-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
;;;
(declare (usual-integrations))
\f
-(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))))))))
\f
(define (parse-define-class-name name lose)
(call-with-values (lambda () (parse-define-class-name-1 name lose))
(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)))))
(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))
\f
(define (extract-generic-definitions! slot-arguments name separator lose)
(let ((definitions '()))
(substring s 1 (fix:- (string-length s) 1))
s)))
\f
-(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))))))))
\f
(define (extract-required-specializers required)
(let loop ((required required) (names '()) (specializers '()))
(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
(illegal (lambda (expr) (error "Illegal expression:" expr))))
do-expr))
\f
-(define (parse-lambda-list lambda-list allow-specializers? specform)
- specform
+(define (parse-lambda-list lambda-list allow-specializers?)
(let ((required '())
(optional '())
(rest #f))
(illegal-element
(lambda (lambda-list)
(error "Illegal parameter list element:" (car lambda-list)))))
- (parse-required lambda-list))))
-\f
-(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
#| -*-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
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
(global-definitions "../runtime/runtime")
(define-package (sos)
- (files)
(parent ()))
(define-package (sos slot)
(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
;;; -*-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
;;;
(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
\f
;;;; 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
,(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))
(make-eq-hash-table))
\f
(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)))
;;; -*-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
;;;
(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?
;;; -*-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
;;;
(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
\f
;;;; 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
,(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))
(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 ()
(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-*
->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!
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
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
choose-maximum-glue
choose-minimum-glue
clean-lost-celled-objects
- ;;clean-lost-protected-objects
cleanup-vanished-objects-for-display
clear-counters!
cleararea
decode-unknown-event
decode-window-attributes
defer
- ;;del-assq!
- ;;del-assv!
- ;;del-op!
+ define-constant ;macro
+ define-in-line ;macro
delete-<interactor>!
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
empty-agenda?
empty-queue?
empty-segments?
- ;;enqueue!
ensure-graphics-context
entry-height-stretch
event!
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
make-point
make-point-event
make-polygon-on-canvas
- ;;make-protection-list
- ;;make-queue
make-radiobutton
make-rect
make-rectangle-event
make-unfilled-rectangle
make-unknown-event
make-vbox
- ;;make-weak-del-op!
- ;;make-weak-lookup
make-widget-on-canvas
makexregion
maybe-defer
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
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
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
scxl-wrapper.wrapped-object
scxl-wrapper/pp
scxl-wrapper?
- ;;search-protection-list
segment-queue
segment-time
segments
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
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
uiobjinternals.used-screen-area-procedure
uiobjinternals/pp
uiobjinternals?
- ;;uitk-protection-list
uitk-queue
uitk-thread
uitk-thread-main-loop
valid-color-for-application?
valid-color?
valid-non-widget?
- ;;weak-delq!
when-idle!
when-unreferenced
widget->screen-area
xtranslatecoordinates
xunionrectspecswithregion!
xunionregion!
- xunloadfont)))
+ xunloadfont
+ )))
(with-working-directory-pathname
(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))
(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)
;;;; -*-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
;;;; -*-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.
;;;; (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))))))))
(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 $
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; - Document dependencies
;; - [SCREWS] see last page
\f
-;;; $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 $
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
(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))))
#| -*-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
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))
\f
(define-structure (dib (constructor %make-dib))
handle)
#| -*-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
02111-1307, USA.
|#
+(declare (usual-integrations))
+\f
#|
WINDOWS PROCEDURE TYPE SYSTEM
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)
+\f
+(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)))))))
+\f
+(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
#| -*-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
(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
#| -*-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
(global-definitions "../runtime/runtime")
(define-package (win32)
- (parent (runtime))
+ (parent ())
(files "winuser"
"wt_user"
"wf_user"
"win_ffi"
"module"
"protect"
- "clipbrd"
- )
+ "clipbrd")
(export ()
%call-foreign-function
parameterize-with-module-entry
win32-clipboard-write-text
win32-screen-height
win32-screen-width)
+ (import (runtime)
+ ucode-primitive)
(initialization
(begin
(initialize-protection-list-package!)
(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")
#| -*-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
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-time<? "ffimacro.bin" "ffimacro.com"))
(cbf "ffimacro"))
- (load "ffimacro")
+ (load "ffimacro" '(WIN32 FFI-MACRO))
(sf-conditionally "winuser")
(sf-conditionally "wingdi")
(sf-conditionally "win_ffi")
(sf-directory "."))
-(load-option 'CREF)
(cref/generate-constructors "win32")
\ No newline at end of file
#| -*-Scheme-*-
-$Id: win_ffi.scm,v 1.7 2001/12/20 20:51:16 cph Exp $
+$Id: win_ffi.scm,v 1.8 2001/12/23 17:21:00 cph Exp $
Copyright (c) 1993, 1999, 2001 Massachusetts Institute of Technology
hIcon hCursor background menu-name name))
-(define-integrable %call-foreign-function (ucode-primitive call-ff))
+(define-integrable %call-foreign-function
+ (ucode-primitive call-ff -1))
(define (windows-procedure-argument-type-check-error type arg)
((access error system-global-environment)
(define-syntax call-case
- (lambda (n)
- #|
+ (non-hygienic-macro-transformer
+ (lambda (n)
+ #|
;; Generate code like this:
(lambda (module-entry)
(let ((arg1-type (list-ref arg-types 0))
(arg1-type arg1)
(arg2-type arg2)))))))
|#
- (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 (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)
#| -*-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
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
#| -*-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
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
#| -*-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
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)
#| -*-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
02111-1307, USA.
|#
+(declare (usual-integrations))
+
;;
;; common win32 types
projects / mit-scheme.git / commitdiff