Skip to content

Commit 8822efa

Browse files
committed
Propagate a trivial expected type for recursive lambda if neccessary.
This does not apply an expected type to the actual function body, it just gives a type to the function when referred to recursively. This addresses a problem with inference for let loop in lambda as the argument to `thread` now that `thread` is a keyword function and therefore lifts its arguments to a `let` ahead of the function. Fixing the relevant problem also requires improving the type of `thread`.
1 parent 4934d75 commit 8822efa

File tree

7 files changed

+15
-8
lines changed

7 files changed

+15
-8
lines changed

typed-racket-lib/typed-racket/base-env/base-env.rkt

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1601,7 +1601,7 @@
16011601
;; Section 11.1 (Threads)
16021602

16031603
;; Section 11.1.1
1604-
[thread (->key (-> Univ) #:keep (Un (-val #f) (-val 'results)) #f #:pool Univ #f -Thread)]
1604+
[thread (->key (-> ManyUniv) #:keep (Un (-val #f) (-val 'results)) #f #:pool Univ #f -Thread)]
16051605
[thread? (unsafe-shallow:make-pred-ty -Thread)]
16061606
[current-thread (-> -Thread)]
16071607
[thread/suspend-to-kill (-> (-> Univ) -Thread)]

typed-racket-lib/typed-racket/typecheck/signatures.rkt

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -61,7 +61,7 @@
6161

6262
(define-signature tc-lambda^
6363
([cond-contracted tc/lambda (syntax? syntax? syntax? (or/c tc-results/c #f) . -> . full-tc-results/c)]
64-
[cond-contracted tc/rec-lambda/check (syntax? syntax? syntax? (listof Type?) tc-results/c . -> .
64+
[cond-contracted tc/rec-lambda/check (syntax? syntax? syntax? (listof Type?) (or/c #f tc-results/c) . -> .
6565
(values full-tc-results/c full-tc-results/c))]))
6666

6767
(define-signature tc-app^

typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-lambda.rkt

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -33,7 +33,6 @@
3333
#:literal-sets (kernel-literals)
3434
;; let loop
3535
(pattern ((letrec-values ([(lp) (~and lam (#%plain-lambda (args ...) . body))]) lp*:id) . actuals)
36-
#:when expected
3736
#:when (not (andmap type-annotation (syntax->list #'(lp args ...))))
3837
#:when (free-identifier=? #'lp #'lp*)
3938
(let-loop-check #'lam #'lp #'actuals #'(args ...) #'body expected))
@@ -69,12 +68,13 @@
6968

7069

7170
(define/cond-contract (let-loop-check lam lp actuals args body expected)
72-
(syntax? syntax? syntax? syntax? syntax? tc-results/c . --> . full-tc-results/c)
71+
(syntax? syntax? syntax? syntax? syntax? (-or/c #f tc-results/c) . --> . full-tc-results/c)
7372
(syntax-parse #`(#,args #,body #,actuals)
7473
#:literal-sets (kernel-literals lambda-literals)
7574
[((val acc ...)
7675
((~and inner-body (if (#%plain-app (~or pair? null?) val*:id) thn els)))
7776
(actual actuals ...))
77+
#:when expected
7878
#:when
7979
(and (free-identifier=? #'val #'val*)
8080
(ormap (lambda (a) (find-annotation #'inner-body a))
@@ -101,6 +101,7 @@
101101
((~or (~and inner-body (if e1 e2 e3:id))
102102
(~and inner-body (let-values () (if e1 e2 e3:id)))))
103103
(null-exp actuals ...))
104+
#:when expected
104105
#:when (free-identifier=? #'val #'e3)
105106
#:when (subtype (tc-expr/t #'null-exp) -Null)
106107
(let ([ts (for/list ([ac (in-syntax #'(actuals ...))]

typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -797,7 +797,9 @@
797797
;; Returns both the tc-results of the function and of the body
798798
(define (tc/rec-lambda/check formals* body name args return)
799799
(define formals (syntax->list formals*))
800-
(define ft (t:->* args (tc-results->values return)))
800+
(define ft (if return
801+
(t:->* args (tc-results->values return))
802+
(t:->* args ManyUniv)))
801803
(define names (cons name formals))
802804
(with-extended-lexical-env
803805
[#:identifiers (cons name formals)

typed-racket-test/succeed/events-with-async-channel.rkt

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -22,7 +22,7 @@
2222
(when l ; still something to read
2323
(intercept l) ; interceptor gets the whole vector
2424
(clear-events))))
25-
(let: loop : Void ()
25+
(let loop ()
2626
(let ([l : (U Log-Receiver-Sync-Result 'stop)
2727
(sync receiver stop-chan)])
2828
(cond [(eq? l 'stop)

typed-racket-test/succeed/events.rkt

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -21,7 +21,7 @@
2121
(when l ; still something to read
2222
(intercept l) ; interceptor gets the whole vector
2323
(clear-events))))
24-
(let: loop : Void ()
24+
(let loop ()
2525
(let: ([l : (U Log-Receiver-Sync-Result 'stop)
2626
(sync receiver stop-chan)])
2727
(cond [(eq? l 'stop)

typed-racket-test/unit-tests/typecheck-tests.rkt

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -5283,6 +5283,10 @@
52835283
d0)
52845284
(-lst* (-val 2) (-val "abc") (-ivec* (-val 1) (-val "b") (-val 'x)))]
52855285

5286+
5287+
5288+
[tc-e (let loop () (loop)) #:ret (-tc-any-results -tt)]
5289+
52865290
;; comparisons must correctly account for if the
52875291
;; #false result was caused by a NaN (see TR Github issue #747)
52885292
;; less-than
@@ -5718,5 +5722,5 @@
57185722
([call-with-values (t:-> (t:-> (-values (list -String -String) (list -true-propset -true-propset) (list -empty-obj -empty-obj)))
57195723
(t:-> -String -String (-values -String -true-propset -empty-obj))
57205724
(-values -String -true-propset -empty-obj))]))
5721-
)
5725+
)
57225726
))

0 commit comments

Comments
 (0)