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

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

@ -45,3 +45,5 @@
(map + (list 1 2 3) (list 1 2 3)) (map + (list 1 2 3) (list 1 2 3))
;; error ;; 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]) (require (rename-in "../utils/utils.ss" [infer r:infer])
"signatures.ss" "tc-metafunctions.ss" "signatures.ss" "tc-metafunctions.ss"
"tc-app-helper.ss" "tc-app-helper.ss"
stxclass scheme/match mzlib/trace stxclass scheme/match mzlib/trace scheme/list
(for-syntax stxclass scheme/base) (for-syntax stxclass scheme/base)
(types utils abbrev union subtype resolve) (types utils abbrev union subtype resolve)
(utils tc-utils) (utils tc-utils)
@ -64,11 +64,20 @@
(tc/let-values #'((x) ...) #'(args ...) #'body (tc/let-values #'((x) ...) #'(args ...) #'body
#'(let-values ([(x) args] ...) . body) #'(let-values ([(x) args] ...) . body)
expected)] 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) [(#%plain-app f . args)
(let* ([f-ty (single-value #'f)] (let* ([f-ty (single-value #'f)]
[arg-tys (map single-value (syntax->list #'args))]) [arg-tys (map single-value (syntax->list #'args))])
(tc/funapp #'f #'args f-ty arg-tys expected))] (tc/funapp #'f #'args f-ty arg-tys expected))]))
[_ (int-err "tc/app NYI")]))
;(trace tc/app/internal) ;(trace tc/app/internal)