1;;; -*- mode:scheme; coding:utf-8; -*-
2;;;
3;;; sitelib/%3a4/numeric-vectors.scm - Homogeneous numeric vector datatypes.
4;;;
5;;;   Copyright (c) 2010-2019  Takashi Kato  <ktakashi@ymail.com>
6;;;
7;;;   Redistribution and use in source and binary forms, with or without
8;;;   modification, are permitted provided that the following conditions
9;;;   are met:
10;;;
11;;;   1. Redistributions of source code must retain the above copyright
12;;;      notice, this list of conditions and the following disclaimer.
13;;;
14;;;   2. Redistributions in binary form must reproduce the above copyright
15;;;      notice, this list of conditions and the following disclaimer in the
16;;;      documentation and/or other materials provided with the distribution.
17;;;
18;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
19;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
20;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
21;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
22;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
23;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
24;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
25;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
26;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29;;;
30
31#!nounbound
32(library (srfi :4 numeric-vectors)
33    (export :export-reader-macro
34	    <s8vector>
35	    make-s8vector s8vector s8vector? s8vector-length s8vector-ref
36	    s8vector-set! s8vector->list list->s8vector
37	    <u8vector>
38	    make-u8vector u8vector u8vector? u8vector-length u8vector-ref
39	    u8vector-set! u8vector->list list->u8vector
40	    <s16vector>
41	    make-s16vector s16vector s16vector? s16vector-length s16vector-ref
42	    s16vector-set! s16vector->list list->s16vector
43	    <u16vector>
44	    make-u16vector u16vector u16vector? u16vector-length u16vector-ref
45	    u16vector-set! u16vector->list list->u16vector
46	    <s32vector>
47	    make-s32vector s32vector s32vector? s32vector-length s32vector-ref
48	    s32vector-set! s32vector->list list->s32vector
49	    <u32vector>
50	    make-u32vector u32vector u32vector? u32vector-length u32vector-ref
51	    u32vector-set! u32vector->list list->u32vector
52	    <s64vector>
53	    make-s64vector s64vector s64vector? s64vector-length s64vector-ref
54	    s64vector-set! s64vector->list list->s64vector
55	    <u64vector>
56	    make-u64vector u64vector u64vector? u64vector-length u64vector-ref
57	    u64vector-set! u64vector->list list->u64vector
58	    <f32vector>
59	    make-f32vector f32vector f32vector? f32vector-length f32vector-ref
60	    f32vector-set! f32vector->list list->f32vector
61	    <f64vector>
62	    make-f64vector f64vector f64vector? f64vector-length f64vector-ref
63	    f64vector-set! f64vector->list list->f64vector
64
65	    ;; for SRFI-160 ...
66	    define-tagged-vector
67	    )
68    (import (rnrs)
69	    (sagittarius reader)
70	    (sagittarius)
71	    (util list)
72	    (clos user))
73
74  (define (write-vector bv prefix bytevector-length offset getter port)
75    (display #\# port)
76    (display prefix port)
77    (display #\( port)
78    (do ((limit (bytevector-length bv))
79	 (i 0 (+ i offset)))
80	((= i limit))
81      (unless (zero? i)
82	(display " " port))
83      (write (getter bv i) port))
84    (display #\) port))
85
86  (define (generate-reader ctr)
87    (lambda (in ctx)
88      (let* ((bv (read-cache-object in ctx))
89	     (r (ctr (bytevector-length bv))))
90	(slot-set! r 'value bv)
91	r)))
92  (define (cache-writer o out ctx)
93    (write-object-cache (slot-ref o 'value) out ctx))
94
95  (define-syntax define-tagged-vector
96    (lambda (x)
97      (syntax-case x ()
98	((k tag offset make-bytevector bytevector-length bytevector=?
99	    getter setter)
100	 (let ((name (format "~avector" (syntax->datum #'tag)))
101	       (formats (lambda (f name)
102			  (string->symbol (format f name)))))
103	   (with-syntax ((meta (datum->syntax #'k (formats "<~a-meta>" name)))
104			 (class (datum->syntax #'k (formats "<~a>" name)))
105			 (ctr   (datum->syntax #'k (formats "make-~a" name)))
106			 (ctr2  (datum->syntax #'k (formats "~a" name)))
107			 (pred  (datum->syntax #'k (formats "~a?" name)))
108			 (len  (datum->syntax #'k (formats "~a-length" name)))
109			 (ref  (datum->syntax #'k (formats "~a-ref" name)))
110			 (set  (datum->syntax #'k (formats "~a-set!" name)))
111			 (->list (datum->syntax #'k
112						(formats "~a->list" name)))
113			 (list-> (datum->syntax #'k
114						(formats "list->~a" name))))
115	     #'(begin
116		 (define-class meta (<class>) ())
117		 ;; ctr is used in initialize, so it must be here
118		 (define (ctr n :optional (value 0))
119		   (let* ((len (* n offset))
120			  (v (make-bytevector len)))
121		     (do ((i 0 (+ i offset)))
122			 ((= i len) (make class :value v))
123		       (setter v i value))))
124
125		 (define (ctr2 . args)
126		   (let* ((len (* (length args) offset))
127			  (bv (make-bytevector len)))
128		     (do ((i 0 (+ i offset)) (v args (cdr v)))
129			 ((= i len) (make class :value bv))
130		       (setter bv i (car v)))))
131
132		 (define-method initialize ((klass meta) initargs)
133		   (call-next-method)
134		   ;; we don't need scanner
135		   (slot-set! klass 'cache-reader (generate-reader ctr))
136		   (slot-set! klass 'cache-writer cache-writer))
137
138		 (define-class class (<sequence>)
139		   ((value :init-keyword :value))
140		   :metaclass meta)
141
142		 (define-method write-object ((o class) (p <port>))
143		   (write-vector (slot-ref o 'value) tag bytevector-length
144				 offset getter p))
145		 (define-method object-equal? ((a class) (b class))
146		   (bytevector=? (slot-ref a 'value) (slot-ref b 'value)))
147
148		 (define (pred o) (is-a? o class))
149		 (define (len bv)
150		   (unless (pred bv)
151		     (assertion-violation 'len
152					  (format "~a required but got ~s"
153						  class bv)))
154		   (/ (bytevector-length (slot-ref bv 'value)) offset))
155		 (define (ref bv i)
156		   (unless (pred bv)
157		     (assertion-violation 'ref
158					  (format "~a required but got ~s"
159						  class bv)))
160		   (getter (slot-ref bv 'value) (* i offset)))
161		 (define (set bv i o)
162		   (unless (pred bv)
163		     (assertion-violation 'set
164					  (format "~a required but got ~s"
165						  class bv)))
166		   (setter (slot-ref bv 'value) (* i offset) o))
167		 (define (->list bv :optional (start 0) (end (len bv)))
168		   (unless (pred bv)
169		     (assertion-violation '->list
170					  (format "~a required but got ~s"
171						  class bv)))
172		   (do ((limit end)
173			(i start (+ i 1))
174			(r '() (cons (ref bv i) r)))
175		       ((= i limit) (reverse! r))))
176		 (define (list-> lst)
177		   (define len (length lst))
178		   (let ((r (ctr len)))
179		     (do ((i 0 (+ i 1)) (lst lst (cdr lst)))
180			 ((null? lst) r)
181		       (set r i (car lst)))))))))
182	((k tag offset getter setter)
183	 #'(k tag offset make-bytevector bytevector-length bytevector=?
184	      getter setter)))))
185
186  (define-tagged-vector "s8" 1 bytevector-s8-ref bytevector-s8-set!)
187  (define-tagged-vector "u8" 1 bytevector-u8-ref bytevector-u8-set!)
188  (define-tagged-vector "s16" 2 bytevector-s16-native-ref
189    bytevector-s16-native-set!)
190  (define-tagged-vector "u16" 2 bytevector-u16-native-ref
191    bytevector-u16-native-set!)
192  (define-tagged-vector "s32" 4 bytevector-s32-native-ref
193    bytevector-s32-native-set!)
194  (define-tagged-vector "u32" 4 bytevector-u32-native-ref
195    bytevector-u32-native-set!)
196  (define-tagged-vector "s64" 8 bytevector-s64-native-ref
197    bytevector-s64-native-set!)
198  (define-tagged-vector "u64" 8 bytevector-u64-native-ref
199    bytevector-u64-native-set!)
200  (define-tagged-vector "f32" 4 bytevector-ieee-single-native-ref
201    bytevector-ieee-single-native-set!)
202  (define-tagged-vector "f64" 8 bytevector-ieee-double-native-ref
203    bytevector-ieee-double-native-set!)
204
205  (define-dispatch-macro |#u-reader| #\# #\u
206    (lambda (port c param)
207      (let ((n (read port)))
208	(unless (integer? n)
209	  (raise-i/o-read-error '|#s-reader| "invalid character for #u" port))
210	(let ((lst (read port))) ;; must be a list
211	  (unless (list? lst)
212	    (raise-i/o-read-error '|#s-reader|
213				  (format "list required, but got ~s" lst)
214				  port))
215	  (let ((ctr (case n
216		       ((8)  u8vector)
217		       ((16) u16vector)
218		       ((32) u32vector)
219		       ((64) u64vector)
220		       (else
221			(raise-i/o-read-error '|#u-reader|
222			 (format "given number was not supported ~a" n)
223			 port)))))
224	    (apply ctr lst))))))
225
226  (define-dispatch-macro |#s-reader| #\# #\s
227    (lambda (port c param)
228      (let ((n (read port)))
229	(unless (integer? n)
230	  (raise-i/o-read-error '|#s-reader| "invalid character for #s" port))
231	(let ((lst (read port))) ;; must be a list
232	  (unless (list? lst)
233	    (raise-i/o-read-error '|#s-reader|
234				  (format "list required, but got ~s" lst)
235				  port))
236	  (let ((ctr (case n
237		       ((8)  s8vector)
238		       ((16) s16vector)
239		       ((32) s32vector)
240		       ((64) s64vector)
241		       (else
242			(raise-i/o-read-error '|#s-reader|
243			 (format "given number was not supported ~a" n)
244			 port)))))
245	    (apply ctr lst))))))
246
247  (define-dispatch-macro |#f-reader| #\# #\f
248    (lambda (port c param)
249      (if (delimited-char? (lookahead-char port))
250	  #f
251	  (let ((n (read port)))
252	    (cond
253	     ((eq? n 'alse) #f) ;; for R7RS support
254	     (else
255	      (unless (integer? n)
256		(raise-i/o-read-error '|#f-reader|
257				      "invalid character for #f" port))
258	      (let ((lst (read port))) ;; must be a list
259		(unless (list? lst)
260		  (raise-i/o-read-error '|#f-reader|
261					(format "list required, but got ~s" lst)
262					port))
263		(let ((ctr (case n
264			     ((32) f32vector)
265			     ((64) f64vector)
266			     (else
267			      (raise-i/o-read-error '|#f-reader|
268			       (format "given number was not supported ~a" n)
269			       port)))))
270		  (apply ctr lst)))))))))
271  )
272