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

Add a type for #%kernel's reverse.

Browse Source 
Present in the expansion of for/list.
This commit is contained in:
Vincent St-Amour 2011-07-29 12:53:42 -04:00
parent 968f3b0905
commit 88a3d93e9e
2 changed files with 7 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/typed-scheme/base-env/base-env.rkt
View File

@ -12,7 +12,7 @@
(only-in rnrs/lists-6 fold-left) (only-in rnrs/lists-6 fold-left)
'#%paramz '#%paramz
"extra-procs.rkt" "extra-procs.rkt"
(only-in '#%kernel [apply kernel:apply]) (only-in '#%kernel [apply kernel:apply] [reverse kernel:reverse])
(only-in racket/private/pre-base new-apply-proc) (only-in racket/private/pre-base new-apply-proc)
scheme/promise scheme/system scheme/promise scheme/system
racket/function racket/function
@ -489,6 +489,7 @@
[touch (-poly (A) ((-future A) . -> . A))] [touch (-poly (A) ((-future A) . -> . A))]
[reverse (-poly (a) (-> (-lst a) (-lst a)))] [reverse (-poly (a) (-> (-lst a) (-lst a)))]
[kernel:reverse (-poly (a) (-> (-lst a) (-lst a)))]
[append (-poly (a) (->* (list) (-lst a) (-lst a)))] [append (-poly (a) (->* (list) (-lst a) (-lst a)))]
[length (-poly (a) (-> (-lst a) -Index))] [length (-poly (a) (-> (-lst a) -Index))]
[memq (-poly (a) (-> a (-lst a) (-opt (-lst a))))] [memq (-poly (a) (-> a (-lst a) (-opt (-lst a))))]

8
collects/typed-scheme/typecheck/tc-app.rkt
View File

@ -10,7 +10,7 @@
scheme/bool scheme/bool
racket/unsafe/ops racket/unsafe/ops
(only-in racket/private/class-internal make-object do-make-object) (only-in racket/private/class-internal make-object do-make-object)
(only-in '#%kernel [apply k:apply]) (only-in '#%kernel [apply k:apply] [reverse k:reverse])
;; end fixme ;; end fixme
(for-syntax syntax/parse scheme/base (utils tc-utils)) (for-syntax syntax/parse scheme/base (utils tc-utils))
(private type-annotation) (private type-annotation)
@ -23,7 +23,7 @@
'#%paramz '#%paramz
(for-template (for-template
racket/unsafe/ops racket/fixnum racket/flonum racket/unsafe/ops racket/fixnum racket/flonum
(only-in '#%kernel [apply k:apply]) (only-in '#%kernel [apply k:apply] [reverse k:reverse])
"internal-forms.rkt" scheme/base scheme/bool '#%paramz "internal-forms.rkt" scheme/base scheme/bool '#%paramz
(only-in racket/private/class-internal make-object do-make-object))) (only-in racket/private/class-internal make-object do-make-object)))
@ -262,7 +262,7 @@
(syntax-parse form (syntax-parse form
#:literals (#%plain-app #%plain-lambda letrec-values quote #:literals (#%plain-app #%plain-lambda letrec-values quote
values apply k:apply not false? list list* call-with-values do-make-object make-object cons values apply k:apply not false? list list* call-with-values do-make-object make-object cons
map andmap ormap reverse extend-parameterization map andmap ormap reverse k:reverse extend-parameterization
vector-ref unsafe-vector-ref unsafe-vector*-ref vector-ref unsafe-vector-ref unsafe-vector*-ref
vector-set! unsafe-vector-set! unsafe-vector*-set! vector-set! unsafe-vector-set! unsafe-vector*-set!
unsafe-struct-ref unsafe-struct*-ref unsafe-struct-set! unsafe-struct*-set!) unsafe-struct-ref unsafe-struct*-ref unsafe-struct-set! unsafe-struct*-set!)
@ -668,7 +668,7 @@
[tys (reverse tys-r)]) [tys (reverse tys-r)])
(ret (foldr make-Pair last tys)))] (ret (foldr make-Pair last tys)))]
;; special case for `reverse' to propagate expected type info ;; special case for `reverse' to propagate expected type info
[(#%plain-app reverse arg) [(#%plain-app (~or reverse k:reverse) arg)
(match expected (match expected
[(tc-result1: (Listof: _)) [(tc-result1: (Listof: _))
(tc-expr/check #'arg expected)] (tc-expr/check #'arg expected)]