Skip some temp file creation in make-contrib
[sbcl.git] / src / pcl / print-object.lisp
blob26d78ac1dc46b8f8c168fdf68c468a4ede3d7ae8
1 ;;;; some basic PRINT-OBJECT functionality
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
6 ;;;; This software is derived from software originally released by Xerox
7 ;;;; Corporation. Copyright and release statements follow. Later modifications
8 ;;;; to the software are in the public domain and are provided with
9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
10 ;;;; information.
12 ;;;; Some of the text in this file was originally taken from various files of
13 ;;;; the PCL system from Xerox Corporation, which carried the following
14 ;;;; copyright information:
15 ;;;;
16 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
17 ;;;; All rights reserved.
18 ;;;;
19 ;;;; Use and copying of this software and preparation of derivative works based
20 ;;;; upon this software are permitted. Any distribution of this software or
21 ;;;; derivative works must comply with all applicable United States export
22 ;;;; control laws.
23 ;;;;
24 ;;;; This software is made available AS IS, and Xerox Corporation makes no
25 ;;;; warranty about the software, its performance or its conformity to any
26 ;;;; specification.
28 (in-package "SB-PCL")
30 ;;;; the PRINT-OBJECT generic function
32 ;;; Blow away the old non-generic function placeholder which was used
33 ;;; by the printer doing bootstrapping, and immediately replace it
34 ;;; with some new printing logic, so that the Lisp printer stays
35 ;;; crippled only for the shortest necessary time.
36 (unless (sb-impl::!c-runtime-noinform-p)
37 (write-string "; Removing placeholder PRINT-OBJECT ...")
38 (force-output))
39 (let ((*print-pretty* t)) ; use pretty printer dispatch table, not PRINT-OBJECT
40 (fmakunbound 'print-object)
41 (defgeneric print-object (object stream))
42 (!install-cross-compiled-methods 'print-object))
43 (unless (sb-impl::!c-runtime-noinform-p)
44 (write-string " done
45 "))
47 ;;;; PRINT-OBJECT methods for objects from PCL classes
48 ;;;;
50 (defmethod print-object ((object standard-object) stream)
51 (print-unreadable-object (object stream :type t :identity t)))
53 (defmethod print-object ((object funcallable-standard-object) stream)
54 (print-unreadable-object (object stream :type t :identity t)))
56 (defmethod print-object ((method standard-method) stream)
57 (if (slot-boundp method '%generic-function)
58 (print-unreadable-object (method stream :type t :identity t)
59 (let ((generic-function (method-generic-function method))
60 (*print-length* 50))
61 (format stream "~:[~*~;~/sb-ext:print-symbol-with-prefix/ ~]~{~S ~}~:S"
62 generic-function
63 (and generic-function
64 (generic-function-name generic-function))
65 (method-qualifiers method)
66 (if generic-function
67 (unparse-specializers generic-function (method-specializers method))
68 (method-specializers method)))))
69 (call-next-method)))
71 (defmethod print-object ((method standard-accessor-method) stream)
72 (if (slot-boundp method '%generic-function)
73 (print-unreadable-object (method stream :type t :identity t)
74 (let ((generic-function (method-generic-function method)))
75 (format stream "~/sb-ext:print-symbol-with-prefix/, slot:~S, ~:S"
76 (and generic-function
77 (generic-function-name generic-function))
78 (accessor-method-slot-name method)
79 (if generic-function
80 (unparse-specializers generic-function (method-specializers method))
81 (method-specializers method)))))
82 (call-next-method)))
84 (defmethod print-object ((mc standard-method-combination) stream)
85 (print-unreadable-object (mc stream :type t :identity t)
86 (format stream "~S ~:S"
87 (slot-value-for-printing mc 'type-name)
88 (slot-value-for-printing mc 'options))))
90 (defun named-object-print-function (instance stream
91 &optional (properly-named-p t)
92 (extra nil extra-p))
93 (cond ((slot-boundp instance 'name) ; case (1): named
94 (let ((name (slot-value instance 'name)))
95 (print-unreadable-object
96 (instance stream :type t :identity (not properly-named-p))
97 (format stream "~/sb-ext:print-symbol-with-prefix/~:[~:; ~:S~]"
98 name extra-p extra))))
99 ((not extra-p) ; case (2): empty body to avoid an extra space
100 (print-unreadable-object (instance stream :type t :identity t)))
101 (t ; case (3). no name, but extra data - show #<unbound slot> and data
102 (print-unreadable-object (instance stream :type t :identity t)
103 (format stream "#<unbound slot> ~:S" extra)))))
105 (defmethod print-object ((class class) stream)
106 ;; Use a similar concept as in OUTPUT-FUN.
107 (if (slot-boundp class 'name)
108 (let* ((name (class-name class))
109 (proper-p (and (symbolp name) (eq (find-class name nil) class))))
110 (print-unreadable-object (class stream :type t :identity (not proper-p))
111 (print-symbol-with-prefix stream name)))
112 ;; "#<CLASS #<unbound slot> {122D1141}>" is ugly. Don't show that.
113 (print-unreadable-object (class stream :type t :identity t))))
115 (defmethod print-object ((slotd slot-definition) stream)
116 (named-object-print-function slotd stream))
118 (defmethod print-object ((generic-function standard-generic-function) stream)
119 (multiple-value-call 'named-object-print-function
120 generic-function
121 stream
122 (and (slot-boundp generic-function 'name)
123 (let ((name (slot-value generic-function 'name)))
124 (and (legal-fun-name-p name)
125 (fboundp name)
126 (eq (fdefinition name) generic-function))))
127 (if (slot-boundp generic-function 'methods)
128 (list (length (generic-function-methods generic-function)))
129 (values))))
131 (defmethod print-object ((cache cache) stream)
132 (print-unreadable-object (cache stream :type t :identity t)
133 (multiple-value-bind (lines-used lines-total) (cache-statistics cache)
134 (format stream
135 "~D key~:P~:[~;, value~], ~D/~D lines~@[ (LF ~,,2F%)~], depth ~D/~D"
136 (cache-key-count cache)
137 (cache-value cache)
138 lines-used
139 lines-total
140 (when (plusp lines-total) (/ lines-used lines-total))
141 (cache-depth cache)
142 (cache-limit cache)))))
144 (defmethod print-object ((dfun-info dfun-info) stream)
145 (declare (type stream stream))
146 (print-unreadable-object (dfun-info stream :type t :identity t)))
148 (defmethod print-object ((ctor ctor) stream)
149 (print-unreadable-object (ctor stream :type t)
150 (format stream "~S ~:S" (ctor-class-or-name ctor) (ctor-initargs ctor)))
151 ctor)
153 (defmethod print-object ((obj class-precedence-description) stream)
154 (print-unreadable-object (obj stream :type t)
155 (format stream "~D" (cpd-count obj))))
157 (defmethod print-object ((self specializer-with-object) stream)
158 (if (and (slot-exists-p self 'object) (slot-boundp self 'object))
159 (print-unreadable-object (self stream :type t)
160 (write (slot-value self 'object) :stream stream))
161 (print-unreadable-object (self stream :type t :identity t))))
163 sb-c::
164 (defmethod print-object ((self policy) stream)
165 (if *print-readably*
166 (call-next-method)
167 (print-unreadable-object (self stream :type t)
168 (write (policy-to-decl-spec self) :stream stream))))
170 sb-kernel::(progn
171 (defmethod print-object ((condition type-error) stream)
172 (if (and *print-escape*
173 (slot-boundp condition 'expected-type)
174 (slot-boundp condition 'datum))
175 (flet ((maybe-string (thing)
176 (ignore-errors
177 (write-to-string thing :lines 1 :readably nil :array nil :pretty t))))
178 (let ((type (maybe-string (type-error-expected-type condition)))
179 (datum (maybe-string (type-error-datum condition))))
180 (if (and type datum)
181 (print-unreadable-object (condition stream :type t)
182 (format stream "~@<expected-type: ~A ~_datum: ~A~:@>"
183 type datum))
184 (call-next-method))))
185 (call-next-method)))
187 (defmethod print-object ((condition cell-error) stream)
188 (if (and *print-escape* (slot-boundp condition 'name))
189 (print-unreadable-object (condition stream :type t :identity t)
190 (princ (cell-error-name condition) stream))
191 (call-next-method)))
193 (defmethod print-object :around ((o reference-condition) s)
194 (call-next-method)
195 (unless (or *print-escape* *print-readably*)
196 (when (and *print-condition-references*
197 (reference-condition-references o))
198 (format s "~&See also:~%")
199 (pprint-logical-block (s nil :per-line-prefix " ")
200 (do* ((rs (reference-condition-references o) (cdr rs))
201 (r (car rs) (car rs)))
202 ((null rs))
203 (print-reference r s)
204 (unless (null (cdr rs))
205 (terpri s)))))))) ; end PROGN
207 ;;; Ordinary DEFMETHOD should be used from here on out.
208 ;;; This variable actually has some semantics to being unbound.
209 ;;; FIXME: see if we can eliminate the associated hack in 'methods.lisp'
210 (makunbound '*!delayed-defmethod-args*)