1 ;;; srfi-4.scm --- Homogeneous Numeric Vector Datatypes
3 ;; Copyright (C) 2001, 2002, 2004, 2006, 2009, 2010,
4 ;; 2012 Free Software Foundation, Inc.
6 ;; This library is free software; you can redistribute it and/or
7 ;; modify it under the terms of the GNU Lesser General Public
8 ;; License as published by the Free Software Foundation; either
9 ;; version 3 of the License, or (at your option) any later version.
11 ;; This library is distributed in the hope that it will be useful,
12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;; Lesser General Public License for more details.
16 ;; You should have received a copy of the GNU Lesser General Public
17 ;; License along with this library; if not, write to the Free Software
18 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20 ;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
24 ;; This module exports the homogeneous numeric vector procedures as
25 ;; defined in SRFI-4. They are fully documented in the Guile
30 (define-module (srfi srfi-4)
31 #:use-module (rnrs bytevectors)
32 #:export (;; Unsigned 8-bit vectors.
33 u8vector? make-u8vector u8vector u8vector-length u8vector-ref
34 u8vector-set! u8vector->list list->u8vector
36 ;; Signed 8-bit vectors.
37 s8vector? make-s8vector s8vector s8vector-length s8vector-ref
38 s8vector-set! s8vector->list list->s8vector
40 ;; Unsigned 16-bit vectors.
41 u16vector? make-u16vector u16vector u16vector-length u16vector-ref
42 u16vector-set! u16vector->list list->u16vector
44 ;; Signed 16-bit vectors.
45 s16vector? make-s16vector s16vector s16vector-length s16vector-ref
46 s16vector-set! s16vector->list list->s16vector
48 ;; Unsigned 32-bit vectors.
49 u32vector? make-u32vector u32vector u32vector-length u32vector-ref
50 u32vector-set! u32vector->list list->u32vector
52 ;; Signed 32-bit vectors.
53 s32vector? make-s32vector s32vector s32vector-length s32vector-ref
54 s32vector-set! s32vector->list list->s32vector
56 ;; Unsigned 64-bit vectors.
57 u64vector? make-u64vector u64vector u64vector-length u64vector-ref
58 u64vector-set! u64vector->list list->u64vector
60 ;; Signed 64-bit vectors.
61 s64vector? make-s64vector s64vector s64vector-length s64vector-ref
62 s64vector-set! s64vector->list list->s64vector
64 ;; 32-bit floating point vectors.
65 f32vector? make-f32vector f32vector f32vector-length f32vector-ref
66 f32vector-set! f32vector->list list->f32vector
68 ;; 64-bit floating point vectors.
69 f64vector? make-f64vector f64vector f64vector-length f64vector-ref
70 f64vector-set! f64vector->list list->f64vector))
72 (cond-expand-provide (current-module) '(srfi-4))
74 ;; Need quasisyntax to do this effectively using syntax-case
75 (define-macro (define-bytevector-type tag infix size)
77 (define (,(symbol-append tag 'vector?) obj)
78 (and (uniform-vector? obj)
79 (eq? (uniform-vector-element-type obj) ',tag)))
80 (define (,(symbol-append 'make- tag 'vector) len . fill)
81 (apply make-srfi-4-vector ',tag len fill))
82 (define (,(symbol-append tag 'vector-length) v)
83 (let ((len (* (uniform-vector-length v)
84 (uniform-vector-element-size v)
88 (error "fractional length" v ',tag ,size))))
89 (define (,(symbol-append tag 'vector) . elts)
90 (,(symbol-append 'list-> tag 'vector) elts))
91 (define (,(symbol-append 'list-> tag 'vector) elts)
92 (let* ((len (length elts))
93 (v (,(symbol-append 'make- tag 'vector) len)))
94 (let lp ((i 0) (elts elts))
95 (if (and (< i len) (pair? elts))
97 (,(symbol-append tag 'vector-set!) v i (car elts))
98 (lp (1+ i) (cdr elts)))
100 (define (,(symbol-append tag 'vector->list) v)
101 (let lp ((i (1- (,(symbol-append tag 'vector-length) v))) (elts '()))
104 (lp (1- i) (cons (,(symbol-append tag 'vector-ref) v i) elts)))))
105 (define (,(symbol-append tag 'vector-ref) v i)
106 (,(symbol-append 'bytevector- infix '-ref) v (* i ,size)))
107 (define (,(symbol-append tag 'vector-set!) v i x)
108 (,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x))
109 (define (,(symbol-append tag 'vector-set!) v i x)
110 (,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x))))
112 (define-bytevector-type u8 u8 1)
113 (define-bytevector-type s8 s8 1)
114 (define-bytevector-type u16 u16-native 2)
115 (define-bytevector-type s16 s16-native 2)
116 (define-bytevector-type u32 u32-native 4)
117 (define-bytevector-type s32 s32-native 4)
118 (define-bytevector-type u64 u64-native 8)
119 (define-bytevector-type s64 s64-native 8)
120 (define-bytevector-type f32 ieee-single-native 4)
121 (define-bytevector-type f64 ieee-double-native 8)
123 (define (bytevector-c32-ref v i)
124 (make-rectangular (bytevector-ieee-single-native-ref v i)
125 (bytevector-ieee-single-native-ref v (+ i 4))))
126 (define (bytevector-c32-set! v i x)
127 (bytevector-ieee-single-native-set! v i x)
128 (bytevector-ieee-single-native-set! v (+ i 4) x))
129 (define-bytevector-type c32 c32 8)
131 (define (bytevector-c64-ref v i)
132 (make-rectangular (bytevector-ieee-double-native-ref v i)
133 (bytevector-ieee-double-native-ref v (+ i 8))))
134 (define (bytevector-c64-set! v i x)
135 (bytevector-ieee-double-native-set! v i x)
136 (bytevector-ieee-double-native-set! v (+ i 8) x))
137 (define-bytevector-type c64 c64 16)