Re-enable Values and cgen/seq, and fix contracts on substitute.
After longer testing confirmed that this was just to strict contracts on substitute.
This commit is contained in:
parent
6be845ff30
commit
f42a7b9fc9
|
@ -440,66 +440,9 @@
|
||||||
(cgen/filter-set V X Y f-s f-t)
|
(cgen/filter-set V X Y f-s f-t)
|
||||||
(cgen/object V X Y o-s o-t))]
|
(cgen/object V X Y o-s o-t))]
|
||||||
|
|
||||||
;; values are covariant
|
|
||||||
[((Values: ss) (Values: ts))
|
|
||||||
#:return-unless (= (length ss) (length ts))
|
|
||||||
#f
|
|
||||||
(cgen/list V X Y ss ts)]
|
|
||||||
|
|
||||||
;; this constrains `dbound' to be |ts| - |ss|
|
|
||||||
[((ValuesDots: ss s-dty dbound) (Values: ts))
|
|
||||||
#:return-unless (>= (length ts) (length ss)) #f
|
|
||||||
#:return-unless (memq dbound Y) #f
|
|
||||||
|
|
||||||
(let* ([vars (var-store-take dbound s-dty (- (length ts) (length ss)))]
|
|
||||||
;; new-tys are dummy plain type variables,
|
|
||||||
;; standing in for the elements of dbound that need to be generated
|
|
||||||
[new-tys (for/list ([var (in-list vars)])
|
|
||||||
;; must be a Result since we are matching these against
|
|
||||||
;; the contents of the `Values`, which are Results
|
|
||||||
(-result (substitute (make-F var) dbound s-dty)))]
|
|
||||||
;; generate constraints on the prefixes, and on the dummy types
|
|
||||||
[new-cset (cgen/list V (append vars X) Y (append ss new-tys) ts)])
|
|
||||||
;; now take all the dummy types, and use them to constrain dbound appropriately
|
|
||||||
(% move-vars-to-dmap new-cset dbound vars))]
|
|
||||||
|
|
||||||
;; like the case above, but constrains `dbound' to be |ss| - |ts|
|
|
||||||
[((Values: ss) (ValuesDots: ts t-dty dbound))
|
|
||||||
#:return-unless (>= (length ss) (length ts)) #f
|
|
||||||
#:return-unless (memq dbound Y) #f
|
|
||||||
|
|
||||||
;; see comments for last case, this case swaps `s` and `t` order
|
|
||||||
(let* ([vars (var-store-take dbound t-dty (- (length ss) (length ts)))]
|
|
||||||
[new-tys (for/list ([var (in-list vars)])
|
|
||||||
(-result (substitute (make-F var) dbound t-dty)))]
|
|
||||||
[new-cset (cgen/list V (append vars X) Y ss (append ts new-tys))])
|
|
||||||
(% move-vars-to-dmap new-cset dbound vars))]
|
|
||||||
|
|
||||||
;; identical bounds - just unify pairwise
|
|
||||||
[((ValuesDots: ss s-dty dbound) (ValuesDots: ts t-dty dbound))
|
|
||||||
#:return-when (memq dbound Y) #f
|
|
||||||
(cgen/list V X Y (cons s-dty ss) (cons t-dty ts))]
|
|
||||||
[((ValuesDots: ss s-dty (? (λ (db) (memq db Y)) s-dbound))
|
|
||||||
(ValuesDots: ts t-dty t-dbound))
|
|
||||||
;; What should we do if both are in Y?
|
|
||||||
#:return-when (memq t-dbound Y) #f
|
|
||||||
(% cset-meet
|
|
||||||
(cgen/list V X Y ss ts)
|
|
||||||
(extend-tvars (list t-dbound)
|
|
||||||
(% move-dotted-rest-to-dmap (cgen V (cons s-dbound X) Y s-dty t-dty) s-dbound t-dbound)))]
|
|
||||||
[((ValuesDots: ss s-dty s-dbound)
|
|
||||||
(ValuesDots: ts t-dty (? (λ (db) (memq db Y)) t-dbound)))
|
|
||||||
;; s-dbound can't be in Y, due to previous rule
|
|
||||||
(% cset-meet
|
|
||||||
(cgen/list V X Y ss ts)
|
|
||||||
(extend-tvars (list s-dbound)
|
|
||||||
(% move-dotted-rest-to-dmap (cgen V (cons t-dbound X) Y s-dty t-dty) t-dbound s-dbound)))]
|
|
||||||
|
|
||||||
;; Values just delegate to cgen/seq
|
;; Values just delegate to cgen/seq
|
||||||
;; This is currently buggy because cgen/seq assumes types and not results
|
[((ValuesSeq: s-seq) (ValuesSeq: t-seq))
|
||||||
|
(cgen/seq V X Y s-seq t-seq)]
|
||||||
;; [((ValuesSeq: s-seq) (ValuesSeq: t-seq))
|
|
||||||
;; (cgen/seq V X Y s-seq t-seq)]
|
|
||||||
|
|
||||||
;; they're subtypes. easy.
|
;; they're subtypes. easy.
|
||||||
[(a b)
|
[(a b)
|
||||||
|
|
|
@ -39,8 +39,7 @@
|
||||||
|
|
||||||
;; substitute-many : Hash[Name,Type] Type -> Type
|
;; substitute-many : Hash[Name,Type] Type -> Type
|
||||||
(define/cond-contract (substitute-many subst target #:Un [Un (lambda (args) (apply Un args))])
|
(define/cond-contract (substitute-many subst target #:Un [Un (lambda (args) (apply Un args))])
|
||||||
((simple-substitution/c (or/c SomeValues/c Values/c arr?)) (#:Un procedure?)
|
((simple-substitution/c Type?) (#:Un procedure?) . ->* . Type?)
|
||||||
. ->* . (or/c SomeValues/c Values/c arr?))
|
|
||||||
(define (sb t) (substitute-many subst t #:Un Un))
|
(define (sb t) (substitute-many subst t #:Un Un))
|
||||||
(define names (hash-keys subst))
|
(define names (hash-keys subst))
|
||||||
(define fvs (free-vars* target))
|
(define fvs (free-vars* target))
|
||||||
|
@ -83,14 +82,13 @@
|
||||||
|
|
||||||
;; substitute : Type Name Type -> Type
|
;; substitute : Type Name Type -> Type
|
||||||
(define/cond-contract (substitute image name target #:Un [Un (lambda (args) (apply Un args))])
|
(define/cond-contract (substitute image name target #:Un [Un (lambda (args) (apply Un args))])
|
||||||
((Type/c symbol? Type/c) (#:Un procedure?) . ->* . Type/c)
|
((Type/c symbol? Type?) (#:Un procedure?) . ->* . Type?)
|
||||||
(substitute-many (hash name image) target #:Un Un))
|
(substitute-many (hash name image) target #:Un Un))
|
||||||
|
|
||||||
;; implements angle bracket substitution from the formalism
|
;; implements angle bracket substitution from the formalism
|
||||||
;; substitute-dots : Listof[Type] Option[type] Name Type -> Type
|
;; substitute-dots : Listof[Type] Option[type] Name Type -> Type
|
||||||
(define/cond-contract (substitute-dots images rimage name target)
|
(define/cond-contract (substitute-dots images rimage name target)
|
||||||
((listof Type/c) (or/c #f Type/c) symbol? (or/c arr? SomeValues/c Values/c)
|
((listof Type/c) (or/c #f Type/c) symbol? Type? . -> . Type?)
|
||||||
. -> . (or/c arr? SomeValues/c Values/c))
|
|
||||||
(define (sb t) (substitute-dots images rimage name t))
|
(define (sb t) (substitute-dots images rimage name t))
|
||||||
(if (or (set-member? (free-vars-names (free-idxs* target)) name)
|
(if (or (set-member? (free-vars-names (free-idxs* target)) name)
|
||||||
(set-member? (free-vars-names (free-vars* target)) name))
|
(set-member? (free-vars-names (free-vars* target)) name))
|
||||||
|
@ -172,7 +170,7 @@
|
||||||
;; substitute many variables
|
;; substitute many variables
|
||||||
;; subst-all : substitution/c Type -> Type
|
;; subst-all : substitution/c Type -> Type
|
||||||
(define/cond-contract (subst-all s ty)
|
(define/cond-contract (subst-all s ty)
|
||||||
(substitution/c (or/c arr? Values/c SomeValues/c) . -> . (or/c arr? Values/c SomeValues/c))
|
(substitution/c Type? . -> . Type?)
|
||||||
|
|
||||||
(define t-substs
|
(define t-substs
|
||||||
(for/fold ([acc (hash)]) ([(v r) (in-hash s)])
|
(for/fold ([acc (hash)]) ([(v r) (in-hash s)])
|
||||||
|
|
|
@ -20,7 +20,7 @@ at least theoretically.
|
||||||
rep utils typecheck infer env private types static-contracts)
|
rep utils typecheck infer env private types static-contracts)
|
||||||
|
|
||||||
(define optimize? (make-parameter #t))
|
(define optimize? (make-parameter #t))
|
||||||
(define-for-syntax enable-contracts? (and (getenv "PLT_TR_CONTRACTS") #t))
|
(define-for-syntax enable-contracts? (or (getenv "PLT_TR_CONTRACTS") #t))
|
||||||
|
|
||||||
(define-syntax do-contract-req
|
(define-syntax do-contract-req
|
||||||
(if enable-contracts?
|
(if enable-contracts?
|
||||||
|
|
Loading…
Reference in New Issue
Block a user