[armedbear-cvs] r13410 - branches/0.26.x/abcl/src/org/armedbear/lisp

[ehuelsmann at common-lisp.net]

Author: ehuelsmann
Date: Sun Jul 17 08:53:11 2011
New Revision: 13410

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

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

Modified: branches/0.26.x/abcl/src/org/armedbear/lisp/pprint.lisp
==============================================================================
--- branches/0.26.x/abcl/src/org/armedbear/lisp/pprint.lisp	Sun Jul 17 03:50:20 2011	(r13409)
+++ branches/0.26.x/abcl/src/org/armedbear/lisp/pprint.lisp	Sun Jul 17 08:53:11 2011	(r13410)
@@ -607,16 +607,23 @@
   (sys:output-object object (sys:out-synonym-of stream))
   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*)))
 
 (defun xp-print (fn stream args)
@@ -862,17 +869,19 @@
     (setf stream-symbol '*standard-output*))
   (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.
 
@@ -1345,14 +1354,14 @@
 ;;                                      stream object))
 ;; 	(t
 ;;          (assert nil)
-;;          (sys:output-object object stream))))
+;;          (syss:output-object object stream))))
 
 (defun output-pretty-object (object stream)
 ;;   (basic-write object stream))
   (cond ((xp-structure-p stream)
          (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
          (assert nil)