From bf5113c37b284a38a38d6ba18f7fd8a6ddba6cf4 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 13 May 2018 20:02:16 -0700
Subject: [PATCH] Fix bug: earlier rewrite of printer broke pp.
---
src/runtime/pp.scm | 4 +---
src/runtime/printer.scm | 10 ++++++++++
src/runtime/runtime.pkg | 3 ++-
3 files changed, 13 insertions(+), 4 deletions(-)
diff --git a/src/runtime/pp.scm b/src/runtime/pp.scm
index 8262b28c3..a654e6857 100644
--- a/src/runtime/pp.scm
+++ b/src/runtime/pp.scm
@@ -787,9 +787,7 @@ USA.
(define (walk-custom object list-depth)
(call-with-output-string
(lambda (port)
- (parameterize* (list (cons param:printer-list-depth-limit list-depth))
- (lambda ()
- (write object port))))))
+ (print-for-pp object port list-depth))))
(define (walk-pair pair list-depth)
(if (let ((limit (get-param:printer-list-depth-limit)))
diff --git a/src/runtime/printer.scm b/src/runtime/printer.scm
index 6e119dc78..2728cf3f3 100644
--- a/src/runtime/printer.scm
+++ b/src/runtime/printer.scm
@@ -215,6 +215,16 @@ USA.
(get-param:printer-list-breadth-limit)
(get-param:printer-list-depth-limit)))))
+(define (print-for-pp object port list-depth)
+ (print-object object
+ (make-context port
+ 'normal
+ list-depth
+ #f
+ (make-labeling-procedure object 'circularity)
+ (get-param:printer-list-breadth-limit)
+ (get-param:printer-list-depth-limit))))
+
(define (make-labeling-procedure object label-mode)
(let ((shared-objects
(case label-mode
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 987d93416..327546925 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4867,7 +4867,8 @@ USA.
(export (runtime pretty-printer)
get-param:printer-list-breadth-limit
get-param:printer-list-depth-limit
- prefix-pair?)
+ prefix-pair?
+ print-for-pp)
(export (runtime swank)
user-object-type))
--
2.25.1