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

Change object-contract to use find-method/who (already exported for Typed

Browse Source 
Scheme) to look for the appropriate method to wrap, which makes Robby's
object-contracts appropriately translucent during contract wrapping.

svn: r18102
This commit is contained in:
Stevie Strickland 2010-02-16 19:58:07 +00:00
parent 520b4feedc
commit 35afebaea3
3 changed files with 48 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
collects/scheme/contract/private/object.ss
View File

@ -72,20 +72,18 @@
(unless (object? val)
(raise-blame-error blame val "expected an object, got ~e" val))
(let ([objs-mtds (interface->method-names (object-interface val))]
[vtable (extract-vtable val)]
[method-ht (extract-method-ht val)])
(for-each (λ (m proj)
(let ([index (hash-ref method-ht m #f)])
(unless index
(raise-blame-error blame val "expected an object with method ~s" m))
;; verify the first-order properties by apply the projection and
;; throwing the result away. Without this, the contract wrappers
;; just check the first-order properties of the wrappers, which is
;; the wrong thing.
(proj (vector-ref vtable index))))
meth-names
meth-projs))
(for-each (λ (m proj)
(let-values ([(method unwrapper)
(find-method/who 'object-contract val m #:error? #f)])
(unless method
(raise-blame-error blame val "expected an object with method ~s" m))
;; verify the first-order properties by apply the projection and
;; throwing the result away. Without this, the contract wrappers
;; just check the first-order properties of the wrappers, which is
;; the wrong thing.
(proj method)))
meth-names
meth-projs)
(let ([fields (field-names val)])
(for-each (λ (f)

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

@ -2944,10 +2944,12 @@
;; -> (values method-proc object)
;; returns the method's procedure and a function to unwrap `this' in the case
;; that this is a wrapper object that is just "falling thru".
(define (find-method/who who in-object name)
(define (find-method/who who in-object name #:error? [error? #t])
(unless (object? in-object)
(obj-error who "target is not an object: ~e for method: ~a"
in-object name))
(if error?
(obj-error who "target is not an object: ~e for method: ~a"
in-object name)
(values #f values)))
(let-syntax ([loop-body
(lambda (stx)
@ -2961,9 +2963,11 @@
[pos (values (vector-ref (class-methods c) pos) abs-object)]
[(wrapper-object? abs-object) wrapper-case]
[else
(obj-error who "no such method: ~a~a"
name
(for-class (class-name c)))])))]))])
(if error?
(obj-error who "no such method: ~a~a"
name
(for-class (class-name c)))
(values #f values))])))]))])
(loop-body
in-object
(let loop ([loop-object in-object])
@ -3677,12 +3681,6 @@
cls)))
; extract-vtable : object -> (vectorof method-proc[this args ... -> res])
(define (extract-vtable o) (class-methods (object-ref o)))
; extract-method-ht : object -> hash-table[sym -> number]
(define (extract-method-ht o) (class-method-ht (object-ref o)))
;;--------------------------------------------------------------------
;; misc utils
;;--------------------------------------------------------------------
@ -3871,8 +3869,6 @@
;; Providing normal functionality:
(provide (protect-out make-wrapper-class
wrapper-object-wrapped
extract-vtable
extract-method-ht
get-field/proc)
(rename-out [_class class]) class* class/derived

26
collects/tests/mzscheme/contract-test.ss
View File

@ -3959,6 +3959,32 @@
(λ (x) x))
1)
(test/spec-passed/result
'object-contract-layered1
'(send (contract (object-contract (m (-> number? number?)))
(contract (object-contract)
(new (class object% (super-new) (define/public (m x) x)))
'pos
'neg)
'pos
'neg)
m
5)
5)
;; Make sure we're not dropping projections on the floor.
(test/neg-blame
'object-contract-layered2
'(send (contract (object-contract (m (-> number? number?)))
(contract (object-contract (m (-> string? string?)))
(new (class object% (super-new) (define/public (m x) x)))
'pos
'neg)
'pos
'neg)
m
5))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; test error message has right format