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

.

Browse Source 
original commit: b1e900e72547b5168bf96723dc582c29cb23f4ec
This commit is contained in:
Matthew Flatt 2001-04-24 15:32:04 +00:00
parent 4a7c055c77
commit 08e1e9e213
1 changed files with 114 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

196
collects/mzlib/class.ss
View File

@ -212,21 +212,19 @@
defn-and-exprs) defn-and-exprs)
;; ----- Sort body into different categories ----- ;; ----- Sort body into different categories -----
(let ([extract (lambda (kws reverse?) (let ([extract (lambda (kws l out-cons)
(let loop ([l defn-and-exprs]) (let loop ([l l])
(cond (if (null? l)
[(null? l) null] (values null null)
[(and (stx-pair? (car l)) (let-values ([(in out) (loop (cdr l))])
(let ([id (stx-car (car l))]) (cond
(and (identifier? id) [(and (stx-pair? (car l))
(ormap (lambda (k) (module-identifier=? k id)) kws)))) (let ([id (stx-car (car l))])
(if reverse? (and (identifier? id)
(loop (cdr l)) (ormap (lambda (k) (module-identifier=? k id)) kws))))
(cons (car l) (loop (cdr l))))] (values (cons (car l) in) out)]
[else [else
(if reverse? (values in (out-cons (car l) out))])))))]
(cons (car l) (loop (cdr l)))
(loop (cdr l)))])))]
[flatten (lambda (alone l) [flatten (lambda (alone l)
(apply append (apply append
(map (lambda (i) (map (lambda (i)
@ -239,32 +237,57 @@
l))) l)))
l)))] l)))]
[pair (lambda (i) (cons i i))]) [pair (lambda (i) (cons i i))])
(let ([init-rest-decls (extract (list (quote-syntax init-rest)) #f)] (let*-values ([(extract*) (lambda (kws l)
[inits (flatten values (extract (list (quote-syntax init) (let-values ([(in out) (extract kws l void)])
(quote-syntax init-field)) in))]
#f))] [(decls exprs)
[plain-inits (flatten values (extract (list (quote-syntax init) (extract (list (quote-syntax inherit-field)
(quote-syntax init-rest)) (quote-syntax private)
#f))] (quote-syntax public)
[plain-fields (flatten values (extract (list (quote-syntax field)) #f))] (quote-syntax override)
[plain-init-fields (flatten values (extract (list (quote-syntax init-field)) #f))] (quote-syntax public-final)
[inherit-fields (flatten values (extract (list (quote-syntax inherit-field)) #f))] (quote-syntax override-final)
[privates (flatten pair (extract (list (quote-syntax private)) #f))] (quote-syntax rename)
[publics (flatten pair (extract (list (quote-syntax public)) #f))] (quote-syntax inherit))
[overrides (flatten pair (extract (list (quote-syntax override)) #f))] defn-and-exprs
[public-finals (flatten pair (extract (list (quote-syntax public-final)) #f))] cons)]
[override-finals (flatten pair (extract (list (quote-syntax override-final)) #f))] [(plain-inits)
[renames (flatten pair (extract (list (quote-syntax rename)) #f))] (flatten values
[inherits (flatten pair (extract (list (quote-syntax inherit)) #f))] (extract* (list (quote-syntax init)
[exprs (extract (list (quote-syntax inherit-field) (quote-syntax init-rest))
(quote-syntax private) exprs))]
(quote-syntax public) [(init-rest-decls _)
(quote-syntax override) (extract (list (quote-syntax init-rest))
(quote-syntax public-final) exprs
(quote-syntax override-final) void)]
(quote-syntax rename) [(inits)
(quote-syntax inherit)) (flatten values (extract* (list (quote-syntax init)
#t)]) (quote-syntax init-field))
exprs))]
[(plain-inits)
(flatten values (extract* (list (quote-syntax init)
(quote-syntax init-rest))
exprs))]
[(plain-fields)
(flatten values (extract* (list (quote-syntax field)) exprs))]
[(plain-init-fields)
(flatten values (extract* (list (quote-syntax init-field)) exprs))]
[(inherit-fields)
(flatten values (extract* (list (quote-syntax inherit-field)) decls))]
[(privates)
(flatten pair (extract* (list (quote-syntax private)) decls))]
[(publics)
(flatten pair (extract* (list (quote-syntax public)) decls))]
[(overrides)
(flatten pair (extract* (list (quote-syntax override)) decls))]
[(public-finals)
(flatten pair (extract* (list (quote-syntax public-final)) decls))]
[(override-finals)
(flatten pair (extract* (list (quote-syntax override-final)) decls))]
[(renames)
(flatten pair (extract* (list (quote-syntax rename)) decls))]
[(inherits)
(flatten pair (extract* (list (quote-syntax inherit)) decls))])
(unless (or (null? init-rest-decls) (unless (or (null? init-rest-decls)
(null? (cdr init-rest-decls))) (null? (cdr init-rest-decls)))
@ -633,49 +656,58 @@
[the-finder the-finder] [the-finder the-finder]
[this-id this-id]) [this-id this-id])
(syntax (syntax
([this-id ([(this-id
(make-this-map (quote-syntax the-finder) all-field ...
(quote the-obj))] rename-orig ...
[all-field method-name ...
(make-field-map (quote-syntax the-finder) private-name ...
(quote the-obj) public-final-name ...
(quote-syntax field-accessor) override-final-name ...)
(quote-syntax field-mutator))] (values
... (make-this-map (quote-syntax the-finder)
[rename-orig (quote the-obj))
(make-rename-map (quote-syntax the-finder) (make-field-map (quote-syntax the-finder)
(quote the-obj) (quote the-obj)
(quote rename-temp))] (quote-syntax field-accessor)
... (quote-syntax field-mutator))
[method-name ...
(make-method-map (quote-syntax the-finder) (make-rename-map (quote-syntax the-finder)
(quote the-obj) (quote the-obj)
(quote-syntax method-accessor))] (quote rename-temp))
... ...
[private-name (make-method-map (quote-syntax the-finder)
(make-direct-method-map (quote-syntax the-finder) (quote the-obj)
(quote the-obj) (quote-syntax method-accessor))
(quote private-temp))] ...
... (make-direct-method-map (quote-syntax the-finder)
[public-final-name (quote the-obj)
(make-direct-method-map (quote-syntax the-finder) (quote private-temp))
(quote the-obj) ...
(quote public-final-temp))] (make-direct-method-map (quote-syntax the-finder)
... (quote the-obj)
[override-final-name (quote public-final-temp))
(make-direct-method-map (quote-syntax the-finder) ...
(quote the-obj) (make-direct-method-map (quote-syntax the-finder)
(quote 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]
[super-make-object-id super-make-object-id]) [super-make-object-id super-make-object-id]
[(init-error-map ...)
(map (lambda (x)
(syntax init-error-map))
plain-inits)])
(syntax (syntax
([plain-init-name init-error-map] ([(plain-init-name ...
... super-instantiate-id
[super-instantiate-id super-error-map] super-make-object-id)
[super-make-object-id super-error-map])))]) (values
init-error-map
...
super-error-map
super-error-map)])))])
(let ([find-method (let ([find-method
(lambda (methods) (lambda (methods)
(lambda (name) (lambda (name)
@ -685,7 +717,7 @@
(with-syntax ([proc (proc-shape (car m) (cdr m) #t)] (with-syntax ([proc (proc-shape (car m) (cdr m) #t)]
[extra-init-mappings extra-init-mappings]) [extra-init-mappings extra-init-mappings])
(syntax (syntax
(letrec-syntax extra-init-mappings (letrec-syntaxes extra-init-mappings
proc))))) proc)))))
methods)))]) methods)))])
@ -756,7 +788,7 @@
field-mutator ... field-mutator ...
rename-temp ... rename-temp ...
method-accessor ...) ; public, override, inherit method-accessor ...) ; public, override, inherit
(letrec-syntax mappings (letrec-syntaxes mappings
(letrec ([private-temp private-method] (letrec ([private-temp private-method]
... ...
[public-final-temp public-final-method] [public-final-temp public-final-method]