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

Correctly check letrec-values clauses with no vars

Browse Source 
Should unbreak the build, my apologies to bisecters

original commit: 36c3861494821c9efb1db9df278c77663e1ddb13
This commit is contained in:
Asumu Takikawa 2014-03-12 01:00:14 -04:00
parent 303f87c5eb
commit fc00888943
2 changed files with 32 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt
View File

@ -194,10 +194,22 @@
;; both the non-recursive clauses and the remaining recursive ones.
(define (get-non-recursive-clauses clauses flat-names)
;; First, filter out clauses with no names. Don't do cycle checking on
;; these because they trivially don't form any.
(define-values (*non-binding *other-clauses)
(for/fold ([non-binding '()] [other-clauses '()])
([clause clauses])
(match-define (lr-clause names _ _) clause)
(if (null? names)
(values (cons clause non-binding) other-clauses)
(values non-binding (cons clause other-clauses)))))
(define-values (non-binding other-clauses)
(values (reverse *non-binding) (reverse *other-clauses)))
;; Set up vertices for Tarjan's algorithm, where each letrec-values
;; clause is a vertex but mapped in the table for each of the clause names
(define vertices (make-bound-id-table))
(for ([clause clauses])
(for ([clause other-clauses])
(match-define (lr-clause names expr _) clause)
(define relevant-free-vars
(for/list ([var (in-list (free-vars expr))]
@ -218,17 +230,20 @@
;; The components with only one entry are non-recursive if they also
;; contain no self-cycles.
(for/fold ([non-recursive '()]
[remaining '()])
([component components])
(cond [(and (= (length component) 1)
(no-self-cycle? (car component)))
(values (cons (vertex-data (car component)) non-recursive)
remaining)]
[else
(values non-recursive
(append (map vertex-data component)
remaining))])))
(define-values (non-recursive remaining)
(for/fold ([non-recursive '()]
[remaining '()])
([component components])
(cond [(and (= (length component) 1)
(no-self-cycle? (car component)))
(values (cons (vertex-data (car component)) non-recursive)
remaining)]
[else
(values non-recursive
(append (map vertex-data component)
remaining))])))
(values (append non-recursive non-binding)
remaining))
;; check-non-recursive-clauses : (Listof lr-clause) ->
;; (Listof Identifier) (Listof Type)

7
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt
View File

@ -2439,12 +2439,15 @@
[tc-err (letrec-values ([(a b) (values x "b")]
[(x y) (values a b)])
a)
#:msg "insufficient type information"]
#:msg "no type information"]
[tc-err (letrec-values ([(a) (values x)]
[(x) (values z)]
[(z) (values a)])
a)
#:msg "insufficient type information"]
#:msg "no type information"]
;; make sure no-binding cases like the middle expression are checked
[tc-err (let () (define r "r") (string-append r 'foo) (define x "x") "y")
#:msg "expected: String.*given: 'foo"]
)
(test-suite
"tc-literal tests"