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

fix checking of augment on a method that is overridable but was formerly augmentable

Browse Source 
svn: r11574
This commit is contained in:
Matthew Flatt 2008-09-08 14:41:56 +00:00
parent cc243ce220
commit 74addc1b71
2 changed files with 71 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1726,6 +1726,7 @@
beta-methods ; vector of vector of methods
meth-flags ; vector: #f => primitive-implemented
; 'final => final
; 'augmentable => can augment
field-width ; total number of fields
field-ht ; maps public field names to (cons class pos)
@ -1835,7 +1836,8 @@
[no-new-methods? (null? public-names)]
[no-method-changes? (and (null? public-names)
(null? override-names)
(null? augride-names))]
(null? augride-names)
(null? overment-names))]
[no-new-fields? (null? public-field-names)]
[xappend (lambda (a b) (if (null? b) a (append a b)))])
@ -2017,6 +2019,7 @@
[dispatcher (lambda (obj n)
;; Extract method:
(vector-ref (class-methods (object-ref obj)) n))])
(setup-all-implemented! i)
(vector-set! (class-supers c) (add1 (class-pos super)) c)
@ -2077,7 +2080,7 @@
(hash-set! field-ht (car ids) (cons c pos))
(loop (cdr ids) (add1 pos))))
;; -- Extract superclass methods and make rename-inners ---
;; -- Extract superclass methods and make rename-inners ---
(let ([rename-supers (map (lambda (index mname)
(let ([vec (vector-ref (class-beta-methods super) index)])
(if (positive? (vector-length vec))
@ -2095,7 +2098,7 @@
(define (get-depth index)
(+ (if (index . < . (class-method-width super))
(vector-length (vector-ref (class-beta-methods super)
index))
index))
0)
(if (vector-ref new-augonly index) 0 -1)))
;; To compute `rename-inner' indices, we need to know which methods
@ -2103,21 +2106,32 @@
(for-each (lambda (id)
(vector-set! new-augonly (hash-ref method-ht id) #t))
(append pubment-names overment-names))
(for-each (lambda (mname index)
(let ([depth (get-depth index)])
(when (negative? depth)
(obj-error 'class*
(string-append
"superclass method for augride, augment, inherit/inner, "
"or rename-inner method is not augmentable: ~a~a")
mname
(for-class name)))))
(append augride-normal-names
augment-final-names
rename-inner-names)
(append (get-indices method-ht "augride" augride-normal-names)
refine-final-indices
rename-inner-indices))
(let ([check-aug
(lambda (maybe-here?)
(lambda (mname index)
(let ([aug-ok?
(or (if (index . < . (class-method-width super))
(eq? (vector-ref (class-meth-flags super) index) 'augmentable)
#f)
(and maybe-here?
(or (memq mname pubment-names)
(memq mname overment-names))))])
(unless aug-ok?
(obj-error 'class*
(string-append
"superclass method for augride, augment, inherit/inner, "
"or rename-inner method is not augmentable: ~a~a")
mname
(for-class name))))))])
(for-each (check-aug #f)
augride-normal-names
(get-indices method-ht "augride" augride-normal-names))
(for-each (check-aug #f)
augment-final-names
refine-final-indices)
(for-each (check-aug #t)
rename-inner-names
rename-inner-indices))
;; Now that checking is done, add `augment':
(for-each (lambda (id)
(vector-set! new-augonly (hash-ref method-ht id) #t))
@ -2157,14 +2171,14 @@
(lambda (name index)
(vector-set! methods index (vector-ref (class-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)))))
;; Add new methods:
(vector-set! meth-flags index (vector-ref (class-meth-flags super) index)))))
;; Add new methods:
(for-each (lambda (index method)
(vector-set! methods index method)
(vector-set! beta-methods index (vector)))
(append new-augonly-indices new-final-indices new-normal-indices)
new-methods)
;; Override old methods:
;; Override old methods:
(for-each (lambda (index method id)
(when (eq? 'final (vector-ref meth-flags index))
(obj-error 'class*
@ -2184,7 +2198,15 @@
refine-augonly-indices refine-final-indices refine-normal-indices)
(append override-methods augride-methods)
(append override-names augride-names))
;; Expand `rename-inner' vector, adding a #f to indicate that
;; Update 'augmentable flags:
(unless no-method-changes?
(for-each (lambda (id)
(vector-set! meth-flags (hash-ref method-ht id) 'augmentable))
(append overment-names pubment-names))
(for-each (lambda (id)
(vector-set! meth-flags (hash-ref method-ht id) #t))
augride-names))
;; Expand `rename-inner' vector, adding a #f to indicate that
;; no rename-inner function is available, so far
(for-each (lambda (id)
(let ([index (hash-ref method-ht id)])

39
collects/tests/mzscheme/object.ss
View File

@ -100,6 +100,17 @@
(define (x) 1)
(define (y) 2)))
(define to-override2-class%
(class to-augment-class%
(augride x y)
(define (x) 1)
(define (y) 1)))
(define to-augment2-class%
(class to-override-class%
(overment x y)
(define (x) 1)
(define (y) 1)))
(define (test-method basic? public object% over? aug? super-ok? inner-ok? over-ok? aug-ok?)
(when basic?
(teval #`(test #t class? (class #,object% (#,public))))
@ -168,19 +179,23 @@
(test-method #t #'public #'object% #f #f #f #f #f #f)
(test-method #t #'public-final #'object% #f #f #f #f #f #f)
(test-method #t #'pubment #'object% #f #f #f #t #f #f)
(test-method #t #'override #'to-override-class% #t #f #t #f #t #f)
(test-method #f #'override #'to-augment-class% #t #f #t #f #f #t)
(test-method #t #'override-final #'to-override-class% #t #f #t #f #t #f)
(test-method #f #'override-final #'to-augment-class% #t #f #t #f #f #t)
(test-method #t #'overment #'to-override-class% #t #f #t #t #t #f)
(test-method #f #'overment #'to-augment-class% #t #f #t #t #f #t)
(test-method #t #'augment #'to-override-class% #f #t #f #t #t #f)
(test-method #f #'augment #'to-augment-class% #f #t #f #t #f #t)
(test-method #t #'augment-final #'to-override-class% #f #t #f #f #t #f)
(test-method #f #'augment-final #'to-augment-class% #f #t #f #f #f #t)
(test-method #t #'augride #'to-override-class% #f #t #f #f #t #f)
(test-method #f #'augride #'to-augment-class% #f #t #f #f #f #t)
(test-method #t #'private #'object% #f #f #f #f #f #f)
(define (test-over/aug to-override-class% to-augment-class%)
(test-method #t #'override to-override-class% #t #f #t #f #t #f)
(test-method #f #'override to-augment-class% #t #f #t #f #f #t)
(test-method #t #'override-final to-override-class% #t #f #t #f #t #f)
(test-method #f #'override-final to-augment-class% #t #f #t #f #f #t)
(test-method #t #'overment to-override-class% #t #f #t #t #t #f)
(test-method #f #'overment to-augment-class% #t #f #t #t #f #t)
(test-method #t #'augment to-override-class% #f #t #f #t #t #f)
(test-method #f #'augment to-augment-class% #f #t #f #t #f #t)
(test-method #t #'augment-final to-override-class% #f #t #f #f #t #f)
(test-method #f #'augment-final to-augment-class% #f #t #f #f #f #t)
(test-method #t #'augride to-override-class% #f #t #f #f #t #f)
(test-method #f #'augride to-augment-class% #f #t #f #f #f #t))
(test-over/aug #'to-override-class% #'to-augment-class%)
(test-over/aug #'to-override2-class% #'to-augment2-class%)
(define (test-rename rename object%)
(teval #`(test #t class? (class #,object% (#,rename))))