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,347 +2849,402 @@ 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))
|
||||||
(λ (cls)
|
(define public-method-projections
|
||||||
(class/c-check-first-order ctc cls (λ args (apply raise-blame-error blame cls args)))
|
(for/list ([name (in-list ctc-methods)]
|
||||||
(let* ([name (class-name cls)]
|
[c (in-list (class/c-method-contracts ctc))])
|
||||||
[never-wrapped? (eq? (class-orig-cls cls) cls)]
|
(and c
|
||||||
;; Only add a new slot if we're not projecting an already contracted class.
|
((contract-projection c) (blame-add-method-context blame name)))))
|
||||||
[supers (if never-wrapped?
|
(define super-projections
|
||||||
(list->vector (append (vector->list (class-supers cls))
|
(for/list ([name (in-list (class/c-supers ctc))]
|
||||||
(list #f)))
|
[c (in-list (class/c-super-contracts ctc))])
|
||||||
(list->vector (vector->list (class-supers cls))))]
|
(and c
|
||||||
[pos (if never-wrapped?
|
((contract-projection c) (blame-add-method-context blame name)))))
|
||||||
(add1 (class-pos cls))
|
(define inner-projections
|
||||||
(class-pos cls))]
|
(for/list ([name (in-list (class/c-inners ctc))]
|
||||||
[method-width (class-method-width cls)]
|
[c (in-list (class/c-inner-contracts ctc))])
|
||||||
[method-ht (class-method-ht cls)]
|
(and c
|
||||||
[method-ictcs (class-method-ictcs cls)]
|
((contract-projection c) (blame-add-method-context bswap name)))))
|
||||||
[ctc-methods (class/c-methods ctc)]
|
|
||||||
[dynamic-features
|
(define internal-field-projections
|
||||||
(append (class/c-overrides ctc)
|
(for/list ([f (in-list (class/c-fields ctc))]
|
||||||
(class/c-augments ctc)
|
[c (in-list (class/c-field-contracts ctc))])
|
||||||
(class/c-augrides ctc)
|
(and c
|
||||||
(class/c-inherits ctc))]
|
(let ([p-pos ((contract-projection c) (blame-add-context blame (format "the ~a field in" f)))]
|
||||||
[dynamic-contracts
|
[p-neg ((contract-projection c) (blame-add-context bswap (format "the ~a field in" f)))])
|
||||||
(append (class/c-override-contracts ctc)
|
(cons p-pos p-neg)))))
|
||||||
(class/c-augment-contracts ctc)
|
(define external-field-projections
|
||||||
(class/c-augride-contracts ctc)
|
(for/list ([f (in-list (class/c-inherit-fields ctc))]
|
||||||
(class/c-inherit-contracts ctc))]
|
[c (in-list (class/c-inherit-field-contracts ctc))])
|
||||||
[methods (if (null? ctc-methods)
|
(and c
|
||||||
(class-methods cls)
|
(let ([p-pos ((contract-projection c) blame)]
|
||||||
(make-vector method-width))]
|
[p-neg ((contract-projection c) bswap)])
|
||||||
[super-methods (if (null? (class/c-supers ctc))
|
(cons p-pos p-neg)))))
|
||||||
(class-super-methods cls)
|
|
||||||
(make-vector method-width))]
|
(define override-projections
|
||||||
[int-methods (if (null? dynamic-features)
|
(for/list ([m (in-list (class/c-overrides ctc))]
|
||||||
(class-int-methods cls)
|
[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)]
|
||||||
|
[never-wrapped? (eq? (class-orig-cls cls) cls)]
|
||||||
|
;; Only add a new slot if we're not projecting an already contracted class.
|
||||||
|
[supers (if never-wrapped?
|
||||||
|
(list->vector (append (vector->list (class-supers cls))
|
||||||
|
(list #f)))
|
||||||
|
(list->vector (vector->list (class-supers cls))))]
|
||||||
|
[pos (if never-wrapped?
|
||||||
|
(add1 (class-pos cls))
|
||||||
|
(class-pos cls))]
|
||||||
|
[method-width (class-method-width cls)]
|
||||||
|
[method-ht (class-method-ht cls)]
|
||||||
|
[method-ictcs (class-method-ictcs cls)]
|
||||||
|
[methods (if (null? ctc-methods)
|
||||||
|
(class-methods cls)
|
||||||
|
(make-vector method-width))]
|
||||||
|
[super-methods (if (null? (class/c-supers ctc))
|
||||||
|
(class-super-methods cls)
|
||||||
(make-vector method-width))]
|
(make-vector method-width))]
|
||||||
[inner-projs (if (null? (class/c-inners ctc))
|
[int-methods (if (null? dynamic-features)
|
||||||
(class-inner-projs cls)
|
(class-int-methods cls)
|
||||||
|
(make-vector method-width))]
|
||||||
|
[inner-projs (if (null? (class/c-inners ctc))
|
||||||
|
(class-inner-projs cls)
|
||||||
|
(make-vector method-width))]
|
||||||
|
[dynamic-idxs (if (null? dynamic-features)
|
||||||
|
(class-dynamic-idxs cls)
|
||||||
|
(make-vector method-width))]
|
||||||
|
[dynamic-projs (if (null? dynamic-features)
|
||||||
|
(class-dynamic-projs cls)
|
||||||
(make-vector method-width))]
|
(make-vector method-width))]
|
||||||
[dynamic-idxs (if (null? dynamic-features)
|
[field-pub-width (class-field-pub-width cls)]
|
||||||
(class-dynamic-idxs cls)
|
[no-field-ctcs? (and (null? (class/c-fields ctc))
|
||||||
(make-vector method-width))]
|
(null? (class/c-inherit-fields ctc)))]
|
||||||
[dynamic-projs (if (null? dynamic-features)
|
[field-ht (if no-field-ctcs?
|
||||||
(class-dynamic-projs cls)
|
(class-field-ht cls)
|
||||||
(make-vector method-width))]
|
(hash-copy (class-field-ht cls)))]
|
||||||
[field-pub-width (class-field-pub-width cls)]
|
[init (class-init cls)]
|
||||||
[no-field-ctcs? (and (null? (class/c-fields ctc))
|
[class-make (if name
|
||||||
(null? (class/c-inherit-fields ctc)))]
|
(make-naming-constructor struct:class name "class")
|
||||||
[field-ht (if no-field-ctcs?
|
make-class)]
|
||||||
(class-field-ht cls)
|
[c (class-make name
|
||||||
(hash-copy (class-field-ht cls)))]
|
pos
|
||||||
[init (class-init cls)]
|
supers
|
||||||
[class-make (if name
|
(class-self-interface cls)
|
||||||
(make-naming-constructor struct:class name "class")
|
void ;; No inspecting
|
||||||
make-class)]
|
|
||||||
[c (class-make name
|
method-width
|
||||||
pos
|
method-ht
|
||||||
supers
|
(class-method-ids cls)
|
||||||
(class-self-interface cls)
|
(class-abstract-ids cls)
|
||||||
void ;; No inspecting
|
(remq* ctc-methods method-ictcs)
|
||||||
|
|
||||||
method-width
|
#f
|
||||||
method-ht
|
|
||||||
(class-method-ids cls)
|
methods
|
||||||
(class-abstract-ids cls)
|
super-methods
|
||||||
(remq* ctc-methods method-ictcs)
|
int-methods
|
||||||
|
(class-beta-methods cls)
|
||||||
#f
|
(class-meth-flags cls)
|
||||||
|
|
||||||
methods
|
inner-projs
|
||||||
super-methods
|
dynamic-idxs
|
||||||
int-methods
|
dynamic-projs
|
||||||
(class-beta-methods cls)
|
|
||||||
(class-meth-flags cls)
|
(class-field-width cls)
|
||||||
|
field-pub-width
|
||||||
inner-projs
|
field-ht
|
||||||
dynamic-idxs
|
(class-field-ids cls)
|
||||||
dynamic-projs
|
|
||||||
|
'struct:object 'object? 'make-object
|
||||||
(class-field-width cls)
|
'field-ref 'field-set!
|
||||||
field-pub-width
|
|
||||||
field-ht
|
;; class/c introduced subclasses do not consume init args
|
||||||
(class-field-ids cls)
|
null
|
||||||
|
'normal
|
||||||
'struct:object 'object? 'make-object
|
#f
|
||||||
'field-ref 'field-set!
|
|
||||||
|
(class-orig-cls cls)
|
||||||
;; class/c introduced subclasses do not consume init args
|
#f #f ; serializer is never set
|
||||||
null
|
#f)]
|
||||||
'normal
|
[obj-name (if name
|
||||||
#f
|
(string->symbol (format "object:~a" name))
|
||||||
|
'object)])
|
||||||
(class-orig-cls cls)
|
(define (make-method proc meth-name)
|
||||||
#f #f ; serializer is never set
|
(procedure-rename
|
||||||
#f)]
|
(procedure->method proc)
|
||||||
[obj-name (if name
|
(string->symbol
|
||||||
(string->symbol (format "object:~a" name))
|
(format "~a method~a~a"
|
||||||
'object)])
|
meth-name
|
||||||
(define (make-method proc meth-name)
|
(if name " in " "")
|
||||||
(procedure-rename
|
(or name "")))))
|
||||||
(procedure->method proc)
|
|
||||||
(string->symbol
|
(vector-set! supers pos c)
|
||||||
(format "~a method~a~a"
|
|
||||||
meth-name
|
;; --- Make the new object struct ---
|
||||||
(if name " in " "")
|
(let-values ([(struct:object object-make object? object-field-ref object-field-set!)
|
||||||
(or name "")))))
|
(make-struct-type obj-name
|
||||||
|
(class-struct:object cls)
|
||||||
(vector-set! supers pos c)
|
0 ;; No init fields
|
||||||
|
0 ;; No new fields in this class replacement
|
||||||
;; --- Make the new object struct ---
|
undefined
|
||||||
(let-values ([(struct:object object-make object? object-field-ref object-field-set!)
|
;; Map object property to class:
|
||||||
(make-struct-type obj-name
|
(list (cons prop:object c)))])
|
||||||
(class-struct:object cls)
|
(set-class-struct:object! c struct:object)
|
||||||
0 ;; No init fields
|
(set-class-object?! c object?)
|
||||||
0 ;; No new fields in this class replacement
|
(set-class-make-object! c object-make)
|
||||||
undefined
|
(set-class-field-ref! c object-field-ref)
|
||||||
;; Map object property to class:
|
(set-class-field-set!! c object-field-set!))
|
||||||
(list (cons prop:object c)))])
|
|
||||||
(set-class-struct:object! c struct:object)
|
;; Handle public method contracts
|
||||||
(set-class-object?! c object?)
|
(unless (null? ctc-methods)
|
||||||
(set-class-make-object! c object-make)
|
;; First, fill in from old methods
|
||||||
(set-class-field-ref! c object-field-ref)
|
(vector-copy! methods 0 (class-methods cls))
|
||||||
(set-class-field-set!! c object-field-set!))
|
;; Concretize any interface contracts handled by this ctc
|
||||||
|
(unless (null? (class-method-ictcs cls))
|
||||||
;; Handle public method contracts
|
(for ([m (in-list (class-method-ictcs cls))])
|
||||||
(unless (null? ctc-methods)
|
;; only concretize if class/c takes responsibility for it
|
||||||
;; First, fill in from old methods
|
(when (memq m ctc-methods)
|
||||||
(vector-copy! methods 0 (class-methods cls))
|
|
||||||
;; Concretize any interface contracts handled by this ctc
|
|
||||||
(unless (null? (class-method-ictcs cls))
|
|
||||||
(for ([m (in-list (class-method-ictcs cls))])
|
|
||||||
;; only concretize if class/c takes responsibility for it
|
|
||||||
(when (memq m ctc-methods)
|
|
||||||
(define i (hash-ref method-ht m))
|
|
||||||
(define entry (vector-ref methods i))
|
|
||||||
;; 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 m (car entry) info)))))
|
|
||||||
;; Now apply projections
|
|
||||||
(for ([m (in-list ctc-methods)]
|
|
||||||
[c (in-list (class/c-method-contracts ctc))])
|
|
||||||
(when c
|
|
||||||
(define i (hash-ref method-ht m))
|
(define i (hash-ref method-ht m))
|
||||||
(define mp (vector-ref methods i))
|
(define entry (vector-ref methods i))
|
||||||
(define p ((contract-projection c) (blame-add-method-context blame mp)))
|
;; we're passing through a contract boundary, so the positive blame (aka
|
||||||
(vector-set! methods i (make-method (p mp) m)))))
|
;; value server) is taking responsibility for any interface-contracted
|
||||||
|
;; methods)
|
||||||
;; Handle super contracts
|
(define info (replace-ictc-blame (cadr entry) #f (blame-positive blame)))
|
||||||
(unless (null? (class/c-supers ctc))
|
(vector-set! methods i (concretize-ictc-method m (car entry) info)))))
|
||||||
;; First, fill in from old (possibly contracted) super methods
|
;; Now apply projections
|
||||||
(vector-copy! super-methods 0 (class-super-methods cls))
|
(for ([m (in-list ctc-methods)]
|
||||||
;; Now apply projections.
|
[p (in-list public-method-projections)])
|
||||||
(for ([m (in-list (class/c-supers ctc))]
|
(when p
|
||||||
[c (in-list (class/c-super-contracts ctc))])
|
(define i (hash-ref method-ht m))
|
||||||
|
(define mp (vector-ref methods i))
|
||||||
|
(vector-set! methods i (make-method (p mp) m)))))
|
||||||
|
|
||||||
|
;; Handle super contracts
|
||||||
|
(unless (null? (class/c-supers ctc))
|
||||||
|
;; First, fill in from old (possibly contracted) super methods
|
||||||
|
(vector-copy! super-methods 0 (class-super-methods cls))
|
||||||
|
;; Now apply projections.
|
||||||
|
(for ([m (in-list (class/c-supers ctc))]
|
||||||
|
[p (in-list super-projections)])
|
||||||
|
(when p
|
||||||
|
(define i (hash-ref method-ht m))
|
||||||
|
(define mp (vector-ref super-methods i))
|
||||||
|
(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))]
|
||||||
|
[p (in-list inner-projections)])
|
||||||
|
(when p
|
||||||
|
(define i (hash-ref method-ht m))
|
||||||
|
(define old-proj (vector-ref inner-projs i))
|
||||||
|
(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))]
|
||||||
|
[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))]
|
||||||
|
[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.
|
||||||
|
(let ([old-idxs (class-dynamic-idxs (class-orig-cls cls))])
|
||||||
|
(unless (null? dynamic-features)
|
||||||
|
;; Go ahead and do all the copies here.
|
||||||
|
(vector-copy! dynamic-projs 0 (class-dynamic-projs cls))
|
||||||
|
(vector-copy! int-methods 0 (class-int-methods cls))
|
||||||
|
(vector-copy! dynamic-idxs 0 (class-dynamic-idxs cls))
|
||||||
|
(for ([m (in-list dynamic-features)]
|
||||||
|
[c (in-list dynamic-contracts)])
|
||||||
(when c
|
(when c
|
||||||
(define i (hash-ref method-ht m))
|
(let* ([i (hash-ref method-ht m)]
|
||||||
(define mp (vector-ref super-methods i))
|
[old-idx (vector-ref old-idxs i)]
|
||||||
(define p ((contract-projection c) (blame-add-method-context blame mp)))
|
[new-idx (vector-ref dynamic-idxs i)])
|
||||||
(vector-set! super-methods i (make-method (p mp) m)))))
|
;; We need to extend all the vectors, so let's do that here.
|
||||||
|
(when (= old-idx new-idx)
|
||||||
|
(let* ([new-idx (add1 old-idx)]
|
||||||
|
[new-proj-vec (make-vector (add1 new-idx))]
|
||||||
|
[old-proj-vec (vector-ref dynamic-projs i)]
|
||||||
|
[new-int-vec (make-vector (add1 new-idx))]
|
||||||
|
[old-int-vec (vector-ref int-methods i)])
|
||||||
|
(vector-set! dynamic-idxs i new-idx)
|
||||||
|
(vector-copy! new-proj-vec 0 old-proj-vec)
|
||||||
|
(vector-set! new-proj-vec new-idx identity)
|
||||||
|
(vector-set! dynamic-projs i new-proj-vec)
|
||||||
|
(vector-copy! new-int-vec 0 old-int-vec)
|
||||||
|
;; Just copy over the last entry here. We'll
|
||||||
|
;; update it appropriately later.
|
||||||
|
(vector-set! new-int-vec new-idx
|
||||||
|
(vector-ref old-int-vec old-idx))
|
||||||
|
(vector-set! int-methods i new-int-vec)))))))
|
||||||
|
|
||||||
;; Add inner projections
|
;; Now we handle updating override contracts... here we just
|
||||||
(unless (null? (class/c-inners ctc))
|
;; update the projections, and not the methods (which we must
|
||||||
(vector-copy! inner-projs 0 (class-inner-projs cls))
|
;; do during class composition).
|
||||||
(for ([m (in-list (class/c-inners ctc))]
|
(unless (null? (class/c-overrides ctc))
|
||||||
[c (in-list (class/c-inner-contracts ctc))])
|
(for ([m (in-list (class/c-overrides ctc))]
|
||||||
(when c
|
[p (in-list override-projections)])
|
||||||
(define i (hash-ref method-ht m))
|
(when p
|
||||||
(define old-proj (vector-ref inner-projs i))
|
(let* ([i (hash-ref method-ht m)]
|
||||||
(define p ((contract-projection c) (blame-add-method-context bswap old-proj)))
|
[old-idx (vector-ref old-idxs i)]
|
||||||
(vector-set! inner-projs i (λ (v) (old-proj (p v)))))))
|
[proj-vec (vector-ref dynamic-projs i)]
|
||||||
|
[old-proj (vector-ref proj-vec old-idx)])
|
||||||
|
(vector-set! proj-vec old-idx (λ (v) (old-proj (p v))))))))
|
||||||
|
|
||||||
;; Handle both internal and external field contracts
|
;; For augment and augride contracts, we both update the projection
|
||||||
(unless no-field-ctcs?
|
;; and go ahead and apply the projection to the last slot (which will
|
||||||
(for ([f (in-list (class/c-fields ctc))]
|
;; only be used by later classes).
|
||||||
[c (in-list (class/c-field-contracts ctc))])
|
(unless (and (null? (class/c-augments ctc))
|
||||||
(when c
|
(null? (class/c-augrides ctc)))
|
||||||
(let ([fi (hash-ref field-ht f)]
|
(for ([m (in-list (append (class/c-augments ctc)
|
||||||
[p-pos ((contract-projection c) (blame-add-context blame (format "the ~a field in" f)))]
|
(class/c-augrides ctc)))]
|
||||||
[p-neg ((contract-projection c) (blame-add-context bswap (format "the ~a field in" f)))])
|
[p (in-list augment/augride-projections)])
|
||||||
(hash-set! field-ht f (field-info-extend-external fi p-pos p-neg)))))
|
(when p
|
||||||
(for ([f (in-list (class/c-inherit-fields ctc))]
|
(let* ([i (hash-ref method-ht m)]
|
||||||
[c (in-list (class/c-inherit-field-contracts ctc))])
|
[old-idx (vector-ref old-idxs i)]
|
||||||
(when c
|
[new-idx (vector-ref dynamic-idxs i)]
|
||||||
(let ([fi (hash-ref field-ht f)]
|
[proj-vec (vector-ref dynamic-projs i)]
|
||||||
[p-pos ((contract-projection c) blame)]
|
[int-vec (vector-ref int-methods i)]
|
||||||
[p-neg ((contract-projection c) bswap)])
|
[old-proj (vector-ref proj-vec old-idx)])
|
||||||
(hash-set! field-ht f (field-info-extend-internal fi p-pos p-neg))))))
|
(vector-set! proj-vec old-idx (λ (v) (p (old-proj v))))
|
||||||
|
(vector-set! int-vec new-idx
|
||||||
|
(make-method (p (vector-ref int-vec new-idx)) m))))))
|
||||||
|
|
||||||
;; Now the trickiest of them all, internal dynamic dispatch.
|
;; Now (that things have been extended appropriately) we handle
|
||||||
;; First we update any dynamic indexes, as applicable.
|
;; inherits.
|
||||||
(let ([old-idxs (class-dynamic-idxs (class-orig-cls cls))])
|
(unless (null? (class/c-inherits ctc))
|
||||||
(unless (null? dynamic-features)
|
(for ([m (in-list (class/c-inherits ctc))]
|
||||||
;; Go ahead and do all the copies here.
|
[p (in-list inherit-projections)])
|
||||||
(vector-copy! dynamic-projs 0 (class-dynamic-projs cls))
|
(when p
|
||||||
(vector-copy! int-methods 0 (class-int-methods cls))
|
(let* ([i (hash-ref method-ht m)]
|
||||||
(vector-copy! dynamic-idxs 0 (class-dynamic-idxs cls))
|
[new-idx (vector-ref dynamic-idxs i)]
|
||||||
(for ([m (in-list dynamic-features)]
|
[int-vec (vector-ref int-methods i)])
|
||||||
[c (in-list dynamic-contracts)])
|
(vector-set! int-vec new-idx
|
||||||
(when c
|
(make-method (p (vector-ref int-vec new-idx)) m)))))))
|
||||||
(let* ([i (hash-ref method-ht m)]
|
|
||||||
[old-idx (vector-ref old-idxs i)]
|
;; Unlike the others, we always want to do this, even if there are no init contracts,
|
||||||
[new-idx (vector-ref dynamic-idxs i)])
|
;; since we still need to handle either calling the previous class/c's init or
|
||||||
;; We need to extend all the vectors, so let's do that here.
|
;; calling continue-make-super appropriately.
|
||||||
(when (= old-idx new-idx)
|
(let ()
|
||||||
(let* ([new-idx (add1 old-idx)]
|
;; grab all the inits+contracts that involve the same init arg
|
||||||
[new-proj-vec (make-vector (add1 new-idx))]
|
;; (assumes that inits and contracts were sorted in class/c creation)
|
||||||
[old-proj-vec (vector-ref dynamic-projs i)]
|
(define (grab-same-inits lst)
|
||||||
[new-int-vec (make-vector (add1 new-idx))]
|
(if (null? lst)
|
||||||
[old-int-vec (vector-ref int-methods i)])
|
(values null null)
|
||||||
(vector-set! dynamic-idxs i new-idx)
|
(let loop ([inits/c (cdr lst)]
|
||||||
(vector-copy! new-proj-vec 0 old-proj-vec)
|
[prefix (list (car lst))])
|
||||||
(vector-set! new-proj-vec new-idx identity)
|
(cond
|
||||||
(vector-set! dynamic-projs i new-proj-vec)
|
[(null? inits/c)
|
||||||
(vector-copy! new-int-vec 0 old-int-vec)
|
(values (reverse prefix) inits/c)]
|
||||||
;; Just copy over the last entry here. We'll
|
[(eq? (list-ref (car inits/c) 0) (list-ref (car prefix) 0))
|
||||||
;; update it appropriately later.
|
(loop (cdr inits/c)
|
||||||
(vector-set! new-int-vec new-idx
|
(cons (car inits/c) prefix))]
|
||||||
(vector-ref old-int-vec old-idx))
|
[else (values (reverse prefix) inits/c)]))))
|
||||||
(vector-set! int-methods i new-int-vec)))))))
|
;; run through the list of init-args and apply contracts for same-named
|
||||||
|
;; init args
|
||||||
;; Now we handle updating override contracts... here we just
|
(define (apply-contracts inits/c init-args)
|
||||||
;; update the projections, and not the methods (which we must
|
(let loop ([init-args init-args]
|
||||||
;; do during class composition).
|
[inits/c inits/c]
|
||||||
(unless (null? (class/c-overrides ctc))
|
[handled-args null])
|
||||||
(for ([m (in-list (class/c-overrides ctc))]
|
(cond
|
||||||
[c (in-list (class/c-override-contracts ctc))])
|
[(null? init-args)
|
||||||
(when c
|
(reverse handled-args)]
|
||||||
(let* ([i (hash-ref method-ht m)]
|
[(null? inits/c)
|
||||||
[p ((contract-projection c) (blame-add-method-context bswap i))]
|
(append (reverse handled-args) init-args)]
|
||||||
[old-idx (vector-ref old-idxs i)]
|
[(eq? (list-ref (car inits/c) 0) (car (car init-args)))
|
||||||
[proj-vec (vector-ref dynamic-projs i)]
|
(let ([init-arg (car init-args)]
|
||||||
[old-proj (vector-ref proj-vec old-idx)])
|
[p (list-ref (car inits/c) 1)])
|
||||||
(vector-set! proj-vec old-idx (λ (v) (old-proj (p v))))))))
|
(loop (cdr init-args)
|
||||||
|
(cdr inits/c)
|
||||||
;; For augment and augride contracts, we both update the projection
|
(cons (cons (car init-arg) (p (cdr init-arg)))
|
||||||
;; and go ahead and apply the projection to the last slot (which will
|
handled-args)))]
|
||||||
;; only be used by later classes).
|
[else (loop (cdr init-args)
|
||||||
(unless (and (null? (class/c-augments ctc))
|
inits/c
|
||||||
(null? (class/c-augrides ctc)))
|
(cons (car init-args) handled-args))])))
|
||||||
(for ([m (in-list (append (class/c-augments ctc)
|
(set-class-init!
|
||||||
(class/c-augrides ctc)))]
|
c
|
||||||
[c (in-list (append (class/c-augment-contracts ctc)
|
(lambda (the-obj super-go si_c si_inited? si_leftovers init-args)
|
||||||
(class/c-augride-contracts ctc)))])
|
(let ([init-args
|
||||||
(when c
|
(let loop ([inits/c inits+contracts]
|
||||||
(let* ([i (hash-ref method-ht m)]
|
[handled-args init-args])
|
||||||
[p ((contract-projection c) (blame-add-method-context blame i))]
|
(if (null? inits/c)
|
||||||
[old-idx (vector-ref old-idxs i)]
|
handled-args
|
||||||
[new-idx (vector-ref dynamic-idxs i)]
|
(let-values ([(prefix suffix) (grab-same-inits inits/c)])
|
||||||
[proj-vec (vector-ref dynamic-projs i)]
|
(loop suffix
|
||||||
[int-vec (vector-ref int-methods i)]
|
(apply-contracts prefix init-args)))))])
|
||||||
[old-proj (vector-ref proj-vec old-idx)])
|
;; Since we never consume init args, we can ignore si_leftovers
|
||||||
(vector-set! proj-vec old-idx (λ (v) (p (old-proj v))))
|
;; since init-args is the same.
|
||||||
(vector-set! int-vec new-idx
|
(if never-wrapped?
|
||||||
(make-method (p (vector-ref int-vec new-idx)) m))))))
|
(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))))))
|
||||||
;; Now (that things have been extended appropriately) we handle
|
|
||||||
;; inherits.
|
c))))
|
||||||
(unless (null? (class/c-inherits ctc))
|
|
||||||
(for ([m (in-list (class/c-inherits ctc))]
|
|
||||||
[c (in-list (class/c-inherit-contracts ctc))])
|
|
||||||
(when c
|
|
||||||
(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
|
|
||||||
(make-method (p (vector-ref int-vec new-idx)) m)))))))
|
|
||||||
|
|
||||||
;; Unlike the others, we always want to do this, even if there are no init contracts,
|
|
||||||
;; 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)
|
|
||||||
(if (null? lst)
|
|
||||||
(values null null)
|
|
||||||
(let loop ([inits/c (cdr lst)]
|
|
||||||
[prefix (list (car lst))])
|
|
||||||
(cond
|
|
||||||
[(null? inits/c)
|
|
||||||
(values (reverse prefix) inits/c)]
|
|
||||||
[(eq? (car (car inits/c)) (car (car prefix)))
|
|
||||||
(loop (cdr inits/c)
|
|
||||||
(cons (car inits/c) prefix))]
|
|
||||||
[else (values (reverse prefix) inits/c)]))))
|
|
||||||
;; run through the list of init-args and apply contracts for same-named
|
|
||||||
;; init args
|
|
||||||
(define (apply-contracts inits/c init-args)
|
|
||||||
(let loop ([init-args init-args]
|
|
||||||
[inits/c inits/c]
|
|
||||||
[handled-args null])
|
|
||||||
(cond
|
|
||||||
[(null? init-args)
|
|
||||||
(reverse handled-args)]
|
|
||||||
[(null? inits/c)
|
|
||||||
(append (reverse handled-args) init-args)]
|
|
||||||
[(eq? (car (car inits/c)) (car (car init-args)))
|
|
||||||
(let ([init-arg (car init-args)]
|
|
||||||
[p ((contract-projection (cdr (car inits/c))) bswap)])
|
|
||||||
(loop (cdr init-args)
|
|
||||||
(cdr inits/c)
|
|
||||||
(cons (cons (car init-arg) (p (cdr init-arg)))
|
|
||||||
handled-args)))]
|
|
||||||
[else (loop (cdr init-args)
|
|
||||||
inits/c
|
|
||||||
(cons (car init-args) handled-args))])))
|
|
||||||
(set-class-init!
|
|
||||||
c
|
|
||||||
(lambda (the-obj super-go si_c si_inited? si_leftovers init-args)
|
|
||||||
(let ([init-args
|
|
||||||
(let loop ([inits/c inits+contracts]
|
|
||||||
[handled-args init-args])
|
|
||||||
(if (null? inits/c)
|
|
||||||
handled-args
|
|
||||||
(let-values ([(prefix suffix) (grab-same-inits inits/c)])
|
|
||||||
(loop suffix
|
|
||||||
(apply-contracts prefix init-args)))))])
|
|
||||||
;; Since we never consume init args, we can ignore si_leftovers
|
|
||||||
;; since init-args is the same.
|
|
||||||
(if never-wrapped?
|
|
||||||
(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)))))
|
|
||||||
|
|
||||||
(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")]))
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user