diff --git a/collects/typed-scheme/private/tc-dots-unit.ss b/collects/typed-scheme/private/tc-dots-unit.ss new file mode 100644 index 0000000000..26c2436960 --- /dev/null +++ b/collects/typed-scheme/private/tc-dots-unit.ss @@ -0,0 +1,35 @@ +#lang scheme/unit + +(require "signatures.ss" + "tc-utils.ss" + "type-environments.ss" + "type-utils.ss" + "type-rep.ss" + syntax/kerncase + scheme/match) + +(require (for-template scheme/base)) + +(import tc-expr^ tc-app^) +(export tc-dots^) + +;; form : syntax[expr] +;; returns two values : one is the type, the other the bound on the ... (always a symbol) +(define (tc/dots form) + (parameterize ([current-orig-stx form]) + (kernel-syntax-case* form #f (map) + [id + (identifier? #'id) + (match (lookup (dotted-env) #'id (lambda (k) (lookup-fail (syntax-e k)))) + [(cons dty dbound) + (values dty dbound)])] + [(#%plain-app map f l) + (let-values ([(lty lbound) (tc/dots #'l)]) + (parameterize ([current-tvars (extend-env (list lbound) + (list (make-DottedBoth (make-F lbound))) + (current-tvars))]) + (match-let* ([ft (tc-expr #'f)] + [(tc-result: t) (tc/funapp #'f #'(l) ft (list (ret lty)) #f)]) + (values t lbound))))] + [_ + (tc-error "form cannot be used where a term of ... type is expected")]))) \ No newline at end of file