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

Use in-syntax instead of in-list/syntax->list.

Browse Source 
(cherry picked from commit 83f38f4d3b)
This commit is contained in:
Eric Dobson 2013-05-24 22:31:50 -07:00 committed by Ryan Culpepper
parent 599f46ad32
commit c4c85ce9c8
18 changed files with 112 additions and 116 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base syntax/parse "internal.rkt" "../utils/disappeared-use.rkt") (require (for-syntax racket/base syntax/parse unstable/sequence
"internal.rkt" "../utils/disappeared-use.rkt")
"../typecheck/internal-forms.rkt" "../typecheck/internal-forms.rkt"
(prefix-in t: "base-types-extra.rkt")) (prefix-in t: "base-types-extra.rkt"))
@ -13,7 +14,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 (in-list (syntax->list #'(x ...)))] #:fail-unless (for/first ([i (in-syntax #'(x ...))]
#:when (identifier? i) #:when (identifier? i)
#:when (free-identifier=? i #'t:->)) #:when (free-identifier=? i #'t:->))
i) i)

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

@ -51,6 +51,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
racket/lazy-require racket/lazy-require
syntax/parse syntax/parse
racket/syntax racket/syntax
unstable/sequence
racket/base racket/base
racket/struct-info racket/struct-info
syntax/struct syntax/struct
@ -466,10 +467,12 @@ This file defines two sorts of primitives. All of them are provided into any mod
(define-syntax (with-handlers: stx) (define-syntax (with-handlers: stx)
(syntax-parse stx (syntax-parse stx
[(_ ([pred? action] ...) . body) [(_ ([pred? action] ...) . body)
(with-syntax ([(pred?* ...) (map (lambda (s) (with-type-property #`(ann #,s : (Any -> Any)) #t)) (with-syntax ([(pred?* ...)
(syntax->list #'(pred? ...)))] (for/list ([s (in-syntax #'(pred? ...))])
(with-type-property #`(ann #,s : (Any -> Any)) #t))]
[(action* ...) [(action* ...)
(map (lambda (s) (exn-handler-property s #t)) (syntax->list #'(action ...)))] (for/list ([s (in-syntax #'(action ...))])
(exn-handler-property s #t))]
[body* (exn-body-property #'(let-values () . body) #t)]) [body* (exn-body-property #'(let-values () . body) #t)])
(with-handlers-property #'(with-handlers ([pred?* action*] ...) body*) #t))])) (with-handlers-property #'(with-handlers ([pred?* action*] ...) body*) #t))]))

6
collects/typed-racket/optimizer/float-complex.rkt
View File

@ -1,7 +1,7 @@
#lang racket/base #lang racket/base
(require syntax/parse syntax/id-table racket/dict unstable/syntax racket/match (require syntax/parse syntax/id-table racket/dict unstable/syntax racket/match
"../utils/utils.rkt" racket/unsafe/ops "../utils/utils.rkt" racket/unsafe/ops unstable/sequence
(for-template racket/base racket/math racket/flonum racket/unsafe/ops) (for-template racket/base racket/math racket/flonum racket/unsafe/ops)
(utils tc-utils) (utils tc-utils)
(types numeric-tower subtype type-table utils) (types numeric-tower subtype type-table utils)
@ -495,7 +495,7 @@
;; reasonable definition. ;; reasonable definition.
(pattern e:arith-expr (pattern e:arith-expr
#:when (when (and (in-complex-layer? #'e) #:when (when (and (in-complex-layer? #'e)
(for/and ([subexpr (in-list (syntax->list #'(e.args ...)))]) (for/and ([subexpr (in-syntax #'(e.args ...))])
(subtypeof? subexpr -Real))) (subtypeof? subexpr -Real)))
(log-missed-optimization (log-missed-optimization
"unexpected complex type" "unexpected complex type"
@ -601,7 +601,7 @@
(pattern (#%plain-app (~literal /) e:expr ...) (pattern (#%plain-app (~literal /) e:expr ...)
#:when (subtypeof? this-syntax -FloatComplex) #:when (subtypeof? this-syntax -FloatComplex)
#:when (let ([irritants #:when (let ([irritants
(for/list ([c (syntax->list #'(e ...))] (for/list ([c (in-syntax #'(e ...))]
#:when (match (type-of c) #:when (match (type-of c)
[(tc-result1: t) [(tc-result1: t)
(subtype -Zero t)] (subtype -Zero t)]

13
collects/typed-racket/optimizer/float.rkt
View File

@ -1,7 +1,6 @@
#lang racket/base #lang racket/base
(require syntax/parse (require syntax/parse unstable/sequence racket/dict racket/flonum
racket/dict racket/flonum
(for-template racket/base racket/flonum racket/unsafe/ops racket/math) (for-template racket/base racket/flonum racket/unsafe/ops racket/math)
"../utils/utils.rkt" "../utils/utils.rkt"
(utils tc-utils) (utils tc-utils)
@ -124,12 +123,12 @@
;; (Note: could allow for more args, if not next to each other, but ;; (Note: could allow for more args, if not next to each other, but
;; probably not worth the trouble (most ops have 2 args anyway)) ;; probably not worth the trouble (most ops have 2 args anyway))
(and (subtypeof? this-syntax -Flonum) (and (subtypeof? this-syntax -Flonum)
(for/and ([a (in-list (syntax->list #'(f1 f2 fs ...)))]) (for/and ([a (in-syntax #'(f1 f2 fs ...))])
;; flonum or provably non-zero ;; flonum or provably non-zero
(or (subtypeof? a -Flonum) (or (subtypeof? a -Flonum)
(subtypeof? a (Un -PosReal -NegReal)))) (subtypeof? a (Un -PosReal -NegReal))))
(>= 1 (>= 1
(for/sum ([a (in-list (syntax->list #'(f1 f2 fs ...)))] (for/sum ([a (in-syntax #'(f1 f2 fs ...))]
#:when (not (subtypeof? a -Flonum))) #:when (not (subtypeof? a -Flonum)))
1)))] 1)))]
;; if we don't have a return type of float, or if the return type is ;; if we don't have a return type of float, or if the return type is
@ -143,7 +142,7 @@
(when missed-optimization? (when missed-optimization?
(log-float-real-missed-opt (log-float-real-missed-opt
this-syntax this-syntax
(for/list ([x (in-list (syntax->list #'(f1 f2 fs ...)))] (for/list ([x (in-syntax #'(f1 f2 fs ...))]
#:unless (subtypeof? x -Flonum)) #:unless (subtypeof? x -Flonum))
x))) x)))
;; If an optimization was expected (whether it was safe or not doesn't matter), ;; If an optimization was expected (whether it was safe or not doesn't matter),
@ -158,7 +157,7 @@
(define extra-precision-subexprs (define extra-precision-subexprs
(filter (filter
values values
(for/list ([subexpr (in-list (syntax->list #'(f1 f2 fs ...)))] (for/list ([subexpr (in-syntax #'(f1 f2 fs ...))]
#:when (or (and (in-real-layer? subexpr) #:when (or (and (in-real-layer? subexpr)
;; exclude single-flonums ;; exclude single-flonums
(not (subtypeof? subexpr -InexactReal))) (not (subtypeof? subexpr -InexactReal)))
@ -173,7 +172,7 @@
;; if a subexpression has any float args, it will be reported as a ;; if a subexpression has any float args, it will be reported as a
;; float-real mix missed opt, so this report would be redundant ;; float-real mix missed opt, so this report would be redundant
#:when (for/and ([s (in-list (syntax->list #'(args ...)))]) #:when (for/and ([s (in-syntax #'(args ...))])
(not (in-float-layer? s))) (not (in-float-layer? s)))
#'e] #'e]
[_ #f])))) [_ #f]))))

11
collects/typed-racket/optimizer/unboxed-let.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require syntax/parse unstable/syntax (require syntax/parse unstable/syntax unstable/sequence
racket/list racket/dict racket/match racket/list racket/dict racket/match
"../utils/utils.rkt" "../utils/utils.rkt"
"../utils/tc-utils.rkt" "../utils/tc-utils.rkt"
@ -135,12 +135,9 @@
this-syntax)) this-syntax))
;; add the unboxed bindings to the table, for them to be used by ;; add the unboxed bindings to the table, for them to be used by
;; further optimizations ;; further optimizations
(for ((v (in-list (syntax->list (for ((v (in-syntax #'(opt-candidates.id ...)))
#'(opt-candidates.id ...)))) (r (in-syntax #'(opt-candidates.real-binding ...)))
(r (in-list (syntax->list (i (in-syntax #'(opt-candidates.imag-binding ...))))
#'(opt-candidates.real-binding ...))))
(i (in-list (syntax->list
#'(opt-candidates.imag-binding ...)))))
(dict-set! unboxed-vars-table v (list r i v))) (dict-set! unboxed-vars-table v (list r i v)))
;; in the case where no bindings are unboxed, we create a let ;; in the case where no bindings are unboxed, we create a let
;; that is equivalent to the original, but with all parts ;; that is equivalent to the original, but with all parts

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

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require unstable/match racket/match (require unstable/match racket/match unstable/sequence
racket/dict syntax/id-table racket/syntax unstable/syntax racket/dict syntax/id-table racket/syntax unstable/syntax
"../utils/utils.rkt" "../utils/utils.rkt"
(for-template racket/base) (for-template racket/base)
@ -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 (in-list (syntax->list #`(#,arg2 #,@rest)))]) ([e (in-syntax #`(#,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)
@ -63,7 +63,7 @@
(cdr l))]))) (cdr l))])))
;; Finally, build the whole thing. ;; Finally, build the whole thing.
#`(let #,(for/list ([lhs (in-list lifted)] #`(let #,(for/list ([lhs (in-list lifted)]
[rhs (in-list (syntax->list #`(#,arg2 #,@rest)))]) [rhs (in-syntax #`(#,arg2 #,@rest))])
#`(#,lhs #,rhs)) #`(#,lhs #,rhs))
(and #,@tests))) (and #,@tests)))

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

@ -8,7 +8,7 @@
[make-arr* make-arr]) [make-arr* make-arr])
(utils tc-utils stxclass-util) (utils tc-utils stxclass-util)
syntax/stx (prefix-in c: (contract-req)) syntax/stx (prefix-in c: (contract-req))
syntax/parse racket/dict syntax/parse racket/dict unstable/sequence
(env type-env-structs tvar-env type-name-env type-alias-env (env type-env-structs tvar-env type-name-env type-alias-env
lexical-env index-env) lexical-env index-env)
racket/match racket/match
@ -47,7 +47,7 @@
(pattern (type)) (pattern (type))
(pattern (x ...) (pattern (x ...)
#:fail-unless (= 1 (length #:fail-unless (= 1 (length
(for/list ([i (in-list (syntax->list #'(x ...)))] (for/list ([i (in-syntax #'(x ...))]
#:when (and (identifier? i) #:when (and (identifier? i)
(free-identifier=? i #'t:->))) (free-identifier=? i #'t:->)))
i))) #f i))) #f
@ -172,10 +172,10 @@
(map list (map list
(map syntax-e (syntax->list #'(fname ...))) (map syntax-e (syntax->list #'(fname ...)))
(map parse-type (syntax->list #'(fty ...))) (map parse-type (syntax->list #'(fty ...)))
(map (lambda (e) (syntax-case e () (for/list ((e (in-syntax #'(rest ...))))
[(#t) #t] (syntax-case e ()
[_ #f])) [(#t) #t]
(syntax->list #'(rest ...)))) [_ #f])))
(map list (map list
(map syntax-e (syntax->list #'(mname ...))) (map syntax-e (syntax->list #'(mname ...)))
(map parse-type (syntax->list #'(mty ...)))))] (map parse-type (syntax->list #'(mty ...)))))]
@ -217,7 +217,7 @@
[((~and kw (~or case-lambda t:case->)) tys ...) [((~and kw (~or case-lambda t:case->)) tys ...)
(add-disappeared-use #'kw) (add-disappeared-use #'kw)
(make-Function (make-Function
(for/list ([ty (syntax->list #'(tys ...))]) (for/list ([ty (in-syntax #'(tys ...))])
(let ([t (parse-type ty)]) (let ([t (parse-type ty)])
(match t (match t
[(Function: (list arr)) arr] [(Function: (list arr)) arr]
@ -278,8 +278,8 @@
(~and kw t:->) (~and kw t:->)
(~and (~seq rest-dom ...) (~seq (~or _ (~between t:-> 1 +inf.0)) ...))) (~and (~seq rest-dom ...) (~seq (~or _ (~between t:-> 1 +inf.0)) ...)))
(add-disappeared-use #'kw) (add-disappeared-use #'kw)
(let ([doms (for/list ([d (syntax->list #'(dom ...))]) (let ([doms (for/list ([d (in-syntax #'(dom ...))])
(parse-type d))]) (parse-type d))])
(make-Function (make-Function
(list (make-arr (list (make-arr
doms doms
@ -334,7 +334,7 @@
;; use expr to rule out keywords ;; use expr to rule out keywords
[(dom:non-keyword-ty ... kws:keyword-tys ... (~and kw t:->) rng) [(dom:non-keyword-ty ... kws:keyword-tys ... (~and kw t:->) rng)
(add-disappeared-use #'kw) (add-disappeared-use #'kw)
(let ([doms (for/list ([d (syntax->list #'(dom ...))]) (let ([doms (for/list ([d (in-syntax #'(dom ...))])
(parse-type d))]) (parse-type d))])
(make-Function (make-Function
(list (make-arr (list (make-arr

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

@ -32,15 +32,15 @@
(tc-error/stx stx "Type ~a could not be converted to a contract." t)) (tc-error/stx stx "Type ~a could not be converted to a contract." t))
(set-box! typed-context? #t) (set-box! typed-context? #t)
(init) (init)
(define fv-types (for/list ([t (in-list (syntax->list fvtys))]) (define fv-types (for/list ([t (in-syntax fvtys)])
(parse-type t))) (parse-type t)))
(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-syntax 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 (in-list (syntax->list extys))]) (define ex-types (for/list ([t (in-syntax 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-syntax extys)])
(type->contract t #:typed-side #t (no-contract t)))) (type->contract t #:typed-side #t (no-contract t))))
(define region-tc-result (define region-tc-result
(and expr? (parse-tc-results resty))) (and expr? (parse-tc-results resty)))
@ -55,7 +55,7 @@
t #:typed-side #t t #:typed-side #t
(no-contract t #'region-ty-stx)))]) (no-contract t #'region-ty-stx)))])
null)) null))
(for ([i (in-list (syntax->list fvids))] (for ([i (in-syntax fvids)]
[ty (in-list fv-types)]) [ty (in-list fv-types)])
(register-type i ty)) (register-type i ty))
(define expanded-body (define expanded-body
@ -87,7 +87,7 @@
(report-all-errors) (report-all-errors)
(set-box! typed-context? old-context) (set-box! typed-context? old-context)
;; then clear the new entries from the env ht ;; then clear the new entries from the env ht
(for ([i (in-list (syntax->list fvids))]) (for ([i (in-syntax fvids)])
(unregister-type i)) (unregister-type i))
(with-syntax ([(fv.id ...) fvids] (with-syntax ([(fv.id ...) fvids]
[(cnt ...) fv-cnts] [(cnt ...) fv-cnts]

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

@ -1,7 +1,7 @@
#lang racket/base #lang racket/base
(require "../utils/utils.rkt" (require "../utils/utils.rkt"
unstable/list syntax/id-table racket/dict racket/syntax unstable/list unstable/sequence syntax/id-table racket/dict racket/syntax
racket/struct-info racket/match syntax/parse syntax/location racket/struct-info racket/match syntax/parse syntax/location
(only-in srfi/1/list s:member) (only-in srfi/1/list s:member)
(only-in (private type-contract) type->contract) (only-in (private type-contract) type->contract)
@ -21,7 +21,9 @@
[_ #f])) [_ #f]))
(define (remove-provides forms) (define (remove-provides forms)
(filter (lambda (e) (not (provide? e))) (syntax->list forms))) (for/list ([e (in-syntax forms)]
#:unless (provide? e))
e))
(define (mem? i vd) (define (mem? i vd)
(cond [(s:member i vd (lambda (i j) (free-identifier=? i (binding-name j)))) => car] (cond [(s:member i vd (lambda (i j) (free-identifier=? i (binding-name j)))) => car]

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

@ -32,7 +32,7 @@
(tc-error/expr #:return error-ret (tc-error/expr #:return error-ret
"Wrong number of arguments, expected at least ~a and got ~a" (length dom) (length t-a))]) "Wrong number of arguments, expected at least ~a and got ~a" (length dom) (length t-a))])
(for ([dom-t (if rest (in-sequence-forever dom rest) (in-list dom))] (for ([dom-t (if rest (in-sequence-forever dom rest) (in-list dom))]
[a (in-list (syntax->list args-stx))] [a (in-syntax args-stx)]
[arg-t (in-list t-a)]) [arg-t (in-list t-a)])
(parameterize ([current-orig-stx a]) (check-below arg-t dom-t)))) (parameterize ([current-orig-stx a]) (check-below arg-t dom-t))))
(let* ([dom-count (length dom)] (let* ([dom-count (length dom)]

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

@ -2,7 +2,7 @@
(require "../../utils/utils.rkt" (require "../../utils/utils.rkt"
(prefix-in c: (contract-req)) (prefix-in c: (contract-req))
syntax/parse racket/match syntax/parse racket/match unstable/sequence
syntax/parse/experimental/reflect syntax/parse/experimental/reflect
"signatures.rkt" "signatures.rkt"
"utils.rkt" "utils.rkt"
@ -107,16 +107,16 @@
(pattern (~and form ((~or vector-immutable vector) args:expr ...)) (pattern (~and form ((~or vector-immutable vector) args:expr ...))
(match expected (match expected
[(tc-result1: (app resolve (Vector: t))) [(tc-result1: (app resolve (Vector: t)))
(define es (syntax->list #'(args ...))) (ret (make-HeterogeneousVector
(for ([e (in-list es)]) (for/list ([e (in-syntax #'(args ...))])
(tc-expr/check e (ret t))) (tc-expr/check e (ret t))
(ret (make-HeterogeneousVector (map (λ (_) t) es)))] t)))]
[(tc-result1: (app resolve (HeterogeneousVector: ts))) [(tc-result1: (app resolve (HeterogeneousVector: ts)))
(unless (= (length ts) (length (syntax->list #'(args ...)))) (unless (= (length ts) (length (syntax->list #'(args ...))))
(tc-error/expr "expected vector with ~a elements, but got ~a" (tc-error/expr "expected vector with ~a elements, but got ~a"
(length ts) (length ts)
(make-HeterogeneousVector (map tc-expr/t (syntax->list #'(args ...)))))) (make-HeterogeneousVector (map tc-expr/t (syntax->list #'(args ...))))))
(for ([e (in-list (syntax->list #'(args ...)))] (for ([e (in-syntax #'(args ...))]
[t (in-list ts)]) [t (in-list ts)])
(tc-expr/check e (ret t))) (tc-expr/check e (ret t)))
expected] expected]
@ -133,6 +133,7 @@
[_ (continue)])] [_ (continue)])]
;; since vectors are mutable, if there is no expected type, we want to generalize the element type ;; since vectors are mutable, if there is no expected type, we want to generalize the element type
[(or #f (tc-any-results:) (tc-result1: _)) [(or #f (tc-any-results:) (tc-result1: _))
(ret (make-HeterogeneousVector (map (lambda (x) (generalize (tc-expr/t x))) (ret (make-HeterogeneousVector
(syntax->list #'(args ...)))))] (for/list ((e (in-syntax #'(args ...))))
(generalize (tc-expr/t e)))))]
[_ (int-err "bad expected: ~a" expected)]))) [_ (int-err "bad expected: ~a" expected)])))

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

@ -69,7 +69,7 @@
(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 (in-list (syntax->list #'(actuals ...)))] (for/list ([a (in-syntax #'(actuals ...))]
[t (in-list 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
@ -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 (in-list (syntax->list #'(actuals ...)))] (let ([ts (for/list ([ac (in-syntax #'(actuals ...))]
[f (in-list (syntax->list #'(acc ...)))]) [f (in-syntax #'(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 (in-list (syntax->list actuals))] (let ([ts (for/list ([ac (in-syntax actuals)]
[f (in-list (syntax->list args))]) [f (in-syntax 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

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

@ -4,7 +4,7 @@
(require "../../utils/utils.rkt" (require "../../utils/utils.rkt"
"signatures.rkt" "signatures.rkt"
"utils.rkt" "utils.rkt"
syntax/parse racket/match syntax/parse racket/match unstable/sequence
syntax/parse/experimental/reflect syntax/parse/experimental/reflect
(only-in '#%kernel [reverse k:reverse]) (only-in '#%kernel [reverse k:reverse])
(typecheck signatures tc-funapp) (typecheck signatures tc-funapp)
@ -81,13 +81,13 @@
(pattern (list . args) (pattern (list . args)
(match expected (match expected
[(tc-result1: (Listof: elem-ty)) [(tc-result1: (Listof: elem-ty))
(for ([i (in-list (syntax->list #'args))]) (for ([i (in-syntax #'args)])
(tc-expr/check i (ret elem-ty))) (tc-expr/check i (ret elem-ty)))
expected] expected]
[(tc-result1: (List: (? (lambda (ts) (= (length (syntax->list #'args)) [(tc-result1: (List: (? (lambda (ts) (= (length (syntax->list #'args))
(length ts))) (length ts)))
ts))) ts)))
(for ([ac (in-list (syntax->list #'args))] (for ([ac (in-syntax #'args)]
[exp (in-list ts)]) [exp (in-list ts)])
(tc-expr/check ac (ret exp))) (tc-expr/check ac (ret exp)))
expected] expected]

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

@ -3,7 +3,7 @@
(require "../../utils/utils.rkt" (require "../../utils/utils.rkt"
"signatures.rkt" "signatures.rkt"
"utils.rkt" "utils.rkt"
syntax/parse racket/match syntax/parse racket/match unstable/sequence
syntax/parse/experimental/reflect syntax/parse/experimental/reflect
(typecheck signatures tc-funapp) (typecheck signatures tc-funapp)
(types abbrev utils) (types abbrev utils)
@ -45,7 +45,7 @@
(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 (in-list (syntax->list #'args))] (for/list ([arg (in-syntax #'args)]
[et (in-list ets)] [et (in-list ets)]
[ef (in-list efs)] [ef (in-list efs)]
[eo (in-list eos)]) [eo (in-list eos)])
@ -55,6 +55,6 @@
(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 (in-list (syntax->list #'args))]) (for/list ([arg (in-syntax #'args)])
(single-value arg))]) (single-value arg))])
(ret ts fs os))]))) (ret ts fs os))])))

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

@ -1,8 +1,8 @@
#lang racket/base #lang racket/base
(require (rename-in "../utils/utils.rkt" [infer r:infer]) (require (rename-in "../utils/utils.rkt" [infer r:infer])
syntax/kerncase racket/syntax syntax/parse syntax/id-table syntax/kerncase racket/syntax syntax/parse syntax/stx syntax/id-table
racket/list unstable/list racket/dict racket/match racket/list unstable/list racket/dict racket/match unstable/sequence
(prefix-in c: (contract-req)) (prefix-in c: (contract-req))
(rep type-rep free-variance) (rep type-rep free-variance)
(types utils abbrev type-table) (types utils abbrev type-table)
@ -233,23 +233,19 @@
;; definitions just need to typecheck their bodies ;; definitions just need to typecheck their bodies
[(define-values (var ...) expr) [(define-values (var ...) expr)
(let* ([vars (syntax->list #'(var ...))] (unless (for/and ([v (in-syntax #'(var ...))])
[ts (map lookup-type vars)]) (free-id-table-ref unann-defs v (lambda _ #f)))
(unless (for/and ([v (in-list (syntax->list #'(var ...)))]) (let ([ts (map lookup-type (syntax->list #'(var ...)))])
(free-id-table-ref unann-defs v (lambda _ #f))) (when (= 1 (length ts))
(when (= 1 (length vars)) (add-scoped-tvars #'expr (lookup-scoped-tvars (stx-car #'(var ...)))))
(add-scoped-tvars #'expr (lookup-scoped-tvars (first vars)))) (tc-expr/check #'expr (ret ts))))
(tc-expr/check #'expr (ret ts))) (void)]
(void))]
;; to handle the top-level, we have to recur into begins ;; to handle the top-level, we have to recur into begins
[(begin) (void)] [(begin) (void)]
[(begin . rest) [(begin . rest)
(let loop ([l (syntax->list #'rest)]) (for/last ([form (in-syntax #'rest)])
(if (null? (cdr l)) (tc-toplevel/pass2 form))]
(tc-toplevel/pass2 (car l))
(begin (tc-toplevel/pass2 (car l))
(loop (cdr l)))))]
;; otherwise, the form was just an expression ;; otherwise, the form was just an expression
[_ (tc-expr/check form tc-any-results)]))) [_ (tc-expr/check form tc-any-results)])))
@ -354,7 +350,7 @@
(~datum expand))))) (~datum expand)))))
(syntax-parse p #:literals (#%provide) (syntax-parse p #:literals (#%provide)
[(#%provide form ...) [(#%provide form ...)
(for/fold ([h h]) ([f (in-list (syntax->list #'(form ...)))]) (for/fold ([h h]) ([f (in-syntax #'(form ...))])
(parameterize ([current-orig-stx f]) (parameterize ([current-orig-stx f])
(syntax-parse f (syntax-parse f
[i:id [i:id
@ -418,7 +414,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 (in-list (syntax->list #'(e ...)))]) (for/last ([form (in-syntax #'(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)))

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

@ -6,7 +6,7 @@
(utils tc-utils) (utils tc-utils)
(types utils resolve base-abbrev match-expanders (types utils resolve base-abbrev match-expanders
numeric-tower substitute current-seen) numeric-tower substitute current-seen)
(for-syntax racket/base syntax/parse)) (for-syntax racket/base syntax/parse unstable/sequence))
(lazy-require (lazy-require
("union.rkt" (Un)) ("union.rkt" (Un))
@ -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 (in-list (syntax->list #'(s ...)))] (for/list ([s (in-syntax #'(s ...))]
[args (in-list (syntax->list #'(args ...)))] [args (in-syntax #'(args ...))]
[A (in-list (syntax->list #'(init A* ...)))] [A (in-syntax #'(init A* ...))]
[A-next (in-list (syntax->list #'(A* ... A-last)))]) [A-next (in-syntax #'(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))))]))

5
collects/typed-racket/utils/mutated-vars.rkt
View File

@ -1,7 +1,7 @@
#lang racket/base #lang racket/base
(require (for-template racket/base) racket/dict (require (for-template racket/base) racket/dict
syntax/id-table syntax/kerncase) syntax/id-table syntax/kerncase unstable/sequence)
;; find and add to mapping all the set!'ed variables in form ;; find and add to mapping all the set!'ed variables in form
;; if the supplied mapping is mutable, mutates it ;; if the supplied mapping is mutable, mutates it
@ -14,8 +14,7 @@
(let loop ([stx form] [tbl tbl]) (let loop ([stx form] [tbl tbl])
;; syntax-list -> table ;; syntax-list -> table
(define (fmv/list lstx) (define (fmv/list lstx)
(for/fold ([tbl tbl]) (for/fold ([tbl tbl]) ([stx (in-syntax lstx)])
([stx (in-list (syntax->list lstx))])
(loop stx tbl))) (loop stx tbl)))
(kernel-syntax-case* stx #f (#%top-interaction) (kernel-syntax-case* stx #f (#%top-interaction)
;; what we care about: set! ;; what we care about: set!

54
collects/typed-racket/utils/utils.rkt
View File

@ -5,7 +5,7 @@ This file is for utilities that are of general interest,
at least theoretically. at least theoretically.
|# |#
(require (for-syntax racket/base syntax/parse racket/string) (require (for-syntax racket/base syntax/parse racket/string unstable/sequence)
racket/require-syntax racket/provide-syntax racket/require-syntax racket/provide-syntax
racket/struct-info "timing.rkt") racket/struct-info "timing.rkt")
@ -42,20 +42,19 @@ at least theoretically.
(syntax-parse stx (syntax-parse stx
[(form id:identifier ...) [(form id:identifier ...)
(with-syntax ([(id* ...) (with-syntax ([(id* ...)
(map (lambda (id) (for/list ([id (in-syntax #'(id ...))])
(datum->syntax (datum->syntax
id id
`(lib `(lib
,(datum->syntax ,(datum->syntax
#f #f
(string-join (string-join
(list "typed-racket" (list "typed-racket"
(symbol->string (syntax-e #'nm)) (symbol->string (syntax-e #'nm))
(string-append (symbol->string (syntax-e id)) ".rkt")) (string-append (symbol->string (syntax-e id)) ".rkt"))
"/") "/")
id id)) id id))
id id)) id id))])
(syntax->list #'(id ...)))])
(syntax-property (syntax/loc stx (combine-in id* ...)) (syntax-property (syntax/loc stx (combine-in id* ...))
'disappeared-use 'disappeared-use
#'form))])) #'form))]))
@ -63,19 +62,18 @@ at least theoretically.
(syntax-parse stx (syntax-parse stx
[(_ id:identifier ...) [(_ id:identifier ...)
(with-syntax ([(id* ...) (with-syntax ([(id* ...)
(map (lambda (id) (for/list ([id (in-syntax #'(id ...))])
(datum->syntax (datum->syntax
id id
`(lib `(lib
,(datum->syntax ,(datum->syntax
#f #f
(string-join (string-join
(list "typed-racket" (list "typed-racket"
(symbol->string (syntax-e #'nm)) (symbol->string (syntax-e #'nm))
(string-append (symbol->string (syntax-e id)) ".rkt")) (string-append (symbol->string (syntax-e id)) ".rkt"))
"/") "/")
id id)))) id id))))])
(syntax->list #'(id ...)))])
(syntax/loc stx (combine-out (all-from-out id*) ...)))])) (syntax/loc stx (combine-out (all-from-out id*) ...)))]))
(provide nm nm-out)))])) (provide nm nm-out)))]))