1;;; print.lisp 2;;; 3;;; Copyright (C) 2004-2006 Peter Graves 4;;; $Id$ 5;;; 6;;; This program is free software; you can redistribute it and/or 7;;; modify it under the terms of the GNU General Public License 8;;; as published by the Free Software Foundation; either version 2 9;;; of the License, or (at your option) any later version. 10;;; 11;;; This program is distributed in the hope that it will be useful, 12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14;;; GNU General Public License for more details. 15;;; 16;;; You should have received a copy of the GNU General Public License 17;;; along with this program; if not, write to the Free Software 18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 19;;; 20;;; As a special exception, the copyright holders of this library give you 21;;; permission to link this library with independent modules to produce an 22;;; executable, regardless of the license terms of these independent 23;;; modules, and to copy and distribute the resulting executable under 24;;; terms of your choice, provided that you also meet, for each linked 25;;; independent module, the terms and conditions of the license of that 26;;; module. An independent module is a module which is not derived from 27;;; or based on this library. If you modify this library, you may extend 28;;; this exception to your version of the library, but you are not 29;;; obligated to do so. If you do not wish to do so, delete this 30;;; exception statement from your version. 31 32;;; Adapted from SBCL. 33 34(in-package #:system) 35 36;;; Can this object contain other objects? 37(defun compound-object-p (x) 38 (or (consp x) 39 (typep x 'structure-object) 40 (typep x 'standard-object) 41 (typep x '(array t *)))) 42 43;;; Punt if INDEX is equal or larger then *PRINT-LENGTH* (and 44;;; *PRINT-READABLY* is NIL) by outputting \"...\" and returning from 45;;; the block named NIL. 46(defmacro punt-print-if-too-long (index stream) 47 `(when (and (not *print-readably*) 48 *print-length* 49 (>= ,index *print-length*)) 50 (write-string "..." ,stream) 51 (return))) 52 53(defun output-integer (integer stream) 54;; (%output-object integer stream)) 55 (if (xp::xp-structure-p stream) 56 (let ((s (sys::%write-to-string integer))) 57 (xp::write-string++ s stream 0 (length s))) 58 (%output-object integer stream))) 59 60(defun output-list (list stream) 61 (cond ((and (null *print-readably*) 62 *print-level* 63 (>= *current-print-level* *print-level*)) 64 (write-char #\# stream)) 65 (t 66 (let ((*current-print-level* (1+ *current-print-level*))) 67 (write-char #\( stream) 68 (let ((*current-print-length* 0) 69 (list list)) 70 (loop 71 (punt-print-if-too-long *current-print-length* stream) 72 (output-object (pop list) stream) 73 (unless list 74 (return)) 75 (when (or (atom list) 76 (check-for-circularity list)) 77 (write-string " . " stream) 78 (output-object list stream) 79 (return)) 80 (write-char #\space stream) 81 (incf *current-print-length*))) 82 (write-char #\) stream)))) 83 list) 84 85;;; Output the abbreviated #< form of an array. 86(defun output-terse-array (array stream) 87 (let ((*print-level* nil) 88 (*print-length* nil)) 89 (print-unreadable-object (array stream :type t :identity t)))) 90 91(defun array-readably-printable-p (array) 92 (and (eq (array-element-type array) t) 93 (let ((zero (position 0 (array-dimensions array))) 94 (number (position 0 (array-dimensions array) 95 :test (complement #'eql) 96 :from-end t))) 97 (or (null zero) (null number) (> zero number))))) 98 99(defun output-vector (vector stream) 100 (declare (vector vector)) 101 (cond ((stringp vector) 102 (assert nil) 103 (sys::%output-object vector stream)) 104 ((not (or *print-array* *print-readably*)) 105 (output-terse-array vector stream)) 106 ((bit-vector-p vector) 107 (assert nil) 108 (sys::%output-object vector stream)) 109 (t 110 (when (and *print-readably* 111 (not (array-readably-printable-p vector))) 112 (error 'print-not-readable :object vector)) 113 (cond ((and (null *print-readably*) 114 *print-level* 115 (>= *current-print-level* *print-level*)) 116 (write-char #\# stream)) 117 (t 118 (let ((*current-print-level* (1+ *current-print-level*))) 119 (write-string "#(" stream) 120 (dotimes (i (length vector)) 121 (unless (zerop i) 122 (write-char #\space stream)) 123 (punt-print-if-too-long i stream) 124 (output-object (aref vector i) stream)) 125 (write-string ")" stream)))))) 126 vector) 127 128(defun output-ugly-object (object stream) 129 (cond ((consp object) 130 (output-list object stream)) 131 ((and (vectorp object) 132 (not (stringp object)) 133 (not (bit-vector-p object))) 134 (output-vector object stream)) 135 ((structure-object-p object) 136 (cond 137 ((and (null *print-readably*) 138 *print-level* 139 (>= *current-print-level* *print-level*)) 140 (write-char #\# stream)) 141 (t 142 (print-object object stream)))) 143 ((standard-object-p object) 144 (print-object object stream)) 145 ((java::java-object-p object) 146 (print-object object stream)) 147 ((xp::xp-structure-p stream) 148 (let ((s (sys::%write-to-string object))) 149 (xp::write-string++ s stream 0 (length s)))) 150 ((functionp object) 151 (print-object object stream)) 152 (t 153 (%output-object object stream)))) 154 155 156;;;; circularity detection stuff 157 158;;; When *PRINT-CIRCLE* is T, this gets bound to a hash table that 159;;; (eventually) ends up with entries for every object printed. When 160;;; we are initially looking for circularities, we enter a T when we 161;;; find an object for the first time, and a 0 when we encounter an 162;;; object a second time around. When we are actually printing, the 0 163;;; entries get changed to the actual marker value when they are first 164;;; printed. 165(defvar *circularity-hash-table* nil) 166 167;;; When NIL, we are just looking for circularities. After we have 168;;; found them all, this gets bound to 0. Then whenever we need a new 169;;; marker, it is incremented. 170(defvar *circularity-counter* nil) 171 172;;; Check to see whether OBJECT is a circular reference, and return 173;;; something non-NIL if it is. If ASSIGN is T, then the number to use 174;;; in the #n= and #n# noise is assigned at this time. 175;;; If ASSIGN is true, reference bookkeeping will only be done for 176;;; existing entries, no new references will be recorded! 177;;; 178;;; Note: CHECK-FOR-CIRCULARITY must be called *exactly* once with 179;;; ASSIGN true, or the circularity detection noise will get confused 180;;; about when to use #n= and when to use #n#. If this returns non-NIL 181;;; when ASSIGN is true, then you must call HANDLE-CIRCULARITY on it. 182;;; If CHECK-FOR-CIRCULARITY returns :INITIATE as the second value, 183;;; you need to initiate the circularity detection noise, e.g. bind 184;;; *CIRCULARITY-HASH-TABLE* and *CIRCULARITY-COUNTER* to suitable values 185;;; (see #'OUTPUT-OBJECT for an example). 186(defun check-for-circularity (object &optional assign) 187 (cond ((null *print-circle*) 188 ;; Don't bother, nobody cares. 189 nil) 190 ((null *circularity-hash-table*) 191 (values nil :initiate)) 192 ((null *circularity-counter*) 193 (ecase (gethash object *circularity-hash-table*) 194 ((nil) 195 ;; first encounter 196 (setf (gethash object *circularity-hash-table*) t) 197 ;; We need to keep looking. 198 nil) 199 ((t) 200 ;; second encounter 201 (setf (gethash object *circularity-hash-table*) 0) 202 ;; It's a circular reference. 203 t) 204 (0 205 ;; It's a circular reference. 206 t))) 207 (t 208 (let ((value (gethash object *circularity-hash-table*))) 209 (case value 210 ((nil t) 211 ;; If NIL, we found an object that wasn't there the 212 ;; first time around. If T, this object appears exactly 213 ;; once. Either way, just print the thing without any 214 ;; special processing. Note: you might argue that 215 ;; finding a new object means that something is broken, 216 ;; but this can happen. If someone uses the ~@<...~:> 217 ;; format directive, it conses a new list each time 218 ;; though format (i.e. the &REST list), so we will have 219 ;; different cdrs. 220 nil) 221 (0 222 (if assign 223 (let ((value (incf *circularity-counter*))) 224 ;; first occurrence of this object: Set the counter. 225 (setf (gethash object *circularity-hash-table*) value) 226 value) 227 t)) 228 (t 229 ;; second or later occurrence 230 (- value))))))) 231 232;;; Handle the results of CHECK-FOR-CIRCULARITY. If this returns T then 233;;; you should go ahead and print the object. If it returns NIL, then 234;;; you should blow it off. 235(defun handle-circularity (marker stream) 236 (case marker 237 (:initiate 238 ;; Someone forgot to initiate circularity detection. 239 (let ((*print-circle* nil)) 240 (error "trying to use CHECK-FOR-CIRCULARITY when ~ 241 circularity checking isn't initiated"))) 242 ((t) 243 ;; It's a second (or later) reference to the object while we are 244 ;; just looking. So don't bother groveling it again. 245 nil) 246 (t 247;; (write-char #\# stream) 248;; (let ((*print-base* 10) 249;; (*print-radix* nil)) 250 (cond ((minusp marker) 251;; (output-integer (- marker) stream) 252;; (write-char #\# stream) 253 (print-reference marker stream) 254 nil) 255 (t 256;; (output-integer marker stream) 257;; (write-char #\= stream) 258 (print-label marker stream) 259 t))))) 260 261(defun print-label (marker stream) 262 (write-char #\# stream) 263 (let ((*print-base* 10) 264 (*print-radix* nil)) 265 (output-integer marker stream)) 266 (write-char #\= stream)) 267 268(defun print-reference (marker stream) 269 (write-char #\# stream) 270 (let ((*print-base* 10) 271 (*print-radix* nil)) 272 (output-integer (- marker) stream)) 273 (write-char #\# stream)) 274 275;;;; OUTPUT-OBJECT -- the main entry point 276 277;; Objects whose print representation identifies them EQLly don't need to be 278;; checked for circularity. 279(defun uniquely-identified-by-print-p (x) 280 (or (numberp x) 281 (characterp x) 282 (and (symbolp x) 283 (symbol-package x)))) 284 285(defun %print-object (object stream) 286 (if *print-pretty* 287 (xp::output-pretty-object object stream) 288 (output-ugly-object object stream))) 289 290(defun %check-object (object stream) 291 (multiple-value-bind (marker initiate) 292 (check-for-circularity object t) 293 (if (eq initiate :initiate) 294 ;; Initialize circularity detection. 295 (let ((*circularity-hash-table* (make-hash-table :test 'eq))) 296 (%check-object object (make-broadcast-stream)) 297 (let ((*circularity-counter* 0)) 298 (%check-object object stream))) 299 ;; Otherwise... 300 (if marker 301 (when (handle-circularity marker stream) 302 (%print-object object stream)) 303 (%print-object object stream))))) 304 305;;; Output OBJECT to STREAM observing all printer control variables. 306(defun output-object (object stream) 307 (cond ((or (not *print-circle*) 308 (uniquely-identified-by-print-p object)) 309 (%print-object object stream)) 310 ;; If we have already started circularity detection, this object might 311 ;; be a shared reference. If we have not, then if it is a compound 312 ;; object, it might contain a circular reference to itself or multiple 313 ;; shared references. 314 ((or *circularity-hash-table* 315 (compound-object-p object)) 316 (%check-object object stream)) 317 (t 318 (%print-object object stream))) 319 object) 320 321(provide "PRINT") 322