diff --git a/collects/tests/typed-scheme/succeed/flvector.ss b/collects/tests/typed-scheme/succeed/flvector.ss new file mode 100644 index 0000000000..22f141176d --- /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 f207b83ec6..d75317162d 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 c7af888c0f..8bcd6539a7 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)