srfi-4.scm 5.7 KB

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