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

adjust class/c to compute projections once, instead of once per

Browse Source 
use of the resulting contract
This commit is contained in:
Robby Findler 2013-02-04 07:12:25 -06:00
parent 44e91ea961
commit 042ec40a7b
1 changed files with 380 additions and 325 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2849,8 +2849,76 @@ An example
#t) #t)
(define (class/c-proj ctc) (define (class/c-proj ctc)
(define ctc-methods (class/c-methods ctc))
(define dynamic-features
(append (class/c-overrides ctc)
(class/c-augments ctc)
(class/c-augrides ctc)
(class/c-inherits ctc)))
(define dynamic-contracts
(append (class/c-override-contracts ctc)
(class/c-augment-contracts ctc)
(class/c-augride-contracts ctc)
(class/c-inherit-contracts ctc)))
(λ (blame) (λ (blame)
(let ([bswap (blame-swap blame)]) (define bswap (blame-swap blame))
(define public-method-projections
(for/list ([name (in-list ctc-methods)]
[c (in-list (class/c-method-contracts ctc))])
(and c
((contract-projection c) (blame-add-method-context blame name)))))
(define super-projections
(for/list ([name (in-list (class/c-supers ctc))]
[c (in-list (class/c-super-contracts ctc))])
(and c
((contract-projection c) (blame-add-method-context blame name)))))
(define inner-projections
(for/list ([name (in-list (class/c-inners ctc))]
[c (in-list (class/c-inner-contracts ctc))])
(and c
((contract-projection c) (blame-add-method-context bswap name)))))
(define internal-field-projections
(for/list ([f (in-list (class/c-fields ctc))]
[c (in-list (class/c-field-contracts ctc))])
(and c
(let ([p-pos ((contract-projection c) (blame-add-context blame (format "the ~a field in" f)))]
[p-neg ((contract-projection c) (blame-add-context bswap (format "the ~a field in" f)))])
(cons p-pos p-neg)))))
(define external-field-projections
(for/list ([f (in-list (class/c-inherit-fields ctc))]
[c (in-list (class/c-inherit-field-contracts ctc))])
(and c
(let ([p-pos ((contract-projection c) blame)]
[p-neg ((contract-projection c) bswap)])
(cons p-pos p-neg)))))
(define override-projections
(for/list ([m (in-list (class/c-overrides ctc))]
[c (in-list (class/c-override-contracts ctc))])
(and c
((contract-projection c) (blame-add-method-context bswap m)))))
(define augment/augride-projections
(for/list ([m (in-list (append (class/c-augments ctc)
(class/c-augrides ctc)))]
[c (in-list (append (class/c-augment-contracts ctc)
(class/c-augride-contracts ctc)))])
(and c
((contract-projection c) (blame-add-method-context blame m)))))
(define inherit-projections
(for/list ([m (in-list (class/c-inherits ctc))]
[c (in-list (class/c-inherit-contracts ctc))])
(and c
((contract-projection c) (blame-add-method-context blame m)))))
;; zip the inits and contracts together for ordered selection
(define inits+contracts
(for/list ([init (in-list (class/c-inits ctc))]
[ctc (in-list (class/c-init-contracts ctc))])
(list init ((contract-projection ctc) bswap))))
(λ (cls) (λ (cls)
(class/c-check-first-order ctc cls (λ args (apply raise-blame-error blame cls args))) (class/c-check-first-order ctc cls (λ args (apply raise-blame-error blame cls args)))
(let* ([name (class-name cls)] (let* ([name (class-name cls)]
@ -2866,17 +2934,6 @@ An example
[method-width (class-method-width cls)] [method-width (class-method-width cls)]
[method-ht (class-method-ht cls)] [method-ht (class-method-ht cls)]
[method-ictcs (class-method-ictcs cls)] [method-ictcs (class-method-ictcs cls)]
[ctc-methods (class/c-methods ctc)]
[dynamic-features
(append (class/c-overrides ctc)
(class/c-augments ctc)
(class/c-augrides ctc)
(class/c-inherits ctc))]
[dynamic-contracts
(append (class/c-override-contracts ctc)
(class/c-augment-contracts ctc)
(class/c-augride-contracts ctc)
(class/c-inherit-contracts ctc))]
[methods (if (null? ctc-methods) [methods (if (null? ctc-methods)
(class-methods cls) (class-methods cls)
(make-vector method-width))] (make-vector method-width))]
@ -2992,11 +3049,10 @@ An example
(vector-set! methods i (concretize-ictc-method m (car entry) info))))) (vector-set! methods i (concretize-ictc-method m (car entry) info)))))
;; Now apply projections ;; Now apply projections
(for ([m (in-list ctc-methods)] (for ([m (in-list ctc-methods)]
[c (in-list (class/c-method-contracts ctc))]) [p (in-list public-method-projections)])
(when c (when p
(define i (hash-ref method-ht m)) (define i (hash-ref method-ht m))
(define mp (vector-ref methods i)) (define mp (vector-ref methods i))
(define p ((contract-projection c) (blame-add-method-context blame mp)))
(vector-set! methods i (make-method (p mp) m))))) (vector-set! methods i (make-method (p mp) m)))))
;; Handle super contracts ;; Handle super contracts
@ -3005,40 +3061,38 @@ An example
(vector-copy! super-methods 0 (class-super-methods cls)) (vector-copy! super-methods 0 (class-super-methods cls))
;; Now apply projections. ;; Now apply projections.
(for ([m (in-list (class/c-supers ctc))] (for ([m (in-list (class/c-supers ctc))]
[c (in-list (class/c-super-contracts ctc))]) [p (in-list super-projections)])
(when c (when p
(define i (hash-ref method-ht m)) (define i (hash-ref method-ht m))
(define mp (vector-ref super-methods i)) (define mp (vector-ref super-methods i))
(define p ((contract-projection c) (blame-add-method-context blame mp)))
(vector-set! super-methods i (make-method (p mp) m))))) (vector-set! super-methods i (make-method (p mp) m)))))
;; Add inner projections ;; Add inner projections
(unless (null? (class/c-inners ctc)) (unless (null? (class/c-inners ctc))
(vector-copy! inner-projs 0 (class-inner-projs cls)) (vector-copy! inner-projs 0 (class-inner-projs cls))
(for ([m (in-list (class/c-inners ctc))] (for ([m (in-list (class/c-inners ctc))]
[c (in-list (class/c-inner-contracts ctc))]) [p (in-list inner-projections)])
(when c (when p
(define i (hash-ref method-ht m)) (define i (hash-ref method-ht m))
(define old-proj (vector-ref inner-projs i)) (define old-proj (vector-ref inner-projs i))
(define p ((contract-projection c) (blame-add-method-context bswap old-proj)))
(vector-set! inner-projs i (λ (v) (old-proj (p v))))))) (vector-set! inner-projs i (λ (v) (old-proj (p v)))))))
;; Handle both internal and external field contracts ;; Handle both internal and external field contracts
(unless no-field-ctcs? (unless no-field-ctcs?
(for ([f (in-list (class/c-fields ctc))] (for ([f (in-list (class/c-fields ctc))]
[c (in-list (class/c-field-contracts ctc))]) [p-pr (in-list internal-field-projections)])
(when c (when p-pr
(let ([fi (hash-ref field-ht f)] (define fi (hash-ref field-ht f))
[p-pos ((contract-projection c) (blame-add-context blame (format "the ~a field in" f)))] (define p-pos (car p-pr))
[p-neg ((contract-projection c) (blame-add-context bswap (format "the ~a field in" f)))]) (define p-neg (cdr p-pr))
(hash-set! field-ht f (field-info-extend-external fi p-pos p-neg))))) (hash-set! field-ht f (field-info-extend-external fi p-pos p-neg))))
(for ([f (in-list (class/c-inherit-fields ctc))] (for ([f (in-list (class/c-inherit-fields ctc))]
[c (in-list (class/c-inherit-field-contracts ctc))]) [p-pr (in-list external-field-projections)])
(when c (when p-pr
(let ([fi (hash-ref field-ht f)] (define fi (hash-ref field-ht f))
[p-pos ((contract-projection c) blame)] (define p-pos (car p-pr))
[p-neg ((contract-projection c) bswap)]) (define p-neg (cdr p-pr))
(hash-set! field-ht f (field-info-extend-internal fi p-pos p-neg)))))) (hash-set! field-ht f (field-info-extend-internal fi p-pos p-neg)))))
;; Now the trickiest of them all, internal dynamic dispatch. ;; Now the trickiest of them all, internal dynamic dispatch.
;; First we update any dynamic indexes, as applicable. ;; First we update any dynamic indexes, as applicable.
@ -3077,10 +3131,9 @@ An example
;; do during class composition). ;; do during class composition).
(unless (null? (class/c-overrides ctc)) (unless (null? (class/c-overrides ctc))
(for ([m (in-list (class/c-overrides ctc))] (for ([m (in-list (class/c-overrides ctc))]
[c (in-list (class/c-override-contracts ctc))]) [p (in-list override-projections)])
(when c (when p
(let* ([i (hash-ref method-ht m)] (let* ([i (hash-ref method-ht m)]
[p ((contract-projection c) (blame-add-method-context bswap i))]
[old-idx (vector-ref old-idxs i)] [old-idx (vector-ref old-idxs i)]
[proj-vec (vector-ref dynamic-projs i)] [proj-vec (vector-ref dynamic-projs i)]
[old-proj (vector-ref proj-vec old-idx)]) [old-proj (vector-ref proj-vec old-idx)])
@ -3093,11 +3146,9 @@ An example
(null? (class/c-augrides ctc))) (null? (class/c-augrides ctc)))
(for ([m (in-list (append (class/c-augments ctc) (for ([m (in-list (append (class/c-augments ctc)
(class/c-augrides ctc)))] (class/c-augrides ctc)))]
[c (in-list (append (class/c-augment-contracts ctc) [p (in-list augment/augride-projections)])
(class/c-augride-contracts ctc)))]) (when p
(when c
(let* ([i (hash-ref method-ht m)] (let* ([i (hash-ref method-ht m)]
[p ((contract-projection c) (blame-add-method-context blame i))]
[old-idx (vector-ref old-idxs i)] [old-idx (vector-ref old-idxs i)]
[new-idx (vector-ref dynamic-idxs i)] [new-idx (vector-ref dynamic-idxs i)]
[proj-vec (vector-ref dynamic-projs i)] [proj-vec (vector-ref dynamic-projs i)]
@ -3111,10 +3162,9 @@ An example
;; inherits. ;; inherits.
(unless (null? (class/c-inherits ctc)) (unless (null? (class/c-inherits ctc))
(for ([m (in-list (class/c-inherits ctc))] (for ([m (in-list (class/c-inherits ctc))]
[c (in-list (class/c-inherit-contracts ctc))]) [p (in-list inherit-projections)])
(when c (when p
(let* ([i (hash-ref method-ht m)] (let* ([i (hash-ref method-ht m)]
[p ((contract-projection c) (blame-add-method-context blame i))]
[new-idx (vector-ref dynamic-idxs i)] [new-idx (vector-ref dynamic-idxs i)]
[int-vec (vector-ref int-methods i)]) [int-vec (vector-ref int-methods i)])
(vector-set! int-vec new-idx (vector-set! int-vec new-idx
@ -3124,8 +3174,6 @@ An example
;; since we still need to handle either calling the previous class/c's init or ;; since we still need to handle either calling the previous class/c's init or
;; calling continue-make-super appropriately. ;; calling continue-make-super appropriately.
(let () (let ()
;; zip the inits and contracts together for ordered selection
(define inits+contracts (map cons (class/c-inits ctc) (class/c-init-contracts ctc)))
;; grab all the inits+contracts that involve the same init arg ;; grab all the inits+contracts that involve the same init arg
;; (assumes that inits and contracts were sorted in class/c creation) ;; (assumes that inits and contracts were sorted in class/c creation)
(define (grab-same-inits lst) (define (grab-same-inits lst)
@ -3136,7 +3184,7 @@ An example
(cond (cond
[(null? inits/c) [(null? inits/c)
(values (reverse prefix) inits/c)] (values (reverse prefix) inits/c)]
[(eq? (car (car inits/c)) (car (car prefix))) [(eq? (list-ref (car inits/c) 0) (list-ref (car prefix) 0))
(loop (cdr inits/c) (loop (cdr inits/c)
(cons (car inits/c) prefix))] (cons (car inits/c) prefix))]
[else (values (reverse prefix) inits/c)])))) [else (values (reverse prefix) inits/c)]))))
@ -3151,9 +3199,9 @@ An example
(reverse handled-args)] (reverse handled-args)]
[(null? inits/c) [(null? inits/c)
(append (reverse handled-args) init-args)] (append (reverse handled-args) init-args)]
[(eq? (car (car inits/c)) (car (car init-args))) [(eq? (list-ref (car inits/c) 0) (car (car init-args)))
(let ([init-arg (car init-args)] (let ([init-arg (car init-args)]
[p ((contract-projection (cdr (car inits/c))) bswap)]) [p (list-ref (car inits/c) 1)])
(loop (cdr init-args) (loop (cdr init-args)
(cdr inits/c) (cdr inits/c)
(cons (cons (car init-arg) (p (cdr init-arg))) (cons (cons (car init-arg) (p (cdr init-arg)))
@ -3178,18 +3226,25 @@ An example
(super-go the-obj si_c si_inited? init-args null null) (super-go the-obj si_c si_inited? init-args null null)
(init the-obj super-go si_c si_inited? init-args init-args)))))) (init the-obj super-go si_c si_inited? init-args init-args))))))
c))))) c))))
(define (blame-add-method-context blame method-proc) (define (blame-add-method-context blame thing)
(define name (object-name method-proc))
(cond (cond
[name [(and (procedure? thing)
(object-name thing))
(define name (object-name thing))
;; the procedure name of a method has ' method in ...' in it; trim that away ;; the procedure name of a method has ' method in ...' in it; trim that away
(define method-name (regexp-replace #rx" method in .*%.?$" (symbol->string name) "")) (define method-name (regexp-replace #rx" method in .*%.?$" (symbol->string name) ""))
(blame-add-context blame (blame-add-context blame
(format "the ~a method in" method-name) (format "the ~a method in" method-name)
#:important #:important
name)] name)]
[(symbol? thing)
;; the procedure name of a method has ' method in ...' in it; trim that away
(blame-add-context blame
(format "the ~a method in" thing)
#:important
thing)]
[else [else
(blame-add-context blame "an unnamed method in")])) (blame-add-context blame "an unnamed method in")]))