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

.

Browse Source 
original commit: f6b22c613884a51c271ca71bce6cc4d66d373d92
This commit is contained in:
Matthew Flatt 2002-11-18 15:43:21 +00:00
parent 2dc74ffd45
commit 6d7cfbe3f2
1 changed files with 51 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

84
collects/mzlib/class.ss
View File

@ -713,23 +713,24 @@
(append publics (append publics
overrides overrides
inherits)))] inherits)))]
[(field-accessor ...) (generate-temporaries [(inherit-field-accessor ...) (generate-temporaries
(map (lambda (id) (map (lambda (id)
(format "get-~a" (format "get-~a"
(syntax-e id))) (syntax-e id)))
(append inherit-field-names inherit-field-names))]
field-names [(inherit-field-mutator ...) (generate-temporaries
private-field-names)))]
[(field-mutator ...) (generate-temporaries
(map (lambda (id) (map (lambda (id)
(format "set-~a!" (format "set-~a!"
(syntax-e id))) (syntax-e id)))
(append inherit-field-names inherit-field-names))]
field-names [(inherit-field-name ...) inherit-field-names]
private-field-names)))] [(local-field ...) (append field-names
[(all-field ...) (append inherit-field-names
field-names
private-field-names)] private-field-names)]
[(local-field-pos ...) (let loop ([pos 0][l (append field-names
private-field-names)])
(if (null? l)
null
(cons pos (loop (add1 pos) (cdr l)))))]
[(plain-init-name ...) plain-init-names]) [(plain-init-name ...) plain-init-names])
(let ([mappings (let ([mappings
;; make-XXX-map is supplied by private/classidmap.ss ;; make-XXX-map is supplied by private/classidmap.ss
@ -738,7 +739,8 @@
[this-id this-id]) [this-id this-id])
(syntax (syntax
([(this-id ([(this-id
all-field ... inherit-field-name ...
local-field ...
rename-orig ... rename-orig ...
method-name ... method-name ...
private-name ... private-name ...
@ -749,9 +751,17 @@
(quote the-obj)) (quote the-obj))
(make-field-map (quote-syntax the-finder) (make-field-map (quote-syntax the-finder)
(quote the-obj) (quote the-obj)
(quote-syntax all-field) (quote-syntax inherit-field-name)
(quote-syntax field-accessor) (quote-syntax inherit-field-accessor)
(quote-syntax field-mutator)) (quote-syntax inherit-field-mutator)
'())
...
(make-field-map (quote-syntax the-finder)
(quote the-obj)
(quote-syntax local-field)
(quote-syntax local-accessor)
(quote-syntax local-mutator)
'(local-field-pos))
... ...
(make-rename-map (quote-syntax the-finder) (make-rename-map (quote-syntax the-finder)
(quote the-obj) (quote the-obj)
@ -869,8 +879,10 @@
`init-names `init-names
(quote init-mode) (quote init-mode)
;; Methods (when given needed super-methods, etc.): ;; Methods (when given needed super-methods, etc.):
(lambda (field-accessor ... ; inherit, public, private (lambda (local-accessor
field-mutator ... local-mutator
inherit-field-accessor ... ; inherit
inherit-field-mutator ...
rename-temp ... rename-temp ...
method-accessor ...) ; public, override, inherit method-accessor ...) ; public, override, inherit
(letrec-syntaxes+values mappings () (letrec-syntaxes+values mappings ()
@ -1340,39 +1352,19 @@
(set-class-struct:object! c struct:object) (set-class-struct:object! c struct:object)
(set-class-object?! c object?) (set-class-object?! c object?)
(set-class-make-object! c tagged-object-make) (set-class-make-object! c tagged-object-make)
(unless (null? public-field-names)
;; We need these only if there are new public fields
(set-class-field-ref! c object-field-ref) (set-class-field-ref! c object-field-ref)
(set-class-field-set!! c object-field-set!) (set-class-field-set!! c object-field-set!))
;; --- Build field accessors and mutators --- ;; --- Build field accessors and mutators ---
;; Use public field names to name the accessors and mutators ;; Use public field names to name the accessors and mutators
(let-values ([(accessors mutators) (let-values ([(inh-accessors inh-mutators)
(let ([rev-fields (reverse public-field-names)])
(let ([mk
(lambda (mk obj-)
(let loop ([n num-fields]
[l null]
[skip (- num-fields (length public-field-names))]
[field-ids rev-fields])
(if (zero? n)
l
(loop (sub1 n)
(cons (apply
mk obj- (sub1 n)
(if (zero? skip)
(list (car field-ids))
null))
l)
(max 0 (sub1 skip))
(if (zero? skip)
(cdr field-ids)
field-ids)))))])
(values (values
(append (map (lambda (id) (make-class-field-accessor super id)) (map (lambda (id) (make-class-field-accessor super id))
inherit-field-names) inherit-field-names)
(mk make-struct-field-accessor object-field-ref)) (map (lambda (id) (make-class-field-mutator super id))
(append (map (lambda (id) (make-class-field-mutator super id)) inherit-field-names))])
inherit-field-names)
(mk make-struct-field-mutator object-field-set!)))))])
;; -- Reset field table to register accessor and mutator info -- ;; -- Reset field table to register accessor and mutator info --
;; There are more accessors and mutators than public fields... ;; There are more accessors and mutators than public fields...
(let loop ([ids public-field-names][pos 0]) (let loop ([ids public-field-names][pos 0])
@ -1395,8 +1387,10 @@
;; -- Get new methods and initializers -- ;; -- Get new methods and initializers --
(let-values ([(new-methods override-methods init) (let-values ([(new-methods override-methods init)
(apply make-methods (apply make-methods
(append accessors object-field-ref
mutators object-field-set!
(append inh-accessors
inh-mutators
renames renames
method-accessors))]) method-accessors))])
;; -- Fill in method tables -- ;; -- Fill in method tables --