[armedbear-cvs] r13408 - trunk/abcl/src/org/armedbear/lisp

[ehuelsmann at common-lisp.net]

Author: ehuelsmann
Date: Sat Jul 16 15:49:01 2011
New Revision: 13408

Log:
Fix 2 more pretty printer (PPRINT-*) test cases.

Modified:
   trunk/abcl/src/org/armedbear/lisp/pprint.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/pprint.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/pprint.lisp	Fri Jul 15 14:18:28 2011	(r13407)
+++ trunk/abcl/src/org/armedbear/lisp/pprint.lisp	Sat Jul 16 15:49:01 2011	(r13408)
@@ -607,17 +607,22 @@
   (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)
 	    (*result* nil))
         (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))
-                (xp-print fn (sys:out-synonym-of stream) args)
-                ))
+                (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*)))
 
@@ -864,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.
 
@@ -1347,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)