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

Start inner projections work. Next, test cases, then I'll fix the test

Browse Source 
cases by implementing the rest.

svn: r18174
This commit is contained in:
Stevie Strickland 2010-02-18 23:54:56 +00:00
parent da7473b867
commit 2b92ea9225
1 changed files with 20 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1773,6 +1773,8 @@
; 'final => final ; 'final => final
; 'augmentable => can augment ; 'augmentable => can augment
inner-projs ; vector of projections for the last inner slot
field-width ; total number of fields field-width ; total number of fields
field-ht ; maps public field names to (cons class pos) field-ht ; maps public field names to (cons class pos)
field-ids ; list of public field names field-ids ; list of public field names
@ -2045,6 +2047,9 @@
[beta-methods (if no-method-changes? [beta-methods (if no-method-changes?
(class-beta-methods super) (class-beta-methods super)
(make-vector method-width))] (make-vector method-width))]
[inner-projs (if no-method-changes?
(class-inner-projs super)
(make-vector method-width))]
[meth-flags (if no-method-changes? [meth-flags (if no-method-changes?
(class-meth-flags super) (class-meth-flags super)
(make-vector method-width))] (make-vector method-width))]
@ -2056,6 +2061,7 @@
make-) make-)
method-width method-ht method-names method-width method-ht method-names
methods super-methods int-methods beta-methods meth-flags methods super-methods int-methods beta-methods meth-flags
inner-projs
field-width field-ht field-names field-width field-ht field-names
'struct:object 'object? 'make-object 'field-ref 'field-set! 'struct:object 'object? 'make-object 'field-ref 'field-set!
init-args init-args
@ -2229,13 +2235,15 @@
(vector-set! super-methods index (vector-ref (class-super-methods super) index)) (vector-set! super-methods index (vector-ref (class-super-methods super) index))
(vector-set! int-methods index (vector-ref (class-int-methods super) index)) (vector-set! int-methods index (vector-ref (class-int-methods super) index))
(vector-set! beta-methods index (vector-ref (class-beta-methods super) index)) (vector-set! beta-methods index (vector-ref (class-beta-methods super) index))
(vector-set! meth-flags index (vector-ref (class-meth-flags super) index))))) (vector-set! meth-flags index (vector-ref (class-meth-flags super) index))
(vector-set! inner-projs index (vector-ref (class-inner-projs super) index)))))
;; Add new methods: ;; Add new methods:
(for-each (lambda (index method) (for-each (lambda (index method)
(vector-set! methods index method) (vector-set! methods index method)
(vector-set! super-methods index method) (vector-set! super-methods index method)
(vector-set! int-methods index method) (vector-set! int-methods index method)
(vector-set! beta-methods index (vector))) (vector-set! beta-methods index (vector))
(vector-set! inner-projs index values))
(append new-augonly-indices new-final-indices new-normal-indices) (append new-augonly-indices new-final-indices new-normal-indices)
new-methods) new-methods)
;; Override old methods: ;; Override old methods:
@ -2253,7 +2261,9 @@
(vector-set! int-methods index method)) (vector-set! int-methods index method))
;; Under final mode - set extended vtable entry ;; Under final mode - set extended vtable entry
(let ([v (list->vector (vector->list v))]) (let ([v (list->vector (vector->list v))])
(vector-set! v (sub1 (vector-length v)) method) (vector-set! v (sub1 (vector-length v))
;; Apply current inner contract projection
((vector-ref inner-projs index) method))
(vector-set! beta-methods index v)))) (vector-set! beta-methods index v))))
(when (not (vector-ref meth-flags index)) (when (not (vector-ref meth-flags index))
(vector-set! meth-flags index (not make-struct:prim)))) (vector-set! meth-flags index (not make-struct:prim))))
@ -2275,6 +2285,8 @@
(let ([index (hash-ref method-ht id)]) (let ([index (hash-ref method-ht id)])
(let ([v (list->vector (append (vector->list (vector-ref beta-methods index)) (let ([v (list->vector (append (vector->list (vector-ref beta-methods index))
(list #f)))]) (list #f)))])
;; Since this starts a new part of the chain, reset the projection.
(vector-set! inner-projs index values)
(vector-set! beta-methods index v)))) (vector-set! beta-methods index v))))
augonly-names) augonly-names)
;; Mark final methods: ;; Mark final methods:
@ -2480,6 +2492,8 @@
(class-beta-methods cls) (class-beta-methods cls)
(class-meth-flags cls) (class-meth-flags cls)
(class-inner-projs cls)
(class-field-width cls) (class-field-width cls)
(class-field-ht cls) (class-field-ht cls)
(class-field-ids cls) (class-field-ids cls)
@ -2942,6 +2956,8 @@
0 (make-hasheq) null 0 (make-hasheq) null
(vector) (vector) (vector) (vector) (vector) (vector) (vector) (vector) (vector) (vector)
(vector)
0 (make-hasheq) null 0 (make-hasheq) null
'struct:object object? 'make-object 'struct:object object? 'make-object
@ -3982,6 +3998,7 @@
methods-vec methods-vec
(list->vector (map (lambda (x) 'final) method-ids)) (list->vector (map (lambda (x) 'final) method-ids))
'dont-use-me! 'dont-use-me!
(make-vector method-count values)
(if old-style? (if old-style?
(+ field-count method-count 1) (+ field-count method-count 1)