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

Last change on this file since 14112 was 14112, checked in by ehuelsmann, 9 years ago

Use PROVIDE/REQUIRE to prevent multiple loading.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 11.7 KB
Line 
1;;; print.lisp
2;;;
3;;; Copyright (C) 2004-2006 Peter Graves
4;;; $Id: print.lisp 14112 2012-08-18 08:17:42Z ehuelsmann $
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        (t
151         (%output-object object stream))))
152
153;;;; circularity detection stuff
154
155;;; When *PRINT-CIRCLE* is T, this gets bound to a hash table that
156;;; (eventually) ends up with entries for every object printed. When
157;;; we are initially looking for circularities, we enter a T when we
158;;; find an object for the first time, and a 0 when we encounter an
159;;; object a second time around. When we are actually printing, the 0
160;;; entries get changed to the actual marker value when they are first
161;;; printed.
162(defvar *circularity-hash-table* nil)
163
164;;; When NIL, we are just looking for circularities. After we have
165;;; found them all, this gets bound to 0. Then whenever we need a new
166;;; marker, it is incremented.
167(defvar *circularity-counter* nil)
168
169;;; Check to see whether OBJECT is a circular reference, and return
170;;; something non-NIL if it is. If ASSIGN is T, then the number to use
171;;; in the #n= and #n# noise is assigned at this time.
172;;; If ASSIGN is true, reference bookkeeping will only be done for
173;;; existing entries, no new references will be recorded!
174;;;
175;;; Note: CHECK-FOR-CIRCULARITY must be called *exactly* once with
176;;; ASSIGN true, or the circularity detection noise will get confused
177;;; about when to use #n= and when to use #n#. If this returns non-NIL
178;;; when ASSIGN is true, then you must call HANDLE-CIRCULARITY on it.
179;;; If CHECK-FOR-CIRCULARITY returns :INITIATE as the second value,
180;;; you need to initiate the circularity detection noise, e.g. bind
181;;; *CIRCULARITY-HASH-TABLE* and *CIRCULARITY-COUNTER* to suitable values
182;;; (see #'OUTPUT-OBJECT for an example).
183(defun check-for-circularity (object &optional assign)
184  (cond ((null *print-circle*)
185   ;; Don't bother, nobody cares.
186   nil)
187  ((null *circularity-hash-table*)
188         (values nil :initiate))
189  ((null *circularity-counter*)
190   (ecase (gethash object *circularity-hash-table*)
191     ((nil)
192      ;; first encounter
193      (setf (gethash object *circularity-hash-table*) t)
194      ;; We need to keep looking.
195      nil)
196     ((t)
197      ;; second encounter
198      (setf (gethash object *circularity-hash-table*) 0)
199      ;; It's a circular reference.
200      t)
201     (0
202      ;; It's a circular reference.
203      t)))
204  (t
205   (let ((value (gethash object *circularity-hash-table*)))
206     (case value
207       ((nil t)
208        ;; If NIL, we found an object that wasn't there the
209        ;; first time around. If T, this object appears exactly
210        ;; once. Either way, just print the thing without any
211        ;; special processing. Note: you might argue that
212        ;; finding a new object means that something is broken,
213        ;; but this can happen. If someone uses the ~@<...~:>
214        ;; format directive, it conses a new list each time
215        ;; though format (i.e. the &REST list), so we will have
216        ;; different cdrs.
217        nil)
218       (0
219        (if assign
220      (let ((value (incf *circularity-counter*)))
221        ;; first occurrence of this object: Set the counter.
222        (setf (gethash object *circularity-hash-table*) value)
223        value)
224      t))
225       (t
226        ;; second or later occurrence
227        (- value)))))))
228
229;;; Handle the results of CHECK-FOR-CIRCULARITY. If this returns T then
230;;; you should go ahead and print the object. If it returns NIL, then
231;;; you should blow it off.
232(defun handle-circularity (marker stream)
233  (case marker
234    (:initiate
235     ;; Someone forgot to initiate circularity detection.
236     (let ((*print-circle* nil))
237       (error "trying to use CHECK-FOR-CIRCULARITY when ~
238       circularity checking isn't initiated")))
239    ((t)
240     ;; It's a second (or later) reference to the object while we are
241     ;; just looking. So don't bother groveling it again.
242     nil)
243    (t
244;;      (write-char #\# stream)
245;;      (let ((*print-base* 10)
246;;            (*print-radix* nil))
247       (cond ((minusp marker)
248;;        (output-integer (- marker) stream)
249;;        (write-char #\# stream)
250              (print-reference marker stream)
251        nil)
252       (t
253;;        (output-integer marker stream)
254;;        (write-char #\= stream)
255              (print-label marker stream)
256        t)))))
257
258(defun print-label (marker stream)
259  (write-char #\# stream)
260  (let ((*print-base* 10)
261        (*print-radix* nil))
262    (output-integer marker stream))
263  (write-char #\= stream))
264
265(defun print-reference (marker stream)
266  (write-char #\# stream)
267  (let ((*print-base* 10)
268        (*print-radix* nil))
269    (output-integer (- marker) stream))
270  (write-char #\# stream))
271
272;;;; OUTPUT-OBJECT -- the main entry point
273
274;; Objects whose print representation identifies them EQLly don't need to be
275;; checked for circularity.
276(defun uniquely-identified-by-print-p (x)
277  (or (numberp x)
278      (characterp x)
279      (and (symbolp x)
280     (symbol-package x))))
281
282(defun %print-object (object stream)
283  (if *print-pretty*
284      (xp::output-pretty-object object stream)
285      (output-ugly-object object stream)))
286
287(defun %check-object (object stream)
288  (multiple-value-bind (marker initiate)
289      (check-for-circularity object t)
290    (if (eq initiate :initiate)
291        ;; Initialize circularity detection.
292        (let ((*circularity-hash-table* (make-hash-table :test 'eq)))
293          (%check-object object (make-broadcast-stream))
294          (let ((*circularity-counter* 0))
295            (%check-object object stream)))
296        ;; Otherwise...
297        (if marker
298            (when (handle-circularity marker stream)
299              (%print-object object stream))
300            (%print-object object stream)))))
301
302;;; Output OBJECT to STREAM observing all printer control variables.
303(defun output-object (object stream)
304  (cond ((or (not *print-circle*)
305             (uniquely-identified-by-print-p object))
306         (%print-object object stream))
307        ;; If we have already started circularity detection, this object might
308        ;; be a shared reference. If we have not, then if it is a compound
309        ;; object, it might contain a circular reference to itself or multiple
310        ;; shared references.
311        ((or *circularity-hash-table*
312             (compound-object-p object))
313         (%check-object object stream))
314        (t
315         (%print-object object stream)))
316  object)
317
318(provide "PRINT")
Note: See TracBrowser for help on using the repository browser.