From 2d28ab5f139bea9b862ee0dc219b742cce1848be Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 1 Jun 2010 18:31:05 -0400 Subject: [PATCH] Special-case (- x 1) for use in loops. original commit: 7f300a2c4f9d934522a3b3ba3d5c949b5bd075ed --- collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt | 5 +++++ collects/typed-scheme/typecheck/tc-app.rkt | 6 ++++++ 2 files changed, 11 insertions(+) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt index 74608a25..b1d8e540 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt @@ -802,6 +802,11 @@ (eq? 'r x) (eq? 's x))) (make-pred-ty (t:Un (-val 'q) (-val 'r) (-val 's)))] + [tc-e (let: ([x : Exact-Positive-Integer 1]) + (vector-ref #("a" "b") x) + (vector-ref #("a" "b") (sub1 x)) + (vector-ref #("a" "b") (- x 1))) + -String] ) (test-suite "check-type tests" diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index 9afae1e2..44e9d45a 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -508,6 +508,12 @@ (tc-error/expr "expected ~a, but got ~a" t (make-HeterogenousVector (map tc-expr/t (syntax->list #'(args ...))))) expected] [_ (int-err "bad expected: ~a" expected)])] + ;; special case for `-' used like `sub1' + [(#%plain-app (~and op (~literal -)) v (~and arg2 ((~literal quote) 1))) + (match-let ([(tc-result1: t) (single-value #'v)]) + (if (subtype t -ExactPositiveInteger) + (ret -Nat) + (tc/funapp #'op #'(v arg2) (single-value #'op) (list (ret t) (single-value #'arg2)) expected)))] ;; call-with-values [(#%plain-app call-with-values prod con) (match (tc/funapp #'prod #'() (single-value #'prod) null #f)