From 9cf45f33924622b0996048de4fa225d26ebcfca0 Mon Sep 17 00:00:00 2001
From: Noel Welsh <noel@racket-lang.org>
Date: Wed, 17 Mar 2010 14:49:29 +0000
Subject: [PATCH] Add FlVector types to Typed Scheme and bindings for all
 flvector operations in scheme/flonum and scheme/unsafe/ops.

svn: r18555

original commit: 39a1489403db3184b23622dfde17548d65681f6a
---
 .../tests/typed-scheme/succeed/flvector.ss    | 39 +++++++++++++++++++
 .../typed-scheme/private/base-env-numeric.ss  | 17 ++++++++
 collects/typed-scheme/types/abbrev.ss         |  3 ++
 3 files changed, 59 insertions(+)
 create mode 100644 collects/tests/typed-scheme/succeed/flvector.ss

diff --git a/collects/tests/typed-scheme/succeed/flvector.ss b/collects/tests/typed-scheme/succeed/flvector.ss
new file mode 100644
index 00000000..22f14117
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/flvector.ss
@@ -0,0 +1,39 @@
+#lang typed/scheme
+
+(require
+ scheme/flonum
+ scheme/unsafe/ops)
+
+;; Test the all the flvector operations have been wrapped with types
+
+;; We aren't really testing the semantics of the
+;; operations. The checks are just to catch anything that is
+;; really badly wrong.
+
+(: check (All (a) ((a a -> Boolean) a a -> Boolean)))
+;; Simple check function as SchemeUnit doesn't work in Typed Scheme (yet)
+(define (check f a b)
+  (if (f a b)
+      #t
+      (error (format "Check (~a ~a ~a) failed" f a b)))) 
+
+(check equal? (flvector 1. 2. 3. 4.) (flvector 1. 2. 3. 4.))
+(check equal? (flvector? (flvector 1. 2. 3.)) #t)
+(check equal? (make-flvector 3 3.0) (flvector 3. 3. 3.))
+(check = (flvector-length (flvector 1. 2. 3.)) 3)
+(check = (flvector-ref (flvector 1. 2. 3.) 0) 1.)
+(check =
+       (let ([v (flvector 1. 2. 3.)])
+         (flvector-set! v 0 10.)
+         (flvector-ref v 0))
+       10.)
+
+;; Unsafe operations
+
+(check = (unsafe-flvector-length (flvector 1. 2. 3.)) 3)
+(check = (unsafe-flvector-ref (flvector 1. 2. 3.) 0) 1.)
+(check =
+       (let ([v (flvector 1. 2. 3.)])
+         (unsafe-flvector-set! v 0 10.)
+         (unsafe-flvector-ref v 0))
+       10.)
\ No newline at end of file
diff --git a/collects/typed-scheme/private/base-env-numeric.ss b/collects/typed-scheme/private/base-env-numeric.ss
index f207b83e..d7531716 100644
--- a/collects/typed-scheme/private/base-env-numeric.ss
+++ b/collects/typed-scheme/private/base-env-numeric.ss
@@ -236,3 +236,20 @@
 [fl>= fl-comp]
 [fl> fl-comp]
 [fl< fl-comp]
+
+;; safe flvector ops
+
+[flvector? (make-pred-ty -FlVector)]
+[flvector (->* (list) -Flonum -FlVector)]
+[make-flvector (-> -Integer -Flonum -FlVector)]
+[flvector-length (-> -FlVector -Nat)]
+[flvector-ref (-> -FlVector -Nat -Flonum)]
+[flvector-set! (-> -FlVector -Nat -Flonum -Void)]
+
+;; unsafe flvector ops
+
+[unsafe-flvector (->* (list) -Flonum -FlVector)]
+[unsafe-make-flvector (-> -Integer -Flonum -FlVector)]
+[unsafe-flvector-length (-> -FlVector -Nat)]
+[unsafe-flvector-ref (-> -FlVector -Nat -Flonum)]
+[unsafe-flvector-set! (-> -FlVector -Nat -Flonum -Void)]
diff --git a/collects/typed-scheme/types/abbrev.ss b/collects/typed-scheme/types/abbrev.ss
index c7af888c..8bcd6539 100644
--- a/collects/typed-scheme/types/abbrev.ss
+++ b/collects/typed-scheme/types/abbrev.ss
@@ -8,6 +8,7 @@
          scheme/list
          scheme/match         
          scheme/promise
+         scheme/flonum
          (prefix-in c: scheme/contract)
          (for-syntax scheme/base syntax/parse)
 	 (for-template scheme/base scheme/contract scheme/promise scheme/tcp))
@@ -99,6 +100,8 @@
 (define -Input-Port (make-Base 'Input-Port #'input-port?))
 (define -TCP-Listener (make-Base 'TCP-Listener #'tcp-listener?))
 
+(define -FlVector (make-Base 'FlVector #'flvector?))
+
 (define -Syntax make-Syntax)
 (define -HT make-Hashtable)
 (define -Promise make-promise-ty)