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

fix object/c's blame context manipulations

Browse Source 
Specifically,
- add field and method contexts, and
- declare methods in object/c contracts to be #:important

closes PR 13765
This commit is contained in:
Robby Findler 2013-05-20 22:15:39 -05:00
parent 797f7f7bd2
commit d1fb3e2c17
2 changed files with 45 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
collects/racket/private/class-internal.rkt
View File

@ -4984,19 +4984,21 @@ An example
[c (in-list method-contracts)]) [c (in-list method-contracts)])
(when c (when c
(let ([i (hash-ref method-ht m)] (let ([i (hash-ref method-ht m)]
[p ((contract-projection c) blame)]) [p ((contract-projection c) (blame-add-context blame (format "the ~a method in" m)
#:important m))])
(vector-set! meths i (make-method (p (vector-ref meths i)) m)))))) (vector-set! meths i (make-method (p (vector-ref meths i)) m))))))
;; Handle external field contracts ;; Handle external field contracts
(unless (null? fields) (unless (null? fields)
(let ([bset (blame-swap blame)]) (for ([f (in-list fields)]
(for ([f (in-list fields)] [c (in-list field-contracts)])
[c (in-list field-contracts)]) (when c
(when c (define fld-context (format "the ~a field in" f))
(let ([fi (hash-ref field-ht f)] (define bset (blame-add-context blame fld-context #:swap? #t))
[p-pos ((contract-projection c) blame)] (let ([fi (hash-ref field-ht f)]
[p-neg ((contract-projection c) bset)]) [p-pos ((contract-projection c) (blame-add-context blame fld-context))]
(hash-set! field-ht f (field-info-extend-external fi p-pos p-neg))))))) [p-neg ((contract-projection c) bset)])
(hash-set! field-ht f (field-info-extend-external fi p-pos p-neg))))))
c)) c))
@ -5007,7 +5009,9 @@ An example
(define (make-wrapper-object ctc obj blame methods method-contracts fields field-contracts) (define (make-wrapper-object ctc obj blame methods method-contracts fields field-contracts)
(check-object-contract obj methods fields (λ args (apply raise-blame-error blame obj args))) (check-object-contract obj methods fields (λ args (apply raise-blame-error blame obj args)))
(let ([original-obj (if (has-original-object? obj) (original-object obj) obj)] (let ([original-obj (if (has-original-object? obj) (original-object obj) obj)]
[new-cls (make-wrapper-class (object-ref obj) blame methods method-contracts fields field-contracts)]) [new-cls (make-wrapper-class (object-ref obj)
blame
methods method-contracts fields field-contracts)])
(impersonate-struct obj object-ref (λ (o c) new-cls) (impersonate-struct obj object-ref (λ (o c) new-cls)
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:original-object original-obj))) impersonator-prop:original-object original-obj)))

31
collects/tests/racket/contract-test.rktl
View File

@ -13826,6 +13826,37 @@ so that propagation occurs.
'pos 'neg) 'pos 'neg)
#f)) #f))
(context-test '("the 1st argument of" "the save-file method in")
'(send (contract (object/c
(save-file (->m string? string?)))
(new (class object%
(define/public (save-file s . args) #f)
(super-new)))
'pos
'neg)
save-file 1))
(context-test '("the f field in")
'(get-field
f
(contract (object/c (field [f string?]))
(new (class object%
(field [f 1])
(super-new)))
'pos
'neg)))
(context-test '("the 1st argument of" "the f field in")
'((get-field
f
(contract (object/c (field [f (-> string? any)]))
(new (class object%
(field [f (λ (x) 1)])
(super-new)))
'pos
'neg))
#f))
(let* ([blame-pos (contract-eval '(make-blame (srcloc #f #f #f #f #f) #f (λ () 'integer?) 'positive 'negative #t))] (let* ([blame-pos (contract-eval '(make-blame (srcloc #f #f #f #f #f) #f (λ () 'integer?) 'positive 'negative #t))]
[blame-neg (contract-eval `(blame-swap ,blame-pos))]) [blame-neg (contract-eval `(blame-swap ,blame-pos))])