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

Last change on this file since 12218 was 12218, checked in by ehuelsmann, 11 years ago

Centralize package creation (in Lisp.java).

This moves the creation of the XP and FORMAT packages away from boot.lisp.

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