From b200b1d3d738455a2364c980c91581385ceef5e3 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 6 Jan 2019 23:32:15 -0800 Subject: [PATCH] Generalize list-like printing, and support list-breadth limit properly. --- src/runtime/printer.scm | 165 +++++++++++++++------------------ tests/runtime/test-printer.scm | 85 +++++++++++++++++ 2 files changed, 161 insertions(+), 89 deletions(-) diff --git a/src/runtime/printer.scm b/src/runtime/printer.scm index 63a152b67..85dd68220 100644 --- a/src/runtime/printer.scm +++ b/src/runtime/printer.scm @@ -310,10 +310,9 @@ USA. object context (lambda (context*) - (for-each (lambda (part) - (*print-char #\space context*) - (print-object part context*)) - (standard-print-method-parts print-method object))))) + (*print-items (standard-print-method-parts print-method object) + context* + print-object)))) (print-method (call-print-method print-method object context)) (else @@ -417,6 +416,38 @@ USA. (define (allowed-char? char context) (char-in-set? char (context-char-set context))) +(define (limit-print-depth context kernel) + (let ((context* (context-down-list context)) + (limit (context-list-depth-limit context))) + (if (and limit + (> (context-list-depth context*) limit)) + (*print-string "..." context*) + (kernel context*)))) + +(define (limit-print-breadth context n-printed kernel) + (if (let ((limit (context-list-breadth-limit context))) + (and limit + (>= n-printed limit))) + (*print-string " ..." context) + (kernel))) + +(define (*general-print-items items context print-item n-printed split) + (let loop ((items items) (n-printed n-printed)) + (split items + (lambda (item rest) + (limit-print-breadth context n-printed + (lambda () + (if (> n-printed 0) + (*print-char #\space context)) + (print-item item context) + (loop rest (+ n-printed 1)))))))) + +(define (*print-items items context print-item) + (*general-print-items items context print-item 0 + (lambda (items k) + (if (pair? items) + (k (car items) (cdr items)))))) + (define (*print-with-brackets name object context procedure) (if (get-param:print-with-maximum-readability?) (*print-readable-hash object context) @@ -648,25 +679,14 @@ USA. (define (print-vector vector context) (limit-print-depth context (lambda (context*) + (*print-string "#(" context*) (let ((end (vector-length vector))) - (if (fix:> end 0) - (begin - (*print-string "#(" context*) - (print-object (safe-vector-ref vector 0) context*) - (let loop ((index 1)) - (if (fix:< index end) - (if (let ((limit - (context-list-breadth-limit context*))) - (and limit - (>= index limit))) - (*print-string " ...)" context*) - (begin - (*print-char #\space context*) - (print-object (safe-vector-ref vector index) - context*) - (loop (fix:+ index 1)))))) - (*print-char #\) context*)) - (*print-string "#()" context*)))))) + (*general-print-items 0 context* print-object 0 + (lambda (index k) + (if (fix:< index end) + (k (safe-vector-ref vector index) + (fix:+ index 1)))))) + (*print-char #\) context*)))) (define (safe-vector-ref vector index) (if (with-absolutely-no-interrupts @@ -679,24 +699,14 @@ USA. (define (print-bytevector bytevector context) (limit-print-depth context (lambda (context*) + (*print-string "#u8(" context*) (let ((end (bytevector-length bytevector))) - (if (fix:> end 0) - (begin - (*print-string "#u8(" context*) - (print-number (bytevector-u8-ref bytevector 0) context*) - (let loop ((index 1)) - (if (fix:< index end) - (if (let ((limit (get-param:printer-list-breadth-limit))) - (and limit - (>= index limit))) - (*print-string " ..." context*) - (begin - (*print-char #\space context*) - (print-number (bytevector-u8-ref bytevector index) - context*) - (loop (fix:+ index 1)))))) - (*print-char #\) context*)) - (*print-string "#u8()" context*)))))) + (*general-print-items 0 context* print-object 0 + (lambda (index k) + (if (fix:< index end) + (k (bytevector-u8-ref bytevector index) + (fix:+ index 1)))))) + (*print-char #\) context*)))) (define (print-record record context) (cond ((string? record) (print-string record context)) @@ -724,36 +734,20 @@ USA. (lambda (context*) (*print-char #\( context*) (print-object (safe-car list) context*) - (print-tail (safe-cdr list) 2 context*) + (*general-print-items (safe-cdr list) context* print-object 1 + (lambda (tail k) + (cond ((datum-label tail context*) + => (lambda (label) + (*print-string " . " context*) + (if (print-datum-label label context*) + (print-object-1 tail context*)))) + ((pair? tail) + (k (safe-car tail) (safe-cdr tail))) + ((not (null? tail)) + (*print-string " . " context*) + (print-object-1 tail context*))))) (*print-char #\) context*)))) -(define (limit-print-depth context kernel) - (let ((context* (context-down-list context)) - (limit (context-list-depth-limit context))) - (if (and limit - (> (context-list-depth-limit context*) limit)) - (*print-string "..." context*) - (kernel context*)))) - -(define (print-tail l n context) - (cond ((datum-label l context) - => (lambda (label) - (*print-string " . " context) - (if (print-datum-label label context) - (print-object-1 l context)))) - ((pair? l) - (*print-char #\space context) - (print-object (safe-car l) context) - (if (let ((limit (context-list-breadth-limit context))) - (and limit - (>= n limit) - (pair? (safe-cdr l)))) - (*print-string " ..." context) - (print-tail (safe-cdr l) (+ n 1) context))) - ((not (null? l)) - (*print-string " . " context) - (print-object l context)))) - (define (prefix-pair? object) (and (get-param:printer-abbreviate-quotations?) (pair? (safe-cdr object)) @@ -774,30 +768,23 @@ USA. (lambda (context*) (*print-char #\{ context*) (print-object (safe-car stream-pair) context*) - (print-stream-tail (safe-cdr stream-pair) 2 context*) + (*general-print-items (safe-cdr stream-pair) context* print-object 1 + (lambda (tail k) + (cond ((not (promise? tail)) + (*print-string " . " context*) + (print-object tail context*)) + ((not (promise-forced? tail)) + (*print-string " ..." context*)) + (else + (let ((value (promise-value tail))) + (cond ((empty-stream? value)) + ((stream-pair? value) + (k (safe-car value) (safe-cdr value))) + (else + (*print-string " . " context*) + (print-object value context*)))))))) (*print-char #\} context*)))) -(define (print-stream-tail tail n context) - (cond ((not (promise? tail)) - (*print-string " . " context) - (print-object tail context)) - ((not (promise-forced? tail)) - (*print-string " ..." context)) - (else - (let ((value (promise-value tail))) - (cond ((empty-stream? value)) - ((stream-pair? value) - (*print-char #\space context) - (print-object (safe-car value) context) - (if (let ((limit (context-list-breadth-limit context))) - (and limit - (>= n limit))) - (*print-string " ..." context) - (print-stream-tail (safe-cdr value) (+ n 1) context))) - (else - (*print-string " . " context) - (print-object value context))))))) - (define (safe-car pair) (map-reference-trap (lambda () (car pair)))) diff --git a/tests/runtime/test-printer.scm b/tests/runtime/test-printer.scm index 1432dc32f..5e88557dd 100644 --- a/tests/runtime/test-printer.scm +++ b/tests/runtime/test-printer.scm @@ -45,3 +45,88 @@ USA. (let ((s (find-shared-objects c))) (assert-= (length s) 1) (assert-eq (car s) c))))) + +(define (assert-prints-as object expected . properties) + (apply assert-string= + (call-with-output-string + (lambda (port) + (write object port))) + expected + properties)) + +(define-test 'print-shared-objects + (lambda () + (let ((clist (circular-list 1 3 5 7))) + (assert-prints-as clist + "#0=(1 3 5 7 . #0#)") + (assert-prints-as (list clist) + "(#0=(1 3 5 7 . #0#))") + (assert-prints-as (vector (circular-list 1 3 5 7)) + "#(#0=(1 3 5 7 . #0#))") + (assert-prints-as (circular-list clist) + "#0=(#1=(1 3 5 7 . #1#) . #0#)") + (assert-prints-as (circular-list clist clist) + "#0=(#1=(1 3 5 7 . #1#) #1# . #0#)")) + (let ((cvector (vector 2 4 6 8))) + (vector-set! cvector 1 cvector) + (assert-prints-as cvector + "#0=#(2 #0# 6 8)") + (assert-prints-as (list cvector cvector) + "(#0=#(2 #0# 6 8) #0#)") + (assert-prints-as (vector cvector cvector) + "#(#0=#(2 #0# 6 8) #0#)") + (assert-prints-as (circular-list cvector cvector) + "#0=(#1=#(2 #1# 6 8) #1# . #0#)")))) + +(define-test 'general-item-printer + (lambda () + (assert-prints-as '() "()") + (assert-prints-as '#() "#()") + (assert-prints-as '#u8() "#u8()") + (assert-prints-as '(2) "(2)") + (assert-prints-as '#(2) "#(2)") + (assert-prints-as '#u8(2) "#u8(2)") + (assert-prints-as '(2 3 5 7 11 13 17 19) + "(2 3 5 7 11 13 17 19)") + (assert-prints-as '#(2 3 5 7 11 13 17 19) + "#(2 3 5 7 11 13 17 19)") + (assert-prints-as '#u8(2 3 5 7 11 13 17 19) + "#u8(2 3 5 7 11 13 17 19)") + (assert-prints-as '(2 3 5 7 11 13 17 19 . foo) + "(2 3 5 7 11 13 17 19 . foo)"))) + +(define-test 'list-breadth-limit + (lambda () + (parameterize ((param:printer-list-breadth-limit 1)) + (assert-prints-as '() "()") + (assert-prints-as '#() "#()") + (assert-prints-as '#u8() "#u8()") + (assert-prints-as '(2) "(2)") + (assert-prints-as '#(2) "#(2)") + (assert-prints-as '#u8(2) "#u8(2)") + (assert-prints-as '(2 3 5 7 11 13 17 19) + "(2 ...)") + (assert-prints-as '#(2 3 5 7 11 13 17 19) + "#(2 ...)") + (assert-prints-as '#u8(2 3 5 7 11 13 17 19) + "#u8(2 ...)") + (assert-prints-as '(2 3 5 7 11 13 17 19 . foo) + "(2 ...)")) + (parameterize ((param:printer-list-breadth-limit 2)) + (assert-prints-as '(2 3 5 7 11 13 17 19) + "(2 3 ...)") + (assert-prints-as '#(2 3 5 7 11 13 17 19) + "#(2 3 ...)") + (assert-prints-as '#u8(2 3 5 7 11 13 17 19) + "#u8(2 3 ...)") + (assert-prints-as '(2 3 5 7 11 13 17 19 . foo) + "(2 3 ...)")) + (parameterize ((param:printer-list-breadth-limit 3)) + (assert-prints-as '(2 3 5 7 11 13 17 19) + "(2 3 5 ...)") + (assert-prints-as '#(2 3 5 7 11 13 17 19) + "#(2 3 5 ...)") + (assert-prints-as '#u8(2 3 5 7 11 13 17 19) + "#u8(2 3 5 ...)") + (assert-prints-as '(2 3 5 7 11 13 17 19 . foo) + "(2 3 5 ...)")))) \ No newline at end of file -- 2.25.1