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

revert previous change

Browse Source 
svn: r12074
This commit is contained in:
Sam Tobin-Hochstadt 2008-10-20 19:01:52 +00:00
parent aad41cc46e
commit 714e356fb4
1 changed files with 4 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -108,8 +108,7 @@
[else [else
(tc-error/delayed (tc-error/delayed
#:stx (car stxs) #:stx (car stxs)
"Wrong function argument type to ~a, expected ~a, got ~a for argument ~a" "Wrong function argument type, expected ~a, got ~a for argument ~a"
(syntax->datum (current-orig-stx))
(car doms) (car args) arg-count) (car doms) (car args) arg-count)
(loop (cdr args) (cdr doms) (cdr stxs) (add1 arg-count))])))) (loop (cdr args) (cdr doms) (cdr stxs) (add1 arg-count))]))))
@ -396,7 +395,6 @@
(define (tc/funapp f-stx args-stx ftype0 argtys expected) (define (tc/funapp f-stx args-stx ftype0 argtys expected)
;(printf "~a~n" (syntax->datum f-stx))
(match-let* ([(list (tc-result: argtypes arg-thn-effs arg-els-effs) ...) argtys]) (match-let* ([(list (tc-result: argtypes arg-thn-effs arg-els-effs) ...) argtys])
(let outer-loop ([ftype ftype0] (let outer-loop ([ftype ftype0]
[argtypes argtypes] [argtypes argtypes]
@ -696,9 +694,7 @@
"Cannot apply expression of type ~a, since it is not a function type" t)])] "Cannot apply expression of type ~a, since it is not a function type" t)])]
;; even more special case for match ;; even more special case for match
[(#%plain-app (letrec-values ([(lp) (#%plain-lambda args . body)]) lp*) . actuals) [(#%plain-app (letrec-values ([(lp) (#%plain-lambda args . body)]) lp*) . actuals)
(begin (and expected (not (andmap type-annotation (syntax->list #'args))) (free-identifier=? #'lp #'lp*))
(printf "got here~n")
(and expected (not (andmap type-annotation (syntax->list #'args))) (free-identifier=? #'lp #'lp*)))
(let-loop-check form #'lp #'actuals #'args #'body expected)] (let-loop-check form #'lp #'actuals #'args #'body expected)]
;; or/andmap of ... argument ;; or/andmap of ... argument
[(#%plain-app or/andmap f arg) [(#%plain-app or/andmap f arg)
@ -721,7 +717,6 @@
(tc/funapp #'f #'(args ...) (tc-expr #'f) (map tc-expr (syntax->list #'(args ...))) expected)])) (tc/funapp #'f #'(args ...) (tc-expr #'f) (map tc-expr (syntax->list #'(args ...))) expected)]))
(define (let-loop-check form lp actuals args body expected) (define (let-loop-check form lp actuals args body expected)
(printf "in let-loop-check~n")
(kernel-syntax-case* #`(#,args #,body #,actuals) #f (null?) (kernel-syntax-case* #`(#,args #,body #,actuals) #f (null?)
[((val acc ...) [((val acc ...)
((if (#%plain-app null? val*) thn els)) ((if (#%plain-app null? val*) thn els))
@ -735,13 +730,10 @@
(or (find-annotation #'(if (#%plain-app null? val*) thn els) a) (or (find-annotation #'(if (#%plain-app null? val*) thn els) a)
(generalize (tc-expr/t ac))))] (generalize (tc-expr/t ac))))]
[ts (cons ts1 ann-ts)]) [ts (cons ts1 ann-ts)])
(printf "in body~n")
;; check that the actual arguments are ok here ;; check that the actual arguments are ok here
(for-each tc-expr/check (syntax->list #'(actuals ...)) ann-ts) (map tc-expr/check (syntax->list #'(actuals ...)) ann-ts)
(printf "checked args~n")
;; then check that the function typechecks with the inferred types ;; then check that the function typechecks with the inferred types
(values #;debug (tc/rec-lambda/check form args body lp ts expected)) (tc/rec-lambda/check form args body lp ts expected)
(printf "done~n")
(ret expected))] (ret expected))]
;; special case when argument needs inference ;; special case when argument needs inference
[_ [_