-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy path160.scm
138 lines (120 loc) · 4.37 KB
/
160.scm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
;; Copyright 2019 John Cowan
;; SPDX-License-Identifier: MIT
(test-begin "srfi-160")
;;;; Shared tests
;;; Hvector = homogeneous vector
;; Test for sameness
(define relerr (expt 2 -24))
(define (inexact-real? x) (and (number? x) (inexact? x) (real? x)))
(define (inexact-complex? x) (and (number? x) (inexact? x) (not (real? x))))
(define (realify z) (* (real-part z) (imag-part z)))
(define (same? result expected)
(cond
((and (inexact-real? result) (inexact-real? expected))
(let ((abserr (abs (* expected relerr))))
(<= (- expected abserr) result (+ expected abserr))))
((and (inexact-complex? result) (inexact-complex? expected))
(let ((abserr (abs (* (realify expected) relerr))))
(<= (- (realify expected) abserr)
(realify result)
(+ (realify expected) abserr))))
((and (number? result) (number? expected))
(= result expected))
((and (pair? result) (pair? expected))
(list-same? result expected))
(else
(equal? result expected))))
(define (list-same? result expected)
(cond
((and (null? result) (null? expected))
#t)
((and (pair? result) (pair? expected))
(and (same? (car result) (car expected))
(list-same? (cdr result) (cdr expected))))
(else
#f)))
(define (create label value)
value)
(define (test-element-type
tag make-Hvector Hvector Hvector? Hvector-length
Hvector-ref Hvector-set! Hvector->list list->Hvector)
(display "STARTING ")
(display tag)
(display "vector TESTS:")
(newline)
(let* ((first 32.0)
(second 32.0+47.0i)
(third -47.0i)
(vec0 (make-Hvector 3))
(vec1 (make-Hvector 3 second))
(vec2 (Hvector first second third))
(vec3 (list->Hvector (list third second first))))
(test-equal #t (Hvector? vec0))
(test-equal #t (Hvector? vec1))
(test-equal #t (Hvector? vec2))
(test-equal #t (Hvector? vec3))
(test-equal 3 (Hvector-length vec0))
(test-equal 3 (Hvector-length vec1))
(test-equal 3 (Hvector-length vec2))
(test-equal 3 (Hvector-length vec3))
(Hvector-set! vec0 0 second)
(Hvector-set! vec0 1 third)
(Hvector-set! vec0 2 first)
(test-equal second (Hvector-ref vec0 0))
(test-equal third (Hvector-ref vec0 1))
(test-equal first (Hvector-ref vec0 2))
(test-equal second (Hvector-ref vec1 0))
(test-equal second (Hvector-ref vec1 1))
(test-equal second (Hvector-ref vec1 2))
(test-equal first (Hvector-ref vec2 0))
(test-equal second (Hvector-ref vec2 1))
(test-equal third (Hvector-ref vec2 2))
(test-equal third (Hvector-ref vec3 0))
(test-equal second (Hvector-ref vec3 1))
(test-equal first (Hvector-ref vec3 2))
(test-equal (list second third first) (Hvector->list vec0))
(test-equal (list second second second) (Hvector->list vec1))
(test-equal (list first second third) (Hvector->list vec2))
(test-equal (list third second first) (Hvector->list vec3))))
(test-element-type
'c64 make-c64vector c64vector c64vector? c64vector-length
c64vector-ref c64vector-set! c64vector->list list->c64vector)
(test-element-type
'c128 make-c128vector c128vector c128vector? c128vector-length
c128vector-ref c128vector-set! c128vector->list list->c128vector)
(define-syntax integral-tests
(syntax-rules ()
((integral-tests pred lo hi)
(begin
(test-assert (not (pred 1/2)))
(test-assert (not (pred 1.0)))
(test-assert (not (pred 1+2i)))
(test-assert (not (pred 1.0+2.0i)))
(test-assert (pred 0))
(test-assert (pred hi))
(test-assert (pred lo))
(test-assert (not (pred (+ hi 1))))
(test-assert (not (pred (- lo 1))))))))
(display "STARTING @? TESTS")
(newline)
(integral-tests u8? 0 255)
(integral-tests s8? -128 127)
(integral-tests u16? 0 65535)
(integral-tests s16? -32768 32767)
(integral-tests u32? 0 4294967295)
(integral-tests s32? -2147483648 2147483647)
(integral-tests u64? 0 18446744073709551615)
(integral-tests s64? -9223372036854775808 9223372036854775807)
(test-assert (f32? 1.0))
(test-assert (not (f32? 1)))
(test-assert (not (f32? 1.0+2.0i)))
(test-assert (f64? 1.0))
(test-assert (not (f64? 1)))
(test-assert (not (f64? 1.0+2.0i)))
(test-assert (c64? 1.0))
(test-assert (not (c64? 1)))
(test-assert (c64? 1.0+2.0i))
(test-assert (c128? 1.0))
(test-assert (not (c128? 1)))
(test-assert (c128? 1.0+2.0i))
(test-end "srfi-160")