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

Make for loops in TR use an annotation when applicable.

Browse Source
This commit is contained in:
Eric Dobson 2013-05-24 20:56:40 -07:00
parent 4310f04eaf
commit f6050d5587
42 changed files with 152 additions and 143 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
collects/typed-racket/base-env/base-env-numeric.rkt
View File

@ -93,10 +93,11 @@
-RealZero -NonNegReal -NonPosReal -Real))))) -RealZero -NonNegReal -NonPosReal -Real)))))
(define (inexact-zero->exact-zero-type) (define (inexact-zero->exact-zero-type)
(for/list ([t (list -FlonumPosZero -FlonumNegZero -FlonumZero (for/list ([t (in-list
-SingleFlonumPosZero -SingleFlonumNegZero -SingleFlonumZero (list -FlonumPosZero -FlonumNegZero -FlonumZero
-InexactRealPosZero -InexactRealNegZero -InexactRealZero -SingleFlonumPosZero -SingleFlonumNegZero -SingleFlonumZero
-RealZero)]) -InexactRealPosZero -InexactRealNegZero -InexactRealZero
-RealZero))])
(-> t -Zero))) (-> t -Zero)))
(define (exact-round-type) ; also used for exact-truncate (define (exact-round-type) ; also used for exact-truncate

2
collects/typed-racket/base-env/colon.rkt
View File

@ -13,7 +13,7 @@
;; explicitly parenthesized ;; explicitly parenthesized
(syntax-parse stx #:literals (: t:->) (syntax-parse stx #:literals (: t:->)
[(: id (~and kw :) x ...) [(: 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 (identifier? i)
#:when (free-identifier=? i #'t:->)) #:when (free-identifier=? i #'t:->))
i) i)

4
collects/typed-racket/env/tvar-env.rkt vendored
View File

@ -59,7 +59,7 @@
;; extend/many : type-env list<symbol> option<list<symbol>> -> type-env ;; extend/many : type-env list<symbol> option<list<symbol>> -> type-env
;; extend type environment for many symbols ;; extend type environment for many symbols
(define (extend/many env vars [fresh-vars #f]) (define (extend/many env vars [fresh-vars #f])
(let ([fresh-vars (or fresh-vars (for/list ([_ vars]) #f))]) (let ([fresh-vars (or fresh-vars (for/list ([_ (in-list vars)]) #f))])
(for/fold ([env env]) ([var vars] [fresh-var fresh-vars]) (for/fold ([env env]) ([var (in-list vars)] [fresh-var (in-list fresh-vars)])
(extend env var fresh-var)))) (extend env var fresh-var))))

4
collects/typed-racket/infer/constraints.rkt
View File

@ -31,7 +31,7 @@
;; index variables Y. For now, we add the widest constraints for ;; index variables Y. For now, we add the widest constraints for
;; variables in X to the cmap and create an empty dmap. ;; variables in X to the cmap and create an empty dmap.
(define (empty-cset X Y) (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)))))) (make-dmap (make-immutable-hash null))))))
@ -82,7 +82,7 @@
(define (cset-meet* args) (define (cset-meet* args)
(for/fold ([c (make-cset (list (cons (make-immutable-hash null) (for/fold ([c (make-cset (list (cons (make-immutable-hash null)
(make-dmap (make-immutable-hash null)))))]) (make-dmap (make-immutable-hash null)))))])
([a args]) ([a (in-list args)])
(cset-meet a c))) (cset-meet a c)))
(define (cset-combine l) (define (cset-combine l)

14
collects/typed-racket/infer/dmap.rkt
View File

@ -18,8 +18,8 @@
(unless (and rest2 (= (length fixed1) (length fixed2))) (unless (and rest2 (= (length fixed1) (length fixed2)))
(fail! fixed1 fixed2)) (fail! fixed1 fixed2))
(make-dcon-exact (make-dcon-exact
(for/list ([c1 fixed1] (for/list ([c1 (in-list fixed1)]
[c2 fixed2]) [c2 (in-list fixed2)])
(c-meet c1 c2 (c-X c1))) (c-meet c1 c2 (c-X c1)))
(c-meet rest1 rest2 (c-X rest1)))] (c-meet rest1 rest2 (c-X rest1)))]
;; redo in the other order to call the first case ;; redo in the other order to call the first case
@ -29,15 +29,15 @@
(unless (= (length fixed1) (length fixed2)) (unless (= (length fixed1) (length fixed2))
(fail! fixed1 fixed2)) (fail! fixed1 fixed2))
(make-dcon (make-dcon
(for/list ([c1 fixed1] (for/list ([c1 (in-list fixed1)]
[c2 fixed2]) [c2 (in-list fixed2)])
(c-meet c1 c2 (c-X c1))) (c-meet c1 c2 (c-X c1)))
#f)] #f)]
[((struct dcon (fixed1 #f)) (struct dcon (fixed2 rest))) [((struct dcon (fixed1 #f)) (struct dcon (fixed2 rest)))
(unless (>= (length fixed1) (length fixed2)) (unless (>= (length fixed1) (length fixed2))
(fail! fixed1 fixed2)) (fail! fixed1 fixed2))
(make-dcon (make-dcon
(for/list ([c1 fixed1] (for/list ([c1 (in-list fixed1)]
[c2 (in-sequence-forever fixed2 rest)]) [c2 (in-sequence-forever fixed2 rest)])
(c-meet c1 c2 (c-X c1))) (c-meet c1 c2 (c-X c1)))
#f)] #f)]
@ -49,7 +49,7 @@
(values fixed1 fixed2 rest1 rest2) (values fixed1 fixed2 rest1 rest2)
(values fixed2 fixed1 rest2 rest1))]) (values fixed2 fixed1 rest2 rest1))])
(make-dcon (make-dcon
(for/list ([c1 longer] (for/list ([c1 (in-list longer)]
[c2 (in-sequence-forever shorter srest)]) [c2 (in-sequence-forever shorter srest)])
(c-meet c1 c2 (c-X c1))) (c-meet c1 c2 (c-X c1)))
(c-meet lrest srest (c-X lrest))))] (c-meet lrest srest (c-X lrest))))]
@ -57,7 +57,7 @@
(unless (and (= (length fixed1) (length fixed2)) (unless (and (= (length fixed1) (length fixed2))
(eq? bound1 bound2)) (eq? bound1 bound2))
(fail! 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 (c-X c1)))
(c-meet c1 c2 bound1) bound1)] (c-meet c1 c2 bound1) bound1)]
[((struct dcon _) (struct dcon-dotted _)) [((struct dcon _) (struct dcon-dotted _))

40
collects/typed-racket/infer/infer-unit.rkt
View File

@ -70,7 +70,7 @@
(cset? symbol? (listof symbol?) . -> . cset?) (cset? symbol? (listof symbol?) . -> . cset?)
(mover cset dbound vars (mover cset dbound vars
(λ (cmap dmap) (λ (cmap dmap)
(make-dcon (for/list ([v vars]) (make-dcon (for/list ([v (in-list vars)])
(hash-ref cmap v (hash-ref cmap v
(λ () (int-err "No constraint for new var ~a" v)))) (λ () (int-err "No constraint for new var ~a" v))))
#f)))) #f))))
@ -110,7 +110,7 @@
(mover cset dbound vars (mover cset dbound vars
(λ (cmap dmap) (λ (cmap dmap)
((if exact? make-dcon-exact make-dcon) ((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)))) (hash-ref cmap v (λ () (int-err "No constraint for new var ~a" v))))
(match (hash-ref (dmap-map dmap) dbound (match (hash-ref (dmap-map dmap) dbound
(λ () (int-err "No constraint for bound ~a" dbound))) (λ () (int-err "No constraint for bound ~a" dbound)))
@ -206,7 +206,7 @@
(unless (<= (length ss) (length ts)) (unless (<= (length ss) (length ts))
(fail! ss ts)) (fail! ss ts))
(let* ([vars (var-store-take dbound dty (- (length ts) (length ss)))] (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))] (substitute (make-F var) dbound dty))]
[new-s-arr (make-arr (append ss new-tys) s #f #f null)] [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)]) [new-cset (cgen/arr V (append vars X) Y new-s-arr t-arr)])
@ -219,7 +219,7 @@
(unless (<= (length ts) (length ss)) (unless (<= (length ts) (length ss))
(fail! ss ts)) (fail! ss ts))
(let* ([vars (var-store-take dbound dty (- (length ss) (length 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))] (substitute (make-F var) dbound dty))]
[new-t-arr (make-arr (append ts new-tys) t #f #f null)] [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)]) [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))) (cset-meet* (list arg-mapping darg-mapping ret-mapping)))
;; the hard case ;; the hard case
(let* ([vars (var-store-take dbound t-dty (- (length ss) (length ts)))] (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))] (substitute (make-F var) dbound t-dty))]
[new-t-arr (make-arr (append ts new-tys) t #f (cons t-dty dbound) null)] [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)]) [new-cset (cgen/arr V (append vars X) Y s-arr new-t-arr)])
@ -283,7 +283,7 @@
(cond [(< (length ss) (length ts)) (cond [(< (length ss) (length ts))
;; the hard case ;; the hard case
(let* ([vars (var-store-take dbound s-dty (- (length ts) (length ss)))] (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))] (substitute (make-F var) dbound s-dty))]
[new-s-arr (make-arr (append ss new-tys) s #f (cons s-dty dbound) null)] [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)]) [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)))] (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 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))] (substitute (make-F var) dbound s-dty))]
;; generate constraints on the prefixes, and on the dummy types ;; generate constraints on the prefixes, and on the dummy types
[new-cset (cgen/list V (append vars X) Y (append ss new-tys) ts)]) [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)] [((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 ;; 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 ;; 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 ;; FIXME: we're using multiple csets here, but I don't think it makes a difference
@ -425,7 +425,7 @@
[(S (Union: es)) [(S (Union: es))
(cset-combine (cset-combine
(filter values (filter values
(for/list ([e es]) (for/list ([e (in-list es)])
(with-handlers ([exn:infer? (λ _ #f)]) (cg S e)))))] (with-handlers ([exn:infer? (λ _ #f)]) (cg S e)))))]
;; two structs with the same name ;; two structs with the same name
@ -488,14 +488,14 @@
(list portable-fixnum? -NonNegFixnum) (list portable-fixnum? -NonNegFixnum)
(list values -Nat))) (list values -Nat)))
(define type (define type
(for/or ((pred-type possibilities)) (for/or ([pred-type (in-list possibilities)])
(match pred-type (match pred-type
((list pred? type) ((list pred? type)
(and (pred? n) type))))) (and (pred? n) type)))))
(cg type t*)] (cg type t*)]
[((Base: _ _ _ _ #t) (Sequence: (list t*))) [((Base: _ _ _ _ #t) (Sequence: (list t*)))
(define type (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))) (and (subtype S t) t)))
(if type (if type
(cg type t*) (cg type t*)
@ -529,7 +529,7 @@
(let* ([vars (var-store-take dbound s-dty (length ts))] (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 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))] (substitute (make-F var) dbound s-dty))]
;; generate constraints on the prefixes, and on the dummy types ;; generate constraints on the prefixes, and on the dummy types
[new-cset (cgen/list V (append vars X) Y new-tys ts)]) [new-cset (cgen/list V (append vars X) Y new-tys ts)])
@ -604,10 +604,10 @@
[((Function: (list s-arr ...)) [((Function: (list s-arr ...))
(Function: (list t-arr ...))) (Function: (list t-arr ...)))
(cset-meet* (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 ;; for each element of t-arr, we need to get at least one element of s-arr that works
(let ([results (filter values (let ([results (filter values
(for/list ([s-arr s-arr]) (for/list ([s-arr (in-list s-arr)])
(with-handlers ([exn:infer? (lambda (_) #f)]) (with-handlers ([exn:infer? (lambda (_) #f)])
(cgen/arr V X Y s-arr t-arr))))]) (cgen/arr V X Y s-arr t-arr))))])
;; ensure that something produces a constraint set ;; ensure that something produces a constraint set
@ -692,26 +692,26 @@
(constraint->type f idx-hash #:variable k))))] (constraint->type f idx-hash #:variable k))))]
[(dcon fixed rest) [(dcon fixed rest)
(values k (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 f idx-hash #:variable k))
(constraint->type rest idx-hash)))] (constraint->type rest idx-hash)))]
[(dcon-exact fixed rest) [(dcon-exact fixed rest)
(values k (values k
(i-subst/starred (i-subst/starred
(for/list ([f fixed]) (for/list ([f (in-list fixed)])
(constraint->type f idx-hash #:variable k)) (constraint->type f idx-hash #:variable k))
(constraint->type rest idx-hash)))] (constraint->type rest idx-hash)))]
[(dcon-dotted fixed dc dbound) [(dcon-dotted fixed dc dbound)
(values k (values k
(i-subst/dotted (i-subst/dotted
(for/list ([f fixed]) (for/list ([f (in-list fixed)])
(constraint->type f idx-hash #:variable k)) (constraint->type f idx-hash #:variable k))
(constraint->type dc idx-hash #:variable k) (constraint->type dc idx-hash #:variable k)
dbound))])) dbound))]))
(for/hash ([(k v) (in-hash cmap)]) (for/hash ([(k v) (in-hash cmap)])
(values k (t-subst (constraint->type v var-hash)))))]) (values k (t-subst (constraint->type v var-hash)))))])
;; verify that we got all the important variables ;; 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)]) (let ([entry (hash-ref subst v #f)])
;; Make sure we got a subst entry for a type var ;; Make sure we got a subst entry for a type var
;; (i.e. just a type to substitute) ;; (i.e. just a type to substitute)
@ -733,7 +733,7 @@
(unless (= (length S) (length T)) (unless (= (length S) (length T))
(fail! S T)) (fail! S T))
(cset-meet* (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. ;; We meet early to prune the csets to a reasonable size.
;; This weakens the inference a bit, but sometimes avoids ;; This weakens the inference a bit, but sometimes avoids
;; constraint explosion. ;; constraint explosion.
@ -784,7 +784,7 @@
[cs-short (cgen/list null X (list dotted-var) short-S T [cs-short (cgen/list null X (list dotted-var) short-S T
#:expected-cset expected-cset)] #:expected-cset expected-cset)]
[new-vars (var-store-take dotted-var T-dotted (length rest-S))] [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 (make-F v) dotted-var
(substitute-dots (map make-F new-vars) #f dotted-var T-dotted)))] (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 [cs-dotted (cgen/list null (append new-vars X) (list dotted-var) rest-S new-Ts

18
collects/typed-racket/infer/promote-demote.rkt
View File

@ -10,7 +10,7 @@
(export promote-demote^) (export promote-demote^)
(define (V-in? V . ts) (define (V-in? V . ts)
(for/or ([e (append* (map fv ts))]) (for/or ([e (in-list (append* (map fv ts)))])
(memq e V))) (memq e V)))
(define (get-filters rng) (define (get-filters rng)
@ -39,19 +39,19 @@
[(apply V-in? V (get-filters rng)) [(apply V-in? V (get-filters rng))
(make-top-arr)] (make-top-arr)]
[(and drest (memq (cdr drest) V)) [(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) (vp rng)
(var-demote (car drest) V) (var-demote (car drest) V)
#f #f
(for/list ([k kws]) (var-demote k V)))] (for/list ([k (in-list kws)]) (var-demote k V)))]
[else [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) (vp rng)
(and rest (var-demote rest V)) (and rest (var-demote rest V))
(and drest (and drest
(cons (var-demote (car drest) V) (cons (var-demote (car drest) V)
(cdr drest))) (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 (var-demote T V)
(define (vd t) (var-demote t V)) (define (vd t) (var-demote t V))
@ -74,16 +74,16 @@
[(apply V-in? V (get-filters rng)) [(apply V-in? V (get-filters rng))
(make-top-arr)] (make-top-arr)]
[(and drest (memq (cdr drest) V)) [(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) (vd rng)
(var-promote (car drest) V) (var-promote (car drest) V)
#f #f
(for/list ([k kws]) (var-demote k V)))] (for/list ([k (in-list kws)]) (var-demote k V)))]
[else [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) (vd rng)
(and rest (var-promote rest V)) (and rest (var-promote rest V))
(and drest (and drest
(cons (var-promote (car drest) V) (cons (var-promote (car drest) V)
(cdr drest))) (cdr drest)))
(for/list ([k kws]) (var-demote k V)))])])) (for/list ([k (in-list kws)]) (var-demote k V)))])]))

4
collects/typed-racket/optimizer/optimizer.rkt
View File

@ -83,8 +83,8 @@
#,@(syntax-map (optimize) #'(e-body ...))))) #,@(syntax-map (optimize) #'(e-body ...)))))
(pattern (kw:identifier expr ...) (pattern (kw:identifier expr ...)
#:when #:when
(for/or ([k (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression (for/or ([k (in-list (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression
#'#%variable-reference #'with-continuation-mark)]) #'#%variable-reference #'with-continuation-mark))])
(free-identifier=? k #'kw)) (free-identifier=? k #'kw))
;; we don't want to optimize in the cases that don't match the #:when clause ;; we don't want to optimize in the cases that don't match the #:when clause
#:with opt (quasisyntax/loc/origin this-syntax #'kw #:with opt (quasisyntax/loc/origin this-syntax #'kw

4
collects/typed-racket/optimizer/utils.rkt
View File

@ -36,7 +36,7 @@
;; generates a table matching safe to unsafe promitives ;; generates a table matching safe to unsafe promitives
(define (mk-unsafe-tbl generic safe-pattern unsafe-pattern) (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)]) (let ([f (format-id g safe-pattern g)] [u (format-id g unsafe-pattern g)])
(dict-set (dict-set h g u) f u)))) (dict-set (dict-set h g u) f u))))
@ -44,7 +44,7 @@
;; this works on operations that are (A A -> A) ;; this works on operations that are (A A -> A)
(define (n-ary->binary op arg1 arg2 rest) (define (n-ary->binary op arg1 arg2 rest)
(for/fold ([o arg1]) (for/fold ([o arg1])
([e (syntax->list #`(#,arg2 #,@rest))]) ([e (in-list (syntax->list #`(#,arg2 #,@rest)))])
#`(#,op #,o #,e))) #`(#,op #,o #,e)))
;; this works on operations that are (A A -> B) ;; this works on operations that are (A A -> B)
(define (n-ary-comp->binary op arg1 arg2 rest) (define (n-ary-comp->binary op arg1 arg2 rest)

2
collects/typed-racket/private/parse-type.rkt
View File

@ -45,7 +45,7 @@
(pattern (type)) (pattern (type))
(pattern (x ...) (pattern (x ...)
#:fail-unless (= 1 (length #:fail-unless (= 1 (length
(for/list ([i (syntax->list #'(x ...))] (for/list ([i (in-list (syntax->list #'(x ...)))]
#:when (and (identifier? i) #:when (and (identifier? i)
(free-identifier=? i #'t:->))) (free-identifier=? i #'t:->)))
i))) #f i))) #f

7
collects/typed-racket/private/type-annotation.rkt
View File

@ -108,8 +108,8 @@
((listof identifier?) syntax? (syntax? . -> . tc-results/c) (syntax? tc-results/c . -> . tc-results/c) . -> . tc-results/c) ((listof identifier?) syntax? (syntax? . -> . tc-results/c) (syntax? tc-results/c . -> . tc-results/c) . -> . tc-results/c)
(match stxs (match stxs
[(list stx ...) [(list stx ...)
(let ([anns (for/list ([s stxs]) (type-annotation s #:infer #t))]) (let ([anns (for/list ([s (in-list stxs)]) (type-annotation s #:infer #t))])
(if (for/and ([a anns]) a) (if (for/and ([a (in-list anns)]) a)
(tc-expr/check expr (ret anns)) (tc-expr/check expr (ret anns))
(let ([ty (tc-expr expr)]) (let ([ty (tc-expr expr)])
(match ty (match ty
@ -126,7 +126,8 @@
(length stxs) (length tys) (stringify tys)) (length stxs) (length tys) (stringify tys))
(ret (map (lambda _ (Un)) stxs))) (ret (map (lambda _ (Un)) stxs)))
(combine-results (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)] (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 ;; mutated variables get generalized, so that we don't infer too small a type
[(is-var-mutated? stx) (ret (generalize ty) f o)] [(is-var-mutated? stx) (ret (generalize ty) f o)]

16
collects/typed-racket/private/type-contract.rkt
View File

@ -98,7 +98,7 @@
((equal? chaperone-sym x) y) ((equal? chaperone-sym x) y)
((equal? chaperone-sym y) x) ((equal? chaperone-sym y) x)
(else impersonator-sym))) (else impersonator-sym)))
(for/fold ((acc i)) ((v args)) (for/fold ((acc i)) ((v (in-list args)))
(contract-kind-max2 v acc))) (contract-kind-max2 v acc)))
(define (contract-kind-min i . args) (define (contract-kind-min i . args)
@ -109,7 +109,7 @@
((equal? chaperone-sym x) x) ((equal? chaperone-sym x) x)
((equal? chaperone-sym y) y) ((equal? chaperone-sym y) y)
(else impersonator-sym))) (else impersonator-sym)))
(for/fold ((acc i)) ((v args)) (for/fold ((acc i)) ((v (in-list args)))
(contract-kind-min2 v acc))) (contract-kind-min2 v acc)))
@ -245,7 +245,7 @@
#'(dom* ... rst-spec ... . -> . rng*) #'(dom* ... rst-spec ... . -> . rng*)
#'((dom* ...) (opt-dom* ...) rst-spec ... . ->* . rng*)) #'((dom* ...) (opt-dom* ...) rst-spec ... . ->* . rng*))
#'(dom* ... . -> . rng*))))) #'(dom* ... . -> . rng*)))))
(unless (no-duplicates (for/list ([t arrs]) (unless (no-duplicates (for/list ([t (in-list arrs)])
(match t (match t
[(arr: dom _ _ _ _) (length dom)] [(arr: dom _ _ _ _) (length dom)]
;; is there something more sensible here? ;; is there something more sensible here?
@ -377,7 +377,7 @@
[(Poly: vs b) [(Poly: vs b)
(if (not (from-untyped? typed-side)) (if (not (from-untyped? typed-side))
;; in typed positions, no checking needed for the variables ;; 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)) (t->c b))
;; in untyped positions, use `parameteric/c' ;; in untyped positions, use `parameteric/c'
(match-let ([(Poly-names: vs-nm _) ty]) (match-let ([(Poly-names: vs-nm _) ty])
@ -402,15 +402,15 @@
(t->c (make-Instance (resolve-once t)))] (t->c (make-Instance (resolve-once t)))]
[(Instance: (Class: _ _ (list (list name fcn) ...))) [(Instance: (Class: _ _ (list (list name fcn) ...)))
(set-impersonator!) (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]) [(names ...) name])
#'(object/c (names fcn-cnts) ...))] #'(object/c (names fcn-cnts) ...))]
;; init args not currently handled by class/c ;; init args not currently handled by class/c
[(Class: _ (list (list by-name-init by-name-init-ty _) ...) (list (list name fcn) ...)) [(Class: _ (list (list by-name-init by-name-init-ty _) ...) (list (list name fcn) ...))
(set-impersonator!) (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] [(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]) [(by-name-init ...) by-name-init])
#'(class/c (name fcn-cnt) ... (init [by-name-init by-name-cnt] ...)))] #'(class/c (name fcn-cnt) ... (init [by-name-init by-name-cnt] ...)))]
[(Value: '()) #'null?] [(Value: '()) #'null?]
@ -425,7 +425,7 @@
[poly? [poly?
(with-syntax* ([struct-ctc (generate-temporary 'struct-ctc)]) (with-syntax* ([struct-ctc (generate-temporary 'struct-ctc)])
(define field-contracts (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)]) (with-syntax* ([rec (generate-temporary 'rec)])
(define required-recursive-kind (define required-recursive-kind
(contract-kind-min kind (if mut? impersonator-sym chaperone-sym))) (contract-kind-min kind (if mut? impersonator-sym chaperone-sym)))

2
collects/typed-racket/private/with-types.rkt
View File

@ -37,7 +37,7 @@
(define fv-cnts (for/list ([t (in-list fv-types)] (define fv-cnts (for/list ([t (in-list fv-types)]
[stx (in-list (syntax->list fvtys))]) [stx (in-list (syntax->list fvtys))])
(type->contract t #:typed-side #f (no-contract t)))) (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))) (parse-type t)))
(define ex-cnts (for/list ([t (in-list ex-types)] (define ex-cnts (for/list ([t (in-list ex-types)]
[stx (in-list (syntax->list extys))]) [stx (in-list (syntax->list extys))])

8
collects/typed-racket/typecheck/check-below.rkt
View File

@ -50,7 +50,7 @@
[((tc-results: ts fs os) (tc-results: ts2 (NoFilter:) (NoObject:))) [((tc-results: ts fs os) (tc-results: ts2 (NoFilter:) (NoObject:)))
(unless (= (length ts) (length ts2)) (unless (= (length ts) (length ts2))
(tc-error/expr "Expected ~a values, but got ~a" (length ts2) (length ts))) (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))) (tc-error/expr "Expected ~a, but got ~a" (stringify ts2) (stringify ts)))
(if (= (length ts) (length ts2)) (if (= (length ts) (length ts2))
(ret ts2 fs os) (ret ts2 fs os)
@ -79,7 +79,7 @@
(unless (= (length t1) (length t2)) (unless (= (length t1) (length t2))
(tc-error/expr "Expected ~a values and ~a ..., but got ~a values" (tc-error/expr "Expected ~a values and ~a ..., but got ~a values"
(length t2) dty (length t1))) (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))) (tc-error/expr "Expected ~a, but got ~a" (stringify t2) (stringify t1)))
expected] expected]
;; case where you have (Values a ... a) but expected something else ;; case where you have (Values a ... a) but expected something else
@ -87,7 +87,7 @@
(unless (= (length t1) (length t2)) (unless (= (length t1) (length t2))
(tc-error/expr "Expected ~a values, but got ~a values and ~a ..." (tc-error/expr "Expected ~a values, but got ~a values and ~a ..."
(length t2) (length t1) dty)) (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))) (tc-error/expr "Expected ~a, but got ~a" (stringify t2) (stringify t1)))
expected] expected]
[((tc-results: t1 f o dty1 dbound) (tc-results: t2 f o dty2 dbound)) [((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)) [((tc-results: t1 fs os) (tc-results: t2 fs os))
(unless (= (length t1) (length t2)) (unless (= (length t1) (length t2))
(tc-error/expr "Expected ~a values, but got ~a" (length t2) (length t1))) (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))) (tc-error/expr "Expected ~a, but got ~a" (stringify t2) (stringify t1)))
expected] expected]
[((tc-any-results:) (or (? Type/c? t) (tc-result1: t _ _))) [((tc-any-results:) (or (? Type/c? t) (tc-result1: t _ _)))

2
collects/typed-racket/typecheck/provide-handling.rkt
View File

@ -61,7 +61,7 @@
(values #'(begin) e null))) (values #'(begin) e null)))
(list* type-desc constr pred super accs))) (list* type-desc constr pred super accs)))
(define/with-syntax (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 (values
#`(begin #`(begin
#,@defns #,@defns

2
collects/typed-racket/typecheck/tc-app-helper.rkt
View File

@ -58,7 +58,7 @@
[((arr: _ _ _ _ [((arr: _ _ _ _
;; at least one mandatory keyword ;; at least one mandatory keyword
(app (λ (kws) (app (λ (kws)
(for/or ([keyword kws]) (for/or ([keyword (in-list kws)])
(match keyword (match keyword
[(Keyword: kw _ #t) kw] [(Keyword: kw _ #t) kw]
[_ #f]))) [_ #f])))

2
collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt
View File

@ -68,7 +68,7 @@
(ret -Void)] (ret -Void)]
[(not i-val) [(not i-val)
(define val-t (single-value val-e)) (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)) (check-below val-t es-type))
(cond-check-below (ret -Void) expected)] (cond-check-below (ret -Void) expected)]
[else [else

12
collects/typed-racket/typecheck/tc-app/tc-app-lambda.rkt
View File

@ -69,8 +69,8 @@
(generalize (tc-expr/t ac)))))] (generalize (tc-expr/t ac)))))]
[ts (cons ts1 ann-ts)]) [ts (cons ts1 ann-ts)])
;; check that the actual arguments are ok here ;; check that the actual arguments are ok here
(for/list ([a (syntax->list #'(actuals ...))] (for/list ([a (in-list (syntax->list #'(actuals ...)))]
[t ann-ts]) [t (in-list ann-ts)])
(tc-expr/check a (ret t))) (tc-expr/check a (ret t)))
;; then check that the function typechecks with the inferred types ;; then check that the function typechecks with the inferred types
(add-typeof-expr lam (tc/rec-lambda/check args body lp ts expected)) (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))) ((~and inner-body (if e1 e2 e3:id)))
(null actuals ...)) (null actuals ...))
#:when (free-identifier=? #'val #'e3) #:when (free-identifier=? #'val #'e3)
(let ([ts (for/list ([ac (syntax->list #'(actuals ...))] (let ([ts (for/list ([ac (in-list (syntax->list #'(actuals ...)))]
[f (syntax->list #'(acc ...))]) [f (in-list (syntax->list #'(acc ...)))])
(let ([type (type-annotation f #:infer #t)]) (let ([type (type-annotation f #:infer #t)])
(if type (if type
(tc-expr/check/t ac (ret type)) (tc-expr/check/t ac (ret type))
@ -96,8 +96,8 @@
expected)] expected)]
;; special case when argument needs inference ;; special case when argument needs inference
[(_ body* _) [(_ body* _)
(let ([ts (for/list ([ac (syntax->list actuals)] (let ([ts (for/list ([ac (in-list (syntax->list actuals))]
[f (syntax->list args)]) [f (in-list (syntax->list args))])
(let* ([infer-t (or (type-annotation f #:infer #t) (let* ([infer-t (or (type-annotation f #:infer #t)
(find-annotation #'(begin . body*) f))]) (find-annotation #'(begin . body*) f))])
(if infer-t (if infer-t

2
collects/typed-racket/typecheck/tc-app/tc-app-list.rkt
View File

@ -41,7 +41,7 @@
(and (Listof: t var) (app (λ _ #f) bound)))) (and (Listof: t var) (app (λ _ #f) bound))))
...)) ...))
(=> fail) (=> 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 (define expected-elem-type
(match expected (match expected
[(or #f (tc-any-results:)) #f] [(or #f (tc-any-results:)) #f]

4
collects/typed-racket/typecheck/tc-app/tc-app-main.rkt
View File

@ -85,7 +85,7 @@
(define (matching-arities arrs) (define (matching-arities arrs)
(for/list ([arr (in-list arrs)] #:when (arr-matches? arr args*)) arr)) (for/list ([arr (in-list arrs)] #:when (arr-matches? arr args*)) arr))
(define (has-drest/filter? arrs) (define (has-drest/filter? arrs)
(for/or ([arr arrs]) (for/or ([arr (in-list arrs)])
(or (has-filter? arr) (arr-drest arr)))) (or (has-filter? arr) (arr-drest arr))))
(define arg-tys (define arg-tys
@ -103,7 +103,7 @@
(in-sequences (in-list dom) (in-cycle (in-value rest))))))) (in-sequences (in-list dom) (in-cycle (in-value rest)))))))
(for/list ([a (in-list args*)] [types matching-domains]) (for/list ([a (in-list args*)] [types matching-domains])
(match-define (cons t ts) types) (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)) (tc-expr/check a (ret t))
(single-value a)))] (single-value a)))]
[_ (map single-value args*)])) [_ (map single-value args*)]))

2
collects/typed-racket/typecheck/tc-app/tc-app-objects.rkt
View File

@ -46,7 +46,7 @@
(for ([pa (in-syntax pos-args)] (for ([pa (in-syntax pos-args)]
[pt (in-list pos-tys)]) [pt (in-list pos-tys)])
(tc-expr/check pa (ret pt))) (tc-expr/check pa (ret pt)))
(for ([n names] (for ([n (in-list names)]
#:unless (memq n tnames)) #:unless (memq n tnames))
(tc-error/delayed (tc-error/delayed
"unknown named argument ~a for class\nlegal named arguments are ~a" "unknown named argument ~a for class\nlegal named arguments are ~a"

8
collects/typed-racket/typecheck/tc-app/tc-app-values.rkt
View File

@ -45,14 +45,16 @@
(match expected (match expected
[(tc-results: ets efs eos) [(tc-results: ets efs eos)
(match-let ([(list (tc-result1: ts fs os) ...) (match-let ([(list (tc-result1: ts fs os) ...)
(for/list ([arg (syntax->list #'args)] (for/list ([arg (in-list (syntax->list #'args))]
[et ets] [ef efs] [eo eos]) [et (in-list ets)]
[ef (in-list efs)]
[eo (in-list eos)])
(single-value arg (ret et ef eo)))]) (single-value arg (ret et ef eo)))])
(if (= (length ts) (length ets) (length (syntax->list #'args))) (if (= (length ts) (length ets) (length (syntax->list #'args)))
(ret ts fs os) (ret ts fs os)
(tc-error/expr #:return expected "wrong number of values: expected ~a but got ~a" (tc-error/expr #:return expected "wrong number of values: expected ~a but got ~a"
(length ets) (length (syntax->list #'args)))))] (length ets) (length (syntax->list #'args)))))]
[_ (match-let ([(list (tc-result1: ts fs os) ...) [_ (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))]) (single-value arg))])
(ret ts fs os))]))) (ret ts fs os))])))

5
collects/typed-racket/typecheck/tc-apply.rkt
View File

@ -19,7 +19,10 @@
(match t (match t
[(Values: (list (Result: ts _ _) ...)) (ret ts)] [(Values: (list (Result: ts _ _) ...)) (ret ts)]
[(ValuesDots: (list (Result: ts _ _) ...) dty dbound) [(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)])) [_ (int-err "do-ret fails: ~a" t)]))
(define (tc/apply f args) (define (tc/apply f args)

2
collects/typed-racket/typecheck/tc-envops.rkt
View File

@ -81,7 +81,7 @@
(([e env?] [fs (listof Filter/c)] [bx (box/c boolean?)]) (([e env?] [fs (listof Filter/c)] [bx (box/c boolean?)])
#:pre (bx) (unbox bx) . ->i . [_ env?]) #:pre (bx) (unbox bx) . ->i . [_ env?])
(define-values (props atoms) (combine-props fs (env-props env) flag)) (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 (match f
[(Bot:) (set-box! flag #f) (env-map (lambda (k v) (Un)) Γ)] [(Bot:) (set-box! flag #f) (env-map (lambda (k v) (Un)) Γ)]
[(or (TypeFilter: _ _ x) (NotTypeFilter: _ _ x)) [(or (TypeFilter: _ _ x) (NotTypeFilter: _ _ x))

2
collects/typed-racket/typecheck/tc-expr-unit.rkt
View File

@ -39,7 +39,7 @@
[(list ty) [(list ty)
(list (list
(for/fold ([ty ty]) (for/fold ([ty ty])
([inst (in-improper-stx inst)]) ([inst (in-list (in-improper-stx inst))])
(cond [(not inst) ty] (cond [(not inst) ty]
[(not (or (Poly? ty) (PolyDots? ty))) [(not (or (Poly? ty) (PolyDots? ty)))
(tc-error/expr #:return (Un) "Cannot instantiate non-polymorphic type ~a" (tc-error/expr #:return (Un) "Cannot instantiate non-polymorphic type ~a"

4
collects/typed-racket/typecheck/tc-funapp.rkt
View File

@ -21,7 +21,7 @@
[(_ (lsts ... arrs) f-stx args-stx pred infer t argtys expected) [(_ (lsts ... arrs) f-stx args-stx pred infer t argtys expected)
(with-syntax ([(vars ... a) (generate-temporaries #'(lsts ... arrs))]) (with-syntax ([(vars ... a) (generate-temporaries #'(lsts ... arrs))])
(syntax/loc stx (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)) #:when (pred vars ... a))
(let ([substitution (infer vars ... a)]) (let ([substitution (infer vars ... a)])
(and substitution (and substitution
@ -135,7 +135,7 @@
(tc/funapp f-stx args-stx (ret (resolve-once t) f o) argtys expected)] (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 ;; a union of functions can be applied if we can apply all of the elements
[((tc-result1: (Union: (and ts (list (Function: _) ...)))) _) [((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) (match (tc/funapp f-stx args-stx (ret fty) argtys expected)
[(tc-result1: t) (Un result t)])))] [(tc-result1: t) (Un result t)])))]
;; error type is a perfectly good fcn type ;; error type is a perfectly good fcn type

6
collects/typed-racket/typecheck/tc-if.rkt
View File

@ -19,7 +19,7 @@
(match tc (match tc
[(tc-any-results:) tc] [(tc-any-results:) tc]
[(tc-results: ts _ _) [(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/if-twoarm tst thn els [expected #f])
(define (tc expr reachable?) (define (tc expr reachable?)
@ -83,7 +83,9 @@
;; if we have the same number of values in both cases ;; if we have the same number of values in both cases
(cond [(= (length ts) (length us)) (cond [(= (length ts) (length us))
(combine-results (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 (let ([filter
(match* (f2 f3) (match* (f2 f3)
[((NoFilter:) _) [((NoFilter:) _)

12
collects/typed-racket/typecheck/tc-lambda-unit.rkt
View File

@ -347,8 +347,8 @@
[(list id ...) [(list id ...)
(list id)]))] (list id)]))]
[scoped-tvarss [scoped-tvarss
(for/list ((tvarss (lookup-scoped-tvar-layer form))) (for/list ((tvarss (in-list (lookup-scoped-tvar-layer form))))
(for/list ((tvar tvarss)) (for/list ((tvar (in-list tvarss)))
(match tvar (match tvar
[(list (list v ...) dotted-v) [(list (list v ...) dotted-v)
(list (map syntax-e v) (syntax-e 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*))) [(tc-result1: (and t (Poly-fresh: ns fresh-ns expected*)))
;; make sure the declared and annotated type variable arities match up ;; make sure the declared and annotated type variable arities match up
;; with the expected type variable arity ;; with the expected type variable arity
(for ((tvars tvarss)) (for ((tvars (in-list tvarss)))
(when (and (cons? tvars) (list? (first tvars))) (when (and (cons? tvars) (list? (first tvars)))
(tc-error (tc-error
"Expected a polymorphic function without ..., but given function/annotation had ...")) "Expected a polymorphic function without ..., but given function/annotation had ..."))
@ -404,7 +404,7 @@
[(tc-result1: (and t (PolyDots-names: (list ns ... dvar) expected*))) [(tc-result1: (and t (PolyDots-names: (list ns ... dvar) expected*)))
;; make sure the declared and annotated type variable arities match up ;; make sure the declared and annotated type variable arities match up
;; with the expected type variable arity ;; with the expected type variable arity
(for ((tvars tvarss)) (for ((tvars (in-list tvarss)))
(match tvars (match tvars
[(list (list vars ...) dotted) [(list (list vars ...) dotted)
(unless (= (length vars) (length ns)) (unless (= (length vars) (length ns))
@ -415,14 +415,14 @@
(make-PolyDots (append ns (list dvar)) (extend-and-loop form ns formals bodies (ret expected*)))] (make-PolyDots (append ns (list dvar)) (extend-and-loop form ns formals bodies (ret expected*)))]
[(or (tc-results: _) (tc-any-results:) #f) [(or (tc-results: _) (tc-any-results:) #f)
(define lengths (define lengths
(for/set ((tvars tvarss)) (for/set ((tvars (in-list tvarss)))
(match tvars (match tvars
[(list (list vars ...) dotted) [(list (list vars ...) dotted)
(length vars)] (length vars)]
[(list vars ...) [(list vars ...)
(length vars)]))) (length vars)])))
(define dots (define dots
(for/set ((tvars tvarss)) (for/set ((tvars (in-list tvarss)))
(match tvars (match tvars
[(list (list vars ...) dotted) #t] [(list (list vars ...) dotted) #t]
[(list vars ...) #f]))) [(list vars ...) #f])))

14
collects/typed-racket/typecheck/tc-let-unit.rkt
View File

@ -21,7 +21,7 @@
(match tc (match tc
[(tc-any-results:) tc] [(tc-any-results:) tc]
[(tc-results: ts _ _) [(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]) (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) (((syntax? syntax? tc-results/c . -> . any/c)
@ -45,9 +45,9 @@
(values ts (values ts
e-ts e-ts
(apply append (apply append
(for/list ([n names] (for/list ([n (in-list names)]
[f+ fs+] [f+ (in-list fs+)]
[f- fs-]) [f- (in-list fs-)])
(list (make-ImpFilter (-not-filter (-val #f) n) f+) (list (make-ImpFilter (-not-filter (-val #f) n) f+)
(make-ImpFilter (-filter (-val #f) n) f-)))))] (make-ImpFilter (-filter (-val #f) n) f-)))))]
[((tc-results: ts (NoFilter:) _) (tc-results: e-ts (NoFilter:) _)) [((tc-results: ts (NoFilter:) _) (tc-results: e-ts (NoFilter:) _))
@ -153,8 +153,8 @@
([(safe-bindings _) ([(safe-bindings _)
(for/fold ([safe-bindings '()] ; includes transitively-safe (for/fold ([safe-bindings '()] ; includes transitively-safe
[transitively-safe-bindings '()]) [transitively-safe-bindings '()])
([names names] ([names (in-list names)]
[clause clauses]) [clause (in-list clauses)])
(case (safe-letrec-values-clause? clause transitively-safe-bindings flat-names) (case (safe-letrec-values-clause? clause transitively-safe-bindings flat-names)
;; transitively safe -> safe to mention in a subsequent rhs ;; transitively safe -> safe to mention in a subsequent rhs
[(transitively-safe) (values (append names safe-bindings) [(transitively-safe) (values (append names safe-bindings)
@ -231,7 +231,7 @@
;; the types of the exprs ;; the types of the exprs
#;[inferred-types (map (tc-expr-t/maybe-expected expected) exprs)] #;[inferred-types (map (tc-expr-t/maybe-expected expected) exprs)]
;; the annotated types of the name (possibly using the inferred types) ;; 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) (get-type/infer name e (tc-expr-t/maybe-expected expected)
tc-expr/check))] tc-expr/check))]
;; the clauses for error reporting ;; the clauses for error reporting

2
collects/typed-racket/typecheck/tc-literal.rkt
View File

@ -95,7 +95,7 @@
(for/list ([l (in-vector (syntax-e #'i))] (for/list ([l (in-vector (syntax-e #'i))]
[t (in-list ts)]) [t (in-list ts)])
check-below (tc-literal l t) t))] 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))))])] (generalize (tc-literal l #f))))])]
[(~var i (3d hash?)) [(~var i (3d hash?))
(match expected (match expected

10
collects/typed-racket/typecheck/tc-metafunctions.rkt
View File

@ -17,19 +17,19 @@
[(tc-any-results:) (make-AnyValues)] [(tc-any-results:) (make-AnyValues)]
[(tc-results: ts fs os dty dbound) [(tc-results: ts fs os dty dbound)
(make-ValuesDots (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))) (make-Result t (abstract-filter arg-names keys f) (abstract-object arg-names keys o)))
dty dbound)] dty dbound)]
[(tc-results: ts fs os) [(tc-results: ts fs os)
(make-Values (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))))])) (make-Result t (abstract-filter arg-names keys f) (abstract-object arg-names keys o))))]))
(define/cond-contract (abstract-object ids keys o) (define/cond-contract (abstract-object ids keys o)
(-> (listof identifier?) (listof name-ref/c) Object? Object?) (-> (listof identifier?) (listof name-ref/c) Object? Object?)
(define (lookup y) (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: (define-match-expander lookup:
(syntax-rules () (syntax-rules ()
[(_ i) (app lookup (? values i))])) [(_ i) (app lookup (? values i))]))
@ -49,7 +49,7 @@
((listof identifier?) (listof name-ref/c) Filter/c . -> . Filter/c) ((listof identifier?) (listof name-ref/c) Filter/c . -> . Filter/c)
(define/cond-contract (lookup y) (define/cond-contract (lookup y)
(identifier? . -> . (or/c #f integer?)) (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: (define-match-expander lookup:
(syntax-rules () (syntax-rules ()
[(_ i) (or (? identifier? (app lookup (? values i))) [(_ i) (or (? identifier? (app lookup (? values i)))
@ -119,7 +119,7 @@
[(AndFilter: ps) (loop derived-props derived-atoms (append ps (cdr worklist)))] [(AndFilter: ps) (loop derived-props derived-atoms (append ps (cdr worklist)))]
[(ImpFilter: a c) [(ImpFilter: a c)
;(printf "combining ~a with ~a\n" p (append derived-props derived-atoms)) ;(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)) (implied-atomic? a p))
(loop derived-props derived-atoms (cons c (cdr worklist))) (loop derived-props derived-atoms (cons c (cdr worklist)))
(loop (cons p derived-props) derived-atoms (cdr worklist)))] (loop (cons p derived-props) derived-atoms (cdr worklist)))]

4
collects/typed-racket/typecheck/tc-structs.rkt
View File

@ -195,7 +195,7 @@
(add-struct-constructor! (struct-names-constructor names)) (add-struct-constructor! (struct-names-constructor names))
(define def-bindings (define def-bindings
(for/list ([b bindings]) (for/list ([b (in-list bindings)])
(define id (car b)) (define id (car b))
(define t (cdr b)) (define t (cdr b))
(register-type id t) (register-type id t)
@ -223,7 +223,7 @@
(define tvarss (map (compose struct-desc-tvars parsed-struct-desc) parsed-structs)) (define tvarss (map (compose struct-desc-tvars parsed-struct-desc) parsed-structs))
(let loop () (let loop ()
(define sames (define sames
(for/list ((sty stys) (tvars tvarss)) (for/list ((sty (in-list stys)) (tvars (in-list tvarss)))
(cond (cond
((null? tvars) #t) ((null? tvars) #t)
(else (else

8
collects/typed-racket/typecheck/tc-toplevel.rkt
View File

@ -235,7 +235,7 @@
[(define-values (var ...) expr) [(define-values (var ...) expr)
(let* ([vars (syntax->list #'(var ...))] (let* ([vars (syntax->list #'(var ...))]
[ts (map lookup-type vars)]) [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))) (free-id-table-ref unann-defs v (lambda _ #f)))
(when (= 1 (length vars)) (when (= 1 (length vars))
(add-scoped-tvars #'expr (lookup-scoped-tvars (first vars)))) (add-scoped-tvars #'expr (lookup-scoped-tvars (first vars))))
@ -311,7 +311,7 @@
(resolve-type-aliases parse-type) (resolve-type-aliases parse-type)
;; Parse and register the structure types ;; Parse and register the structure types
(define parsed-structs (define parsed-structs
(for/list ((def struct-defs)) (for/list ((def (in-list struct-defs)))
(define parsed (parse-define-struct-internal def)) (define parsed (parse-define-struct-internal def))
(register-parsed-struct-sty! parsed) (register-parsed-struct-sty! parsed)
parsed)) parsed))
@ -354,7 +354,7 @@
(~datum expand))))) (~datum expand)))))
(syntax-parse p #:literals (#%provide) (syntax-parse p #:literals (#%provide)
[(#%provide form ...) [(#%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]) (parameterize ([current-orig-stx f])
(syntax-parse f (syntax-parse f
[i:id [i:id
@ -418,7 +418,7 @@
;; Don't open up `begin`s that are supposed to be ignored ;; Don't open up `begin`s that are supposed to be ignored
#:when (not (or (ignore-property form) (ignore-some-property form))) #:when (not (or (ignore-property form) (ignore-some-property form)))
(define result (define result
(for/last ([form (syntax->list #'(e ...))]) (for/last ([form (in-list (syntax->list #'(e ...)))])
(define-values (_ result) (tc-toplevel-form form)) (define-values (_ result) (tc-toplevel-form form))
result)) result))
(begin0 (values #f (or result (void))) (begin0 (values #f (or result (void)))

4
collects/typed-racket/types/abbrev.rkt
View File

@ -70,14 +70,14 @@
(c:-> (c:listof Type/c) (c:or/c Type/c Values?)) (c:-> (c:listof Type/c) (c:or/c Type/c Values?))
(match args (match args
;[(list t) t] ;[(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 ;; convenient constructor for ValuesDots
;; (wraps arg types with Result) ;; (wraps arg types with Result)
(define/cond-contract (-values-dots args dty dbound) (define/cond-contract (-values-dots args dty dbound)
(c:-> (c:listof Type/c) Type/c (c:or/c symbol? c:natural-number/c) (c:-> (c:listof Type/c) Type/c (c:or/c symbol? c:natural-number/c)
ValuesDots?) ValuesDots?)
(make-ValuesDots (for/list ([i args]) (-result i)) (make-ValuesDots (for/list ([i (in-list args)]) (-result i))
dty dbound)) dty dbound))
;; basic types ;; basic types

4
collects/typed-racket/types/base-abbrev.rkt
View File

@ -35,7 +35,7 @@
;; -lst* Type is needed by substitute for ListDots ;; -lst* Type is needed by substitute for ListDots
(define -pair make-Pair) (define -pair make-Pair)
(define (-lst* #:tail [tail (-val null)] . args) (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 ;; Simple union type, does not check for overlaps
@ -206,7 +206,7 @@
(with-syntax ([((extra ...) ...) (with-syntax ([((extra ...) ...)
(for/list ([i (in-range (add1 (length l)))]) (for/list ([i (in-range (add1 (length l)))])
(take l i))] (take l i))]
[(rsts ...) (for/list ([i (add1 (length l))]) #'rst)]) [(rsts ...) (for/list ([i (in-range (add1 (length l)))]) #'rst)])
#'(make-Function #'(make-Function
(list (list
(make-arr* (list ty ... extra ...) (make-arr* (list ty ... extra ...)

12
collects/typed-racket/types/kw-types.rkt
View File

@ -12,7 +12,7 @@
(int-err "drest passed to kw-convert")) (int-err "drest passed to kw-convert"))
(define arities (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)) (make-arr* (append plain-t (take opt-t i))
rng rng
#:kws kw-t #:kws kw-t
@ -21,7 +21,7 @@
(define ts (define ts
(flatten (flatten
(list (list
(for/list ([k mand-kw-t]) (for/list ([k (in-list mand-kw-t)])
(match k (match k
[(Keyword: _ t _) t])) [(Keyword: _ t _) t]))
(for/list ([k (in-list opt-kw-t)]) (for/list ([k (in-list opt-kw-t)])
@ -35,7 +35,7 @@
(define ts/true (define ts/true
(flatten (flatten
(list (list
(for/list ([k mand-kw-t]) (for/list ([k (in-list mand-kw-t)])
(match k (match k
[(Keyword: _ t _) t])) [(Keyword: _ t _) t]))
(for/list ([k (in-list opt-kw-t)]) (for/list ([k (in-list opt-kw-t)])
@ -49,7 +49,7 @@
(define ts/false (define ts/false
(flatten (flatten
(list (list
(for/list ([k mand-kw-t]) (for/list ([k (in-list mand-kw-t)])
(match k (match k
[(Keyword: _ t _) t])) [(Keyword: _ t _) t]))
(for/list ([k (in-list opt-kw-t)]) (for/list ([k (in-list opt-kw-t)])
@ -79,7 +79,7 @@
[(_ _) #f])) [(_ _) #f]))
(define (kw-equal? a b) (define (kw-equal? a b)
(and (equal? (length a) (length 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)))) (type-equal? k1 k2))))
(match* (a b) (match* (a b)
[((arr: args result rest drest kws) [((arr: args result rest drest kws)
@ -89,7 +89,7 @@
(drest-equal? drest drest*) (drest-equal? drest drest*)
(type-equal? result result*) (type-equal? result result*)
(kw-equal? kws kws*) (kw-equal? kws kws*)
(for/and ([p args] [p* args*]) (for/and ([p (in-list args)] [p* (in-list args*)])
(type-equal? p p*)))])) (type-equal? p p*)))]))
(define (arity-length a) (define (arity-length a)

6
collects/typed-racket/types/printer.rkt
View File

@ -160,7 +160,7 @@
(define-values (next _) (define-values (next _)
(for/fold ([next (car candidates)] (for/fold ([next (car candidates)]
[max-cover (covers-how-many? (car candidates))]) [max-cover (covers-how-many? (car candidates))])
([c candidates]) ([c (in-list candidates)])
(let ([how-many? (covers-how-many? c)]) (let ([how-many? (covers-how-many? c)])
(if (> how-many? max-cover) (if (> how-many? max-cover)
(values c how-many?) (values c how-many?)
@ -183,7 +183,7 @@
(fp "-> ~a" ret))) (fp "-> ~a" ret)))
(fp "(") (fp "(")
(for-each (lambda (t) (fp "~a " t)) dom) (for-each (lambda (t) (fp "~a " t)) dom)
(for ([kw kws]) (for ([kw (in-list kws)])
(match kw (match kw
[(Keyword: k t req?) [(Keyword: k t req?)
(if req? (if req?
@ -206,7 +206,7 @@
(if (null? pth) (if (null? pth)
(fp "-> ~a : ~a" t ft) (fp "-> ~a : ~a" t ft)
(begin (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:)))) [(Values: (list (Result: t fs (Empty:))))
(fp/filter "-> ~a : ~a" t fs)] (fp/filter "-> ~a : ~a" t fs)]
[(Values: (list (Result: t lf lo))) [(Values: (list (Result: t lf lo)))

2
collects/typed-racket/types/remove-intersect.rkt
View File

@ -86,7 +86,7 @@
[(list (Struct: n _ flds _ _ _) [(list (Struct: n _ flds _ _ _)
(Struct: n* _ flds* _ _ _)) (=> nevermind) (Struct: n* _ flds* _ _ _)) (=> nevermind)
(unless (free-identifier=? n n*) (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*) (match* (f f*)
[((fld: t _ _) (fld: t* _ _)) (overlap t t*)]))] [((fld: t _ _) (fld: t* _ _)) (overlap t t*)]))]
[(list (Struct: n #f _ _ _ _) [(list (Struct: n #f _ _ _ _)

4
collects/typed-racket/types/substitute.rkt
View File

@ -98,7 +98,7 @@
;; We need to recur first, just to expand out any dotted usages of this. ;; We need to recur first, just to expand out any dotted usages of this.
(let ([expanded (sb dty)]) (let ([expanded (sb dty)])
(for/fold ([t (make-Value null)]) (for/fold ([t (make-Value null)])
([img (reverse images)]) ([img (in-list (reverse images))])
(make-Pair (substitute img name expanded) t))) (make-Pair (substitute img name expanded) t)))
(make-ListDots (sb dty) dbound))] (make-ListDots (sb dty) dbound))]
[#:ValuesDots types dty dbound [#:ValuesDots types dty dbound
@ -108,7 +108,7 @@
(map sb types) (map sb types)
;; We need to recur first, just to expand out any dotted usages of this. ;; We need to recur first, just to expand out any dotted usages of this.
(let ([expanded (sb dty)]) (let ([expanded (sb dty)])
(for/list ([img images]) (for/list ([img (in-list images)])
(make-Result (make-Result
(substitute img name expanded) (substitute img name expanded)
(make-FilterSet (make-Top) (make-Top)) (make-FilterSet (make-Top) (make-Top))

16
collects/typed-racket/types/subtype.rkt
View File

@ -66,10 +66,10 @@
[(_ init (s:sub* . args) ...+) [(_ init (s:sub* . args) ...+)
(with-syntax ([(A* ... A-last) (generate-temporaries #'(s ...))]) (with-syntax ([(A* ... A-last) (generate-temporaries #'(s ...))])
(with-syntax ([(clauses ...) (with-syntax ([(clauses ...)
(for/list ([s (syntax->list #'(s ...))] (for/list ([s (in-list (syntax->list #'(s ...)))]
[args (syntax->list #'(args ...))] [args (in-list (syntax->list #'(args ...)))]
[A (syntax->list #'(init A* ...))] [A (in-list (syntax->list #'(init A* ...)))]
[A-next (syntax->list #'(A* ... A-last))]) [A-next (in-list (syntax->list #'(A* ... A-last)))])
#`[#,A-next (#,s #,A . #,args)])]) #`[#,A-next (#,s #,A . #,args)])])
(syntax/loc stx (let*/and (clauses ...) (syntax/loc stx (let*/and (clauses ...)
A-last))))])) A-last))))]))
@ -322,7 +322,7 @@
[((Base: _ _ _ _ #t) (Sequence: (list t*))) [((Base: _ _ _ _ #t) (Sequence: (list t*)))
(define type (define type
;; FIXME: thread the store through here ;; 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)))) (or (and (subtype* A0 s t) t))))
(if type (if type
(subtype* A0 type t*) (subtype* A0 type t*)
@ -487,11 +487,11 @@
[((Vector: _) (VectorTop:)) A0] [((Vector: _) (VectorTop:)) A0]
[((HeterogeneousVector: _) (VectorTop:)) A0] [((HeterogeneousVector: _) (VectorTop:)) A0]
[((HeterogeneousVector: (list e ...)) (Vector: e*)) [((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*)))] (and A (type-equiv? A e e*)))]
[((HeterogeneousVector: (list s* ...)) (HeterogeneousVector: (list t* ...))) [((HeterogeneousVector: (list s* ...)) (HeterogeneousVector: (list t* ...)))
(if (= (length s*) (length 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)) (type-equiv? A s t))
#f)] #f)]
[((MPair: s1 s2) (MPair: t1 t2)) [((MPair: s1 s2) (MPair: t1 t2))
@ -546,7 +546,7 @@
[((Class: '() '() (list (and s (list names meths )) ...)) [((Class: '() '() (list (and s (list names meths )) ...))
(Class: '() '() (list (and s* (list names* meths*)) ...))) (Class: '() '() (list (and s* (list names* meths*)) ...)))
(for/fold ([A A0]) (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))] (and A (cond [(assq n s) => (lambda (spec) (subtype* A (cadr spec) m))]
[else #f])))] [else #f])))]
;; otherwise, not a subtype ;; otherwise, not a subtype

6
collects/typed-racket/types/tc-result.rkt
View File

@ -72,15 +72,15 @@
(cond [(Type/c? t) (cond [(Type/c? t)
(list (make-tc-result t (mk t) (make-Empty)))] (list (make-tc-result t (mk t) (make-Empty)))]
[else [else
(for/list ([i t]) (for/list ([i (in-list t)])
(make-tc-result i (mk t) (make-Empty)))]) (make-tc-result i (mk t) (make-Empty)))])
#f))] #f))]
[(t f) [(t f)
(make-tc-results (make-tc-results
(if (Type/c? t) (if (Type/c? t)
(list (make-tc-result t f (make-Empty))) (list (make-tc-result t f (make-Empty)))
(for/list ([i t] [f f]) (for/list ([i (in-list t)] [f (in-list f)])
(make-tc-result i f (make-Empty)))) (make-tc-result i f (make-Empty))))
#f)] #f)]
[(t f o) [(t f o)
(make-tc-results (make-tc-results

4
collects/typed-racket/utils/tc-utils.rkt
View File

@ -92,7 +92,7 @@ don't depend on any other portion of the system
(raise-typecheck-error msg stx)] (raise-typecheck-error msg stx)]
[l [l
(let ([stxs (let ([stxs
(for/list ([e l]) (for/list ([e (in-list l)])
(with-handlers ([exn:fail:syntax? (with-handlers ([exn:fail:syntax?
(λ (e) ((error-display-handler) (exn-message e) e))]) (λ (e) ((error-display-handler) (exn-message e) e))])
(raise-typecheck-error (err-msg e) (err-stx 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. ;; vars and such don't confuse the user.
(cond (cond
[(or (not (orig-module-stx)) [(or (not (orig-module-stx))
(for/and ([s ostxs]) (for/and ([s (in-list ostxs)])
(eq? (syntax-source s) (syntax-source (orig-module-stx))))) (eq? (syntax-source s) (syntax-source (orig-module-stx)))))
(raise-typecheck-error (apply format msg rest) stxs)] (raise-typecheck-error (apply format msg rest) stxs)]
[else (raise-typecheck-error [else (raise-typecheck-error