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

inner default expr shouldn't evaluate when a target is available

Browse Source 
svn: r3094
This commit is contained in:
Matthew Flatt 2006-05-28 11:49:41 +00:00
parent e8239629f2
commit 9877a98a00
3 changed files with 25 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/mzlib/private/class-internal.ss
View File

@ -1877,12 +1877,10 @@
augment-names) augment-names)
(map (lambda (mname index) (map (lambda (mname index)
(let ([depth (get-depth index)]) (let ([depth (get-depth index)])
(lambda (obj default) (lambda (obj)
(let* ([rename-inner (vector-ref (vector-ref (class-beta-methods (object-ref obj)) (vector-ref (vector-ref (class-beta-methods (object-ref obj))
index) index)
depth)]) depth))))
(or rename-inner
(lambda args default))))))
rename-inner-names rename-inner-names
rename-inner-indices))]) rename-inner-indices))])
;; -- Create method accessors -- ;; -- Create method accessors --

7
collects/mzlib/private/classidmap.ss
View File

@ -1,6 +1,5 @@
(module classidmap mzscheme (module classidmap mzscheme
(require (lib "stx.ss" "syntax")) (require (lib "stx.ss" "syntax"))
(define-values (struct:s!t make-s!t s!t? s!t-ref s!t-set!) (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)]) (let ([target (find the-finder the-obj stx)])
(datum->syntax-object (datum->syntax-object
the-finder the-finder
(make-method-apply (list (find the-finder rename-temp stx) target default-expr) `(let ([i (,(find the-finder rename-temp stx) ,target)])
target args) (if i
,(make-method-apply 'i target args)
,default-expr))
stx)) stx))
stx)) stx))

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

@ -500,6 +500,23 @@
(test '(9 (13 (15 (6 (3 24))))) 'bjt (send (new bjjbjfoo-jbjjbgoo%) goo 24)) (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)) (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% (define rest-arg-fish%