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

Class Contracts Phase 2: Object/c Boogaloo

Browse Source 
This isn't just a copy of trunk r18264 -- it has a slight difference in how
local field accessors and mutators are handled that will eventually play a
larger role.

svn: r18265
This commit is contained in:
Stevie Strickland 2010-02-22 19:09:42 +00:00
parent f1e7c7e4b0
commit c2fcdbba65
1 changed files with 12 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/scheme/private/class-internal.ss
View File

@ -1329,17 +1329,13 @@
;; Methods (when given needed super-methods, etc.): ;; Methods (when given needed super-methods, etc.):
#, ;; Attach srcloc (useful for profiling) #, ;; Attach srcloc (useful for profiling)
(quasisyntax/loc stx (quasisyntax/loc stx
(lambda (local-accessor (lambda (local-field-accessor ...
local-mutator local-field-mutator ...
inherit-field-accessor ... ; inherit inherit-field-accessor ... ; inherit
inherit-field-mutator ... inherit-field-mutator ...
rename-super-temp ... rename-super-extra-temp ... rename-super-temp ... rename-super-extra-temp ...
rename-inner-temp ... rename-inner-extra-temp ... rename-inner-temp ... rename-inner-extra-temp ...
method-accessor ...) ; for a local call that needs a dynamic lookup method-accessor ...) ; for a local call that needs a dynamic lookup
(let ([local-field-accessor (make-struct-field-accessor local-accessor local-field-pos #f)]
...
[local-field-mutator (make-struct-field-mutator local-mutator local-field-pos #f)]
...)
(syntax-parameterize (syntax-parameterize
([this-param (make-this-map (quote-syntax this-id) ([this-param (make-this-map (quote-syntax this-id)
(quote-syntax the-finder) (quote-syntax the-finder)
@ -1461,7 +1457,7 @@
(quote-syntax plain-init-name-localized))] ...) (quote-syntax plain-init-name-localized))] ...)
([(local-plain-init-name) undefined] ...) ([(local-plain-init-name) undefined] ...)
(void) ; in case the body is empty (void) ; in case the body is empty
. exprs))))))))))))) . exprs))))))))))))
;; Not primitive: ;; Not primitive:
#f)))))))))))))))) #f))))))))))))))))
@ -2160,7 +2156,12 @@
;; --- 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 ([(inh-accessors inh-mutators) (let-values ([(local-accessors local-mutators)
(values (for/list ([n (in-range num-fields)])
(make-struct-field-accessor object-field-ref n #f))
(for/list ([n (in-range num-fields)])
(make-struct-field-mutator object-field-set! n #f)))]
[(inh-accessors inh-mutators)
(values (map (lambda (id) (vector-ref int-field-refs (hash-ref field-ht id))) (values (map (lambda (id) (vector-ref int-field-refs (hash-ref field-ht id)))
inherit-field-names) inherit-field-names)
(map (lambda (id) (vector-ref int-field-sets (hash-ref field-ht id))) (map (lambda (id) (vector-ref int-field-sets (hash-ref field-ht id)))
@ -2260,9 +2261,9 @@
;; -- Get new methods and initializers -- ;; -- Get new methods and initializers --
(let-values ([(new-methods override-methods augride-methods init) (let-values ([(new-methods override-methods augride-methods init)
(apply make-methods (apply make-methods
object-field-ref (append local-accessors
object-field-set! local-mutators
(append inh-accessors inh-accessors
inh-mutators inh-mutators
rename-supers rename-supers
rename-inners rename-inners