Make for loops in TR use an annotation when applicable.
original commit: f6050d5587ce33d46d4ea3b4698582fcf78eed23
This commit is contained in:
Eric Dobson
parent
469244b914
commit
a5311c029c
|
|
@ -93,10 +93,11 @@
|
|||
-RealZero -NonNegReal -NonPosReal -Real)))))
|
||||
|
||||
(define (inexact-zero->exact-zero-type)
|
||||
(for/list ([t (list -FlonumPosZero -FlonumNegZero -FlonumZero
|
||||
-SingleFlonumPosZero -SingleFlonumNegZero -SingleFlonumZero
|
||||
-InexactRealPosZero -InexactRealNegZero -InexactRealZero
|
||||
-RealZero)])
|
||||
(for/list ([t (in-list
|
||||
(list -FlonumPosZero -FlonumNegZero -FlonumZero
|
||||
-SingleFlonumPosZero -SingleFlonumNegZero -SingleFlonumZero
|
||||
-InexactRealPosZero -InexactRealNegZero -InexactRealZero
|
||||
-RealZero))])
|
||||
(-> t -Zero)))
|
||||
|
||||
(define (exact-round-type) ; also used for exact-truncate
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@
|
|||
;; explicitly parenthesized
|
||||
(syntax-parse stx #:literals (: t:->)
|
||||
[(: id (~and kw :) x ...)
|
||||
#:fail-unless (for/first ([i (syntax->list #'(x ...))]
|
||||
#:fail-unless (for/first ([i (in-list (syntax->list #'(x ...)))]
|
||||
#:when (identifier? i)
|
||||
#:when (free-identifier=? i #'t:->))
|
||||
i)
|
||||
|
|
|
|||
4
collects/typed-racket/env/tvar-env.rkt
vendored
4
collects/typed-racket/env/tvar-env.rkt
vendored
|
|
@ -59,7 +59,7 @@
|
|||
;; extend/many : type-env list<symbol> option<list<symbol>> -> type-env
|
||||
;; extend type environment for many symbols
|
||||
(define (extend/many env vars [fresh-vars #f])
|
||||
(let ([fresh-vars (or fresh-vars (for/list ([_ vars]) #f))])
|
||||
(for/fold ([env env]) ([var vars] [fresh-var fresh-vars])
|
||||
(let ([fresh-vars (or fresh-vars (for/list ([_ (in-list vars)]) #f))])
|
||||
(for/fold ([env env]) ([var (in-list vars)] [fresh-var (in-list fresh-vars)])
|
||||
(extend env var fresh-var))))
|
||||
|
||||
|
|
|
|||
|
|
@ -31,7 +31,7 @@
|
|||
;; index variables Y. For now, we add the widest constraints for
|
||||
;; variables in X to the cmap and create an empty dmap.
|
||||
(define (empty-cset X Y)
|
||||
(make-cset (list (cons (for/hash ([x X]) (values x (no-constraint x)))
|
||||
(make-cset (list (cons (for/hash ([x (in-list X)]) (values x (no-constraint x)))
|
||||
(make-dmap (make-immutable-hash null))))))
|
||||
|
||||
|
||||
|
|
@ -82,7 +82,7 @@
|
|||
(define (cset-meet* args)
|
||||
(for/fold ([c (make-cset (list (cons (make-immutable-hash null)
|
||||
(make-dmap (make-immutable-hash null)))))])
|
||||
([a args])
|
||||
([a (in-list args)])
|
||||
(cset-meet a c)))
|
||||
|
||||
(define (cset-combine l)
|
||||
|
|
|
|||
|
|
@ -18,8 +18,8 @@
|
|||
(unless (and rest2 (= (length fixed1) (length fixed2)))
|
||||
(fail! fixed1 fixed2))
|
||||
(make-dcon-exact
|
||||
(for/list ([c1 fixed1]
|
||||
[c2 fixed2])
|
||||
(for/list ([c1 (in-list fixed1)]
|
||||
[c2 (in-list fixed2)])
|
||||
(c-meet c1 c2 (c-X c1)))
|
||||
(c-meet rest1 rest2 (c-X rest1)))]
|
||||
;; redo in the other order to call the first case
|
||||
|
|
@ -29,15 +29,15 @@
|
|||
(unless (= (length fixed1) (length fixed2))
|
||||
(fail! fixed1 fixed2))
|
||||
(make-dcon
|
||||
(for/list ([c1 fixed1]
|
||||
[c2 fixed2])
|
||||
(for/list ([c1 (in-list fixed1)]
|
||||
[c2 (in-list fixed2)])
|
||||
(c-meet c1 c2 (c-X c1)))
|
||||
#f)]
|
||||
[((struct dcon (fixed1 #f)) (struct dcon (fixed2 rest)))
|
||||
(unless (>= (length fixed1) (length fixed2))
|
||||
(fail! fixed1 fixed2))
|
||||
(make-dcon
|
||||
(for/list ([c1 fixed1]
|
||||
(for/list ([c1 (in-list fixed1)]
|
||||
[c2 (in-sequence-forever fixed2 rest)])
|
||||
(c-meet c1 c2 (c-X c1)))
|
||||
#f)]
|
||||
|
|
@ -49,7 +49,7 @@
|
|||
(values fixed1 fixed2 rest1 rest2)
|
||||
(values fixed2 fixed1 rest2 rest1))])
|
||||
(make-dcon
|
||||
(for/list ([c1 longer]
|
||||
(for/list ([c1 (in-list longer)]
|
||||
[c2 (in-sequence-forever shorter srest)])
|
||||
(c-meet c1 c2 (c-X c1)))
|
||||
(c-meet lrest srest (c-X lrest))))]
|
||||
|
|
@ -57,7 +57,7 @@
|
|||
(unless (and (= (length fixed1) (length fixed2))
|
||||
(eq? bound1 bound2))
|
||||
(fail! bound1 bound2))
|
||||
(make-dcon-dotted (for/list ([c1 fixed1] [c2 fixed2])
|
||||
(make-dcon-dotted (for/list ([c1 (in-list fixed1)] [c2 (in-list fixed2)])
|
||||
(c-meet c1 c2 (c-X c1)))
|
||||
(c-meet c1 c2 bound1) bound1)]
|
||||
[((struct dcon _) (struct dcon-dotted _))
|
||||
|
|
|
|||
|
|
@ -70,7 +70,7 @@
|
|||
(cset? symbol? (listof symbol?) . -> . cset?)
|
||||
(mover cset dbound vars
|
||||
(λ (cmap dmap)
|
||||
(make-dcon (for/list ([v vars])
|
||||
(make-dcon (for/list ([v (in-list vars)])
|
||||
(hash-ref cmap v
|
||||
(λ () (int-err "No constraint for new var ~a" v))))
|
||||
#f))))
|
||||
|
|
@ -110,7 +110,7 @@
|
|||
(mover cset dbound vars
|
||||
(λ (cmap dmap)
|
||||
((if exact? make-dcon-exact make-dcon)
|
||||
(for/list ([v vars])
|
||||
(for/list ([v (in-list vars)])
|
||||
(hash-ref cmap v (λ () (int-err "No constraint for new var ~a" v))))
|
||||
(match (hash-ref (dmap-map dmap) dbound
|
||||
(λ () (int-err "No constraint for bound ~a" dbound)))
|
||||
|
|
@ -206,7 +206,7 @@
|
|||
(unless (<= (length ss) (length ts))
|
||||
(fail! ss ts))
|
||||
(let* ([vars (var-store-take dbound dty (- (length ts) (length ss)))]
|
||||
[new-tys (for/list ([var vars])
|
||||
[new-tys (for/list ([var (in-list vars)])
|
||||
(substitute (make-F var) dbound dty))]
|
||||
[new-s-arr (make-arr (append ss new-tys) s #f #f null)]
|
||||
[new-cset (cgen/arr V (append vars X) Y new-s-arr t-arr)])
|
||||
|
|
@ -219,7 +219,7 @@
|
|||
(unless (<= (length ts) (length ss))
|
||||
(fail! ss ts))
|
||||
(let* ([vars (var-store-take dbound dty (- (length ss) (length ts)))]
|
||||
[new-tys (for/list ([var vars])
|
||||
[new-tys (for/list ([var (in-list vars)])
|
||||
(substitute (make-F var) dbound dty))]
|
||||
[new-t-arr (make-arr (append ts new-tys) t #f #f null)]
|
||||
[new-cset (cgen/arr V (append vars X) Y s-arr new-t-arr)])
|
||||
|
|
@ -270,7 +270,7 @@
|
|||
(cset-meet* (list arg-mapping darg-mapping ret-mapping)))
|
||||
;; the hard case
|
||||
(let* ([vars (var-store-take dbound t-dty (- (length ss) (length ts)))]
|
||||
[new-tys (for/list ([var vars])
|
||||
[new-tys (for/list ([var (in-list vars)])
|
||||
(substitute (make-F var) dbound t-dty))]
|
||||
[new-t-arr (make-arr (append ts new-tys) t #f (cons t-dty dbound) null)]
|
||||
[new-cset (cgen/arr V (append vars X) Y s-arr new-t-arr)])
|
||||
|
|
@ -283,7 +283,7 @@
|
|||
(cond [(< (length ss) (length ts))
|
||||
;; the hard case
|
||||
(let* ([vars (var-store-take dbound s-dty (- (length ts) (length ss)))]
|
||||
[new-tys (for/list ([var vars])
|
||||
[new-tys (for/list ([var (in-list vars)])
|
||||
(substitute (make-F var) dbound s-dty))]
|
||||
[new-s-arr (make-arr (append ss new-tys) s #f (cons s-dty dbound) null)]
|
||||
[new-cset (cgen/arr V (append vars X) Y new-s-arr t-arr)])
|
||||
|
|
@ -362,7 +362,7 @@
|
|||
|
||||
(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 vars])
|
||||
[new-tys (for/list ([var (in-list vars)])
|
||||
(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)])
|
||||
|
|
@ -417,7 +417,7 @@
|
|||
[((Poly: v1 b1) T) (cgen (append v1 V) X Y b1 T)]
|
||||
|
||||
;; constrain *each* element of es to be below T, and then combine the constraints
|
||||
[((Union: es) T) (cset-meet* (cons empty (for/list ([e es]) (cg e T))))]
|
||||
[((Union: es) T) (cset-meet* (cons empty (for/list ([e (in-list es)]) (cg e T))))]
|
||||
|
||||
;; find *an* element of es which can be made to be a supertype of S
|
||||
;; FIXME: we're using multiple csets here, but I don't think it makes a difference
|
||||
|
|
@ -425,7 +425,7 @@
|
|||
[(S (Union: es))
|
||||
(cset-combine
|
||||
(filter values
|
||||
(for/list ([e es])
|
||||
(for/list ([e (in-list es)])
|
||||
(with-handlers ([exn:infer? (λ _ #f)]) (cg S e)))))]
|
||||
|
||||
;; two structs with the same name
|
||||
|
|
@ -488,14 +488,14 @@
|
|||
(list portable-fixnum? -NonNegFixnum)
|
||||
(list values -Nat)))
|
||||
(define type
|
||||
(for/or ((pred-type possibilities))
|
||||
(for/or ([pred-type (in-list possibilities)])
|
||||
(match pred-type
|
||||
((list pred? type)
|
||||
(and (pred? n) type)))))
|
||||
(cg type t*)]
|
||||
[((Base: _ _ _ _ #t) (Sequence: (list t*)))
|
||||
(define type
|
||||
(for/or ((t (list -Byte -Index -NonNegFixnum -Nat)))
|
||||
(for/or ([t (in-list (list -Byte -Index -NonNegFixnum -Nat))])
|
||||
(and (subtype S t) t)))
|
||||
(if type
|
||||
(cg type t*)
|
||||
|
|
@ -529,7 +529,7 @@
|
|||
|
||||
(let* ([vars (var-store-take dbound s-dty (length ts))]
|
||||
;; new-tys are dummy plain type variables, standing in for the elements of dbound that need to be generated
|
||||
[new-tys (for/list ([var vars])
|
||||
[new-tys (for/list ([var (in-list vars)])
|
||||
(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 new-tys ts)])
|
||||
|
|
@ -604,10 +604,10 @@
|
|||
[((Function: (list s-arr ...))
|
||||
(Function: (list t-arr ...)))
|
||||
(cset-meet*
|
||||
(for/list ([t-arr t-arr])
|
||||
(for/list ([t-arr (in-list t-arr)])
|
||||
;; for each element of t-arr, we need to get at least one element of s-arr that works
|
||||
(let ([results (filter values
|
||||
(for/list ([s-arr s-arr])
|
||||
(for/list ([s-arr (in-list s-arr)])
|
||||
(with-handlers ([exn:infer? (lambda (_) #f)])
|
||||
(cgen/arr V X Y s-arr t-arr))))])
|
||||
;; ensure that something produces a constraint set
|
||||
|
|
@ -692,26 +692,26 @@
|
|||
(constraint->type f idx-hash #:variable k))))]
|
||||
[(dcon fixed rest)
|
||||
(values k
|
||||
(i-subst/starred (for/list ([f fixed])
|
||||
(i-subst/starred (for/list ([f (in-list fixed)])
|
||||
(constraint->type f idx-hash #:variable k))
|
||||
(constraint->type rest idx-hash)))]
|
||||
[(dcon-exact fixed rest)
|
||||
(values k
|
||||
(i-subst/starred
|
||||
(for/list ([f fixed])
|
||||
(for/list ([f (in-list fixed)])
|
||||
(constraint->type f idx-hash #:variable k))
|
||||
(constraint->type rest idx-hash)))]
|
||||
[(dcon-dotted fixed dc dbound)
|
||||
(values k
|
||||
(i-subst/dotted
|
||||
(for/list ([f fixed])
|
||||
(for/list ([f (in-list fixed)])
|
||||
(constraint->type f idx-hash #:variable k))
|
||||
(constraint->type dc idx-hash #:variable k)
|
||||
dbound))]))
|
||||
(for/hash ([(k v) (in-hash cmap)])
|
||||
(values k (t-subst (constraint->type v var-hash)))))])
|
||||
;; verify that we got all the important variables
|
||||
(and (for/and ([v (fv R)])
|
||||
(and (for/and ([v (in-list (fv R))])
|
||||
(let ([entry (hash-ref subst v #f)])
|
||||
;; Make sure we got a subst entry for a type var
|
||||
;; (i.e. just a type to substitute)
|
||||
|
|
@ -733,7 +733,7 @@
|
|||
(unless (= (length S) (length T))
|
||||
(fail! S T))
|
||||
(cset-meet*
|
||||
(for/list ([s S] [t T])
|
||||
(for/list ([s (in-list S)] [t (in-list T)])
|
||||
;; We meet early to prune the csets to a reasonable size.
|
||||
;; This weakens the inference a bit, but sometimes avoids
|
||||
;; constraint explosion.
|
||||
|
|
@ -784,7 +784,7 @@
|
|||
[cs-short (cgen/list null X (list dotted-var) short-S T
|
||||
#:expected-cset expected-cset)]
|
||||
[new-vars (var-store-take dotted-var T-dotted (length rest-S))]
|
||||
[new-Ts (for/list ([v new-vars])
|
||||
[new-Ts (for/list ([v (in-list new-vars)])
|
||||
(substitute (make-F v) dotted-var
|
||||
(substitute-dots (map make-F new-vars) #f dotted-var T-dotted)))]
|
||||
[cs-dotted (cgen/list null (append new-vars X) (list dotted-var) rest-S new-Ts
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@
|
|||
(export promote-demote^)
|
||||
|
||||
(define (V-in? V . ts)
|
||||
(for/or ([e (append* (map fv ts))])
|
||||
(for/or ([e (in-list (append* (map fv ts)))])
|
||||
(memq e V)))
|
||||
|
||||
(define (get-filters rng)
|
||||
|
|
@ -39,19 +39,19 @@
|
|||
[(apply V-in? V (get-filters rng))
|
||||
(make-top-arr)]
|
||||
[(and drest (memq (cdr drest) V))
|
||||
(make-arr (for/list ([d dom]) (var-demote d V))
|
||||
(make-arr (for/list ([d (in-list dom)]) (var-demote d V))
|
||||
(vp rng)
|
||||
(var-demote (car drest) V)
|
||||
#f
|
||||
(for/list ([k kws]) (var-demote k V)))]
|
||||
(for/list ([k (in-list kws)]) (var-demote k V)))]
|
||||
[else
|
||||
(make-arr (for/list ([d dom]) (var-demote d V))
|
||||
(make-arr (for/list ([d (in-list dom)]) (var-demote d V))
|
||||
(vp rng)
|
||||
(and rest (var-demote rest V))
|
||||
(and drest
|
||||
(cons (var-demote (car drest) V)
|
||||
(cdr drest)))
|
||||
(for/list ([k kws]) (var-demote k V)))])]))
|
||||
(for/list ([k (in-list kws)]) (var-demote k V)))])]))
|
||||
|
||||
(define (var-demote T V)
|
||||
(define (vd t) (var-demote t V))
|
||||
|
|
@ -74,16 +74,16 @@
|
|||
[(apply V-in? V (get-filters rng))
|
||||
(make-top-arr)]
|
||||
[(and drest (memq (cdr drest) V))
|
||||
(make-arr (for/list ([d dom]) (var-promote d V))
|
||||
(make-arr (for/list ([d (in-list dom)]) (var-promote d V))
|
||||
(vd rng)
|
||||
(var-promote (car drest) V)
|
||||
#f
|
||||
(for/list ([k kws]) (var-demote k V)))]
|
||||
(for/list ([k (in-list kws)]) (var-demote k V)))]
|
||||
[else
|
||||
(make-arr (for/list ([d dom]) (var-promote d V))
|
||||
(make-arr (for/list ([d (in-list dom)]) (var-promote d V))
|
||||
(vd rng)
|
||||
(and rest (var-promote rest V))
|
||||
(and drest
|
||||
(cons (var-promote (car drest) V)
|
||||
(cdr drest)))
|
||||
(for/list ([k kws]) (var-demote k V)))])]))
|
||||
(for/list ([k (in-list kws)]) (var-demote k V)))])]))
|
||||
|
|
|
|||
|
|
@ -83,8 +83,8 @@
|
|||
#,@(syntax-map (optimize) #'(e-body ...)))))
|
||||
(pattern (kw:identifier expr ...)
|
||||
#:when
|
||||
(for/or ([k (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression
|
||||
#'#%variable-reference #'with-continuation-mark)])
|
||||
(for/or ([k (in-list (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression
|
||||
#'#%variable-reference #'with-continuation-mark))])
|
||||
(free-identifier=? k #'kw))
|
||||
;; we don't want to optimize in the cases that don't match the #:when clause
|
||||
#:with opt (quasisyntax/loc/origin this-syntax #'kw
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@
|
|||
|
||||
;; generates a table matching safe to unsafe promitives
|
||||
(define (mk-unsafe-tbl generic safe-pattern unsafe-pattern)
|
||||
(for/fold ([h (make-immutable-free-id-table)]) ([g generic])
|
||||
(for/fold ([h (make-immutable-free-id-table)]) ([g (in-list generic)])
|
||||
(let ([f (format-id g safe-pattern g)] [u (format-id g unsafe-pattern g)])
|
||||
(dict-set (dict-set h g u) f u))))
|
||||
|
||||
|
|
@ -44,7 +44,7 @@
|
|||
;; this works on operations that are (A A -> A)
|
||||
(define (n-ary->binary op arg1 arg2 rest)
|
||||
(for/fold ([o arg1])
|
||||
([e (syntax->list #`(#,arg2 #,@rest))])
|
||||
([e (in-list (syntax->list #`(#,arg2 #,@rest)))])
|
||||
#`(#,op #,o #,e)))
|
||||
;; this works on operations that are (A A -> B)
|
||||
(define (n-ary-comp->binary op arg1 arg2 rest)
|
||||
|
|
|
|||
|
|
@ -45,7 +45,7 @@
|
|||
(pattern (type))
|
||||
(pattern (x ...)
|
||||
#:fail-unless (= 1 (length
|
||||
(for/list ([i (syntax->list #'(x ...))]
|
||||
(for/list ([i (in-list (syntax->list #'(x ...)))]
|
||||
#:when (and (identifier? i)
|
||||
(free-identifier=? i #'t:->)))
|
||||
i))) #f
|
||||
|
|
|
|||
|
|
@ -108,8 +108,8 @@
|
|||
((listof identifier?) syntax? (syntax? . -> . tc-results/c) (syntax? tc-results/c . -> . tc-results/c) . -> . tc-results/c)
|
||||
(match stxs
|
||||
[(list stx ...)
|
||||
(let ([anns (for/list ([s stxs]) (type-annotation s #:infer #t))])
|
||||
(if (for/and ([a anns]) a)
|
||||
(let ([anns (for/list ([s (in-list stxs)]) (type-annotation s #:infer #t))])
|
||||
(if (for/and ([a (in-list anns)]) a)
|
||||
(tc-expr/check expr (ret anns))
|
||||
(let ([ty (tc-expr expr)])
|
||||
(match ty
|
||||
|
|
@ -126,7 +126,8 @@
|
|||
(length stxs) (length tys) (stringify tys))
|
||||
(ret (map (lambda _ (Un)) stxs)))
|
||||
(combine-results
|
||||
(for/list ([stx stxs] [ty tys] [a anns] [f fs] [o os])
|
||||
(for/list ([stx (in-list stxs)] [ty (in-list tys)]
|
||||
[a (in-list anns)] [f (in-list fs)] [o (in-list os)])
|
||||
(cond [a (check-type stx ty a) (ret a f o)]
|
||||
;; mutated variables get generalized, so that we don't infer too small a type
|
||||
[(is-var-mutated? stx) (ret (generalize ty) f o)]
|
||||
|
|
|
|||
|
|
@ -98,7 +98,7 @@
|
|||
((equal? chaperone-sym x) y)
|
||||
((equal? chaperone-sym y) x)
|
||||
(else impersonator-sym)))
|
||||
(for/fold ((acc i)) ((v args))
|
||||
(for/fold ((acc i)) ((v (in-list args)))
|
||||
(contract-kind-max2 v acc)))
|
||||
|
||||
(define (contract-kind-min i . args)
|
||||
|
|
@ -109,7 +109,7 @@
|
|||
((equal? chaperone-sym x) x)
|
||||
((equal? chaperone-sym y) y)
|
||||
(else impersonator-sym)))
|
||||
(for/fold ((acc i)) ((v args))
|
||||
(for/fold ((acc i)) ((v (in-list args)))
|
||||
(contract-kind-min2 v acc)))
|
||||
|
||||
|
||||
|
|
@ -245,7 +245,7 @@
|
|||
#'(dom* ... rst-spec ... . -> . rng*)
|
||||
#'((dom* ...) (opt-dom* ...) rst-spec ... . ->* . rng*))
|
||||
#'(dom* ... . -> . rng*)))))
|
||||
(unless (no-duplicates (for/list ([t arrs])
|
||||
(unless (no-duplicates (for/list ([t (in-list arrs)])
|
||||
(match t
|
||||
[(arr: dom _ _ _ _) (length dom)]
|
||||
;; is there something more sensible here?
|
||||
|
|
@ -377,7 +377,7 @@
|
|||
[(Poly: vs b)
|
||||
(if (not (from-untyped? typed-side))
|
||||
;; in typed positions, no checking needed for the variables
|
||||
(parameterize ([vars (append (for/list ([v vs]) (list v #'any/c)) (vars))])
|
||||
(parameterize ([vars (append (for/list ([v (in-list vs)]) (list v #'any/c)) (vars))])
|
||||
(t->c b))
|
||||
;; in untyped positions, use `parameteric/c'
|
||||
(match-let ([(Poly-names: vs-nm _) ty])
|
||||
|
|
@ -402,15 +402,15 @@
|
|||
(t->c (make-Instance (resolve-once t)))]
|
||||
[(Instance: (Class: _ _ (list (list name fcn) ...)))
|
||||
(set-impersonator!)
|
||||
(with-syntax ([(fcn-cnts ...) (for/list ([f fcn]) (t->c/fun f #:method #t))]
|
||||
(with-syntax ([(fcn-cnts ...) (for/list ([f (in-list fcn)]) (t->c/fun f #:method #t))]
|
||||
[(names ...) name])
|
||||
#'(object/c (names fcn-cnts) ...))]
|
||||
;; init args not currently handled by class/c
|
||||
[(Class: _ (list (list by-name-init by-name-init-ty _) ...) (list (list name fcn) ...))
|
||||
(set-impersonator!)
|
||||
(with-syntax ([(fcn-cnt ...) (for/list ([f fcn]) (t->c/fun f #:method #t))]
|
||||
(with-syntax ([(fcn-cnt ...) (for/list ([f (in-list fcn)]) (t->c/fun f #:method #t))]
|
||||
[(name ...) name]
|
||||
[(by-name-cnt ...) (for/list ([t by-name-init-ty]) (t->c/neg t))]
|
||||
[(by-name-cnt ...) (for/list ([t (in-list by-name-init-ty)]) (t->c/neg t))]
|
||||
[(by-name-init ...) by-name-init])
|
||||
#'(class/c (name fcn-cnt) ... (init [by-name-init by-name-cnt] ...)))]
|
||||
[(Value: '()) #'null?]
|
||||
|
|
@ -425,7 +425,7 @@
|
|||
[poly?
|
||||
(with-syntax* ([struct-ctc (generate-temporary 'struct-ctc)])
|
||||
(define field-contracts
|
||||
(for/list ([fty flds] [mut? mut?])
|
||||
(for/list ([fty (in-list flds)] [mut? (in-list mut?)])
|
||||
(with-syntax* ([rec (generate-temporary 'rec)])
|
||||
(define required-recursive-kind
|
||||
(contract-kind-min kind (if mut? impersonator-sym chaperone-sym)))
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@
|
|||
(define fv-cnts (for/list ([t (in-list fv-types)]
|
||||
[stx (in-list (syntax->list fvtys))])
|
||||
(type->contract t #:typed-side #f (no-contract t))))
|
||||
(define ex-types (for/list ([t (syntax->list extys)])
|
||||
(define ex-types (for/list ([t (in-list (syntax->list extys))])
|
||||
(parse-type t)))
|
||||
(define ex-cnts (for/list ([t (in-list ex-types)]
|
||||
[stx (in-list (syntax->list extys))])
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@
|
|||
[((tc-results: ts fs os) (tc-results: ts2 (NoFilter:) (NoObject:)))
|
||||
(unless (= (length ts) (length ts2))
|
||||
(tc-error/expr "Expected ~a values, but got ~a" (length ts2) (length ts)))
|
||||
(unless (for/and ([t ts] [s ts2]) (subtype t s))
|
||||
(unless (for/and ([t (in-list ts)] [s (in-list ts2)]) (subtype t s))
|
||||
(tc-error/expr "Expected ~a, but got ~a" (stringify ts2) (stringify ts)))
|
||||
(if (= (length ts) (length ts2))
|
||||
(ret ts2 fs os)
|
||||
|
|
@ -79,7 +79,7 @@
|
|||
(unless (= (length t1) (length t2))
|
||||
(tc-error/expr "Expected ~a values and ~a ..., but got ~a values"
|
||||
(length t2) dty (length t1)))
|
||||
(unless (for/and ([t t1] [s t2]) (subtype t s))
|
||||
(unless (for/and ([t (in-list t1)] [s (in-list t2)]) (subtype t s))
|
||||
(tc-error/expr "Expected ~a, but got ~a" (stringify t2) (stringify t1)))
|
||||
expected]
|
||||
;; case where you have (Values a ... a) but expected something else
|
||||
|
|
@ -87,7 +87,7 @@
|
|||
(unless (= (length t1) (length t2))
|
||||
(tc-error/expr "Expected ~a values, but got ~a values and ~a ..."
|
||||
(length t2) (length t1) dty))
|
||||
(unless (for/and ([t t1] [s t2]) (subtype t s))
|
||||
(unless (for/and ([t (in-list t1)] [s (in-list t2)]) (subtype t s))
|
||||
(tc-error/expr "Expected ~a, but got ~a" (stringify t2) (stringify t1)))
|
||||
expected]
|
||||
[((tc-results: t1 f o dty1 dbound) (tc-results: t2 f o dty2 dbound))
|
||||
|
|
@ -101,7 +101,7 @@
|
|||
[((tc-results: t1 fs os) (tc-results: t2 fs os))
|
||||
(unless (= (length t1) (length t2))
|
||||
(tc-error/expr "Expected ~a values, but got ~a" (length t2) (length t1)))
|
||||
(unless (for/and ([t t1] [s t2]) (subtype t s))
|
||||
(unless (for/and ([t (in-list t1)] [s (in-list t2)]) (subtype t s))
|
||||
(tc-error/expr "Expected ~a, but got ~a" (stringify t2) (stringify t1)))
|
||||
expected]
|
||||
[((tc-any-results:) (or (? Type/c? t) (tc-result1: t _ _)))
|
||||
|
|
|
|||
|
|
@ -61,7 +61,7 @@
|
|||
(values #'(begin) e null)))
|
||||
(list* type-desc constr pred super accs)))
|
||||
(define/with-syntax (type-desc* constr* pred* super* accs* ...)
|
||||
(for/list ([i new-ids]) (if (identifier? i) #`(syntax #,i) i)))
|
||||
(for/list ([i (in-list new-ids)]) (if (identifier? i) #`(syntax #,i) i)))
|
||||
(values
|
||||
#`(begin
|
||||
#,@defns
|
||||
|
|
|
|||
|
|
@ -58,7 +58,7 @@
|
|||
[((arr: _ _ _ _
|
||||
;; at least one mandatory keyword
|
||||
(app (λ (kws)
|
||||
(for/or ([keyword kws])
|
||||
(for/or ([keyword (in-list kws)])
|
||||
(match keyword
|
||||
[(Keyword: kw _ #t) kw]
|
||||
[_ #f])))
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@
|
|||
(ret -Void)]
|
||||
[(not i-val)
|
||||
(define val-t (single-value val-e))
|
||||
(for ((es-type es-t))
|
||||
(for ((es-type (in-list es-t)))
|
||||
(check-below val-t es-type))
|
||||
(cond-check-below (ret -Void) expected)]
|
||||
[else
|
||||
|
|
|
|||
|
|
@ -69,8 +69,8 @@
|
|||
(generalize (tc-expr/t ac)))))]
|
||||
[ts (cons ts1 ann-ts)])
|
||||
;; check that the actual arguments are ok here
|
||||
(for/list ([a (syntax->list #'(actuals ...))]
|
||||
[t ann-ts])
|
||||
(for/list ([a (in-list (syntax->list #'(actuals ...)))]
|
||||
[t (in-list ann-ts)])
|
||||
(tc-expr/check a (ret t)))
|
||||
;; then check that the function typechecks with the inferred types
|
||||
(add-typeof-expr lam (tc/rec-lambda/check args body lp ts expected))
|
||||
|
|
@ -80,8 +80,8 @@
|
|||
((~and inner-body (if e1 e2 e3:id)))
|
||||
(null actuals ...))
|
||||
#:when (free-identifier=? #'val #'e3)
|
||||
(let ([ts (for/list ([ac (syntax->list #'(actuals ...))]
|
||||
[f (syntax->list #'(acc ...))])
|
||||
(let ([ts (for/list ([ac (in-list (syntax->list #'(actuals ...)))]
|
||||
[f (in-list (syntax->list #'(acc ...)))])
|
||||
(let ([type (type-annotation f #:infer #t)])
|
||||
(if type
|
||||
(tc-expr/check/t ac (ret type))
|
||||
|
|
@ -96,8 +96,8 @@
|
|||
expected)]
|
||||
;; special case when argument needs inference
|
||||
[(_ body* _)
|
||||
(let ([ts (for/list ([ac (syntax->list actuals)]
|
||||
[f (syntax->list args)])
|
||||
(let ([ts (for/list ([ac (in-list (syntax->list actuals))]
|
||||
[f (in-list (syntax->list args))])
|
||||
(let* ([infer-t (or (type-annotation f #:infer #t)
|
||||
(find-annotation #'(begin . body*) f))])
|
||||
(if infer-t
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@
|
|||
(and (Listof: t var) (app (λ _ #f) bound))))
|
||||
...))
|
||||
(=> fail)
|
||||
(unless (for/and ([b bound]) (or (not b) (eq? bound0 b))) (fail))
|
||||
(unless (for/and ([b (in-list bound)]) (or (not b) (eq? bound0 b))) (fail))
|
||||
(define expected-elem-type
|
||||
(match expected
|
||||
[(or #f (tc-any-results:)) #f]
|
||||
|
|
|
|||
|
|
@ -85,7 +85,7 @@
|
|||
(define (matching-arities arrs)
|
||||
(for/list ([arr (in-list arrs)] #:when (arr-matches? arr args*)) arr))
|
||||
(define (has-drest/filter? arrs)
|
||||
(for/or ([arr arrs])
|
||||
(for/or ([arr (in-list arrs)])
|
||||
(or (has-filter? arr) (arr-drest arr))))
|
||||
|
||||
(define arg-tys
|
||||
|
|
@ -103,7 +103,7 @@
|
|||
(in-sequences (in-list dom) (in-cycle (in-value rest)))))))
|
||||
(for/list ([a (in-list args*)] [types matching-domains])
|
||||
(match-define (cons t ts) types)
|
||||
(if (for/and ((t2 ts)) (equal? t t2))
|
||||
(if (for/and ((t2 (in-list ts))) (equal? t t2))
|
||||
(tc-expr/check a (ret t))
|
||||
(single-value a)))]
|
||||
[_ (map single-value args*)]))
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@
|
|||
(for ([pa (in-syntax pos-args)]
|
||||
[pt (in-list pos-tys)])
|
||||
(tc-expr/check pa (ret pt)))
|
||||
(for ([n names]
|
||||
(for ([n (in-list names)]
|
||||
#:unless (memq n tnames))
|
||||
(tc-error/delayed
|
||||
"unknown named argument ~a for class\nlegal named arguments are ~a"
|
||||
|
|
|
|||
|
|
@ -45,14 +45,16 @@
|
|||
(match expected
|
||||
[(tc-results: ets efs eos)
|
||||
(match-let ([(list (tc-result1: ts fs os) ...)
|
||||
(for/list ([arg (syntax->list #'args)]
|
||||
[et ets] [ef efs] [eo eos])
|
||||
(for/list ([arg (in-list (syntax->list #'args))]
|
||||
[et (in-list ets)]
|
||||
[ef (in-list efs)]
|
||||
[eo (in-list eos)])
|
||||
(single-value arg (ret et ef eo)))])
|
||||
(if (= (length ts) (length ets) (length (syntax->list #'args)))
|
||||
(ret ts fs os)
|
||||
(tc-error/expr #:return expected "wrong number of values: expected ~a but got ~a"
|
||||
(length ets) (length (syntax->list #'args)))))]
|
||||
[_ (match-let ([(list (tc-result1: ts fs os) ...)
|
||||
(for/list ([arg (syntax->list #'args)])
|
||||
(for/list ([arg (in-list (syntax->list #'args))])
|
||||
(single-value arg))])
|
||||
(ret ts fs os))])))
|
||||
|
|
|
|||
|
|
@ -19,7 +19,10 @@
|
|||
(match t
|
||||
[(Values: (list (Result: ts _ _) ...)) (ret ts)]
|
||||
[(ValuesDots: (list (Result: ts _ _) ...) dty dbound)
|
||||
(ret ts (for/list ([t ts]) (make-NoFilter)) (for/list ([t ts]) (make-Empty)) dty dbound)]
|
||||
(ret ts
|
||||
(for/list ([t (in-list ts)]) (make-NoFilter))
|
||||
(for/list ([t (in-list ts)]) (make-Empty))
|
||||
dty dbound)]
|
||||
[_ (int-err "do-ret fails: ~a" t)]))
|
||||
|
||||
(define (tc/apply f args)
|
||||
|
|
|
|||
|
|
@ -81,7 +81,7 @@
|
|||
(([e env?] [fs (listof Filter/c)] [bx (box/c boolean?)])
|
||||
#:pre (bx) (unbox bx) . ->i . [_ env?])
|
||||
(define-values (props atoms) (combine-props fs (env-props env) flag))
|
||||
(for/fold ([Γ (replace-props env (append atoms props))]) ([f atoms])
|
||||
(for/fold ([Γ (replace-props env (append atoms props))]) ([f (in-list atoms)])
|
||||
(match f
|
||||
[(Bot:) (set-box! flag #f) (env-map (lambda (k v) (Un)) Γ)]
|
||||
[(or (TypeFilter: _ _ x) (NotTypeFilter: _ _ x))
|
||||
|
|
|
|||
|
|
@ -39,7 +39,7 @@
|
|||
[(list ty)
|
||||
(list
|
||||
(for/fold ([ty ty])
|
||||
([inst (in-improper-stx inst)])
|
||||
([inst (in-list (in-improper-stx inst))])
|
||||
(cond [(not inst) ty]
|
||||
[(not (or (Poly? ty) (PolyDots? ty)))
|
||||
(tc-error/expr #:return (Un) "Cannot instantiate non-polymorphic type ~a"
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@
|
|||
[(_ (lsts ... arrs) f-stx args-stx pred infer t argtys expected)
|
||||
(with-syntax ([(vars ... a) (generate-temporaries #'(lsts ... arrs))])
|
||||
(syntax/loc stx
|
||||
(or (for/or ([vars lsts] ... [a arrs]
|
||||
(or (for/or ([vars (in-list lsts)] ... [a (in-list arrs)]
|
||||
#:when (pred vars ... a))
|
||||
(let ([substitution (infer vars ... a)])
|
||||
(and substitution
|
||||
|
|
@ -135,7 +135,7 @@
|
|||
(tc/funapp f-stx args-stx (ret (resolve-once t) f o) argtys expected)]
|
||||
;; a union of functions can be applied if we can apply all of the elements
|
||||
[((tc-result1: (Union: (and ts (list (Function: _) ...)))) _)
|
||||
(ret (for/fold ([result (Un)]) ([fty ts])
|
||||
(ret (for/fold ([result (Un)]) ([fty (in-list ts)])
|
||||
(match (tc/funapp f-stx args-stx (ret fty) argtys expected)
|
||||
[(tc-result1: t) (Un result t)])))]
|
||||
;; error type is a perfectly good fcn type
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@
|
|||
(match tc
|
||||
[(tc-any-results:) tc]
|
||||
[(tc-results: ts _ _)
|
||||
(ret ts (for/list ([f ts]) (make-NoFilter)) (for/list ([f ts]) (make-NoObject)))]))
|
||||
(ret ts (for/list ([f (in-list ts)]) (make-NoFilter)) (for/list ([f (in-list ts)]) (make-NoObject)))]))
|
||||
|
||||
(define (tc/if-twoarm tst thn els [expected #f])
|
||||
(define (tc expr reachable?)
|
||||
|
|
@ -83,7 +83,9 @@
|
|||
;; if we have the same number of values in both cases
|
||||
(cond [(= (length ts) (length us))
|
||||
(combine-results
|
||||
(for/list ([f2 fs2] [f3 fs3] [t2 ts] [t3 us] [o2 os2] [o3 os3])
|
||||
(for/list ([f2 (in-list fs2)] [f3 (in-list fs3)]
|
||||
[t2 (in-list ts)] [t3 (in-list us)]
|
||||
[o2 (in-list os2)] [o3 (in-list os3)])
|
||||
(let ([filter
|
||||
(match* (f2 f3)
|
||||
[((NoFilter:) _)
|
||||
|
|
|
|||
|
|
@ -347,8 +347,8 @@
|
|||
[(list id ...)
|
||||
(list id)]))]
|
||||
[scoped-tvarss
|
||||
(for/list ((tvarss (lookup-scoped-tvar-layer form)))
|
||||
(for/list ((tvar tvarss))
|
||||
(for/list ((tvarss (in-list (lookup-scoped-tvar-layer form))))
|
||||
(for/list ((tvar (in-list tvarss)))
|
||||
(match tvar
|
||||
[(list (list v ...) dotted-v)
|
||||
(list (map syntax-e v) (syntax-e dotted-v))]
|
||||
|
|
@ -393,7 +393,7 @@
|
|||
[(tc-result1: (and t (Poly-fresh: ns fresh-ns expected*)))
|
||||
;; make sure the declared and annotated type variable arities match up
|
||||
;; with the expected type variable arity
|
||||
(for ((tvars tvarss))
|
||||
(for ((tvars (in-list tvarss)))
|
||||
(when (and (cons? tvars) (list? (first tvars)))
|
||||
(tc-error
|
||||
"Expected a polymorphic function without ..., but given function/annotation had ..."))
|
||||
|
|
@ -404,7 +404,7 @@
|
|||
[(tc-result1: (and t (PolyDots-names: (list ns ... dvar) expected*)))
|
||||
;; make sure the declared and annotated type variable arities match up
|
||||
;; with the expected type variable arity
|
||||
(for ((tvars tvarss))
|
||||
(for ((tvars (in-list tvarss)))
|
||||
(match tvars
|
||||
[(list (list vars ...) dotted)
|
||||
(unless (= (length vars) (length ns))
|
||||
|
|
@ -415,14 +415,14 @@
|
|||
(make-PolyDots (append ns (list dvar)) (extend-and-loop form ns formals bodies (ret expected*)))]
|
||||
[(or (tc-results: _) (tc-any-results:) #f)
|
||||
(define lengths
|
||||
(for/set ((tvars tvarss))
|
||||
(for/set ((tvars (in-list tvarss)))
|
||||
(match tvars
|
||||
[(list (list vars ...) dotted)
|
||||
(length vars)]
|
||||
[(list vars ...)
|
||||
(length vars)])))
|
||||
(define dots
|
||||
(for/set ((tvars tvarss))
|
||||
(for/set ((tvars (in-list tvarss)))
|
||||
(match tvars
|
||||
[(list (list vars ...) dotted) #t]
|
||||
[(list vars ...) #f])))
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@
|
|||
(match tc
|
||||
[(tc-any-results:) tc]
|
||||
[(tc-results: ts _ _)
|
||||
(ret ts (for/list ([f ts]) (make-NoFilter)) (for/list ([f ts]) (make-NoObject)))]))
|
||||
(ret ts (for/list ([f (in-list ts)]) (make-NoFilter)) (for/list ([f (in-list ts)]) (make-NoObject)))]))
|
||||
|
||||
(define/cond-contract (do-check expr->type namess results expected-results form exprs body clauses expected #:abstract [abstract null])
|
||||
(((syntax? syntax? tc-results/c . -> . any/c)
|
||||
|
|
@ -45,9 +45,9 @@
|
|||
(values ts
|
||||
e-ts
|
||||
(apply append
|
||||
(for/list ([n names]
|
||||
[f+ fs+]
|
||||
[f- fs-])
|
||||
(for/list ([n (in-list names)]
|
||||
[f+ (in-list fs+)]
|
||||
[f- (in-list fs-)])
|
||||
(list (make-ImpFilter (-not-filter (-val #f) n) f+)
|
||||
(make-ImpFilter (-filter (-val #f) n) f-)))))]
|
||||
[((tc-results: ts (NoFilter:) _) (tc-results: e-ts (NoFilter:) _))
|
||||
|
|
@ -153,8 +153,8 @@
|
|||
([(safe-bindings _)
|
||||
(for/fold ([safe-bindings '()] ; includes transitively-safe
|
||||
[transitively-safe-bindings '()])
|
||||
([names names]
|
||||
[clause clauses])
|
||||
([names (in-list names)]
|
||||
[clause (in-list clauses)])
|
||||
(case (safe-letrec-values-clause? clause transitively-safe-bindings flat-names)
|
||||
;; transitively safe -> safe to mention in a subsequent rhs
|
||||
[(transitively-safe) (values (append names safe-bindings)
|
||||
|
|
@ -231,7 +231,7 @@
|
|||
;; the types of the exprs
|
||||
#;[inferred-types (map (tc-expr-t/maybe-expected expected) exprs)]
|
||||
;; the annotated types of the name (possibly using the inferred types)
|
||||
[types (for/list ([name names] [e exprs])
|
||||
[types (for/list ([name (in-list names)] [e (in-list exprs)])
|
||||
(get-type/infer name e (tc-expr-t/maybe-expected expected)
|
||||
tc-expr/check))]
|
||||
;; the clauses for error reporting
|
||||
|
|
|
|||
|
|
@ -95,7 +95,7 @@
|
|||
(for/list ([l (in-vector (syntax-e #'i))]
|
||||
[t (in-list ts)])
|
||||
check-below (tc-literal l t) t))]
|
||||
[_ (make-HeterogeneousVector (for/list ([l (syntax-e #'i)])
|
||||
[_ (make-HeterogeneousVector (for/list ([l (in-vector (syntax-e #'i))])
|
||||
(generalize (tc-literal l #f))))])]
|
||||
[(~var i (3d hash?))
|
||||
(match expected
|
||||
|
|
|
|||
|
|
@ -17,19 +17,19 @@
|
|||
[(tc-any-results:) (make-AnyValues)]
|
||||
[(tc-results: ts fs os dty dbound)
|
||||
(make-ValuesDots
|
||||
(for/list ([t ts] [f fs] [o os])
|
||||
(for/list ([t (in-list ts)] [f (in-list fs)] [o (in-list os)])
|
||||
(make-Result t (abstract-filter arg-names keys f) (abstract-object arg-names keys o)))
|
||||
dty dbound)]
|
||||
[(tc-results: ts fs os)
|
||||
(make-Values
|
||||
(for/list ([t ts] [f fs] [o os])
|
||||
(for/list ([t (in-list ts)] [f (in-list fs)] [o (in-list os)])
|
||||
(make-Result t (abstract-filter arg-names keys f) (abstract-object arg-names keys o))))]))
|
||||
|
||||
|
||||
(define/cond-contract (abstract-object ids keys o)
|
||||
(-> (listof identifier?) (listof name-ref/c) Object? Object?)
|
||||
(define (lookup y)
|
||||
(for/first ([x ids] [i keys] #:when (free-identifier=? x y)) i))
|
||||
(for/first ([x (in-list ids)] [i (in-list keys)] #:when (free-identifier=? x y)) i))
|
||||
(define-match-expander lookup:
|
||||
(syntax-rules ()
|
||||
[(_ i) (app lookup (? values i))]))
|
||||
|
|
@ -49,7 +49,7 @@
|
|||
((listof identifier?) (listof name-ref/c) Filter/c . -> . Filter/c)
|
||||
(define/cond-contract (lookup y)
|
||||
(identifier? . -> . (or/c #f integer?))
|
||||
(for/first ([x xs] [i idxs] #:when (free-identifier=? x y)) i))
|
||||
(for/first ([x (in-list xs)] [i (in-list idxs)] #:when (free-identifier=? x y)) i))
|
||||
(define-match-expander lookup:
|
||||
(syntax-rules ()
|
||||
[(_ i) (or (? identifier? (app lookup (? values i)))
|
||||
|
|
@ -119,7 +119,7 @@
|
|||
[(AndFilter: ps) (loop derived-props derived-atoms (append ps (cdr worklist)))]
|
||||
[(ImpFilter: a c)
|
||||
;(printf "combining ~a with ~a\n" p (append derived-props derived-atoms))
|
||||
(if (for/or ([p (append derived-props derived-atoms)])
|
||||
(if (for/or ([p (in-list (append derived-props derived-atoms))])
|
||||
(implied-atomic? a p))
|
||||
(loop derived-props derived-atoms (cons c (cdr worklist)))
|
||||
(loop (cons p derived-props) derived-atoms (cdr worklist)))]
|
||||
|
|
|
|||
|
|
@ -195,7 +195,7 @@
|
|||
(add-struct-constructor! (struct-names-constructor names))
|
||||
|
||||
(define def-bindings
|
||||
(for/list ([b bindings])
|
||||
(for/list ([b (in-list bindings)])
|
||||
(define id (car b))
|
||||
(define t (cdr b))
|
||||
(register-type id t)
|
||||
|
|
@ -223,7 +223,7 @@
|
|||
(define tvarss (map (compose struct-desc-tvars parsed-struct-desc) parsed-structs))
|
||||
(let loop ()
|
||||
(define sames
|
||||
(for/list ((sty stys) (tvars tvarss))
|
||||
(for/list ((sty (in-list stys)) (tvars (in-list tvarss)))
|
||||
(cond
|
||||
((null? tvars) #t)
|
||||
(else
|
||||
|
|
|
|||
|
|
@ -235,7 +235,7 @@
|
|||
[(define-values (var ...) expr)
|
||||
(let* ([vars (syntax->list #'(var ...))]
|
||||
[ts (map lookup-type vars)])
|
||||
(unless (for/and ([v (syntax->list #'(var ...))])
|
||||
(unless (for/and ([v (in-list (syntax->list #'(var ...)))])
|
||||
(free-id-table-ref unann-defs v (lambda _ #f)))
|
||||
(when (= 1 (length vars))
|
||||
(add-scoped-tvars #'expr (lookup-scoped-tvars (first vars))))
|
||||
|
|
@ -311,7 +311,7 @@
|
|||
(resolve-type-aliases parse-type)
|
||||
;; Parse and register the structure types
|
||||
(define parsed-structs
|
||||
(for/list ((def struct-defs))
|
||||
(for/list ((def (in-list struct-defs)))
|
||||
(define parsed (parse-define-struct-internal def))
|
||||
(register-parsed-struct-sty! parsed)
|
||||
parsed))
|
||||
|
|
@ -354,7 +354,7 @@
|
|||
(~datum expand)))))
|
||||
(syntax-parse p #:literals (#%provide)
|
||||
[(#%provide form ...)
|
||||
(for/fold ([h h]) ([f (syntax->list #'(form ...))])
|
||||
(for/fold ([h h]) ([f (in-list (syntax->list #'(form ...)))])
|
||||
(parameterize ([current-orig-stx f])
|
||||
(syntax-parse f
|
||||
[i:id
|
||||
|
|
@ -418,7 +418,7 @@
|
|||
;; Don't open up `begin`s that are supposed to be ignored
|
||||
#:when (not (or (ignore-property form) (ignore-some-property form)))
|
||||
(define result
|
||||
(for/last ([form (syntax->list #'(e ...))])
|
||||
(for/last ([form (in-list (syntax->list #'(e ...)))])
|
||||
(define-values (_ result) (tc-toplevel-form form))
|
||||
result))
|
||||
(begin0 (values #f (or result (void)))
|
||||
|
|
|
|||
|
|
@ -70,14 +70,14 @@
|
|||
(c:-> (c:listof Type/c) (c:or/c Type/c Values?))
|
||||
(match args
|
||||
;[(list t) t]
|
||||
[_ (make-Values (for/list ([i args]) (-result i)))]))
|
||||
[_ (make-Values (for/list ([i (in-list args)]) (-result i)))]))
|
||||
|
||||
;; convenient constructor for ValuesDots
|
||||
;; (wraps arg types with Result)
|
||||
(define/cond-contract (-values-dots args dty dbound)
|
||||
(c:-> (c:listof Type/c) Type/c (c:or/c symbol? c:natural-number/c)
|
||||
ValuesDots?)
|
||||
(make-ValuesDots (for/list ([i args]) (-result i))
|
||||
(make-ValuesDots (for/list ([i (in-list args)]) (-result i))
|
||||
dty dbound))
|
||||
|
||||
;; basic types
|
||||
|
|
|
|||
|
|
@ -35,7 +35,7 @@
|
|||
;; -lst* Type is needed by substitute for ListDots
|
||||
(define -pair make-Pair)
|
||||
(define (-lst* #:tail [tail (-val null)] . args)
|
||||
(for/fold ([tl tail]) ([a (reverse args)]) (-pair a tl)))
|
||||
(for/fold ([tl tail]) ([a (in-list (reverse args))]) (-pair a tl)))
|
||||
|
||||
|
||||
;; Simple union type, does not check for overlaps
|
||||
|
|
@ -206,7 +206,7 @@
|
|||
(with-syntax ([((extra ...) ...)
|
||||
(for/list ([i (in-range (add1 (length l)))])
|
||||
(take l i))]
|
||||
[(rsts ...) (for/list ([i (add1 (length l))]) #'rst)])
|
||||
[(rsts ...) (for/list ([i (in-range (add1 (length l)))]) #'rst)])
|
||||
#'(make-Function
|
||||
(list
|
||||
(make-arr* (list ty ... extra ...)
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@
|
|||
(int-err "drest passed to kw-convert"))
|
||||
|
||||
(define arities
|
||||
(for/list ([i (length opt-t)])
|
||||
(for/list ([i (in-range (length opt-t))])
|
||||
(make-arr* (append plain-t (take opt-t i))
|
||||
rng
|
||||
#:kws kw-t
|
||||
|
|
@ -21,7 +21,7 @@
|
|||
(define ts
|
||||
(flatten
|
||||
(list
|
||||
(for/list ([k mand-kw-t])
|
||||
(for/list ([k (in-list mand-kw-t)])
|
||||
(match k
|
||||
[(Keyword: _ t _) t]))
|
||||
(for/list ([k (in-list opt-kw-t)])
|
||||
|
|
@ -35,7 +35,7 @@
|
|||
(define ts/true
|
||||
(flatten
|
||||
(list
|
||||
(for/list ([k mand-kw-t])
|
||||
(for/list ([k (in-list mand-kw-t)])
|
||||
(match k
|
||||
[(Keyword: _ t _) t]))
|
||||
(for/list ([k (in-list opt-kw-t)])
|
||||
|
|
@ -49,7 +49,7 @@
|
|||
(define ts/false
|
||||
(flatten
|
||||
(list
|
||||
(for/list ([k mand-kw-t])
|
||||
(for/list ([k (in-list mand-kw-t)])
|
||||
(match k
|
||||
[(Keyword: _ t _) t]))
|
||||
(for/list ([k (in-list opt-kw-t)])
|
||||
|
|
@ -79,7 +79,7 @@
|
|||
[(_ _) #f]))
|
||||
(define (kw-equal? a b)
|
||||
(and (equal? (length a) (length b))
|
||||
(for/and ([k1 a] [k2 b])
|
||||
(for/and ([k1 (in-list a)] [k2 (in-list b)])
|
||||
(type-equal? k1 k2))))
|
||||
(match* (a b)
|
||||
[((arr: args result rest drest kws)
|
||||
|
|
@ -89,7 +89,7 @@
|
|||
(drest-equal? drest drest*)
|
||||
(type-equal? result result*)
|
||||
(kw-equal? kws kws*)
|
||||
(for/and ([p args] [p* args*])
|
||||
(for/and ([p (in-list args)] [p* (in-list args*)])
|
||||
(type-equal? p p*)))]))
|
||||
|
||||
(define (arity-length a)
|
||||
|
|
|
|||
|
|
@ -160,7 +160,7 @@
|
|||
(define-values (next _)
|
||||
(for/fold ([next (car candidates)]
|
||||
[max-cover (covers-how-many? (car candidates))])
|
||||
([c candidates])
|
||||
([c (in-list candidates)])
|
||||
(let ([how-many? (covers-how-many? c)])
|
||||
(if (> how-many? max-cover)
|
||||
(values c how-many?)
|
||||
|
|
@ -183,7 +183,7 @@
|
|||
(fp "-> ~a" ret)))
|
||||
(fp "(")
|
||||
(for-each (lambda (t) (fp "~a " t)) dom)
|
||||
(for ([kw kws])
|
||||
(for ([kw (in-list kws)])
|
||||
(match kw
|
||||
[(Keyword: k t req?)
|
||||
(if req?
|
||||
|
|
@ -206,7 +206,7 @@
|
|||
(if (null? pth)
|
||||
(fp "-> ~a : ~a" t ft)
|
||||
(begin (fp "-> ~a : ~a @" t ft)
|
||||
(for ([pe pth]) (fp " ~a" pe))))]
|
||||
(for ([pe (in-list pth)]) (fp " ~a" pe))))]
|
||||
[(Values: (list (Result: t fs (Empty:))))
|
||||
(fp/filter "-> ~a : ~a" t fs)]
|
||||
[(Values: (list (Result: t lf lo)))
|
||||
|
|
|
|||
|
|
@ -86,7 +86,7 @@
|
|||
[(list (Struct: n _ flds _ _ _)
|
||||
(Struct: n* _ flds* _ _ _)) (=> nevermind)
|
||||
(unless (free-identifier=? n n*) (nevermind))
|
||||
(for/and ([f flds] [f* flds*])
|
||||
(for/and ([f (in-list flds)] [f* (in-list flds*)])
|
||||
(match* (f f*)
|
||||
[((fld: t _ _) (fld: t* _ _)) (overlap t t*)]))]
|
||||
[(list (Struct: n #f _ _ _ _)
|
||||
|
|
|
|||
|
|
@ -98,7 +98,7 @@
|
|||
;; We need to recur first, just to expand out any dotted usages of this.
|
||||
(let ([expanded (sb dty)])
|
||||
(for/fold ([t (make-Value null)])
|
||||
([img (reverse images)])
|
||||
([img (in-list (reverse images))])
|
||||
(make-Pair (substitute img name expanded) t)))
|
||||
(make-ListDots (sb dty) dbound))]
|
||||
[#:ValuesDots types dty dbound
|
||||
|
|
@ -108,7 +108,7 @@
|
|||
(map sb types)
|
||||
;; We need to recur first, just to expand out any dotted usages of this.
|
||||
(let ([expanded (sb dty)])
|
||||
(for/list ([img images])
|
||||
(for/list ([img (in-list images)])
|
||||
(make-Result
|
||||
(substitute img name expanded)
|
||||
(make-FilterSet (make-Top) (make-Top))
|
||||
|
|
|
|||
|
|
@ -66,10 +66,10 @@
|
|||
[(_ init (s:sub* . args) ...+)
|
||||
(with-syntax ([(A* ... A-last) (generate-temporaries #'(s ...))])
|
||||
(with-syntax ([(clauses ...)
|
||||
(for/list ([s (syntax->list #'(s ...))]
|
||||
[args (syntax->list #'(args ...))]
|
||||
[A (syntax->list #'(init A* ...))]
|
||||
[A-next (syntax->list #'(A* ... A-last))])
|
||||
(for/list ([s (in-list (syntax->list #'(s ...)))]
|
||||
[args (in-list (syntax->list #'(args ...)))]
|
||||
[A (in-list (syntax->list #'(init A* ...)))]
|
||||
[A-next (in-list (syntax->list #'(A* ... A-last)))])
|
||||
#`[#,A-next (#,s #,A . #,args)])])
|
||||
(syntax/loc stx (let*/and (clauses ...)
|
||||
A-last))))]))
|
||||
|
|
@ -322,7 +322,7 @@
|
|||
[((Base: _ _ _ _ #t) (Sequence: (list t*)))
|
||||
(define type
|
||||
;; FIXME: thread the store through here
|
||||
(for/or ((t (list -Byte -Index -NonNegFixnum -Nat)))
|
||||
(for/or ((t (in-list (list -Byte -Index -NonNegFixnum -Nat))))
|
||||
(or (and (subtype* A0 s t) t))))
|
||||
(if type
|
||||
(subtype* A0 type t*)
|
||||
|
|
@ -487,11 +487,11 @@
|
|||
[((Vector: _) (VectorTop:)) A0]
|
||||
[((HeterogeneousVector: _) (VectorTop:)) A0]
|
||||
[((HeterogeneousVector: (list e ...)) (Vector: e*))
|
||||
(for/fold ((A A0)) ((e e) #:break (not A))
|
||||
(for/fold ((A A0)) ((e (in-list e)) #:break (not A))
|
||||
(and A (type-equiv? A e e*)))]
|
||||
[((HeterogeneousVector: (list s* ...)) (HeterogeneousVector: (list t* ...)))
|
||||
(if (= (length s*) (length t*))
|
||||
(for/fold ((A A0)) ((s s*) (t t*) #:break (not A))
|
||||
(for/fold ((A A0)) ((s (in-list s*)) (t (in-list t*)) #:break (not A))
|
||||
(type-equiv? A s t))
|
||||
#f)]
|
||||
[((MPair: s1 s2) (MPair: t1 t2))
|
||||
|
|
@ -546,7 +546,7 @@
|
|||
[((Class: '() '() (list (and s (list names meths )) ...))
|
||||
(Class: '() '() (list (and s* (list names* meths*)) ...)))
|
||||
(for/fold ([A A0])
|
||||
([n names*] [m meths*] #:break (not A))
|
||||
([n (in-list names*)] [m (in-list meths*)] #:break (not A))
|
||||
(and A (cond [(assq n s) => (lambda (spec) (subtype* A (cadr spec) m))]
|
||||
[else #f])))]
|
||||
;; otherwise, not a subtype
|
||||
|
|
|
|||
|
|
@ -72,15 +72,15 @@
|
|||
(cond [(Type/c? t)
|
||||
(list (make-tc-result t (mk t) (make-Empty)))]
|
||||
[else
|
||||
(for/list ([i t])
|
||||
(for/list ([i (in-list t)])
|
||||
(make-tc-result i (mk t) (make-Empty)))])
|
||||
#f))]
|
||||
[(t f)
|
||||
(make-tc-results
|
||||
(if (Type/c? t)
|
||||
(list (make-tc-result t f (make-Empty)))
|
||||
(for/list ([i t] [f f])
|
||||
(make-tc-result i f (make-Empty))))
|
||||
(for/list ([i (in-list t)] [f (in-list f)])
|
||||
(make-tc-result i f (make-Empty))))
|
||||
#f)]
|
||||
[(t f o)
|
||||
(make-tc-results
|
||||
|
|
|
|||
|
|
@ -92,7 +92,7 @@ don't depend on any other portion of the system
|
|||
(raise-typecheck-error msg stx)]
|
||||
[l
|
||||
(let ([stxs
|
||||
(for/list ([e l])
|
||||
(for/list ([e (in-list l)])
|
||||
(with-handlers ([exn:fail:syntax?
|
||||
(λ (e) ((error-display-handler) (exn-message e) e))])
|
||||
(raise-typecheck-error (err-msg e) (err-stx e)))
|
||||
|
|
@ -126,7 +126,7 @@ don't depend on any other portion of the system
|
|||
;; vars and such don't confuse the user.
|
||||
(cond
|
||||
[(or (not (orig-module-stx))
|
||||
(for/and ([s ostxs])
|
||||
(for/and ([s (in-list ostxs)])
|
||||
(eq? (syntax-source s) (syntax-source (orig-module-stx)))))
|
||||
(raise-typecheck-error (apply format msg rest) stxs)]
|
||||
[else (raise-typecheck-error
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user