adjust class/c to compute projections once, instead of once per
use of the resulting contract
This commit is contained in:
Robby Findler
parent
44e91ea961
commit
042ec40a7b
|
|
@ -2849,8 +2849,76 @@ An example
|
|||
#t)
|
||||
|
||||
(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)
|
||||
(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)
|
||||
(class/c-check-first-order ctc cls (λ args (apply raise-blame-error blame cls args)))
|
||||
(let* ([name (class-name cls)]
|
||||
|
|
@ -2866,17 +2934,6 @@ An example
|
|||
[method-width (class-method-width cls)]
|
||||
[method-ht (class-method-ht 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)
|
||||
(class-methods cls)
|
||||
(make-vector method-width))]
|
||||
|
|
@ -2992,11 +3049,10 @@ An example
|
|||
(vector-set! methods i (concretize-ictc-method m (car entry) info)))))
|
||||
;; Now apply projections
|
||||
(for ([m (in-list ctc-methods)]
|
||||
[c (in-list (class/c-method-contracts ctc))])
|
||||
(when c
|
||||
[p (in-list public-method-projections)])
|
||||
(when p
|
||||
(define i (hash-ref method-ht m))
|
||||
(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)))))
|
||||
|
||||
;; Handle super contracts
|
||||
|
|
@ -3005,40 +3061,38 @@ An example
|
|||
(vector-copy! super-methods 0 (class-super-methods cls))
|
||||
;; Now apply projections.
|
||||
(for ([m (in-list (class/c-supers ctc))]
|
||||
[c (in-list (class/c-super-contracts ctc))])
|
||||
(when c
|
||||
[p (in-list super-projections)])
|
||||
(when p
|
||||
(define i (hash-ref method-ht m))
|
||||
(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)))))
|
||||
|
||||
;; Add inner projections
|
||||
(unless (null? (class/c-inners ctc))
|
||||
(vector-copy! inner-projs 0 (class-inner-projs cls))
|
||||
(for ([m (in-list (class/c-inners ctc))]
|
||||
[c (in-list (class/c-inner-contracts ctc))])
|
||||
(when c
|
||||
[p (in-list inner-projections)])
|
||||
(when p
|
||||
(define i (hash-ref method-ht m))
|
||||
(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)))))))
|
||||
|
||||
;; Handle both internal and external field contracts
|
||||
(unless no-field-ctcs?
|
||||
(for ([f (in-list (class/c-fields ctc))]
|
||||
[c (in-list (class/c-field-contracts ctc))])
|
||||
(when c
|
||||
(let ([fi (hash-ref field-ht f)]
|
||||
[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)))])
|
||||
(hash-set! field-ht f (field-info-extend-external fi p-pos p-neg)))))
|
||||
[p-pr (in-list internal-field-projections)])
|
||||
(when p-pr
|
||||
(define fi (hash-ref field-ht f))
|
||||
(define p-pos (car p-pr))
|
||||
(define p-neg (cdr p-pr))
|
||||
(hash-set! field-ht f (field-info-extend-external fi p-pos p-neg))))
|
||||
(for ([f (in-list (class/c-inherit-fields ctc))]
|
||||
[c (in-list (class/c-inherit-field-contracts ctc))])
|
||||
(when c
|
||||
(let ([fi (hash-ref field-ht f)]
|
||||
[p-pos ((contract-projection c) blame)]
|
||||
[p-neg ((contract-projection c) bswap)])
|
||||
(hash-set! field-ht f (field-info-extend-internal fi p-pos p-neg))))))
|
||||
[p-pr (in-list external-field-projections)])
|
||||
(when p-pr
|
||||
(define fi (hash-ref field-ht f))
|
||||
(define p-pos (car p-pr))
|
||||
(define p-neg (cdr p-pr))
|
||||
(hash-set! field-ht f (field-info-extend-internal fi p-pos p-neg)))))
|
||||
|
||||
;; Now the trickiest of them all, internal dynamic dispatch.
|
||||
;; First we update any dynamic indexes, as applicable.
|
||||
|
|
@ -3077,10 +3131,9 @@ An example
|
|||
;; do during class composition).
|
||||
(unless (null? (class/c-overrides ctc))
|
||||
(for ([m (in-list (class/c-overrides ctc))]
|
||||
[c (in-list (class/c-override-contracts ctc))])
|
||||
(when c
|
||||
[p (in-list override-projections)])
|
||||
(when p
|
||||
(let* ([i (hash-ref method-ht m)]
|
||||
[p ((contract-projection c) (blame-add-method-context bswap i))]
|
||||
[old-idx (vector-ref old-idxs i)]
|
||||
[proj-vec (vector-ref dynamic-projs i)]
|
||||
[old-proj (vector-ref proj-vec old-idx)])
|
||||
|
|
@ -3093,11 +3146,9 @@ An example
|
|||
(null? (class/c-augrides ctc)))
|
||||
(for ([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)))])
|
||||
(when c
|
||||
[p (in-list augment/augride-projections)])
|
||||
(when p
|
||||
(let* ([i (hash-ref method-ht m)]
|
||||
[p ((contract-projection c) (blame-add-method-context blame i))]
|
||||
[old-idx (vector-ref old-idxs i)]
|
||||
[new-idx (vector-ref dynamic-idxs i)]
|
||||
[proj-vec (vector-ref dynamic-projs i)]
|
||||
|
|
@ -3111,10 +3162,9 @@ An example
|
|||
;; inherits.
|
||||
(unless (null? (class/c-inherits ctc))
|
||||
(for ([m (in-list (class/c-inherits ctc))]
|
||||
[c (in-list (class/c-inherit-contracts ctc))])
|
||||
(when c
|
||||
[p (in-list inherit-projections)])
|
||||
(when p
|
||||
(let* ([i (hash-ref method-ht m)]
|
||||
[p ((contract-projection c) (blame-add-method-context blame i))]
|
||||
[new-idx (vector-ref dynamic-idxs i)]
|
||||
[int-vec (vector-ref int-methods i)])
|
||||
(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
|
||||
;; calling continue-make-super appropriately.
|
||||
(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
|
||||
;; (assumes that inits and contracts were sorted in class/c creation)
|
||||
(define (grab-same-inits lst)
|
||||
|
|
@ -3136,7 +3184,7 @@ An example
|
|||
(cond
|
||||
[(null? 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)
|
||||
(cons (car inits/c) prefix))]
|
||||
[else (values (reverse prefix) inits/c)]))))
|
||||
|
|
@ -3151,9 +3199,9 @@ An example
|
|||
(reverse handled-args)]
|
||||
[(null? inits/c)
|
||||
(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)]
|
||||
[p ((contract-projection (cdr (car inits/c))) bswap)])
|
||||
[p (list-ref (car inits/c) 1)])
|
||||
(loop (cdr init-args)
|
||||
(cdr inits/c)
|
||||
(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)
|
||||
(init the-obj super-go si_c si_inited? init-args init-args))))))
|
||||
|
||||
c)))))
|
||||
c))))
|
||||
|
||||
(define (blame-add-method-context blame method-proc)
|
||||
(define name (object-name method-proc))
|
||||
(define (blame-add-method-context blame thing)
|
||||
(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
|
||||
(define method-name (regexp-replace #rx" method in .*%.?$" (symbol->string name) ""))
|
||||
(blame-add-context blame
|
||||
(format "the ~a method in" method-name)
|
||||
#:important
|
||||
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
|
||||
(blame-add-context blame "an unnamed method in")]))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user