source: trunk/abcl/src/org/armedbear/lisp/print.lisp

Last change on this file was 14933, checked in by Mark Evenson, 4 years ago

(Alan Ruttenberg) small changes to enable better introspection

Small jss tweak that caused some trouble.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 11.8 KB
Line 
1;;; print.lisp
2;;;
3;;; Copyright (C) 2004-2006 Peter Graves
4;;; $Id: print.lisp 14933 2016-12-28 09:19:00Z mevenson $
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")
Note: See TracBrowser for help on using the repository browser.