diff options
author | Andy Wingo <wingo@pobox.com> | 2014-02-08 14:44:11 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2014-02-08 14:44:11 +0100 |
commit | 5fc051babef5ea07cf48c02c31ef729344639f9a (patch) | |
tree | 7a4387c806236e7defdc7c8dd98f5c28c40da3ae | |
parent | 730639e9a7bca966c6e884ec47b3166544767f2f (diff) | |
parent | 2f3b7e9a41677bfe802e8a1ee851827297384c58 (diff) | |
download | guile-5fc051babef5ea07cf48c02c31ef729344639f9a.tar.gz |
Merge commit '2f3b7e9a41677bfe802e8a1ee851827297384c58'
Conflicts:
module/ice-9/pretty-print.scm
-rw-r--r-- | module/ice-9/pretty-print.scm | 11 | ||||
-rw-r--r-- | module/srfi/srfi-4.scm | 18 | ||||
-rw-r--r-- | module/srfi/srfi-4/gnu.scm | 45 |
3 files changed, 10 insertions, 64 deletions
diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm index 1573c6fd5..007061f6e 100644 --- a/module/ice-9/pretty-print.scm +++ b/module/ice-9/pretty-print.scm @@ -1,7 +1,7 @@ ;;;; -*- coding: utf-8; mode: scheme -*- ;;;; ;;;; Copyright (C) 2001, 2004, 2006, 2009, 2010, -;;;; 2012, 2013 Free Software Foundation, Inc. +;;;; 2012, 2013, 2014 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -20,6 +20,7 @@ (define-module (ice-9 pretty-print) #:use-module (ice-9 match) #:use-module (srfi srfi-1) + #:use-module (rnrs bytevectors) #:export (pretty-print truncated-print)) @@ -418,12 +419,12 @@ sub-expression, via the @var{breadth-first?} keyword argument." (display ")")) (else (display "#")))) - ((uniform-vector? x) + ((bytevector? x) (cond ((>= width 9) - (format #t "#~a(" (uniform-vector-element-type x)) - (print-sequence x (- width 6) (uniform-vector-length x) - uniform-vector-ref identity) + (format #t "#~a(" (array-type x)) + (print-sequence x (- width 6) (array-length x) + array-ref identity) (display ")")) (else (display "#")))) diff --git a/module/srfi/srfi-4.scm b/module/srfi/srfi-4.scm index 5b7b894f6..b2e6f4928 100644 --- a/module/srfi/srfi-4.scm +++ b/module/srfi/srfi-4.scm @@ -116,21 +116,3 @@ (define-bytevector-type s64 s64-native 8) (define-bytevector-type f32 ieee-single-native 4) (define-bytevector-type f64 ieee-double-native 8) - -(define (bytevector-c32-ref v i) - (make-rectangular (bytevector-ieee-single-native-ref v i) - (bytevector-ieee-single-native-ref v (+ i 4)))) -(define (bytevector-c32-set! v i x) - (bytevector-ieee-single-native-set! v i x) - (bytevector-ieee-single-native-set! v (+ i 4) x)) -(define-bytevector-type c32 c32 8) - -(define (bytevector-c64-ref v i) - (make-rectangular (bytevector-ieee-double-native-ref v i) - (bytevector-ieee-double-native-ref v (+ i 8)))) -(define (bytevector-c64-set! v i x) - (bytevector-ieee-double-native-set! v i x) - (bytevector-ieee-double-native-set! v (+ i 8) x)) -(define-bytevector-type c64 c64 16) - - diff --git a/module/srfi/srfi-4/gnu.scm b/module/srfi/srfi-4/gnu.scm index 7f595d628..42bbf33c5 100644 --- a/module/srfi/srfi-4/gnu.scm +++ b/module/srfi/srfi-4/gnu.scm @@ -1,6 +1,6 @@ ;;; Extensions to SRFI-4 -;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -42,44 +42,6 @@ (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) - (uniform-vector-element-size v) - (/ ,size)))) - (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)))) @@ -92,8 +54,9 @@ (define (bytevector-c64-native-set! v i x) (bytevector-ieee-double-native-set! v i (real-part x)) (bytevector-ieee-double-native-set! v (+ i 8) (imag-part x))) -(define-bytevector-type c32 c32-native 8) -(define-bytevector-type c64 c64-native 16) + +((@@ (srfi srfi-4) define-bytevector-type) c32 c32-native 8) +((@@ (srfi srfi-4) define-bytevector-type) c64 c64-native 16) (define-macro (define-any->vector . tags) `(begin |