suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

.

Browse Source 
original commit: 167a11757fbe3b2c7442c92913a9614851f94ced
This commit is contained in:
Matthew Flatt 2001-03-31 00:26:26 +00:00
parent af77872825
commit 32b27e5ac2
1 changed files with 49 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

85
collects/mzlib/class.ss
View File

@ -19,9 +19,8 @@
...) ...)
(let-values ([(defn-and-exprs) (syntax->list (syntax (defn-or-expr ...)))] (let-values ([(defn-and-exprs) (syntax->list (syntax (defn-or-expr ...)))]
[(this-id) (syntax this-id)] [(this-id) (syntax this-id)]
[(the-obj) (datum->syntax-object (quote-syntax here) [(the-obj) (datum->syntax-object (quote-syntax here) (gensym 'self))]
;; Non-hygenic: [(the-finder) (datum->syntax-object (quote-syntax here) (gensym 'find-self))]
(gensym (box 'self)))]
[(super-instantiate-id super-make-object-id) [(super-instantiate-id super-make-object-id)
(let ([s (syntax supers)]) (let ([s (syntax supers)])
(if (stx-null? s) (if (stx-null? s)
@ -326,11 +325,13 @@
(vars-ok? (syntax vars)) (vars-ok? (syntax vars))
(if xform? (if xform?
(with-syntax ([the-obj the-obj] (with-syntax ([the-obj the-obj]
[the-finder the-finder]
[name (mk-name name)]) [name (mk-name name)])
(syntax/loc stx (syntax/loc stx
(let ([name (let ([name
(lambda (the-obj . vars) (lambda (the-obj . vars)
body1 body ...)]) (fluid-let-syntax ([the-finder (quote-syntax the-obj)])
body1 body ...))])
name))) name)))
stx)] stx)]
[(lambda . _) [(lambda . _)
@ -339,11 +340,13 @@
(andmap vars-ok? (syntax->list (syntax (vars ...)))) (andmap vars-ok? (syntax->list (syntax (vars ...))))
(if xform? (if xform?
(with-syntax ([the-obj the-obj] (with-syntax ([the-obj the-obj]
[the-finder the-finder]
[name (mk-name name)]) [name (mk-name name)])
(syntax/loc stx (syntax/loc stx
(let ([name (let ([name
(case-lambda [(the-obj . vars) (case-lambda [(the-obj . vars)
body1 body ...] ...)]) (fluid-let-syntax ([the-finder (quote-syntax the-obj)])
body1 body ...)] ...)])
name))) name)))
stx)] stx)]
[(case-lambda . _) [(case-lambda . _)
@ -362,8 +365,7 @@
(lambda (id) (lambda (id)
(datum->syntax-object (datum->syntax-object
#f #f
;; NOT HYGIENIC!! (gensym (syntax-e id))))
(gensym (box (syntax-e id)))))
ids) ids)
ids)] ids)]
[body-locals (append ids locals)] [body-locals (append ids locals)]
@ -390,10 +392,12 @@
(lambda (old-id new-id) (lambda (old-id new-id)
(with-syntax ([old-id old-id] (with-syntax ([old-id old-id]
[new-id new-id] [new-id new-id]
[the-obj the-obj]) [the-obj the-obj]
[the-finder the-finder])
(syntax (old-id (make-direct-method-map (syntax (old-id (make-direct-method-map
(quote-syntax the-obj) (quote-syntax the-finder)
(quote-syntax new-id)))))) (quote the-obj)
(quote new-id))))))
ids new-ids) ids new-ids)
null)] null)]
[body body]) [body body])
@ -565,9 +569,8 @@
[mk-method-temp [mk-method-temp
(lambda (id-stx) (lambda (id-stx)
(datum->syntax-object (quote-syntax here) (datum->syntax-object (quote-syntax here)
;; Non-hygenic: (gensym (syntax-e id-stx))))])
(gensym (box (syntax-e id-stx)))))])
;; ---- set up field and method mappings ---- ;; ---- set up field and method mappings ----
(with-syntax ([(rename-orig ...) (map car renames)] (with-syntax ([(rename-orig ...) (map car renames)]
[(rename-temp ...) (generate-temporaries (map car renames))] [(rename-temp ...) (generate-temporaries (map car renames))]
@ -613,34 +616,42 @@
(let ([mappings (let ([mappings
;; make-XXX-map is supplied by private/classidmap.ss ;; make-XXX-map is supplied by private/classidmap.ss
(with-syntax ([the-obj the-obj] (with-syntax ([the-obj the-obj]
[the-finder the-finder]
[this-id this-id]) [this-id this-id])
(syntax (syntax
([this-id ([this-id
(make-this-map (quote-syntax the-obj))] (make-this-map (quote-syntax the-finder)
(quote the-obj))]
[all-field [all-field
(make-field-map (quote-syntax the-obj) (make-field-map (quote-syntax the-finder)
(quote the-obj)
(quote-syntax field-accessor) (quote-syntax field-accessor)
(quote-syntax field-mutator))] (quote-syntax field-mutator))]
... ...
[rename-orig [rename-orig
(make-rename-map (quote-syntax the-obj) (make-rename-map (quote-syntax the-finder)
(quote-syntax rename-temp))] (quote the-obj)
(quote rename-temp))]
... ...
[method-name [method-name
(make-method-map (quote-syntax the-obj) (make-method-map (quote-syntax the-finder)
(quote the-obj)
(quote-syntax method-accessor))] (quote-syntax method-accessor))]
... ...
[private-name [private-name
(make-direct-method-map (quote-syntax the-obj) (make-direct-method-map (quote-syntax the-finder)
(quote-syntax private-temp))] (quote the-obj)
(quote private-temp))]
... ...
[public-final-name [public-final-name
(make-direct-method-map (quote-syntax the-obj) (make-direct-method-map (quote-syntax the-finder)
(quote-syntax public-final-temp))] (quote the-obj)
(quote public-final-temp))]
... ...
[override-final-name [override-final-name
(make-direct-method-map (quote-syntax the-obj) (make-direct-method-map (quote-syntax the-finder)
(quote-syntax override-final-temp))] (quote the-obj)
(quote override-final-temp))]
...)))] ...)))]
[extra-init-mappings [extra-init-mappings
(with-syntax ([super-instantiate-id super-instantiate-id] (with-syntax ([super-instantiate-id super-instantiate-id]
@ -701,6 +712,7 @@
[extra-init-mappings extra-init-mappings] [extra-init-mappings extra-init-mappings]
[exprs exprs] [exprs exprs]
[the-obj the-obj] [the-obj the-obj]
[the-finder the-finder]
[super-instantiate-id super-instantiate-id] [super-instantiate-id super-instantiate-id]
[super-make-object-id super-make-object-id] [super-make-object-id super-make-object-id]
[name class-name]) [name class-name])
@ -742,18 +754,19 @@
(list override-final-temp ... . override-methods) (list override-final-temp ... . override-methods)
;; Initialization ;; Initialization
(lambda (the-obj super-id init-args) (lambda (the-obj super-id init-args)
(letrec-syntax ([super-instantiate-id (fluid-let-syntax ([the-finder (quote-syntax the-obj)])
(lambda (stx) (letrec-syntax ([super-instantiate-id
(syntax-case stx () (lambda (stx)
[(_ (arg (... ...)) (kw kwarg) (... ...)) (syntax-case stx ()
(syntax (-instantiate super-id _ #f (list arg (... ...)) (kw kwarg) (... ...)))]))]) [(_ (arg (... ...)) (kw kwarg) (... ...))
(let ([super-make-object-id (syntax (-instantiate super-id _ #f (list arg (... ...)) (kw kwarg) (... ...)))]))])
(lambda args (let ([super-make-object-id
(super-id #f args null))]) (lambda args
(let ([plain-init-name undefined] (super-id #f args null))])
...) (let ([plain-init-name undefined]
(void) ; in case the body is empty ...)
. exprs)))))))) (void) ; in case the body is empty
. exprs)))))))))
;; Not primitive: ;; Not primitive:
#f)))))))))))))))]))) #f)))))))))))))))])))