summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2014-02-08 14:44:11 +0100
committerAndy Wingo <wingo@pobox.com>2014-02-08 14:44:11 +0100
commit5fc051babef5ea07cf48c02c31ef729344639f9a (patch)
tree7a4387c806236e7defdc7c8dd98f5c28c40da3ae
parent730639e9a7bca966c6e884ec47b3166544767f2f (diff)
parent2f3b7e9a41677bfe802e8a1ee851827297384c58 (diff)
downloadguile-5fc051babef5ea07cf48c02c31ef729344639f9a.tar.gz
Merge commit '2f3b7e9a41677bfe802e8a1ee851827297384c58'
Conflicts: module/ice-9/pretty-print.scm
-rw-r--r--module/ice-9/pretty-print.scm11
-rw-r--r--module/srfi/srfi-4.scm18
-rw-r--r--module/srfi/srfi-4/gnu.scm45
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