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

Make class/c and interface contracts cooperate

Browse Source 
- also fixed a problem with subclassing, though I'm not
   sure it's quite correct yet
This commit is contained in:
Asumu Takikawa 2012-04-28 00:45:45 -04:00 committed by Stevie Strickland
parent 670154bd2b
commit 10967a22ce
1 changed files with 26 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2428,9 +2428,13 @@
;; Store blame information that will be instantiated later ;; Store blame information that will be instantiated later
(define ictc-infos (get-interface-contract-info (define ictc-infos (get-interface-contract-info
(class-self-interface c) id)) (class-self-interface c) id))
(define meth-entry (vector-ref methods index))
(define meth (if (pair? meth-entry)
(car meth-entry)
meth-entry))
(vector-set! methods index (vector-set! methods index
(list (vector-ref methods index) (list meth
;; Make positive parties this class ;; Replace #f positive parties w/ this class
(replace-ictc-blame ictc-infos #t name))))) (replace-ictc-blame ictc-infos #t name)))))
(class-method-ictcs c)) (class-method-ictcs c))
@ -2802,7 +2806,7 @@ An example
method-width method-width
method-ht method-ht
(class-method-ids cls) (class-method-ids cls)
(class-method-ictcs cls) null
methods methods
super-methods super-methods
@ -2863,6 +2867,13 @@ An example
(unless (null? (class/c-methods ctc)) (unless (null? (class/c-methods ctc))
;; First, fill in from old methods ;; First, fill in from old methods
(vector-copy! methods 0 (class-methods cls)) (vector-copy! methods 0 (class-methods cls))
;; Concretize any interface contracts first
(unless (null? (class-method-ictcs cls))
(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)))
(vector-set! methods i (concretize-ictc-method (car entry) info))))
;; Now apply projections ;; Now apply projections
(for ([m (in-list (class/c-methods ctc))] (for ([m (in-list (class/c-methods ctc))]
[c (in-list (class/c-method-contracts ctc))]) [c (in-list (class/c-method-contracts ctc))])
@ -3844,17 +3855,20 @@ An example
(define entry (vector-ref meths index)) (define entry (vector-ref meths index))
(define meth (car entry)) (define meth (car entry))
(define ictc-infos (replace-ictc-blame (cadr entry) #f blame)) (define ictc-infos (replace-ictc-blame (cadr entry) #f blame))
(define wrapped-meth (define wrapped-meth (concretize-ictc-method meth ictc-infos))
(for/fold ([meth meth])
([info ictc-infos])
(define ctc (car info))
(define ifc-name (cadr info))
(define pos-blame (caddr info))
(define neg-blame (cadddr info))
(contract ctc meth pos-blame neg-blame)))
(vector-set! meths index wrapped-meth)) (vector-set! meths index wrapped-meth))
c))) c)))
;; method info -> method
;; appropriately wraps the method with interface contracts
(define (concretize-ictc-method meth info)
(for/fold ([meth meth])
([info (in-list info)])
(define ctc (car info))
(define pos-blame (caddr info))
(define neg-blame (cadddr info))
(contract ctc meth pos-blame neg-blame)))
(define (do-make-object blame class by-pos-args named-args) (define (do-make-object blame class by-pos-args named-args)
(unless (class? class) (unless (class? class)
(raise-type-error 'instantiate "class" class)) (raise-type-error 'instantiate "class" class))