Changeset 13410
- Timestamp:
- 07/17/11 15:53:11 (12 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/0.26.x/abcl/src/org/armedbear/lisp/pprint.lisp
r12230 r13410 610 610 object) 611 611 612 (defun maybe-initiate-xp-printing ( fn stream &rest args)612 (defun maybe-initiate-xp-printing (object fn stream &rest args) 613 613 (if (xp-structure-p stream) 614 614 (apply fn stream args) 615 615 (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*))620 616 (*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)) 622 629 *result*))) 623 630 … … 865 872 (when (and prefix-p per-line-prefix-p) 866 873 (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+ 875 884 (,stream-symbol +l +p +s ,per-line-prefix-p t nil) 876 885 ,@ body nil))) 877 (sys:out-synonym-of ,stream-symbol)))886 (sys:out-synonym-of ,stream-symbol)))) 878 887 879 888 ;Assumes var and args must be variables. Other arguments must be literals or variables. … … 1348 1357 ;; (t 1349 1358 ;; (assert nil) 1350 ;; (sys :output-object object stream))))1359 ;; (syss:output-object object stream)))) 1351 1360 1352 1361 (defun output-pretty-object (object stream) … … 1355 1364 (write+ object stream)) 1356 1365 (*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)) 1358 1367 stream object)) 1359 1368 (t
Note: See TracChangeset
for help on using the changeset viewer.