(module tc-let-unit (lib "a-unit.ss")
(require "signatures.ss"
(lib "match.ss")
"types.ss"
"types-aux.ss"
"effects.ss"
"tc-utils.ss"
"subtype.ss"
"subst.ss"
"infer2.ss"
"type-annotation.ss"
"type-env.ss"
"type-environments.ss"
"lexical-env.ss"
"free-vars.ss"
(lib "kerncase.ss" "syntax"))
(require-for-template (lib "match.ss") "internal-forms.ss" mzscheme)
(require-for-syntax (lib "match.ss") "internal-forms.ss")
(require (rename (lib "1.ss" "srfi") member1 member))
(import typechecker^)
(export tc-let^)
(define (do-check expr->type namess types form exprs body clauses)
(define clauses (syntax-case form () [(lv cl . b) (syntax->list #'cl)]))
(with-lexical-env/extend
namess
types
(for-each (lambda (stx e t) (check-type stx (expr->type e) t))
clauses
exprs
(map list->values-ty types))
(tc-exprs (syntax->list body))))
(define (tc/letrec-values namess exprs body form)
(let* ([names (map syntax->list (syntax->list namess))]
[flat-names (apply append names)]
[exprs (syntax->list exprs)]
[clauses (syntax-case form () [(lv cl . b) (syntax->list #'cl)])])
(let loop ([names names] [exprs exprs] [flat-names flat-names] [clauses clauses])
(cond [(null? names) (tc-exprs (syntax->list body))]
[(not (ormap (lambda (n) (member1 n flat-names bound-identifier=?)) (free-vars (car exprs))))
(let ([t (tc-expr/t (car exprs))])
(with-lexical-env/extend
(list (car names))
(list (get-type/infer (car names) t))
(loop (cdr names) (cdr exprs) (apply append (cdr names)) (cdr clauses))))]
[else
(do-check tc-expr/t names (map (lambda (l) (map get-type l)) names) form exprs body clauses)]))))
(define (tc/let-values namess exprs body form)
(let* ( [names (map syntax->list (syntax->list namess))]
[exprs (syntax->list exprs)]
[inferred-types (map tc-expr/t exprs)]
[types (map get-type/infer names inferred-types)]
[clauses (syntax-case form () [(lv cl . b) (syntax->list #'cl)])])
(do-check (lambda (x) x) names types form inferred-types body clauses)))
)