module/srfi/srfi-4.scm

   1 ;;; srfi-4.scm --- Homogeneous Numeric Vector Datatypes
   2
   3 ;; Copyright (C) 2001, 2002, 2004, 2006, 2009, 2010,
   4 ;;   2012, 2014 Free Software Foundation, Inc.
   5 ;;
   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.
  10 ;;
  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.
  15 ;;
  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
  19
  20 ;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
  21
  22 ;;; Commentary:
  23
  24 ;; This module exports the homogeneous numeric vector procedures as
  25 ;; defined in SRFI-4.  They are fully documented in the Guile
  26 ;; Reference Manual.
  27
  28 ;;; Code:
  29
  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
  35
  36             ;; Signed 8-bit vectors.
  37             s8vector? make-s8vector s8vector s8vector-length s8vector-ref
  38             s8vector-set! s8vector->list list->s8vector
  39
  40             ;; Unsigned 16-bit vectors.
  41             u16vector? make-u16vector u16vector u16vector-length u16vector-ref
  42             u16vector-set! u16vector->list list->u16vector
  43
  44             ;; Signed 16-bit vectors.
  45             s16vector? make-s16vector s16vector s16vector-length s16vector-ref
  46             s16vector-set! s16vector->list list->s16vector
  47
  48             ;; Unsigned 32-bit vectors.
  49             u32vector? make-u32vector u32vector u32vector-length u32vector-ref
  50             u32vector-set! u32vector->list list->u32vector
  51
  52             ;; Signed 32-bit vectors.
  53             s32vector? make-s32vector s32vector s32vector-length s32vector-ref
  54             s32vector-set! s32vector->list list->s32vector
  55
  56             ;; Unsigned 64-bit vectors.
  57             u64vector? make-u64vector u64vector u64vector-length u64vector-ref
  58             u64vector-set! u64vector->list list->u64vector
  59
  60             ;; Signed 64-bit vectors.
  61             s64vector? make-s64vector s64vector s64vector-length s64vector-ref
  62             s64vector-set! s64vector->list list->s64vector
  63
  64             ;; 32-bit floating point vectors.
  65             f32vector? make-f32vector f32vector f32vector-length f32vector-ref
  66             f32vector-set! f32vector->list list->f32vector
  67
  68             ;; 64-bit floating point vectors.
  69             f64vector? make-f64vector f64vector f64vector-length f64vector-ref
  70             f64vector-set! f64vector->list list->f64vector))
  71
  72 (cond-expand-provide (current-module) '(srfi-4))
  73
  74 ;; Need quasisyntax to do this effectively using syntax-case
  75 (define-macro (define-bytevector-type tag infix size)
  76   `(begin
  77      (define (,(symbol-append tag 'vector?) obj)
  78        (and (bytevector? obj) (eq? (array-type obj) ',tag)))
  79      (define (,(symbol-append 'make- tag 'vector) len . fill)
  80        (apply make-srfi-4-vector ',tag len fill))
  81      (define (,(symbol-append tag 'vector-length) v)
  82        (let ((len (/ (bytevector-length v) ,size)))
  83          (if (integer? len)
  84              len
  85              (error "fractional length" v ',tag ,size))))
  86      (define (,(symbol-append tag 'vector) . elts)
  87        (,(symbol-append 'list-> tag 'vector) elts))
  88      (define (,(symbol-append 'list-> tag 'vector) elts)
  89        (let* ((len (length elts))
  90               (v (,(symbol-append 'make- tag 'vector) len)))
  91          (let lp ((i 0) (elts elts))
  92            (if (and (< i len) (pair? elts))
  93                (begin
  94                  (,(symbol-append tag 'vector-set!) v i (car elts))
  95                  (lp (1+ i) (cdr elts)))
  96                v))))
  97      (define (,(symbol-append tag 'vector->list) v)
  98        (let lp ((i (1- (,(symbol-append tag 'vector-length) v))) (elts '()))
  99          (if (< i 0)
 100              elts
 101              (lp (1- i) (cons (,(symbol-append tag 'vector-ref) v i) elts)))))
 102      (define (,(symbol-append tag 'vector-ref) v i)
 103        (,(symbol-append 'bytevector- infix '-ref) v (* i ,size)))
 104      (define (,(symbol-append tag 'vector-set!) v i x)
 105        (,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x))
 106      (define (,(symbol-append tag 'vector-set!) v i x)
 107        (,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x))))
 108
 109 (define-bytevector-type u8 u8 1)
 110 (define-bytevector-type s8 s8 1)
 111 (define-bytevector-type u16 u16-native 2)
 112 (define-bytevector-type s16 s16-native 2)
 113 (define-bytevector-type u32 u32-native 4)
 114 (define-bytevector-type s32 s32-native 4)
 115 (define-bytevector-type u64 u64-native 8)
 116 (define-bytevector-type s64 s64-native 8)
 117 (define-bytevector-type f32 ieee-single-native 4)
 118 (define-bytevector-type f64 ieee-double-native 8)