diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm index 22bbb8a94..d3d765202 100644 --- a/module/ice-9/pretty-print.scm +++ b/module/ice-9/pretty-print.scm @@ -328,7 +328,7 @@ sub-expression, via the @var{breadth-first?} keyword argument." (let ((ellipsis-width (string-length ellipsis))) - (define (print-sequence x width len ref next) + (define* (print-sequence x width len ref next #:key inner?) (let lp ((x x) (width width) (i 0)) @@ -337,7 +337,7 @@ sub-expression, via the @var{breadth-first?} keyword argument." (cond ((= i len)) ; catches 0-length case ((and (= i (1- len)) (or (zero? i) (> width 1))) - (print (ref x i) (if (zero? i) width (1- width)))) + (print (ref x i) (if (zero? i) width (1- width)) #:inner? inner?)) ((<= width (+ 1 ellipsis-width)) (display ellipsis)) (else @@ -347,7 +347,8 @@ sub-expression, via the @var{breadth-first?} keyword argument." (if breadth-first? (max 1 (1- (floor (/ width (- len i))))) - (- width (+ 1 ellipsis-width)))))))) + (- width (+ 1 ellipsis-width))) + #:inner? inner?))))) (display str) (lp (next x) (- width 1 (string-length str)) (1+ i))))))) @@ -397,7 +398,7 @@ sub-expression, via the @var{breadth-first?} keyword argument." (else (lp (cdr fixes)))))) - (define* (print x width #:key top?) + (define* (print x width #:key inner?) (cond ((<= width 0) (error "expected a positive width" width)) @@ -429,19 +430,25 @@ sub-expression, via the @var{breadth-first?} keyword argument." (else (display "#")))) ((and (array? x) (not (string? x))) - (let* ((prefix (if top? - (let ((s (format #f "~a" - (apply make-typed-array (array-type x) - *unspecified* - (make-list (array-rank x) 0))))) - (substring s 0 (- (string-length s) 2))) - "")) + (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)))))) (width-prefix (string-length prefix))) (cond ((>= width (+ 2 width-prefix ellipsis-width)) (format #t "~a(" prefix) - (print-sequence x (- width width-prefix 2) (array-length x) - array-cell-ref identity) + (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 + #:inner? (< 1 (array-rank x)))) (display ")")) (else (display "#"))))) @@ -463,4 +470,4 @@ sub-expression, via the @var{breadth-first?} keyword argument." (with-output-to-port port (lambda () - (print x width #:top? #t))))) + (print x width))))) diff --git a/test-suite/tests/print.test b/test-suite/tests/print.test index 836fa2271..82cc77603 100644 --- a/test-suite/tests/print.test +++ b/test-suite/tests/print.test @@ -147,6 +147,18 @@ (pass-if-equal "#" (tprint (current-module) 20 "UTF-8")) + (pass-if-equal "#0(#)" + (tprint (make-typed-array #t 9.0) 6 "UTF-8")) + + (pass-if-equal "#0(9.0)" + (tprint (make-typed-array #t 9.0) 7 "UTF-8")) + + (pass-if-equal "#0f64(#)" + (tprint (make-typed-array 'f64 9.0) 8 "UTF-8")) + + (pass-if-equal "#0f64(9.0)" + (tprint (make-typed-array 'f64 9.0) 10 "UTF-8")) + (pass-if-equal "#" (tprint (make-typed-array 's32 0 20 20) 7 "UTF-8")) @@ -160,4 +172,19 @@ (tprint (make-typed-array 's32 0 20 20) 12 "UTF-8")) (pass-if-equal "#2s32((0 …) …)" - (tprint (make-typed-array 's32 0 20 20) 14 "UTF-8"))) + (tprint (make-typed-array 's32 0 20 20) 14 "UTF-8")) + + (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")) + + (pass-if-equal "#(#2((9 9) (9 9)) #2((9 9) (9 9)))" + (tprint (make-vector 2 (make-typed-array #t 9 2 2)) 40 "UTF-8")) + + (pass-if-equal "(#2((9 9) (9 9)) #2((9 9) (9 9)))" + (tprint (make-list 2 (make-typed-array #t 9 2 2)) 40 "UTF-8")) + + (pass-if-equal "(#0(9) #0(9))" + (tprint (make-list 2 (make-typed-array #t 9)) 20 "UTF-8")) + + (pass-if-equal "(#0(9) #)" + (tprint (make-list 2 (make-typed-array #t 9)) 10 "UTF-8")))