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