From fcfa476f15fc8ea54c7a61fe72519442dd6ed78d Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 29 Jul 2011 12:53:42 -0400 Subject: [PATCH] Add a type for #%kernel's reverse. Present in the expansion of for/list. original commit: 88a3d93e9e93118a57a25c5da0b392763552a3bd --- collects/typed-scheme/base-env/base-env.rkt | 3 ++- collects/typed-scheme/typecheck/tc-app.rkt | 10 +++++----- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/collects/typed-scheme/base-env/base-env.rkt b/collects/typed-scheme/base-env/base-env.rkt index 9de38303..9ab5ed55 100644 --- a/collects/typed-scheme/base-env/base-env.rkt +++ b/collects/typed-scheme/base-env/base-env.rkt @@ -12,7 +12,7 @@ (only-in rnrs/lists-6 fold-left) '#%paramz "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) scheme/promise scheme/system racket/function @@ -489,6 +489,7 @@ [touch (-poly (A) ((-future A) . -> . A))] [reverse (-poly (a) (-> (-lst a) (-lst a)))] +[kernel:reverse (-poly (a) (-> (-lst a) (-lst a)))] [append (-poly (a) (->* (list) (-lst a) (-lst a)))] [length (-poly (a) (-> (-lst a) -Index))] [memq (-poly (a) (-> a (-lst a) (-opt (-lst a))))] diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index 40500a57..7f6744a9 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -5,12 +5,12 @@ "tc-app-helper.rkt" "find-annotation.rkt" "tc-funapp.rkt" "tc-subst.rkt" (prefix-in c: racket/contract) syntax/parse racket/match racket/trace scheme/list - unstable/sequence unstable/list + unstable/sequence unstable/list ;; fixme - don't need to be bound in this phase - only to make tests work scheme/bool racket/unsafe/ops (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 (for-syntax syntax/parse scheme/base (utils tc-utils)) (private type-annotation) @@ -23,7 +23,7 @@ '#%paramz (for-template 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 (only-in racket/private/class-internal make-object do-make-object))) @@ -262,7 +262,7 @@ (syntax-parse form #: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 - map andmap ormap reverse extend-parameterization + map andmap ormap reverse k:reverse extend-parameterization vector-ref unsafe-vector-ref unsafe-vector*-ref vector-set! unsafe-vector-set! unsafe-vector*-set! unsafe-struct-ref unsafe-struct*-ref unsafe-struct-set! unsafe-struct*-set!) @@ -668,7 +668,7 @@ [tys (reverse tys-r)]) (ret (foldr make-Pair last tys)))] ;; special case for `reverse' to propagate expected type info - [(#%plain-app reverse arg) + [(#%plain-app (~or reverse k:reverse) arg) (match expected [(tc-result1: (Listof: _)) (tc-expr/check #'arg expected)]