Changeset 13410

Timestamp:

07/17/11 15:53:11 (12 years ago)

Author:

ehuelsmann

Message:

Backport r13407 and r13408: fixes for pretty printer output with circular
or shared structure.

File:

• branches/0.26.x/abcl/src/org/armedbear/lisp/pprint.lisp (modified) (4 diffs)

branches/0.26.x/abcl/src/org/armedbear/lisp/pprint.lisp

@@ -610 +610 @@
   object)
 
-(defun maybe-initiate-xp-printing (fn stream &rest args)
+(defun maybe-initiate-xp-printing (object fn stream &rest args)
   (if (xp-structure-p stream)
       (apply fn stream args)
       (let ((*abbreviation-happened* nil)
-      (sys::*circularity-hash-table*
-             (if (and *print-circle* (null sys::*circularity-hash-table*))
-                 (make-hash-table :test 'eq)
-                 sys::*circularity-hash-table*))
       (*result* nil))
-  (xp-print fn (sys:out-synonym-of stream) args)
+        (if (and *print-circle* (null sys::*circularity-hash-table*))
+            (let ((sys::*circularity-hash-table* (make-hash-table :test 'eq)))
+              (setf (gethash object sys::*circularity-hash-table*) t)
+              (xp-print fn (make-broadcast-stream) args)
+              (let ((sys::*circularity-counter* 0))
+                (when (eql 0 (gethash object sys::*circularity-hash-table*))
+                  (setf (gethash object sys::*circularity-hash-table*)
+                        (incf sys::*circularity-counter*))
+                  (sys::print-label (gethash object sys::*circularity-hash-table*)
+                               (sys:out-synonym-of stream)))
+                (xp-print fn (sys:out-synonym-of stream) args)))
+            (xp-print fn (sys:out-synonym-of stream) args))
   *result*)))
 
@@ -865 +872 @@
   (when (and prefix-p per-line-prefix-p)
     (error "Cannot specify values for both PREFIX and PER-LINE-PREFIX."))
-  `(maybe-initiate-xp-printing
-     #'(lambda (,stream-symbol)
-   (let ((+l ,object)
-               (+p ,(cond (prefix-p prefix)
-                          (per-line-prefix-p per-line-prefix)
-                          (t "")))
-         (+s ,suffix))
-     (pprint-logical-block+
+  `(let ((+l ,object))
+     (maybe-initiate-xp-printing
+      +l
+      #'(lambda (,stream-symbol)
+          (let ((+l +l)
+                (+p ,(cond (prefix-p prefix)
+                           (per-line-prefix-p per-line-prefix)
+                           (t "")))
+                (+s ,suffix))
+            (pprint-logical-block+
        (,stream-symbol +l +p +s ,per-line-prefix-p t nil)
        ,@ body nil)))
-     (sys:out-synonym-of ,stream-symbol)))
+      (sys:out-synonym-of ,stream-symbol))))
 
 ;Assumes var and args must be variables.  Other arguments must be literals or variables.
@@ -1348 +1357 @@
 ;;  (t
 ;;          (assert nil)
-;;          (sys:output-object object stream))))
+;;          (syss:output-object object stream))))
 
 (defun output-pretty-object (object stream)
@@ -1355 +1364 @@
          (write+ object stream))
   (*print-pretty*
-         (maybe-initiate-xp-printing #'(lambda (s o) (write+ o s))
+         (maybe-initiate-xp-printing object #'(lambda (s o) (write+ o s))
                                      stream object))
   (t