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

abstract even when out of bindings

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2010-05-12 21:34:18 -04:00
parent 60aed123ce
commit a7a56ce856
1 changed files with 12 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
collects/typed-scheme/typecheck/tc-let-unit.rkt
View File

@ -21,11 +21,12 @@
(import tc-expr^) (import tc-expr^)
(export tc-let^) (export tc-let^)
(d/c (do-check expr->type namess results form exprs body clauses expected) (d/c (do-check expr->type namess results form exprs body clauses expected #:abstract [abstract null])
((syntax? syntax? tc-results? . c:-> . any/c) (((syntax? syntax? tc-results? . c:-> . any/c)
(listof (listof identifier?)) (listof tc-results?) (listof (listof identifier?)) (listof tc-results?)
syntax? (listof syntax?) syntax? (listof syntax?) (or/c #f tc-results?) syntax? (listof syntax?) syntax? (listof syntax?) (or/c #f tc-results?))
. c:-> . (#:abstract any/c)
. c:->* .
tc-results?) tc-results?)
(w/c t/p ([types (listof (listof Type/c))] (w/c t/p ([types (listof (listof Type/c))]
[props (listof (listof Filter?))]) [props (listof (listof Filter?))])
@ -62,12 +63,12 @@
(let ([subber (lambda (proc lst) (let ([subber (lambda (proc lst)
(for/list ([i (in-list lst)]) (for/list ([i (in-list lst)])
(for/fold ([s i]) (for/fold ([s i])
([nm (in-list (apply append namess))]) ([nm (in-list (apply append abstract namess))])
(proc s nm (make-Empty) #t))))]) (proc s nm (make-Empty) #t))))])
(if expected (if expected
(begin (begin
(hash-update! to-be-abstr expected (hash-update! to-be-abstr expected
(lambda (old-l) (apply append old-l namess)) (lambda (old-l) (apply append old-l abstract namess))
null) null)
(tc-exprs/check (syntax->list body) expected)) (tc-exprs/check (syntax->list body) expected))
(match (tc-exprs (syntax->list body)) (match (tc-exprs (syntax->list body))
@ -97,7 +98,7 @@
(define (tc/letrec-values/internal namess exprs body form expected) (define (tc/letrec-values/internal namess exprs body form expected)
(let* ([names (map syntax->list (syntax->list namess))] (let* ([names (map syntax->list (syntax->list namess))]
[flat-names (apply append names)] [orig-flat-names (apply append names)]
[exprs (syntax->list exprs)] [exprs (syntax->list exprs)]
;; the clauses for error reporting ;; the clauses for error reporting
[clauses (syntax-case form () [(lv cl . b) (syntax->list #'cl)])]) [clauses (syntax-case form () [(lv cl . b) (syntax->list #'cl)])])
@ -110,10 +111,12 @@
[_ (void)])) [_ (void)]))
names names
exprs) exprs)
(let loop ([names names] [exprs exprs] [flat-names flat-names] [clauses clauses]) (let loop ([names names] [exprs exprs] [flat-names orig-flat-names] [clauses clauses])
(cond (cond
;; after everything, check the body expressions ;; after everything, check the body expressions
[(null? names) [(null? names)
(do-check void null null form null body null expected #:abstract orig-flat-names)
#;
(if expected (tc-exprs/check (syntax->list body) expected) (tc-exprs (syntax->list body)))] (if expected (tc-exprs/check (syntax->list body) expected) (tc-exprs (syntax->list body)))]
;; if none of the names bound in the letrec are free vars of this rhs ;; if none of the names bound in the letrec are free vars of this rhs
[(not (ormap (lambda (n) (s:member n flat-names bound-identifier=?)) (free-vars (car exprs)))) [(not (ormap (lambda (n) (s:member n flat-names bound-identifier=?)) (free-vars (car exprs))))