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