Fix pprint dispatch and circularity-aware pretty printing

src/org/armedbear/lisp/pprint.lisp

@@ -613,7 +613,21 @@
 
 (defun maybe-initiate-xp-printing (object fn stream &rest args)
   (if (xp-structure-p stream)
-      (apply fn stream args)
+      (cond ((or (not *print-circle*)
+                 (null sys::*circularity-hash-table*)
+                 (sys::uniquely-identified-by-print-p object)
+                 ;; Our caller (%check-object) already consulted the
+                 ;; circularity hash table for this object and emitted
+                 ;; #n= if needed. Don't repeat the work.
+                 (eq object sys::*circularity-handled-object*))
+             (let ((sys::*circularity-handled-object* nil))
+               (apply fn stream args)))
+            (t
+             (let ((marker (sys::check-for-circularity object t)))
+               (cond ((null marker)
+                      (apply fn stream args))
+                     ((sys::handle-circularity marker stream)
+                      (apply fn stream args))))))
       (let ((*abbreviation-happened* nil)
             (*result* nil))
         (if (and *print-circle* (null sys::*circularity-hash-table*))

src/org/armedbear/lisp/print.lisp

@@ -144,11 +144,11 @@
          (print-object object stream))
         ((java::java-object-p object)
          (print-object object stream))
+        ((functionp object)
+          (print-object object stream))
         ((xp::xp-structure-p stream)
          (let ((s (sys::%write-to-string object)))
            (xp::write-string++ s stream 0 (length s))))
-        ((functionp object)
-          (print-object object stream))
         (t
          (%output-object object stream))))
 
@@ -287,6 +287,12 @@
       (xp::output-pretty-object object stream)
       (output-ugly-object object stream)))
 
+(defvar *circularity-handled-object* nil
+  "Bound to the current object when %check-object has already consulted
+the circularity hash table on its behalf. Downstream callers of
+maybe-initiate-xp-printing use this to avoid a redundant check when
+pprint-logical-block is entered from a dispatched pretty-printer.")
+
 (defun %check-object (object stream)
   (multiple-value-bind (marker initiate)
       (check-for-circularity object t)
@@ -299,8 +305,10 @@
         ;; Otherwise...
         (if marker
             (when (handle-circularity marker stream)
-              (%print-object object stream))
-            (%print-object object stream)))))
+              (let ((*circularity-handled-object* object))
+                (%print-object object stream)))
+            (let ((*circularity-handled-object* object))
+              (%print-object object stream))))))
 
 ;;; Output OBJECT to STREAM observing all printer control variables.
 (defun output-object (object stream)