diff options
Diffstat (limited to 'module/srfi/srfi-4/gnu.scm')
-rw-r--r-- | module/srfi/srfi-4/gnu.scm | 66 |
1 files changed, 65 insertions, 1 deletions
diff --git a/module/srfi/srfi-4/gnu.scm b/module/srfi/srfi-4/gnu.scm index c5c41ea92..ccb1ab1d8 100644 --- a/module/srfi/srfi-4/gnu.scm +++ b/module/srfi/srfi-4/gnu.scm @@ -23,13 +23,77 @@ ;;; Code: (define-module (srfi srfi-4 gnu) + #:use-module (rnrs bytevector) #:use-module (srfi srfi-4) - #:export (;; Somewhat polymorphic conversions. + #:export (;; Complex numbers with 32- and 64-bit components. + c32vector? make-c32vector c32vector c32vector-length c32vector-ref + c32vector-set! c32vector->list list->c32vector + + c64vector? make-c64vector c64vector c64vector-length c64vector-ref + c64vector-set! c64vector->list list->c64vector + + make-srfi-4-vector + + ;; Somewhat polymorphic conversions. any->u8vector any->s8vector any->u16vector any->s16vector any->u32vector any->s32vector any->u64vector any->s64vector any->f32vector any->f64vector any->c32vector any->c64vector)) +(define make-srfi-4-vector (@@ (srfi srfi-4) make-srfi-4-vector)) + +;; Need quasisyntax to do this effectively using syntax-case +(define-macro (define-bytevector-type tag infix size) + `(begin + (define (,(symbol-append tag 'vector?) obj) + (and (uniform-vector? obj) + (eq? (uniform-vector-element-type obj) ',tag))) + (define (,(symbol-append 'make- tag 'vector) len . fill) + (apply make-srfi-4-vector ',tag len fill)) + (define (,(symbol-append tag 'vector-length) v) + (let ((len (* (uniform-vector-length v) + (/ ,size (uniform-vector-element-size v))))) + (if (integer? len) + len + (error "fractional length" v ',tag ,size)))) + (define (,(symbol-append tag 'vector) . elts) + (,(symbol-append 'list-> tag 'vector) elts)) + (define (,(symbol-append 'list-> tag 'vector) elts) + (let* ((len (length elts)) + (v (,(symbol-append 'make- tag 'vector) len))) + (let lp ((i 0) (elts elts)) + (if (and (< i len) (pair? elts)) + (begin + (,(symbol-append tag 'vector-set!) v i (car elts)) + (lp (1+ i) (cdr elts))) + v)))) + (define (,(symbol-append tag 'vector->list) v) + (let lp ((i (1- (,(symbol-append tag 'vector-length) v))) (elts '())) + (if (< i 0) + elts + (lp (1- i) (cons (,(symbol-append tag 'vector-ref) v i) elts))))) + (define (,(symbol-append tag 'vector-ref) v i) + (,(symbol-append 'bytevector- infix '-ref) v (* i ,size))) + (define (,(symbol-append tag 'vector-set!) v i x) + (,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x)) + (define (,(symbol-append tag 'vector-set!) v i x) + (,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x)))) + +(define (bytevector-c32-native-ref v i) + (make-rectangular (bytevector-ieee-single-native-ref v i) + (bytevector-ieee-single-native-ref v (+ i 4)))) +(define (bytevector-c32-native-set! v i x) + (bytevector-ieee-single-native-set! v i x) + (bytevector-ieee-single-native-set! v (+ i 4) x)) +(define (bytevector-c64-native-ref v i) + (make-rectangular (bytevector-ieee-double-native-ref v i) + (bytevector-ieee-double-native-ref v (+ i 8)))) +(define (bytevector-c64-native-set! v i x) + (bytevector-ieee-double-native-set! v i x) + (bytevector-ieee-double-native-set! v (+ i 8) x)) +(define-bytevector-type c32 c32-native 8) +(define-bytevector-type c64 c64-native 16) + (define-macro (define-any->vector . tags) `(begin ,@(map (lambda (tag) |