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

Consolidate errors so they only happen once (could get rest arg-related

Browse Source 
error and formal number mismatch error), and then consolidate code.
This commit is contained in:
Stevie Strickland 2008-06-18 15:57:41 -04:00
parent 948286f0c6
commit 5299c9fd5a
1 changed files with 15 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
collects/typed-scheme/private/tc-lambda-unit.ss
View File

@ -53,14 +53,10 @@
(map get-type arg-list)
(cond
[(= arg-len tys-len) arg-tys]
[(< arg-len tys-len) (tc-error/expr
#:return (take arg-tys arg-len)
(expected-str tys-len rest-ty arg-len rest))]
[(> arg-len tys-len) (tc-error/expr
#:return (append arg-tys
(map (lambda _ (if rest-ty rest-ty (Un)))
(drop arg-list tys-len)))
(expected-str tys-len rest-ty arg-len rest))]))])
[(< arg-len tys-len) (take arg-tys arg-len)]
[(> arg-len tys-len) (append arg-tys
(map (lambda _ (if rest-ty rest-ty (Un)))
(drop arg-list tys-len)))]))])
(define (check-body)
(with-lexical-env/extend
arg-list arg-types
@ -75,24 +71,21 @@
[else (make-arr arg-types t rest-ty)])]
[t (int-err "bad match - not a tc-result: ~a ~a ~a" t ret-ty (syntax->datum body))])))
(for-each (lambda (a) (printf/log "Lambda Var: ~a~n" (syntax-e a))) arg-list)
(when (or (not (= arg-len tys-len))
(and rest (not rest-ty)))
(tc-error/delayed (expected-str tys-len rest-ty arg-len rest)))
(cond
[(not rest)
(check-body)]
[rest-ty
(with-lexical-env/extend
(list rest) (list (-lst rest-ty))
(check-body))]
[else
(with-lexical-env/extend
(list rest)
(list (tc-error/expr #:return (-lst (cond
[(type-annotation #'rest)
(get-type #'rest)]
[(< arg-len tys-len)
(list-ref arg-tys arg-len)]
[else (Un)]))
"Expected no rest argument, but got one"))
(check-body))])))
(let ([rest-type (cond
[rest-ty rest-ty]
[(type-annotation rest) (-lst (get-type rest))]
[(< arg-len tys-len) (-lst (list-ref arg-tys arg-len))]
[else (-lst (Un))])])
(with-lexical-env/extend
(list rest) (list (-lst rest-type))
(check-body)))])))
(syntax-case args ()
[(args* ...)
(check-clause (syntax->list #'(args* ...)) #f body arg-tys rest-ty ret-ty)]