From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED!not-for-mail From: daniel.llorens@bluewin.ch Newsgroups: gmane.lisp.guile.devel Subject: [PATCH 6/6] Fix bitvectors and non-zero lower bound arrays in truncated-print Date: Mon, 13 Feb 2017 15:04:28 +0100 Message-ID: <20170213140428.54258-7-daniel.llorens@bluewin.ch> References: <20170213140428.54258-1-daniel.llorens@bluewin.ch> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit X-Trace: blaine.gmane.org 1486995492 29491 195.159.176.226 (13 Feb 2017 14:18:12 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Mon, 13 Feb 2017 14:18:12 +0000 (UTC) To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Mon Feb 13 15:18:04 2017 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by blaine.gmane.org with esmtp (Exim 4.84_2) (envelope-from ) id 1cdHS6-00073d-UL for guile-devel@m.gmane.org; Mon, 13 Feb 2017 15:18:03 +0100 Original-Received: from localhost ([::1]:57116 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1cdHSC-0007oz-FI for guile-devel@m.gmane.org; Mon, 13 Feb 2017 09:18:08 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:52205) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1cdHFM-0004Q3-Ao for guile-devel@gnu.org; Mon, 13 Feb 2017 09:04:54 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1cdHFI-0006nl-96 for guile-devel@gnu.org; Mon, 13 Feb 2017 09:04:52 -0500 Original-Received: from vimdzmsp-sfwd03.bluewin.ch ([195.186.120.132]:49836 helo=smtpauths.lb.bluewin.ch) by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1cdHFH-0006mC-U8 for guile-devel@gnu.org; Mon, 13 Feb 2017 09:04:48 -0500 Original-Received: from 4box.hq.corp.viasat.com ([213.193.80.99]) by vimdzmsp-sfwd03.bluewin.ch Swisscom AG with SMTP id dHFDc7qUQNBT7dHFFcMOm3; Mon, 13 Feb 2017 15:04:45 +0100 X-Bluewin-Spam-Analysis: v=2.1 cv=cpQ76wMi c=1 sm=1 tr=0 a=DzaHVtLsrNCQ5PccsnG91A==:117 a=DzaHVtLsrNCQ5PccsnG91A==:17 a=L9H7d07YOLsA:10 a=9cW_t1CCXrUA:10 a=s5jvgZ67dGcA:10 a=IkcTkHD0fZMA:10 a=hs28RkquM3yYofxgFekA:9 a=B9AplxiBaX1GxVg7:21 a=OniQdLZNq56qq7pV:21 a=QEXdDO2ut3YA:10 X-Bluewin-Spam-Score: 0.00 X-FXIT-IP: IPv4[213.193.80.99] Epoch[1486994685] X-Bluewin-AuthAs: daniel.llorens@bluewin.ch X-Mailer: git-send-email 2.10.1 In-Reply-To: <20170213140428.54258-1-daniel.llorens@bluewin.ch> X-CMAE-Envelope: MS4wfE+vXfZKkbe7B1k02uJI3rCCgg11ox4g0nqUTRQCs+t5QYchSHKjyQfaCs0TqpTHcGPHM+RtkHDLvHI7GZEc6VMoU7qTD4GdFj319titO11SNv4FxRlL uDd4YgLsUM2dTieQyD7PA37ICuh19IwBgYWdAk99XrSOoUUnxVs+KFUd2s/Sc9axM4k5yNaURumnOs0GYbt99S+KAaACRqW+Nj1yAVAz7aIKRqVmRwjtW+vT X-detected-operating-system: by eggs.gnu.org: GNU/Linux 3.x [fuzzy] X-Received-From: 195.186.120.132 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.21 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Original-Sender: "guile-devel" Xref: news.gmane.org gmane.lisp.guile.devel:18908 Archived-At: From: Daniel Llorens * module/ice-9/arrays.scm (array-print-prefix, array-print): New private functions. * libguile/arrays.c (scm_i_print_array): Reuse (array-print-prefix) from (ice-9 arrays). Make sure to release the array handle. * module/ice-9/pretty-print.scm (truncated-print): Support bitvectors. Don't try to guess the array prefix but call array-print-prefix from (ice-9 arrays) instead. Fix call to print-sequence to support non-zero lower bound arrays. * test-suite/tests/arrays.test: Test that arrays print properly. * test-suite/tests/print.test: Test truncated-print with bitvectors, non-zero lower bound arrays. --- libguile/arrays.c | 48 ++++++------------------------- module/ice-9/arrays.scm | 66 ++++++++++++++++++++++++++++++++++++++++++- module/ice-9/pretty-print.scm | 26 +++++++++++------ test-suite/tests/arrays.test | 55 +++++++++++++++++++++++++++++++++++- test-suite/tests/print.test | 58 +++++++++++++++++++++++++++++++------ 5 files changed, 196 insertions(+), 57 deletions(-) diff --git a/libguile/arrays.c b/libguile/arrays.c index 8b8bc48..682fbf6 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -908,50 +908,17 @@ scm_i_print_array_dimension (scm_t_array_handle *h, int dim, int pos, return 1; } -/* Print an array. -*/ - int scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) { scm_t_array_handle h; - size_t i; - int print_lbnds = 0, zero_size = 0, print_lens = 0; + int d; + scm_call_2 (scm_c_private_ref ("ice-9 arrays", "array-print-prefix"), + array, port); + scm_array_get_handle (array, &h); - scm_putc ('#', port); - if (SCM_I_ARRAYP (array)) - scm_intprint (h.ndims, 10, port); - if (h.element_type != SCM_ARRAY_ELEMENT_TYPE_SCM) - scm_write (scm_array_handle_element_type (&h), port); - - for (i = 0; i < h.ndims; i++) - { - if (h.dims[i].lbnd != 0) - print_lbnds = 1; - if (h.dims[i].ubnd - h.dims[i].lbnd + 1 == 0) - zero_size = 1; - else if (zero_size) - print_lens = 1; - } - - if (print_lbnds || print_lens) - for (i = 0; i < h.ndims; i++) - { - if (print_lbnds) - { - scm_putc ('@', port); - scm_intprint (h.dims[i].lbnd, 10, port); - } - if (print_lens) - { - scm_putc (':', port); - scm_intprint (h.dims[i].ubnd - h.dims[i].lbnd + 1, - 10, port); - } - } - if (h.ndims == 0) { /* Rank zero arrays, which are really just scalars, are printed @@ -977,10 +944,13 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) scm_putc ('(', port); scm_i_print_array_dimension (&h, 0, 0, port, pstate); scm_putc (')', port); - return 1; + d = 1; } else - return scm_i_print_array_dimension (&h, 0, 0, port, pstate); + d = scm_i_print_array_dimension (&h, 0, 0, port, pstate); + + scm_array_handle_release (&h); + return d; } void diff --git a/module/ice-9/arrays.scm b/module/ice-9/arrays.scm index 5d5276c..4850522 100644 --- a/module/ice-9/arrays.scm +++ b/module/ice-9/arrays.scm @@ -17,6 +17,8 @@ ;;; 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 typed-array-copy)) ; This is actually defined in boot-9.scm, apparently for b.c. @@ -24,7 +26,7 @@ ;; (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 +;; FIXME writes over the array twice if (array-type) is #t (define (typed-array-copy t a) (let ((b (apply make-typed-array t *unspecified* (array-shape a)))) (array-copy! a b) @@ -33,3 +35,65 @@ (define (array-copy a) (typed-array-copy (array-type a) a)) + +;; Printing arrays +;; FIXME replace scm_i_print_array() when performance allows. + +(define (array-print-prefix a port) + (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? #f)) + (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?)))))))) + +(define (array-print a port) + (define (array-rest a s) + (apply make-shared-array a (lambda i i) + (cons (list (+ 1 (caar s)) (cadar s)) (cdr s)))) + (array-print-prefix a port) + (let ((ss (array-shape a))) + (cond + ((zero? (array-rank a)) + (put-char port #\() + (display (array-ref a) port) + (put-char port #\))) + (else + (let loop ((a a) (s ss)) + (put-char port #\() + (let ((len (- (cadar s) (caar s)))) + (cond + ((= 1 (array-rank a)) + (when (not (negative? len)) + (display (array-ref a (caar s)) port) + (when (positive? len) + (array-for-each + (lambda (x) (put-char port #\space) (display x port)) + (array-rest a s))))) + (else + (when (not (negative? len)) + (loop (array-slice a (caar s)) (cdr s)) + (when (positive? len) + (array-slice-for-each 1 + (lambda (x) (put-char port #\space) (loop x (cdr s))) + (array-rest a s))))))) + (put-char port #\))))))) + diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm index d3d7652..5be108d 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 + (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/test-suite/tests/arrays.test b/test-suite/tests/arrays.test index 1df77b1..e913e30 100644 --- a/test-suite/tests/arrays.test +++ b/test-suite/tests/arrays.test @@ -999,4 +999,57 @@ "#1(b c)" (format #f "~a" (make-shared-array #(a b c) (lambda (i) (list (+ i 1))) - 2)))) + 2))) + + (pass-if-equal "0-array" + "#0(9)" + (format #f "~a" (make-array 9))) + + (pass-if-equal "2-array" + "#2f64((0.0 1.0) (2.0 3.0))" + (format #f "~a" #2f64((0 1) (2 3)))) + + (pass-if-equal "empty 3-array" + "#3()" + (format #f "~a" (make-array 1 0 0 0))) + + (pass-if-equal "empty 3-array with last nonempty dim." + "#3:0:0:1()" + (format #f "~a" (make-array 1 0 0 1))) + + (pass-if-equal "empty 3-array with middle nonempty dim." + "#3:0:1:0()" + (format #f "~a" (make-array 1 0 1 0))) + + (pass-if-equal "empty 3-array with first nonempty dim." + "#3(())" + (format #f "~a" (make-array 1 1 0 0))) + + (pass-if-equal "3-array with non-zero lower bounds" + "#3@1@0@1(((1 1 1) (1 1 1)) ((1 1 1) (1 1 1)))" + (format #f "~a" (make-array 1 '(1 2) '(0 1) '(1 3)))) + + (pass-if-equal "3-array with non-zero-lower bounds and last nonempty dim." + "#3@0:0@0:0@1:3()" + (format #f "~a" (make-array 1 0 0 '(1 3)))) + + (pass-if-equal "3-array with non-zero-lower bounds and middle nonempty dim." + "#3@0:0@1:3@0:0()" + (format #f "~a" (make-array 1 0 '(1 3) 0))) + + (pass-if-equal "3-array with non-zero-lower bounds and first nonempty dim." + "#3@1@0@0(() () ())" + (format #f "~a" (make-array 1 '(1 3) 0 0))) + + (pass-if-equal "3-array with singleton dim case I" + "#3@1@1@-1(((1 1 1)))" + (format #f "~a" (make-array 1 '(1 1) '(1 1) '(-1 1)))) + + (pass-if-equal "3-array with singleton dim case II" + "#3@-1@1@1(((1) (1) (1)))" + (format #f "~a" (make-array 1 '(-1 -1) '(1 3) '(1 1)))) + + (pass-if-equal "3-array with singleton dim case III" + "#3@1@-1@1(((1)) ((1)) ((1)))" + (format #f "~a" (make-array 1 '(1 3) '(-1 -1) '(1 1))))) + diff --git a/test-suite/tests/print.test b/test-suite/tests/print.test index 82cc776..f2e3145 100644 --- a/test-suite/tests/print.test +++ b/test-suite/tests/print.test @@ -147,6 +147,35 @@ (pass-if-equal "#" (tprint (current-module) 20 "UTF-8")) + ;; bitvectors + + (let ((testv (bitvector #t #f #f #t #t #f #t #t))) + (pass-if-equal "#*10011011" + (tprint testv 11 "UTF-8")) + + (pass-if-equal "#*10011011" + (tprint testv 11 "ISO-8859-1")) + + (pass-if-equal "#*10011…" + (tprint testv 8 "UTF-8")) + + (pass-if-equal "#*100..." + (tprint testv 8 "ISO-8859-1")) + + (pass-if-equal "#*10…" + (tprint testv 5 "UTF-8")) + + (pass-if-equal "#*..." + (tprint testv 5 "ISO-8859-1")) + + (pass-if-equal "#*1…" + (tprint testv 4 "UTF-8")) + + (pass-if-equal "#" + (tprint testv 4 "ISO-8859-1"))) + + ;; rank 0 arrays + (pass-if-equal "#0(#)" (tprint (make-typed-array #t 9.0) 6 "UTF-8")) @@ -162,18 +191,31 @@ (pass-if-equal "#" (tprint (make-typed-array 's32 0 20 20) 7 "UTF-8")) - (pass-if-equal "#2s32(…)" - (tprint (make-typed-array 's32 0 20 20) 8 "UTF-8")) + ;; higher dimensional arrays + + (let ((testa (make-typed-array 's32 0 20 20))) + (pass-if-equal "#2s32(…)" + (tprint testa 8 "UTF-8")) + + (pass-if-equal "#2s32(# …)" + (tprint testa 10 "UTF-8")) - (pass-if-equal "#2s32(# …)" - (tprint (make-typed-array 's32 0 20 20) 10 "UTF-8")) + (pass-if-equal "#2s32((…) …)" + (tprint testa 12 "UTF-8")) - (pass-if-equal "#2s32((…) …)" - (tprint (make-typed-array 's32 0 20 20) 12 "UTF-8")) + (pass-if-equal "#2s32((0 …) …)" + (tprint testa 14 "UTF-8"))) - (pass-if-equal "#2s32((0 …) …)" - (tprint (make-typed-array 's32 0 20 20) 14 "UTF-8")) + ;; check that bounds are printed correctly + (pass-if-equal "#2@-1@0((foo foo foo foo …) …)" + (tprint (make-array 'foo '(-1 3) 5) 30 "UTF-8")) + + (pass-if-equal "#3@-1:5@0:0@0:5(() () () # #)" + (tprint (make-array 'foo '(-1 3) 0 5) 30 "UTF-8")) + + ;; nested objects including arrays + (pass-if-equal "#2((#(9 9) #(9 9)) (#(9 9) #(9 9)))" (tprint (make-typed-array #t (make-typed-array #t 9 2) 2 2) 40 "UTF-8")) -- 2.10.1