From 74addc1b715580899493571fc7f0df65e8ecdffd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 8 Sep 2008 14:41:56 +0000 Subject: [PATCH] fix checking of augment on a method that is overridable but was formerly augmentable svn: r11574 --- collects/scheme/private/class-internal.ss | 66 +++++++++++++++-------- collects/tests/mzscheme/object.ss | 39 +++++++++----- 2 files changed, 71 insertions(+), 34 deletions(-) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index 38265b0ffa..bf4b21bf5b 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -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)]) diff --git a/collects/tests/mzscheme/object.ss b/collects/tests/mzscheme/object.ss index 840abe6685..4fe2ff01b4 100644 --- a/collects/tests/mzscheme/object.ss +++ b/collects/tests/mzscheme/object.ss @@ -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))))