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

require/typed is really a definition for the purpose of provide.

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

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

@ -40,7 +40,9 @@
;; require/typed
[(define-values () (begin (quote-syntax (require/typed-internal nm ty)) (#%plain-app values)))
(register-type #'nm (parse-type #'ty))]
(let ([t (parse-type #'ty)])
(register-type #'nm t)
(list (make-def-binding #'nm t)))]
;; define-typed-struct
[(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...))) (#%plain-app values)))