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

Small fixes.

Browse Source 
* Use #f instead of (lambda () #f) in hash-ref call
 * We want the positive blame, not negative, when interface-contracted
   methods are passing through a class/c application.
 * Use (interface <i>) and (class <c>) for interface and class blame.
This commit is contained in:
Stevie Strickland 2012-05-03 00:36:34 -04:00
parent ba8e879703
commit 14da5dacc5
2 changed files with 13 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2427,7 +2427,8 @@
final-names)
;; Handle interface contracted methods:
(for-each (lambda (id)
(let ([index (hash-ref method-ht id)])
(let ([index (hash-ref method-ht id)]
[blame `(class ,name)])
;; Store blame information that will be instantiated later
(define ictc-infos (get-interface-contract-info
(class-self-interface c) id))
@ -2438,7 +2439,7 @@
(vector-set! methods index
(list meth
;; Replace #f positive parties w/ this class
(replace-ictc-blame ictc-infos #t name)))))
(replace-ictc-blame ictc-infos #t blame)))))
(class-method-ictcs c))
;; --- Install serialize info into class --
@ -2573,7 +2574,7 @@ An example
(λ (i1 i2) (eq? (car i1) (car i2)))))))))
(define our-ctc (hash-ref (interface-contracts ifc) meth #f))
(define our-ctcs (hash-keys (interface-contracts ifc)))
(define our-name (interface-name ifc))
(define our-name `(interface ,(interface-name ifc)))
(cond ;; if we don't have the contract, the parent's info is fine
[(not our-ctc) dedup-infos]
;; if the parent's don't contract it, then it's just our ctc
@ -2877,7 +2878,10 @@ An example
(for ([m (in-list (class-method-ictcs cls))])
(define i (hash-ref method-ht m))
(define entry (vector-ref methods i))
(define info (replace-ictc-blame (cadr entry) #f (blame-negative blame)))
;; we're passing through a contract boundary, so the positive blame (aka
;; value server) is taking responsibility for any interface-contracted
;; methods)
(define info (replace-ictc-blame (cadr entry) #f (blame-positive blame)))
(vector-set! methods i (concretize-ictc-method (car entry) info))))
;; Now apply projections
(for ([m (in-list (class/c-methods ctc))]
@ -3783,7 +3787,7 @@ An example
;; takes a class and concretize interface ctc methods
(define (fetch-concrete-class cls blame)
(cond [(null? (class-method-ictcs cls)) cls]
[(hash-ref (class-ictc-classes cls) blame (λ () #f)) => values]
[(hash-ref (class-ictc-classes cls) blame #f) => values]
[else
;; if there are contracted methods to concretize, do so
(let* ([name (class-name cls)]

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

@ -8489,7 +8489,7 @@
'(let* ([i<%> (interface () [m (->m number? number?)])]
[c% (class* object% (i<%>) (super-new) (define/public (m) x))])
(new c%))
"c%")
"(class c%)")
(test/spec-passed
'interface-higher-order-1
@ -8509,7 +8509,7 @@
'(let* ([i<%> (interface () [m (->m number? number?)])]
[c% (class* object% (i<%>) (super-new) (define/public (m x) "bad"))])
(send (new c%) m 3))
"c%")
"(class c%)")
(test/spec-failed
'interface-higher-order-4
@ -8517,7 +8517,7 @@
[i2<%> (interface (i1<%>) [m (->m integer? integer?)])]
[c% (class* object% (i2<%>) (super-new) (define/public (m x) x))])
(send (new c%) m 3.14))
"i1<%>")
"(interface i1<%>)")
(test/spec-failed
'interface-higher-order-5
@ -8525,7 +8525,7 @@
[i2<%> (interface (i1<%>) [m (->m integer? integer?)])]
[c% (class* object% (i2<%>) (super-new) (define/public (m x) 3.14))])
(send (new c%) m 3))
"c%")
"(class c%)")
;
;