1;;;; some basic PRINT-OBJECT functionality
2
3;;;; This software is part of the SBCL system. See the README file for
4;;;; more information.
5
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.
11
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.
27
28(in-package "SB-PCL")
29
30;;;; the PRINT-OBJECT generic function
31
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(/show0 "about to replace placeholder PRINT-OBJECT with DEFGENERIC")
37(let (;; (If we don't suppress /SHOW printing while the printer is
38      ;; crippled here, it becomes really easy to crash the bootstrap
39      ;; sequence by adding /SHOW statements e.g. to the compiler,
40      ;; which kinda defeats the purpose of /SHOW being a harmless
41      ;; tracing-style statement.)
42      #+sb-show (*/show* nil)
43      ;; (another workaround for the problem of debugging while the
44      ;; printer is disabled here)
45      ;; FIXME: the way to do this is bind print-pprint-dispatch
46      ;; to an "emergency fallback" table. Give it sane entries for
47      ;; CONDITION, STRUCTURE-OBJECT, INSTANCE, and T.
48      ;; Bind *print-pretty* to T for the duration of these forms,
49      ;; and then we no longer need this extra state variable.
50      (sb-impl::*print-object-is-disabled-p* t))
51  (fmakunbound 'print-object)
52  (defgeneric print-object (object stream))
53  (defmethod print-object ((x t) stream)
54    (if *print-pretty*
55        (pprint-logical-block (stream nil)
56          (print-unreadable-object (x stream :type t :identity t)))
57        (print-unreadable-object (x stream :type t :identity t)))))
58(/show0 "done replacing placeholder PRINT-OBJECT with DEFGENERIC")
59
60;;;; a hook called by the printer to take care of dispatching to PRINT-OBJECT
61;;;; for appropriate FUNCALLABLE-INSTANCE objects
62
63;;; Now that CLOS is working, we can replace our old temporary placeholder code
64;;; for writing funcallable instances with permanent code:
65(fmakunbound 'sb-impl::printed-as-funcallable-standard-class)
66(defun sb-impl::printed-as-funcallable-standard-class (object stream)
67  (when (funcallable-standard-class-p (class-of object))
68    (print-object object stream)
69    t))
70
71;;;; PRINT-OBJECT methods for objects from PCL classes
72;;;;
73
74(defmethod print-object ((method standard-method) stream)
75  (if (slot-boundp method '%generic-function)
76      (print-unreadable-object (method stream :type t :identity t)
77        (let ((generic-function (method-generic-function method))
78              (*print-length* 50))
79          (format stream "~:[~*~;~/sb-impl::print-symbol-with-prefix/ ~]~{~S ~}~:S"
80                  generic-function
81                  (and generic-function
82                       (generic-function-name generic-function))
83                  (method-qualifiers method)
84                  (if generic-function
85                      (unparse-specializers generic-function (method-specializers method))
86                      (method-specializers method)))))
87      (call-next-method)))
88
89(defmethod print-object ((method standard-accessor-method) stream)
90  (if (slot-boundp method '%generic-function)
91      (print-unreadable-object (method stream :type t :identity t)
92        (let ((generic-function (method-generic-function method)))
93          (format stream "~/sb-impl::print-symbol-with-prefix/, slot:~S, ~:S"
94                  (and generic-function
95                       (generic-function-name generic-function))
96                  (accessor-method-slot-name method)
97                  (if generic-function
98                      (unparse-specializers generic-function (method-specializers method))
99                      (method-specializers method)))))
100      (call-next-method)))
101
102(defmethod print-object ((mc standard-method-combination) stream)
103  (print-unreadable-object (mc stream :type t :identity t)
104    (format stream "~S ~:S"
105            (slot-value-for-printing mc 'type-name)
106            (slot-value-for-printing mc 'options))))
107
108(defun named-object-print-function (instance stream
109                                    &optional (properly-named-p t)
110                                              (extra nil extra-p))
111  (cond ((slot-boundp instance 'name) ; case (1): named
112         (let ((name (slot-value instance 'name)))
113           (print-unreadable-object
114               (instance stream :type t :identity (not properly-named-p))
115             (format stream "~/sb-impl::print-symbol-with-prefix/~:[~:; ~:S~]"
116                     name extra-p extra))))
117        ((not extra-p) ; case (2): empty body to avoid an extra space
118         (print-unreadable-object (instance stream :type t :identity t)))
119        (t ; case (3). no name, but extra data - show #<unbound slot> and data
120         (print-unreadable-object (instance stream :type t :identity t)
121           (format stream "#<unbound slot> ~:S" extra)))))
122
123(defmethod print-object ((class class) stream)
124  ;; Use a similar concept as in OUTPUT-FUN.
125  (if (slot-boundp class 'name)
126      (let* ((name (class-name class))
127             (proper-p (and (symbolp name) (eq (find-class name nil) class))))
128        (print-unreadable-object (class stream :type t :identity (not proper-p))
129          (print-symbol-with-prefix stream name)))
130      ;; "#<CLASS #<unbound slot> {122D1141}>" is ugly. Don't show that.
131      (print-unreadable-object (class stream :type t :identity t))))
132
133(defmethod print-object ((slotd slot-definition) stream)
134  (named-object-print-function slotd stream))
135
136(defmethod print-object ((generic-function standard-generic-function) stream)
137  (multiple-value-call 'named-object-print-function
138    generic-function
139    stream
140    (and (slot-boundp generic-function 'name)
141         (let ((name (slot-value generic-function 'name)))
142           (and (legal-fun-name-p name)
143                (fboundp name)
144                (eq (fdefinition name) generic-function))))
145    (if (slot-boundp generic-function 'methods)
146        (list (length (generic-function-methods generic-function)))
147        (values))))
148
149(defmethod print-object ((cache cache) stream)
150  (print-unreadable-object (cache stream :type t :identity t)
151    (multiple-value-bind (lines-used lines-total max-depth depth-limit)
152        (cache-statistics cache)
153      (format stream
154              "~D key~P, ~:[no value~;value~], ~D/~D lines, depth ~D/~D"
155              (cache-key-count cache)
156              (cache-key-count cache)
157              (cache-value cache)
158              lines-used
159              lines-total
160              max-depth
161              depth-limit))))
162
163(defmethod print-object ((dfun-info dfun-info) stream)
164  (declare (type stream stream))
165  (print-unreadable-object (dfun-info stream :type t :identity t)))
166
167(defmethod print-object ((ctor ctor) stream)
168  (print-unreadable-object (ctor stream :type t)
169    (format stream "~S ~:S" (ctor-class-or-name ctor) (ctor-initargs ctor)))
170  ctor)
171
172(defmethod print-object ((obj class-precedence-description) stream)
173  (print-unreadable-object (obj stream :type t)
174    (format stream "~D" (cpd-count obj))))
175
176(defmethod print-object ((self eql-specializer) stream)
177  (let ((have-obj (slot-boundp self 'object)))
178    (print-unreadable-object (self stream :type t :identity (not have-obj))
179      (when have-obj
180        (write (slot-value self 'object) :stream stream)))))
181
182sb-c::
183(defmethod print-object ((self policy) stream)
184  (if *print-readably*
185      (call-next-method)
186      (print-unreadable-object (self stream :type t)
187        (write (policy-to-decl-spec self) :stream stream))))
188
189(!incorporate-cross-compiled-methods 'print-object :except '(t condition))
190
191;;; Print-object methods on subtypes of CONDITION can't be cross-compiled
192;;; until CLOS is fully working. Compile them now.
193#.`(progn
194     ,@(mapcar (lambda (args)
195                 `(setf (slot-value (defmethod ,@(cdr args)) 'source)
196                        ,(car args)))
197               *!delayed-defmethod-args*))
198
199;;; Ordinary DEFMETHOD should be used from here on out.
200;;; This variable actually has some semantics to being unbound.
201;;; FIXME: see if we can eliminate the associated hack in 'methods.lisp'
202(makunbound '*!delayed-defmethod-args*)
203