diff options
author | Andy Wingo <wingo@pobox.com> | 2017-11-29 21:04:59 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2017-11-29 21:04:59 +0100 |
commit | f85d3c0bd886e46e6ab3fc858231c8b2aa3e954d (patch) | |
tree | 9afe1139ddece9c4686e177b49e847ac0730f8d7 /module | |
parent | 39520f879a41821ad63ed85fd227b9ec421cb8b7 (diff) | |
parent | e0bcda4ad940c4e15679cc2b229838b33acdd36c (diff) | |
download | guile-f85d3c0bd886e46e6ab3fc858231c8b2aa3e954d.tar.gz |
Merge until e0bcda4ad940c4e15679cc2b229838b33acdd36c from stable-2.2
Diffstat (limited to 'module')
-rw-r--r-- | module/Makefile.am | 1 | ||||
-rw-r--r-- | module/ice-9/arrays.scm | 88 | ||||
-rw-r--r-- | module/ice-9/pretty-print.scm | 24 | ||||
-rw-r--r-- | module/system/vm/traps.scm | 5 |
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 |