Changeset 13410


Ignore:
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:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/0.26.x/abcl/src/org/armedbear/lisp/pprint.lisp

    r12230 r13410  
    610610  object)
    611611
    612 (defun maybe-initiate-xp-printing (fn stream &rest args)
     612(defun maybe-initiate-xp-printing (object fn stream &rest args)
    613613  (if (xp-structure-p stream)
    614614      (apply fn stream args)
    615615      (let ((*abbreviation-happened* nil)
    616       (sys::*circularity-hash-table*
    617              (if (and *print-circle* (null sys::*circularity-hash-table*))
    618                  (make-hash-table :test 'eq)
    619                  sys::*circularity-hash-table*))
    620616      (*result* nil))
    621   (xp-print fn (sys:out-synonym-of stream) args)
     617        (if (and *print-circle* (null sys::*circularity-hash-table*))
     618            (let ((sys::*circularity-hash-table* (make-hash-table :test 'eq)))
     619              (setf (gethash object sys::*circularity-hash-table*) t)
     620              (xp-print fn (make-broadcast-stream) args)
     621              (let ((sys::*circularity-counter* 0))
     622                (when (eql 0 (gethash object sys::*circularity-hash-table*))
     623                  (setf (gethash object sys::*circularity-hash-table*)
     624                        (incf sys::*circularity-counter*))
     625                  (sys::print-label (gethash object sys::*circularity-hash-table*)
     626                               (sys:out-synonym-of stream)))
     627                (xp-print fn (sys:out-synonym-of stream) args)))
     628            (xp-print fn (sys:out-synonym-of stream) args))
    622629  *result*)))
    623630
     
    865872  (when (and prefix-p per-line-prefix-p)
    866873    (error "Cannot specify values for both PREFIX and PER-LINE-PREFIX."))
    867   `(maybe-initiate-xp-printing
    868      #'(lambda (,stream-symbol)
    869    (let ((+l ,object)
    870                (+p ,(cond (prefix-p prefix)
    871                           (per-line-prefix-p per-line-prefix)
    872                           (t "")))
    873          (+s ,suffix))
    874      (pprint-logical-block+
     874  `(let ((+l ,object))
     875     (maybe-initiate-xp-printing
     876      +l
     877      #'(lambda (,stream-symbol)
     878          (let ((+l +l)
     879                (+p ,(cond (prefix-p prefix)
     880                           (per-line-prefix-p per-line-prefix)
     881                           (t "")))
     882                (+s ,suffix))
     883            (pprint-logical-block+
    875884       (,stream-symbol +l +p +s ,per-line-prefix-p t nil)
    876885       ,@ body nil)))
    877      (sys:out-synonym-of ,stream-symbol)))
     886      (sys:out-synonym-of ,stream-symbol))))
    878887
    879888;Assumes var and args must be variables.  Other arguments must be literals or variables.
     
    13481357;;  (t
    13491358;;          (assert nil)
    1350 ;;          (sys:output-object object stream))))
     1359;;          (syss:output-object object stream))))
    13511360
    13521361(defun output-pretty-object (object stream)
     
    13551364         (write+ object stream))
    13561365  (*print-pretty*
    1357          (maybe-initiate-xp-printing #'(lambda (s o) (write+ o s))
     1366         (maybe-initiate-xp-printing object #'(lambda (s o) (write+ o s))
    13581367                                     stream object))
    13591368  (t
Note: See TracChangeset for help on using the changeset viewer.