diff --git a/typed-racket-lib/typed-racket/base-env/base-env.rkt b/typed-racket-lib/typed-racket/base-env/base-env.rkt index 482055780..09d1b0bd9 100644 --- a/typed-racket-lib/typed-racket/base-env/base-env.rkt +++ b/typed-racket-lib/typed-racket/base-env/base-env.rkt @@ -1601,7 +1601,7 @@ ;; Section 11.1 (Threads) ;; Section 11.1.1 -[thread (->key (-> Univ) #:keep (Un (-val #f) (-val 'results)) #f #:pool Univ #f -Thread)] +[thread (->key (-> ManyUniv) #:keep (Un (-val #f) (-val 'results)) #f #:pool Univ #f -Thread)] [thread? (unsafe-shallow:make-pred-ty -Thread)] [current-thread (-> -Thread)] [thread/suspend-to-kill (-> (-> Univ) -Thread)] diff --git a/typed-racket-lib/typed-racket/rep/rep-utils.rkt b/typed-racket-lib/typed-racket/rep/rep-utils.rkt index 18bd1027b..52d957664 100644 --- a/typed-racket-lib/typed-racket/rep/rep-utils.rkt +++ b/typed-racket-lib/typed-racket/rep/rep-utils.rkt @@ -611,7 +611,8 @@ #'(begin) #`(provide #,@non-constr-li))) #'(constr-provide nonconstr-provide)])] - [struct-def #'(struct var.name parent ... (flds.ids ...) + [struct-def (syntax/loc #'var.name + (struct var.name parent ... (flds.ids ...) maybe-transparent ... #:constructor-name constructor-name #:property prop:uid uid-id @@ -625,7 +626,7 @@ Rep-free-idxs-def Rep-for-each-def Rep-fmap-def] - extra-defs ...)]) + extra-defs ...))]) ;; - - - - - - - - - - - - - - - ;; macro output ;; - - - - - - - - - - - - - - - diff --git a/typed-racket-lib/typed-racket/typecheck/signatures.rkt b/typed-racket-lib/typed-racket/typecheck/signatures.rkt index a917f4129..dd370675f 100644 --- a/typed-racket-lib/typed-racket/typecheck/signatures.rkt +++ b/typed-racket-lib/typed-racket/typecheck/signatures.rkt @@ -61,7 +61,7 @@ (define-signature tc-lambda^ ([cond-contracted tc/lambda (syntax? syntax? syntax? (or/c tc-results/c #f) . -> . full-tc-results/c)] - [cond-contracted tc/rec-lambda/check (syntax? syntax? syntax? (listof Type?) tc-results/c . -> . + [cond-contracted tc/rec-lambda/check (syntax? syntax? syntax? (listof Type?) (or/c #f tc-results/c) . -> . (values full-tc-results/c full-tc-results/c))])) (define-signature tc-app^ diff --git a/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-lambda.rkt b/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-lambda.rkt index 2d7e8a86a..d78917cdd 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-lambda.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-lambda.rkt @@ -33,7 +33,6 @@ #:literal-sets (kernel-literals) ;; let loop (pattern ((letrec-values ([(lp) (~and lam (#%plain-lambda (args ...) . body))]) lp*:id) . actuals) - #:when expected #:when (not (andmap type-annotation (syntax->list #'(lp args ...)))) #:when (free-identifier=? #'lp #'lp*) (let-loop-check #'lam #'lp #'actuals #'(args ...) #'body expected)) @@ -69,12 +68,13 @@ (define/cond-contract (let-loop-check lam lp actuals args body expected) - (syntax? syntax? syntax? syntax? syntax? tc-results/c . --> . full-tc-results/c) + (syntax? syntax? syntax? syntax? syntax? (-or/c #f tc-results/c) . --> . full-tc-results/c) (syntax-parse #`(#,args #,body #,actuals) #:literal-sets (kernel-literals lambda-literals) [((val acc ...) ((~and inner-body (if (#%plain-app (~or pair? null?) val*:id) thn els))) (actual actuals ...)) + #:when expected #:when (and (free-identifier=? #'val #'val*) (ormap (lambda (a) (find-annotation #'inner-body a)) @@ -101,6 +101,7 @@ ((~or (~and inner-body (if e1 e2 e3:id)) (~and inner-body (let-values () (if e1 e2 e3:id))))) (null-exp actuals ...)) + #:when expected #:when (free-identifier=? #'val #'e3) #:when (subtype (tc-expr/t #'null-exp) -Null) (let ([ts (for/list ([ac (in-syntax #'(actuals ...))] diff --git a/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt b/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt index 6af500811..c15cf1ac1 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt @@ -797,7 +797,9 @@ ;; Returns both the tc-results of the function and of the body (define (tc/rec-lambda/check formals* body name args return) (define formals (syntax->list formals*)) - (define ft (t:->* args (tc-results->values return))) + (define ft (if return + (t:->* args (tc-results->values return)) + (t:->* args ManyUniv))) (define names (cons name formals)) (with-extended-lexical-env [#:identifiers (cons name formals) diff --git a/typed-racket-test/succeed/events-with-async-channel.rkt b/typed-racket-test/succeed/events-with-async-channel.rkt index 60eafec33..640e92c50 100644 --- a/typed-racket-test/succeed/events-with-async-channel.rkt +++ b/typed-racket-test/succeed/events-with-async-channel.rkt @@ -22,7 +22,7 @@ (when l ; still something to read (intercept l) ; interceptor gets the whole vector (clear-events)))) - (let: loop : Void () + (let loop () (let ([l : (U Log-Receiver-Sync-Result 'stop) (sync receiver stop-chan)]) (cond [(eq? l 'stop) diff --git a/typed-racket-test/succeed/events.rkt b/typed-racket-test/succeed/events.rkt index 5ac086813..3d9aa167d 100644 --- a/typed-racket-test/succeed/events.rkt +++ b/typed-racket-test/succeed/events.rkt @@ -21,7 +21,7 @@ (when l ; still something to read (intercept l) ; interceptor gets the whole vector (clear-events)))) - (let: loop : Void () + (let loop () (let: ([l : (U Log-Receiver-Sync-Result 'stop) (sync receiver stop-chan)]) (cond [(eq? l 'stop) diff --git a/typed-racket-test/unit-tests/typecheck-tests.rkt b/typed-racket-test/unit-tests/typecheck-tests.rkt index 8bd94ff4f..c84cd4419 100644 --- a/typed-racket-test/unit-tests/typecheck-tests.rkt +++ b/typed-racket-test/unit-tests/typecheck-tests.rkt @@ -5283,6 +5283,10 @@ d0) (-lst* (-val 2) (-val "abc") (-ivec* (-val 1) (-val "b") (-val 'x)))] + + + [tc-e (let loop () (loop)) #:ret (-tc-any-results -tt)] + ;; comparisons must correctly account for if the ;; #false result was caused by a NaN (see TR Github issue #747) ;; less-than @@ -5718,5 +5722,5 @@ ([call-with-values (t:-> (t:-> (-values (list -String -String) (list -true-propset -true-propset) (list -empty-obj -empty-obj))) (t:-> -String -String (-values -String -true-propset -empty-obj)) (-values -String -true-propset -empty-obj))])) - ) +) ))