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

Type inference for ((lambda with rest args

Browse Source 
svn: r14739
This commit is contained in:
Sam Tobin-Hochstadt 2009-05-07 17:40:29 +00:00
parent 50696a08a3
commit aa887be6d2
2 changed files with 15 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/typed-scheme/test2.ss
View File

@ -44,4 +44,6 @@
(map + (list 1 2 3))
(map + (list 1 2 3) (list 1 2 3))
;; error
;(map + (list 1 2 3) (list 1 2 "foo"))
;(map + (list 1 2 3) (list 1 2 "foo"))
((lambda (a b . c) (+ a b (car c))) 1 2 3 4)

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

@ -3,7 +3,7 @@
(require (rename-in "../utils/utils.ss" [infer r:infer])
"signatures.ss" "tc-metafunctions.ss"
"tc-app-helper.ss"
stxclass scheme/match mzlib/trace
stxclass scheme/match mzlib/trace scheme/list
(for-syntax stxclass scheme/base)
(types utils abbrev union subtype resolve)
(utils tc-utils)
@ -64,11 +64,20 @@
(tc/let-values #'((x) ...) #'(args ...) #'body
#'(let-values ([(x) args] ...) . body)
expected)]
;; inference for ((lambda with dotted rest
[(#%plain-app (#%plain-lambda (x ... . rst:id) . body) args ...)
#:when (<= (length (syntax->list #'(x ...)))
(length (syntax->list #'(args ...))))
(let-values ([(fixed-args varargs) (split-at (syntax->list #'(args ...)) (length (syntax->list #'(x ...))))])
(with-syntax ([(fixed-args ...) fixed-args]
[varg #`(#%plain-app list #,@varargs)])
(tc/let-values #'((x) ... (rst)) #`(fixed-args ... varg) #'body
#'(let-values ([(x) fixed-args] ... [(rst) varg]) . body)
expected)))]
[(#%plain-app f . args)
(let* ([f-ty (single-value #'f)]
[arg-tys (map single-value (syntax->list #'args))])
(tc/funapp #'f #'args f-ty arg-tys expected))]
[_ (int-err "tc/app NYI")]))
(tc/funapp #'f #'args f-ty arg-tys expected))]))
;(trace tc/app/internal)