From 9cbdbd8ed76941f1cb0be49932bca4e068d77ef5 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Mon, 21 Jun 2010 17:50:35 -0400
Subject: [PATCH] Added support for unsafe operations on heterogenous vectors.

original commit: 379d9a21251696293a997aa1c58611b85b41b6ce
---
 .../typed-scheme/private/base-env-indexing-abs.rkt   |  2 ++
 collects/typed-scheme/typecheck/tc-app.rkt           | 12 ++++++++----
 2 files changed, 10 insertions(+), 4 deletions(-)

diff --git a/collects/typed-scheme/private/base-env-indexing-abs.rkt b/collects/typed-scheme/private/base-env-indexing-abs.rkt
index 5e451994..8e9b7250 100644
--- a/collects/typed-scheme/private/base-env-indexing-abs.rkt
+++ b/collects/typed-scheme/private/base-env-indexing-abs.rkt
@@ -134,6 +134,8 @@
    [unsafe-vector*-ref (-poly (a) ((-vec a) index-type . -> . a))]
    [build-vector (-poly (a) (index-type (index-type . -> . a) . -> . (-vec a)))]
    [vector-set! (-poly (a) (-> (-vec a) index-type a -Void))]
+   [unsafe-vector-set! (-poly (a) (-> (-vec a) index-type a -Void))]
+   [unsafe-vector*-set! (-poly (a) (-> (-vec a) index-type a -Void))]
    [vector-copy! (-poly (a) ((-vec a) index-type (-vec a) [index-type index-type] . ->opt . -Void))]
    [make-vector (-poly (a) (cl-> [(index-type) (-vec (Un -Nat a))]
                                  [(index-type a) (-vec a)]))]
diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt
index af8a9053..cfa4fb9c 100644
--- a/collects/typed-scheme/typecheck/tc-app.rkt
+++ b/collects/typed-scheme/typecheck/tc-app.rkt
@@ -8,6 +8,7 @@
 	 unstable/sequence unstable/debug
          ;; fixme - don't need to be bound in this phase - only to make syntax/parse happy
          scheme/bool
+         racket/unsafe/ops
          (only-in racket/private/class-internal make-object do-make-object)
          (only-in '#%kernel [apply k:apply])
          ;; end fixme
@@ -20,7 +21,8 @@
          (rep type-rep filter-rep object-rep)
          (r:infer infer)
          '#%paramz
-         (for-template 
+         (for-template
+          racket/unsafe/ops
           (only-in '#%kernel [apply k:apply])
           "internal-forms.rkt" scheme/base scheme/bool '#%paramz
           (only-in racket/private/class-internal make-object do-make-object)))
@@ -441,7 +443,9 @@
   (syntax-parse form
     #:literals (#%plain-app #%plain-lambda letrec-values quote
                 values apply k:apply not list list* call-with-values do-make-object make-object cons
-                map andmap ormap reverse extend-parameterization vector-ref)
+                map andmap ormap reverse extend-parameterization
+                vector-ref unsafe-vector-ref unsafe-vector*-ref
+                vector-set! unsafe-vector-set! unsafe-vector*-set!)
     [(#%plain-app extend-parameterization pmz args ...)
      (let loop ([args (syntax->list #'(args ...))])
        (if (null? args) (ret Univ)
@@ -457,7 +461,7 @@
                 (tc-error/expr #:return (or expected (ret Univ)) "expected Parameter, but got ~a" t)
                 (loop (cddr args))]))))]
     ;; vector-ref on het vectors
-    [(#%plain-app (~and op (~literal vector-ref)) v e:expr)
+    [(#%plain-app (~and op (~or (~literal vector-ref) (~literal unsafe-vector-ref) (~literal unsafe-vector*-ref))) v e:expr)
      (let ([e-t (single-value #'e)])
        (match (single-value #'v)
          [(tc-result1: (and t (HeterogenousVector: es)))
@@ -483,7 +487,7 @@
          [v-ty
           (let ([arg-tys (list v-ty e-t)])
             (tc/funapp #'op #'(v e) (single-value #'op) arg-tys expected))]))]
-    [(#%plain-app (~and op (~literal vector-set!)) v e:expr val:expr)
+    [(#%plain-app (~and op (~or (~literal vector-set!) (~literal unsafe-vector-set!) (~literal unsafe-vector*-set!))) v e:expr val:expr)
      (let ([e-t (single-value #'e)])
        (match (single-value #'v)
          [(tc-result1: (and t (HeterogenousVector: es)))