diff --git a/collects/mzlib/private/class-internal.ss b/collects/mzlib/private/class-internal.ss index 62f47f7027..9a251a9de7 100644 --- a/collects/mzlib/private/class-internal.ss +++ b/collects/mzlib/private/class-internal.ss @@ -1877,12 +1877,10 @@ augment-names) (map (lambda (mname index) (let ([depth (get-depth index)]) - (lambda (obj default) - (let* ([rename-inner (vector-ref (vector-ref (class-beta-methods (object-ref obj)) - index) - depth)]) - (or rename-inner - (lambda args default)))))) + (lambda (obj) + (vector-ref (vector-ref (class-beta-methods (object-ref obj)) + index) + depth)))) rename-inner-names rename-inner-indices))]) ;; -- Create method accessors -- diff --git a/collects/mzlib/private/classidmap.ss b/collects/mzlib/private/classidmap.ss index 186e57232e..e62334964f 100644 --- a/collects/mzlib/private/classidmap.ss +++ b/collects/mzlib/private/classidmap.ss @@ -1,6 +1,5 @@ (module classidmap mzscheme - (require (lib "stx.ss" "syntax")) (define-values (struct:s!t make-s!t s!t? s!t-ref s!t-set!) @@ -207,8 +206,10 @@ (let ([target (find the-finder the-obj stx)]) (datum->syntax-object the-finder - (make-method-apply (list (find the-finder rename-temp stx) target default-expr) - target args) + `(let ([i (,(find the-finder rename-temp stx) ,target)]) + (if i + ,(make-method-apply 'i target args) + ,default-expr)) stx)) stx)) diff --git a/collects/tests/mzscheme/object.ss b/collects/tests/mzscheme/object.ss index 033fa530a2..05db5381d0 100644 --- a/collects/tests/mzscheme/object.ss +++ b/collects/tests/mzscheme/object.ss @@ -500,6 +500,23 @@ (test '(9 (13 (15 (6 (3 24))))) 'bjt (send (new bjjbjfoo-jbjjbgoo%) goo 24)) (test '(14 (12 (8 (10 (20 (7 25)))))) 'bjt (send (new bjjbjfoo-jbjjbgoo%) hoo 25)) +;; ---------------------------------------- +;; Make sure inner default isn't called when augment is available: + +(let ([x 0]) + (define c% (class object% + (define/pubment (m v) + (inner (set! x (+ x v)) m v)) + (super-new))) + (define d% (class c% + (define/augment (m v) + (list v)) + (super-new))) + (test (void) 'no-inner (send (new c%) m 5)) + (test 5 values x) + (test '(6) 'inner (send (new d%) m 6)) + (test 5 values x)) + ;; ---------------------------------------- (define rest-arg-fish%