Don't go through fdefn when referencing #'known-functions.
[sbcl.git] / src / pcl / print-object.lisp
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 \f
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       (sb-impl::*print-object-is-disabled-p* t))
46   (fmakunbound 'print-object)
47   (defgeneric print-object (object stream))
48   (defmethod print-object ((x t) stream)
49     (if *print-pretty*
50         (pprint-logical-block (stream nil)
51           (print-unreadable-object (x stream :type t :identity t)))
52         (print-unreadable-object (x stream :type t :identity t)))))
53 (/show0 "done replacing placeholder PRINT-OBJECT with DEFGENERIC")
54 \f
55 ;;;; a hook called by the printer to take care of dispatching to PRINT-OBJECT
56 ;;;; for appropriate FUNCALLABLE-INSTANCE objects
57
58 ;;; Now that CLOS is working, we can replace our old temporary placeholder code
59 ;;; for writing funcallable instances with permanent code:
60 (defun sb-impl::printed-as-funcallable-standard-class (object stream)
61   (when (funcallable-standard-class-p (class-of object))
62     (print-object object stream)
63     t))
64 \f
65 ;;;; PRINT-OBJECT methods for objects from PCL classes
66 ;;;;
67 ;;;; FIXME: Perhaps these should be moved back alongside the definitions of
68 ;;;; the classes they print. (Bootstrapping problems could be avoided by
69 ;;;; using DEF!METHOD to do this.)
70
71 (defmethod print-object ((method standard-method) stream)
72   (print-unreadable-object (method stream :type t :identity t)
73     (if (slot-boundp method '%generic-function)
74         (let ((generic-function (method-generic-function method)))
75           (format stream "~S ~{~S ~}~:S"
76                   (and generic-function
77                        (generic-function-name generic-function))
78                   (method-qualifiers method)
79                   (if generic-function
80                       (unparse-specializers generic-function (method-specializers method))
81                       (method-specializers method))))
82         ;; FIXME: Why do we do CALL-NEXT-METHOD in this method (and
83         ;; in the PRINT-OBJECT STANDARD-ACCESSOR-METHOD method too)?
84         (call-next-method))))
85
86 (defmethod print-object ((method standard-accessor-method) stream)
87   (print-unreadable-object (method stream :type t :identity t)
88     (if (slot-boundp method '%generic-function)
89         (let ((generic-function (method-generic-function method)))
90           (format stream "~S, slot:~S, ~:S"
91                   (and generic-function
92                        (generic-function-name generic-function))
93                   (accessor-method-slot-name method)
94                   (if generic-function
95                       (unparse-specializers generic-function (method-specializers method))
96                       (method-specializers method))))
97         (call-next-method))))
98
99 (defmethod print-object ((mc standard-method-combination) stream)
100   (print-unreadable-object (mc stream :type t :identity t)
101     (format stream
102             "~S ~S"
103             (slot-value-or-default mc 'type-name)
104             (slot-value-or-default mc 'options))))
105
106 (defun named-object-print-function (instance stream
107                                     &optional (extra nil extra-p))
108   (let ((name (slot-value-or-default instance 'name)))
109     (print-unreadable-object (instance stream :type t :identity (not name))
110       (if extra-p
111           (format stream "~S ~:S" name extra)
112           (format stream "~S" name)))))
113
114 (defmethod print-object ((class class) stream)
115   (named-object-print-function class stream))
116
117 (defmethod print-object ((slotd slot-definition) stream)
118   (named-object-print-function slotd stream))
119
120 (defmethod print-object ((generic-function standard-generic-function) stream)
121   (named-object-print-function
122     generic-function
123     stream
124     (if (slot-boundp generic-function 'methods)
125         (list (length (generic-function-methods generic-function)))
126         "?")))
127
128 (defmethod print-object ((cache cache) stream)
129   (print-unreadable-object (cache stream :type t :identity t)
130     (multiple-value-bind (lines-used lines-total max-depth depth-limit)
131         (cache-statistics cache)
132       (format stream
133               "~D key~P, ~:[no value~;value~], ~D/~D lines, depth ~D/~D"
134               (cache-key-count cache)
135               (cache-key-count cache)
136               (cache-value cache)
137               lines-used
138               lines-total
139               max-depth
140               depth-limit))))
141
142 (defmethod print-object ((wrapper wrapper) stream)
143   (print-unreadable-object (wrapper stream :type t :identity t)
144     (prin1 (wrapper-class wrapper) stream)))
145
146 (defmethod print-object ((dfun-info dfun-info) stream)
147   (declare (type stream stream))
148   (print-unreadable-object (dfun-info stream :type t :identity t)))
149
150 (defmethod print-object ((ctor ctor) stream)
151   (print-unreadable-object (ctor stream :type t)
152     (format stream "~S ~:S" (ctor-class-or-name ctor) (ctor-initargs ctor)))
153   ctor)