summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2017-11-29 21:04:59 +0100
committerAndy Wingo <wingo@pobox.com>2017-11-29 21:04:59 +0100
commitf85d3c0bd886e46e6ab3fc858231c8b2aa3e954d (patch)
tree9afe1139ddece9c4686e177b49e847ac0730f8d7 /module
parent39520f879a41821ad63ed85fd227b9ec421cb8b7 (diff)
parente0bcda4ad940c4e15679cc2b229838b33acdd36c (diff)
downloadguile-f85d3c0bd886e46e6ab3fc858231c8b2aa3e954d.tar.gz
Merge until e0bcda4ad940c4e15679cc2b229838b33acdd36c from stable-2.2
Diffstat (limited to 'module')
-rw-r--r--module/Makefile.am1
-rw-r--r--module/ice-9/arrays.scm88
-rw-r--r--module/ice-9/pretty-print.scm24
-rw-r--r--module/system/vm/traps.scm5
4 files changed, 89 insertions, 29 deletions
diff --git a/module/Makefile.am b/module/Makefile.am
index 5a5a0bd77..81fd3fdb4 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -44,6 +44,7 @@ ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm
SOURCES = \
ice-9/and-let-star.scm \
+ ice-9/arrays.scm \
ice-9/atomic.scm \
ice-9/binary-ports.scm \
ice-9/boot-9.scm \
diff --git a/module/ice-9/arrays.scm b/module/ice-9/arrays.scm
index f7f9e5eed..f03eb351b 100644
--- a/module/ice-9/arrays.scm
+++ b/module/ice-9/arrays.scm
@@ -1,22 +1,70 @@
-;;; installed-scm-file
+;;; -*- mode: scheme; coding: utf-8; -*-
+;;;
+;;; Copyright (C) 1999, 2001, 2004, 2006, 2017 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
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-;;;; Copyright (C) 1999, 2001, 2004, 2006 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-;;;;
+(define-module (ice-9 arrays)
+ #:use-module (rnrs io ports)
+ #:use-module (srfi srfi-1)
+ #:export (array-copy))
-(define (array-shape a)
- (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
- (array-dimensions a)))
+;; This is actually defined in boot-9.scm, apparently for backwards
+;; compatibility.
+
+;; (define (array-shape a)
+;; (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
+;; (array-dimensions a)))
+
+; FIXME writes over the array twice if (array-type) is #t
+(define (array-copy a)
+ (let ((b (apply make-typed-array (array-type a) *unspecified* (array-shape a))))
+ (array-copy! a b)
+ b))
+
+
+;; Printing arrays
+
+;; The dimensions aren't printed out unless they cannot be deduced from
+;; the content, which happens only when certain axes are empty. #:dims?
+;; can be used to force this printing. An array with all the dimensions
+;; printed out is still readable syntax, this can be useful for
+;; truncated-print.
+
+(define* (array-print-prefix a port #:key dims?)
+ (put-char port #\#)
+ (display (array-rank a) port)
+ (let ((t (array-type a)))
+ (unless (eq? #t t)
+ (display t port)))
+ (let ((ss (array-shape a)))
+ (let loop ((s ss) (slos? #f) (szero? #f) (slens? dims?))
+ (define lo caar)
+ (define hi cadar)
+ (if (null? s)
+ (when (or slos? slens?)
+ (pair-for-each (lambda (s)
+ (when slos?
+ (put-char port #\@)
+ (display (lo s) port))
+ (when slens?
+ (put-char port #\:)
+ (display (- (hi s) (lo s) -1) port)))
+ ss))
+ (let ((zero-size? (zero? (- (hi s) (lo s) -1))))
+ (loop (cdr s)
+ (or slos? (not (zero? (lo s))))
+ (or szero? zero-size?)
+ (or slens? (and (not zero-size?) szero?))))))))
diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm
index d3d765202..f90e15d38 100644
--- a/module/ice-9/pretty-print.scm
+++ b/module/ice-9/pretty-print.scm
@@ -429,17 +429,25 @@ sub-expression, via the @var{breadth-first?} keyword argument."
(display ")"))
(else
(display "#"))))
+ ((bitvector? x)
+ (cond
+ ((>= width (+ 2 (array-length x)))
+ (format #t "~a" x))
+ ;; the truncated bitvector would print as #1b(...), so we print by hand.
+ ((>= width (+ 2 ellipsis-width))
+ (format #t "#*")
+ (array-for-each (lambda (xi) (format #t (if xi "1" "0")))
+ (make-shared-array x list (- width 2 ellipsis-width)))
+ (format #t ellipsis))
+ (else
+ (display "#"))))
((and (array? x) (not (string? x)))
(let* ((type (array-type x))
(prefix
(if inner?
""
- (if (zero? (array-rank x))
- (string-append "#0" (if (eq? #t type) "" (symbol->string type)))
- (let ((s (format #f "~a"
- (apply make-typed-array type *unspecified*
- (make-list (array-rank x) 0)))))
- (substring s 0 (- (string-length s) 2))))))
+ (call-with-output-string
+ (lambda (s) ((@@ (ice-9 arrays) array-print-prefix) x s)))))
(width-prefix (string-length prefix)))
(cond
((>= width (+ 2 width-prefix ellipsis-width))
@@ -447,7 +455,9 @@ sub-expression, via the @var{breadth-first?} keyword argument."
(if (zero? (array-rank x))
(print (array-ref x) (- width width-prefix 2))
(print-sequence x (- width width-prefix 2) (array-length x)
- array-cell-ref identity
+ (let ((base (caar (array-shape x))))
+ (lambda (x i) (array-cell-ref x (+ base i))))
+ identity
#:inner? (< 1 (array-rank x))))
(display ")"))
(else
diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm
index c4861c925..8bee10355 100644
--- a/module/system/vm/traps.scm
+++ b/module/system/vm/traps.scm
@@ -1,6 +1,6 @@
;;; Traps: stepping, breakpoints, and such.
-;; Copyright (C) 2010, 2012, 2013, 2014 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2012, 2013, 2014, 2017 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
@@ -124,7 +124,8 @@
(end (program-last-ip proc)))
(lambda (frame)
(let ((ip (frame-instruction-pointer frame)))
- (and (<= start ip) (< ip end))))))
+ (and (<= start ip)
+ end (< ip end))))))
((struct? proc)
(frame-matcher (procedure proc)))
(else