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

Extend time-apply to work with procedures with more than 2 arguments.

Browse Source
This commit is contained in:
Vincent St-Amour 2012-06-17 22:02:36 -04:00
parent a5f2ca8fb0
commit 24b6ecf2a6
2 changed files with 19 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/tests/typed-racket/unit-tests/typecheck-tests.rkt
View File

@ -822,7 +822,15 @@
[tc-e [tc-e
(call-with-values (lambda () (time-apply + (list 1 2))) (call-with-values (lambda () ((inst time-apply Number Number Number) + (list 1 2)))
(lambda: ([v : (Listof Number)]
[cpu : Number]
[user : Number]
[gc : Number])
'whatever))
#:ret (ret (-val 'whatever) -true-filter)]
[tc-e
(call-with-values (lambda () ((inst time-apply Number Number Number Number Number Number Number) + (list 1 2 3 4 5 6)))
(lambda: ([v : (Listof Number)] (lambda: ([v : (Listof Number)]
[cpu : Number] [cpu : Number]
[user : Number] [user : Number]

26
collects/typed-racket/base-env/base-env.rkt
View File

@ -25,12 +25,14 @@
racket/file racket/file
(only-in racket/private/pre-base new-apply-proc) (only-in racket/private/pre-base new-apply-proc)
(only-in (types abbrev numeric-tower) [-Number N] [-Boolean B] [-Symbol Sym]) (only-in (types abbrev numeric-tower) [-Number N] [-Boolean B] [-Symbol Sym])
(only-in (rep type-rep) make-MPairTop (only-in (rep type-rep)
make-MPairTop
make-BoxTop make-ChannelTop make-VectorTop make-BoxTop make-ChannelTop make-VectorTop
make-ThreadCellTop make-ThreadCellTop
make-Ephemeron make-Ephemeron
make-CustodianBox make-CustodianBox
make-HeterogenousVector)) make-HeterogenousVector
make-ListDots))
;Section 9.2 ;Section 9.2
@ -564,20 +566,12 @@
[apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))] [apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))]
[new-apply-proc (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))] [new-apply-proc (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))]
[kernel:apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))] [kernel:apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))]
[time-apply (-poly (a b c) [time-apply
(cl->* (-polydots (b a) (cl->*
(-> (-> (-> b) (-val '()) (-values (list (-pair b (-val '())) -Nat -Nat -Nat)))
(-> a) (-> (->... '() (a a) b)
(-Tuple (list)) (make-ListDots a 'a)
(-values (list (-pair a (-val '())) -Nat -Nat -Nat))) (-values (list (-pair b (-val '())) -Nat -Nat -Nat)))))]
(->
(-> b a)
(-Tuple (list b))
(-values (list (-pair a (-val '())) -Nat -Nat -Nat)))
(->
(-> b c a)
(-Tuple (list b c))
(-values (list (-pair a (-val '())) -Nat -Nat -Nat)))))]
[call/cc (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (Un a b)))] [call/cc (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (Un a b)))]
[call/ec (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (Un a b)))] [call/ec (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (Un a b)))]