Changeset 13408 for trunk/abcl/src/org


Ignore:
Timestamp:
07/16/11 22:49:01 (10 years ago)
Author:
ehuelsmann
Message:

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

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/pprint.lisp

    r13407 r13408  
    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)
     
    617617        (if (and *print-circle* (null sys::*circularity-hash-table*))
    618618            (let ((sys::*circularity-hash-table* (make-hash-table :test 'eq)))
     619              (setf (gethash object sys::*circularity-hash-table*) t)
    619620              (xp-print fn (make-broadcast-stream) args)
    620621              (let ((sys::*circularity-counter* 0))
    621                 (xp-print fn (sys:out-synonym-of stream) args)
    622                 ))
     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)))
    623628            (xp-print fn (sys:out-synonym-of stream) args))
    624629  *result*)))
     
    867872  (when (and prefix-p per-line-prefix-p)
    868873    (error "Cannot specify values for both PREFIX and PER-LINE-PREFIX."))
    869   `(maybe-initiate-xp-printing
    870      #'(lambda (,stream-symbol)
    871    (let ((+l ,object)
    872                (+p ,(cond (prefix-p prefix)
    873                           (per-line-prefix-p per-line-prefix)
    874                           (t "")))
    875          (+s ,suffix))
    876      (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+
    877884       (,stream-symbol +l +p +s ,per-line-prefix-p t nil)
    878885       ,@ body nil)))
    879      (sys:out-synonym-of ,stream-symbol)))
     886      (sys:out-synonym-of ,stream-symbol))))
    880887
    881888;Assumes var and args must be variables.  Other arguments must be literals or variables.
     
    13501357;;  (t
    13511358;;          (assert nil)
    1352 ;;          (sys:output-object object stream))))
     1359;;          (syss:output-object object stream))))
    13531360
    13541361(defun output-pretty-object (object stream)
     
    13571364         (write+ object stream))
    13581365  (*print-pretty*
    1359          (maybe-initiate-xp-printing #'(lambda (s o) (write+ o s))
     1366         (maybe-initiate-xp-printing object #'(lambda (s o) (write+ o s))
    13601367                                     stream object))
    13611368  (t
Note: See TracChangeset for help on using the changeset viewer.