279 lines
9.6 KiB
Scheme
279 lines
9.6 KiB
Scheme
|
|
(load-relative "loadtest.ss")
|
|
|
|
(Section 'unsafe)
|
|
|
|
(require scheme/unsafe/ops
|
|
scheme/flonum
|
|
scheme/foreign)
|
|
|
|
(let ()
|
|
(define (test-tri result proc x y z
|
|
#:pre [pre void]
|
|
#:post [post (lambda (x) x)]
|
|
#:literal-ok? [lit-ok? #t])
|
|
(pre)
|
|
(test result (compose post (eval proc)) x y z)
|
|
(pre)
|
|
(test result (compose post (eval `(lambda (x y z) (,proc x y z)))) x y z)
|
|
(when lit-ok?
|
|
(pre)
|
|
(test result (compose post (eval `(lambda (y z) (,proc ,x y z)))) y z))
|
|
(pre)
|
|
(test result (compose post (eval `(lambda (x z) (,proc x ,y z)))) x z)
|
|
(pre)
|
|
(test result (compose post (eval `(lambda (x y) (,proc x y ,z)))) x y)
|
|
(pre)
|
|
(test result (compose post (eval `(lambda (x) (,proc x ,y ,z)))) x)
|
|
(when lit-ok?
|
|
(pre)
|
|
(test result (compose post (eval `(lambda (y) (,proc ,x y ,z)))) y)
|
|
(pre)
|
|
(test result (compose post (eval `(lambda (z) (,proc ,x ,y z)))) z)))
|
|
(define (test-bin result proc x y
|
|
#:pre [pre void]
|
|
#:post [post (lambda (x) x)]
|
|
#:literal-ok? [lit-ok? #t])
|
|
(pre)
|
|
(test result (compose post (eval proc)) x y)
|
|
(pre)
|
|
(test result (compose post (eval `(lambda (x y) (,proc x y)))) x y)
|
|
(when lit-ok?
|
|
(pre)
|
|
(test result (compose post (eval `(lambda (y) (,proc ,x y)))) y))
|
|
(pre)
|
|
(test result (compose post (eval `(lambda (x) (,proc x ,y)))) x))
|
|
(define (test-un result proc x)
|
|
(test result (eval proc) x)
|
|
(test result (eval `(lambda (x) (,proc x))) x))
|
|
|
|
(test-bin 3 'unsafe-fx+ 1 2)
|
|
(test-bin -1 'unsafe-fx+ 1 -2)
|
|
|
|
(test-bin 8 'unsafe-fx- 10 2)
|
|
(test-bin 3 'unsafe-fx- 1 -2)
|
|
|
|
(test-bin 20 'unsafe-fx* 10 2)
|
|
(test-bin -20 'unsafe-fx* 10 -2)
|
|
|
|
(test-bin 3 'unsafe-fxquotient 17 5)
|
|
(test-bin -3 'unsafe-fxquotient 17 -5)
|
|
|
|
(test-bin 2 'unsafe-fxremainder 17 5)
|
|
(test-bin 2 'unsafe-fxremainder 17 -5)
|
|
|
|
(test-bin 3.4 'unsafe-fl+ 1.4 2.0)
|
|
(test-bin -1.1 'unsafe-fl+ 1.0 -2.1)
|
|
(test-bin +inf.0 'unsafe-fl+ 1.0 +inf.0)
|
|
(test-bin -inf.0 'unsafe-fl+ 1.0 -inf.0)
|
|
(test-bin +nan.0 'unsafe-fl+ +nan.0 -inf.0)
|
|
|
|
(test-bin #f unsafe-fx= 1 2)
|
|
(test-bin #t unsafe-fx= 2 2)
|
|
(test-bin #f unsafe-fx= 2 1)
|
|
|
|
(test-bin #t unsafe-fx< 1 2)
|
|
(test-bin #f unsafe-fx< 2 2)
|
|
(test-bin #f unsafe-fx< 2 1)
|
|
|
|
(test-bin #f unsafe-fx> 1 2)
|
|
(test-bin #f unsafe-fx> 2 2)
|
|
(test-bin #t unsafe-fx> 2 1)
|
|
|
|
(test-bin #t unsafe-fx<= 1 2)
|
|
(test-bin #t unsafe-fx<= 2 2)
|
|
(test-bin #f unsafe-fx<= 2 1)
|
|
|
|
(test-bin #f unsafe-fx>= 1 2)
|
|
(test-bin #t unsafe-fx>= 2 2)
|
|
(test-bin #t unsafe-fx>= 2 1)
|
|
|
|
(test-bin 3 unsafe-fxmin 3 30)
|
|
(test-bin -30 unsafe-fxmin 3 -30)
|
|
|
|
(test-bin 30 unsafe-fxmax 3 30)
|
|
(test-bin 3 unsafe-fxmax 3 -30)
|
|
|
|
(test-bin 7.9 'unsafe-fl- 10.0 2.1)
|
|
(test-bin 3.7 'unsafe-fl- 1.0 -2.7)
|
|
|
|
(test-bin 20.02 'unsafe-fl* 10.01 2.0)
|
|
(test-bin -20.02 'unsafe-fl* 10.01 -2.0)
|
|
|
|
(test-bin (exact->inexact 17/5) 'unsafe-fl/ 17.0 5.0)
|
|
(test-bin +inf.0 'unsafe-fl/ 17.0 0.0)
|
|
(test-bin -inf.0 'unsafe-fl/ -17.0 0.0)
|
|
|
|
(test-bin 3 'unsafe-fxand 7 3)
|
|
(test-bin 2 'unsafe-fxand 6 3)
|
|
(test-bin 3 'unsafe-fxand -1 3)
|
|
|
|
(test-bin 7 'unsafe-fxior 7 3)
|
|
(test-bin 7 'unsafe-fxior 6 3)
|
|
(test-bin -1 'unsafe-fxior -1 3)
|
|
|
|
(test-bin 4 'unsafe-fxxor 7 3)
|
|
(test-bin 5 'unsafe-fxxor 6 3)
|
|
(test-bin -4 'unsafe-fxxor -1 3)
|
|
|
|
(test-un -1 'unsafe-fxnot 0)
|
|
(test-un -4 'unsafe-fxnot 3)
|
|
|
|
(test-bin 32 'unsafe-fxlshift 2 4)
|
|
(test-bin 32 'unsafe-fxlshift 8 2)
|
|
(test-bin 8 'unsafe-fxlshift 8 0)
|
|
|
|
(test-bin 2 'unsafe-fxrshift 32 4)
|
|
(test-bin 8 'unsafe-fxrshift 32 2)
|
|
(test-bin 8 'unsafe-fxrshift 8 0)
|
|
|
|
(test-un 5 unsafe-fxabs 5)
|
|
(test-un 5 unsafe-fxabs -5)
|
|
(test-un 5.0 unsafe-flabs 5.0)
|
|
(test-un 5.0 unsafe-flabs -5.0)
|
|
(test-un 0.0 unsafe-flabs -0.0)
|
|
(test-un +inf.0 unsafe-flabs -inf.0)
|
|
|
|
(test-un 5.0 unsafe-flsqrt 25.0)
|
|
(test-un 0.5 unsafe-flsqrt 0.25)
|
|
(test-un +nan.0 unsafe-flsqrt -1.0)
|
|
|
|
(test-un 8.0 'unsafe-fx->fl 8)
|
|
(test-un -8.0 'unsafe-fx->fl -8)
|
|
|
|
(test-bin 3.7 'unsafe-flmin 3.7 4.1)
|
|
(test-bin 2.1 'unsafe-flmin 3.7 2.1)
|
|
(test-bin +nan.0 'unsafe-flmin +nan.0 2.1)
|
|
(test-bin +nan.0 'unsafe-flmin 2.1 +nan.0)
|
|
(test-bin 3.7 'unsafe-flmax 3.7 2.1)
|
|
(test-bin 4.1 'unsafe-flmax 3.7 4.1)
|
|
(test-bin +nan.0 'unsafe-flmax +nan.0 2.1)
|
|
(test-bin +nan.0 'unsafe-flmax 2.1 +nan.0)
|
|
|
|
;; test unboxing:
|
|
(test-tri 9.0 '(lambda (x y z) (unsafe-fl+ (unsafe-fl- x z) y)) 4.5 7.0 2.5)
|
|
(test-tri 9.0 '(lambda (x y z) (unsafe-fl+ y (unsafe-fl- x z))) 4.5 7.0 2.5)
|
|
(test-bin 10.0 '(lambda (x y) (unsafe-fl+ (unsafe-fx->fl x) y)) 2 8.0)
|
|
(test-bin 10.0 '(lambda (x y) (unsafe-fl+ (unsafe-fx->fl x) y)) 2 8.0)
|
|
(test-bin 9.5 '(lambda (x y) (unsafe-fl+ (unsafe-flabs x) y)) -2.0 7.5)
|
|
(test-tri (/ 20.0 0.8) '(lambda (x y z) (unsafe-fl/ (unsafe-fl* x z) y)) 4.0 0.8 5.0)
|
|
(test-tri (/ 0.8 20.0) '(lambda (x y z) (unsafe-fl/ y (unsafe-fl* x z))) 4.0 0.8 5.0)
|
|
(test-tri #t '(lambda (x y z) (unsafe-fl< (unsafe-fl+ x y) z)) 1.2 3.4 5.0)
|
|
(test-tri 'yes '(lambda (x y z) (if (unsafe-fl< (unsafe-fl+ x y) z) 'yes 'no)) 1.2 3.4 5.0)
|
|
(test-tri #f '(lambda (x y z) (unsafe-fl> (unsafe-fl+ x y) z)) 1.2 3.4 5.0)
|
|
(test-tri 'no '(lambda (x y z) (if (unsafe-fl> (unsafe-fl+ x y) z) 'yes 'no)) 1.2 3.4 5.0)
|
|
|
|
;; test unboxing interaction with free variables:
|
|
(test-tri 4.4 '(lambda (x y z) (with-handlers ([exn:fail:contract:variable?
|
|
(lambda (exn) (unsafe-fl+ x y))])
|
|
(unsafe-fl- (unsafe-fl+ x y) NO-SUCH-VARIABLE)))
|
|
1.1 3.3 5.2)
|
|
|
|
(test-un 5 'unsafe-car (cons 5 9))
|
|
(test-un 9 'unsafe-cdr (cons 5 9))
|
|
(test-un 15 'unsafe-mcar (mcons 15 19))
|
|
(test-un 19 'unsafe-mcdr (mcons 15 19))
|
|
(let ([v (mcons 3 7)])
|
|
(test-bin 8 'unsafe-set-mcar! v 8
|
|
#:pre (lambda () (set-mcar! v 0))
|
|
#:post (lambda (x) (mcar v))
|
|
#:literal-ok? #f)
|
|
(test-bin 9 'unsafe-set-mcdr! v 9
|
|
#:pre (lambda () (set-mcdr! v 0))
|
|
#:post (lambda (x) (mcdr v))
|
|
#:literal-ok? #f))
|
|
|
|
(test-bin 5 'unsafe-vector-ref #(1 5 7) 1)
|
|
(test-un 3 'unsafe-vector-length #(1 5 7))
|
|
(let ([v (vector 0 3 7)])
|
|
(test-tri (list (void) 5) 'unsafe-vector-set! v 2 5
|
|
#:pre (lambda () (vector-set! v 2 0))
|
|
#:post (lambda (x) (list x (vector-ref v 2)))
|
|
#:literal-ok? #f))
|
|
|
|
(test-bin 53 'unsafe-bytes-ref #"157" 1)
|
|
(test-un 3 'unsafe-bytes-length #"157")
|
|
(let ([v (bytes 0 3 7)])
|
|
(test-tri (list (void) 135) 'unsafe-bytes-set! v 2 135
|
|
#:pre (lambda () (bytes-set! v 2 0))
|
|
#:post (lambda (x) (list x (bytes-ref v 2)))
|
|
#:literal-ok? #f))
|
|
|
|
(test-bin #\5 'unsafe-string-ref "157" 1)
|
|
(test-un 3 'unsafe-string-length "157")
|
|
(let ([v (string #\0 #\3 #\7)])
|
|
(test-tri (list (void) #\5) 'unsafe-string-set! v 2 #\5
|
|
#:pre (lambda () (string-set! v 2 #\0))
|
|
#:post (lambda (x) (list x (string-ref v 2)))
|
|
#:literal-ok? #f))
|
|
|
|
(test-bin 9.5 'unsafe-flvector-ref (flvector 1.0 9.5 18.7) 1)
|
|
(test-un 5 'unsafe-flvector-length (flvector 1.1 2.0 3.1 4.5 5.7))
|
|
(let ([v (flvector 1.0 9.5 18.7)])
|
|
(test-tri (list (void) 27.4) 'unsafe-flvector-set! v 2 27.4
|
|
#:pre (lambda () (flvector-set! v 2 0.0))
|
|
#:post (lambda (x) (list x (flvector-ref v 2)))
|
|
#:literal-ok? #f))
|
|
|
|
(test-bin 9.5 'unsafe-f64vector-ref (f64vector 1.0 9.5 18.7) 1)
|
|
(let ([v (f64vector 1.0 9.5 18.7)])
|
|
(test-tri (list (void) 27.4) 'unsafe-f64vector-set! v 2 27.4
|
|
#:pre (lambda () (f64vector-set! v 2 0.0))
|
|
#:post (lambda (x) (list x (f64vector-ref v 2)))
|
|
#:literal-ok? #f))
|
|
|
|
(let ()
|
|
(define-struct posn (x [y #:mutable] z))
|
|
(test-bin 'a unsafe-struct-ref (make-posn 'a 'b 'c) 0 #:literal-ok? #f)
|
|
(test-bin 'b unsafe-struct-ref (make-posn 'a 'b 'c) 1 #:literal-ok? #f)
|
|
(let ([p (make-posn 100 200 300)])
|
|
(test-tri 500 'unsafe-struct-set! p 1 500
|
|
#:pre (lambda () (set-posn-y! p 0))
|
|
#:post (lambda (x) (posn-y p))
|
|
#:literal-ok? #f)))
|
|
;; test unboxing:
|
|
(test-tri 5.4 '(lambda (x y z) (unsafe-fl+ x (unsafe-f64vector-ref y z))) 1.2 (f64vector 1.0 4.2 6.7) 1)
|
|
(test-tri 3.2 '(lambda (x y z)
|
|
(unsafe-f64vector-set! y 1 (unsafe-fl+ x z))
|
|
(unsafe-f64vector-ref y 1))
|
|
1.2 (f64vector 1.0 4.2 6.7) 2.0)
|
|
|
|
(void))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Interaction of unboxing, closures, etc.
|
|
(let ([f (lambda (x)
|
|
(let ([x (unsafe-fl+ x 1.0)])
|
|
(let loop ([v 0.0][n 10000])
|
|
(if (zero? n)
|
|
v
|
|
(loop (unsafe-fl+ v x)
|
|
(- n 1))))))])
|
|
(test 20000.0 f 1.0))
|
|
(let ([f (lambda (x)
|
|
(let ([x (unsafe-fl+ x 1.0)])
|
|
(let loop ([v 0.0][n 10000][q 2.0])
|
|
(if (zero? n)
|
|
(unsafe-fl+ v q)
|
|
(loop (unsafe-fl+ v x)
|
|
(- n 1)
|
|
(unsafe-fl- 0.0 q))))))])
|
|
(test 20002.0 f 1.0))
|
|
(let ([f (lambda (x)
|
|
(let loop ([a 0.0][v 0.0][n 1000000])
|
|
(if (zero? n)
|
|
v
|
|
(if (odd? n)
|
|
(let ([b (unsafe-fl+ a a)])
|
|
(loop b v (sub1 n)))
|
|
;; First arg is un place, but may need re-boxing
|
|
(loop a
|
|
(unsafe-fl+ v x)
|
|
(- n 1))))))])
|
|
(test 500000.0 f 1.0))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(report-errs)
|