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

Type goes before symbol in drest.

Browse Source 
Handle tc-results properly in a few places.

svn: r14785

original commit: ce9f98098d8c6429e8586d3ff0cbe1cca2477ba0
This commit is contained in:
Sam Tobin-Hochstadt 2009-05-12 16:53:24 +00:00
parent bc9f01899a
commit f33aee2881
4 changed files with 10 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/typed-scheme/typecheck/signatures.ss
View File

@ -37,7 +37,7 @@
(define-signature tc-app^
([cnt tc/app (syntax? . -> . tc-results?)]
[cnt tc/app/check (syntax? tc-results? . -> . tc-results?)]
[cnt tc/funapp (syntax? syntax? tc-result? (listof tc-results?) (or/c #f tc-results?) . -> . tc-results?)]))
[cnt tc/funapp (syntax? syntax? tc-results? (listof tc-results?) (or/c #f tc-results?) . -> . tc-results?)]))
(define-signature tc-let^
([cnt tc/let-values ((syntax? syntax? syntax? syntax?) ((or/c #f tc-results?)) . ->* . tc-results?)]

10
collects/typed-scheme/typecheck/tc-app.ss
View File

@ -100,8 +100,8 @@
[name-assoc (map list names (syntax->list named-args))])
(let loop ([t (tc-expr cl)])
(match t
[(tc-result: (? Mu? t)) (loop (ret (unfold t)))]
[(tc-result: (and c (Class: pos-tys (list (and tnflds (list tnames _ _)) ...) _)))
[(tc-result1: (? Mu? t)) (loop (ret (unfold t)))]
[(tc-result1: (and c (Class: pos-tys (list (and tnflds (list tnames _ _)) ...) _)))
(unless (= (length pos-tys)
(length (syntax->list pos-args)))
(tc-error/delayed "expected ~a positional arguments, but got ~a"
@ -129,7 +129,7 @@
#f))])
tnflds)
(ret (make-Instance c))]
[(tc-result: t)
[(tc-result1: t)
(tc-error/expr #:return (ret (Un)) "expected a class value for object creation, got: ~a" t)]))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -227,7 +227,7 @@
(let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests])
(cond [(null? doms*)
(match f-ty
[(tc-result: (Poly-names: _ (Function: (list (arr: doms rngs rests drests '()) ..1))))
[(tc-result1: (Poly-names: _ (Function: (list (arr: doms rngs rests drests '()) ..1))))
(tc-error/expr #:return (ret (Un))
(string-append
"Bad arguments to polymorphic function in apply:~n"
@ -279,7 +279,7 @@
(let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests])
(cond [(null? doms*)
(match f-ty
[(tc-result: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests '()) ..1))))
[(tc-result1: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests '()) ..1))))
(tc-error/expr #:return (ret (Un))
(string-append
"Bad arguments to polymorphic function in apply:~n"

4
collects/typed-scheme/typecheck/tc-expr-unit.ss
View File

@ -192,8 +192,8 @@
[(quote-syntax datum) (ret (-Syntax (tc-literal #'datum)) true-filter)]
;; mutation!
[(set! id val)
(match-let* ([(tc-result: id-t) (tc-expr #'id)]
[(tc-result: val-t) (tc-expr #'val)])
(match-let* ([(tc-result1: id-t) (single-value #'id)]
[(tc-result1: val-t) (single-value #'val)])
(unless (subtype val-t id-t)
(tc-error/expr "Mutation only allowed with compatible types:~n~a is not a subtype of ~a" val-t id-t))
(ret -Void))]

4
collects/typed-scheme/typecheck/tc-lambda-unit.ss
View File

@ -23,7 +23,7 @@
(d-s/c lam-result ([args (listof (list/c identifier? Type/c))]
[kws (listof (list/c keyword? identifier? Type/c boolean?))]
[rest (or/c #f Type/c)]
[drest (or/c #f (cons/c symbol? Type/c))]
[drest (or/c #f (cons/c Type/c symbol?))]
[body tc-results?])
#:transparent)
@ -146,7 +146,7 @@
(map list arg-list arg-types)
null
#f
(cons bound rest-type)
(cons rest-type bound)
(tc-exprs (syntax->list body)))))))]
[else
(let ([rest-type (get-type #'rest #:default Univ)])