1; Part of Scheme 48 1.9.  See file COPYING for notices and license.
2
3; Authors: Harald Glab-Phlak, Mike Sperber
4
5(define (bytevector:nan? x)
6  (and (real? x)
7       (not (= x x))))
8
9(define (bytevector:infinite? x)
10  (and (real? x)
11       (not (bytevector:nan? x))
12       (bytevector:nan? (- x x))))
13
14;exported stuff
15(define (bytevector-ieee-single-native-ref bytevector k)
16  (r6rs-bytevect->float bytevector k))
17
18(define (bytevector-ieee-double-native-ref bytevector k)
19  (r6rs-bytevect->double bytevector k))
20
21
22(define (bytevector-ieee-single-ref bytevector k endness)
23  (if (eq? endness (native-endianness))
24      (if (= 0 (remainder k 4))
25          (bytevector-ieee-single-native-ref bytevector k)
26          (let ((b (make-bytevector 4)))
27            (bytevector-copy! bytevector k b 0 4)
28            (bytevector-ieee-single-native-ref b 0)))
29      (let ((b (make-bytevector 4)))
30        (bytevector-u8-set! b 0 (bytevector-u8-ref bytevector (+ k 3)))
31        (bytevector-u8-set! b 1 (bytevector-u8-ref bytevector (+ k 2)))
32        (bytevector-u8-set! b 2 (bytevector-u8-ref bytevector (+ k 1)))
33        (bytevector-u8-set! b 3 (bytevector-u8-ref bytevector k))
34        (bytevector-ieee-single-native-ref b 0))))
35
36(define (bytevector-ieee-double-ref bytevector k endness)
37  (if (eq? endness (native-endianness))
38      (if (= 0 (remainder k 8))
39          (bytevector-ieee-double-native-ref bytevector k)
40          (let ((b (make-bytevector 8)))
41            (bytevector-copy! bytevector k b 0 8)
42            (bytevector-ieee-double-native-ref b 0)))
43      (let ((b (make-bytevector 8)))
44        (bytevector-u8-set! b 0 (bytevector-u8-ref bytevector (+ k 7)))
45        (bytevector-u8-set! b 1 (bytevector-u8-ref bytevector (+ k 6)))
46        (bytevector-u8-set! b 2 (bytevector-u8-ref bytevector (+ k 5)))
47        (bytevector-u8-set! b 3 (bytevector-u8-ref bytevector (+ k 4)))
48        (bytevector-u8-set! b 4 (bytevector-u8-ref bytevector (+ k 3)))
49        (bytevector-u8-set! b 5 (bytevector-u8-ref bytevector (+ k 2)))
50        (bytevector-u8-set! b 6 (bytevector-u8-ref bytevector (+ k 1)))
51        (bytevector-u8-set! b 7 (bytevector-u8-ref bytevector k))
52        (bytevector-ieee-double-native-ref b 0))))
53
54(define (bytevector-ieee-single-native-set! bytevector k x)
55  (r6rs-float->bytevect!  x bytevector k))
56
57(define (bytevector-ieee-double-native-set! bytevector k x)
58  (r6rs-double->bytevect!  x bytevector k))
59
60(define (bytevector-ieee-single-set! bytevector k x endness)
61  (if (eq? endness (native-endianness))
62      (if (= 0 (remainder k 4))
63          (bytevector-ieee-single-native-set! bytevector k x)
64          (let ((b (make-bytevector 4)))
65            (bytevector-ieee-single-native-set! b 0 x)
66            (bytevector-copy! b 0 bytevector k 4)))
67      (let ((b (make-bytevector 4)))
68        (bytevector-ieee-single-native-set! b 0 x)
69        (bytevector-u8-set! bytevector k (bytevector-u8-ref b 3))
70        (bytevector-u8-set! bytevector (+ k 1) (bytevector-u8-ref b 2))
71        (bytevector-u8-set! bytevector (+ k 2) (bytevector-u8-ref b 1))
72        (bytevector-u8-set! bytevector (+ k 3) (bytevector-u8-ref b 0)))))
73
74(define (bytevector-ieee-double-set! bytevector k x endness)
75  (if (eq? endness (native-endianness))
76      (if (= 0 (remainder k 8))
77          (bytevector-ieee-double-native-set! bytevector k x)
78          (let ((b (make-bytevector 8)))
79            (bytevector-ieee-double-native-set! b 0 x)
80            (bytevector-copy! b 0 bytevector k 8)))
81      (let ((b (make-bytevector 8)))
82        (bytevector-ieee-double-native-set! b 0 x)
83        (bytevector-u8-set! bytevector k (bytevector-u8-ref b 7))
84        (bytevector-u8-set! bytevector (+ k 1) (bytevector-u8-ref b 6))
85        (bytevector-u8-set! bytevector (+ k 2) (bytevector-u8-ref b 5))
86        (bytevector-u8-set! bytevector (+ k 3) (bytevector-u8-ref b 4))
87        (bytevector-u8-set! bytevector (+ k 4) (bytevector-u8-ref b 3))
88        (bytevector-u8-set! bytevector (+ k 5) (bytevector-u8-ref b 2))
89        (bytevector-u8-set! bytevector (+ k 6) (bytevector-u8-ref b 1))
90        (bytevector-u8-set! bytevector (+ k 7) (bytevector-u8-ref b 0)))))
91
92
93(define (r6rs-float->bytevect!  float bytevect index)
94  (external-r6rs-float->bytevect! float bytevect index))
95
96(define (r6rs-bytevect->float bytevect index)
97  (external-r6rs-bytevect->float bytevect index))
98
99(define (r6rs-double->bytevect!  double bytevect index)
100  (external-r6rs-double->bytevect! double bytevect index))
101
102(define (r6rs-bytevect->double bytevect index)
103  (external-r6rs-bytevect->double bytevect index))
104
105
106;; external fun definition
107
108(import-lambda-definition-2 external-r6rs-float->bytevect!
109			    (double bytevect index)
110			    "r6rs_float_to_bytevect")
111
112(import-lambda-definition-2 external-r6rs-bytevect->float
113			    (bytevect index)
114			    "r6rs_bytevect_to_float")
115
116(import-lambda-definition-2 external-r6rs-double->bytevect!
117			    (double bytevect index)
118			    "r6rs_double_to_bytevect")
119
120(import-lambda-definition-2 external-r6rs-bytevect->double
121			    (bytevect index)
122			    "r6rs_bytevect_to_double")
123
124