1 ;;;; some basic PRINT-OBJECT functionality
3 ;;;; This software is part of the SBCL system. See the README file for
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
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:
16 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
17 ;;;; All rights reserved.
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
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
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 (/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
)
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")
60 ;;;; a hook called by the printer to take care of dispatching to PRINT-OBJECT
61 ;;;; for appropriate FUNCALLABLE-INSTANCE objects
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
)
71 ;;;; PRINT-OBJECT methods for objects from PCL classes
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
))
79 (format stream
"~:[~*~;~/sb-impl::print-symbol-with-prefix/ ~]~{~S ~}~:S"
82 (generic-function-name generic-function
))
83 (method-qualifiers method
)
85 (unparse-specializers generic-function
(method-specializers method
))
86 (method-specializers method
)))))
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"
95 (generic-function-name generic-function
))
96 (accessor-method-slot-name method
)
98 (unparse-specializers generic-function
(method-specializers method
))
99 (method-specializers method
)))))
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
))))
108 (defun named-object-print-function (instance stream
109 &optional
(properly-named-p t
)
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
)))))
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
))))
133 (defmethod print-object ((slotd slot-definition
) stream
)
134 (named-object-print-function slotd stream
))
136 (defmethod print-object ((generic-function standard-generic-function
) stream
)
137 (multiple-value-call 'named-object-print-function
140 (and (slot-boundp generic-function
'name
)
141 (let ((name (slot-value generic-function
'name
)))
142 (and (legal-fun-name-p name
)
144 (eq (fdefinition name
) generic-function
))))
145 (if (slot-boundp generic-function
'methods
)
146 (list (length (generic-function-methods generic-function
)))
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
)
154 "~D key~P, ~:[no value~;value~], ~D/~D lines, depth ~D/~D"
155 (cache-key-count cache
)
156 (cache-key-count cache
)
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
)))
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
)))
172 (defmethod print-object ((obj class-precedence-description
) stream
)
173 (print-unreadable-object (obj stream
:type t
)
174 (format stream
"~D" (cpd-count obj
))))
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
))
180 (write (slot-value self
'object
) :stream stream
)))))
183 (defmethod print-object ((self policy
) stream
)
186 (print-unreadable-object (self stream
:type t
)
187 (write (policy-to-decl-spec self
) :stream stream
))))
189 (!incorporate-cross-compiled-methods
'print-object
:except
'(t condition
))
191 ;;; Print-object methods on subtypes of CONDITION can't be cross-compiled
192 ;;; until CLOS is fully working. Compile them now.
194 ,@(mapcar (lambda (args)
195 `(setf (slot-value (defmethod ,@(cdr args
)) 'source
)
197 *!delayed-defmethod-args
*))
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
*)