0.6.12.24:
[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 (let (;; (If we don't suppress /SHOW printing while the printer is
37       ;; crippled here, it becomes really easy to crash the bootstrap
38       ;; sequence by adding /SHOW statements e.g. to the compiler,
39       ;; which kinda defeats the purpose of /SHOW being a harmless
40       ;; tracing-style statement.)
41       #+sb-show (*/show* nil))
42   (fmakunbound 'print-object)
43   (defgeneric print-object (object stream))
44   (defmethod print-object ((x t) stream)
45     (print-unreadable-object (x stream :type t :identity t))))
46 \f
47 ;;;; a hook called by the printer to take care of dispatching to PRINT-OBJECT
48 ;;;; for appropriate FUNCALLABLE-INSTANCE objects
49
50 ;;; Now that CLOS is working, we can replace our old temporary placeholder code
51 ;;; for writing funcallable instances with permanent code:
52 (defun sb-impl::printed-as-funcallable-standard-class (object stream)
53   (when (funcallable-standard-class-p (class-of object))
54     (print-object object stream)
55     t))
56 \f
57 ;;;; PRINT-OBJECT methods for objects from PCL classes
58 ;;;;
59 ;;;; FIXME: Perhaps these should be moved back alongside the definitions of
60 ;;;; the classes they print. (Bootstrapping problems could be avoided by
61 ;;;; using DEF!METHOD to do this.)
62
63 (defmethod print-object ((method standard-method) stream)
64   (print-unreadable-object (method stream :type t :identity t)
65     (if (slot-boundp method 'generic-function)
66         (let ((generic-function (method-generic-function method)))
67           (format stream "~S ~{~S ~}~:S"
68                   (and generic-function
69                        (generic-function-name generic-function))
70                   (method-qualifiers method)
71                   (unparse-specializers method)))
72         ;; FIXME: Why do we do CALL-NEXT-METHOD in this method (and
73         ;; in the PRINT-OBJECT STANDARD-ACCESSOR-METHOD method too)?
74         (call-next-method))))
75
76 (defmethod print-object ((method standard-accessor-method) stream)
77   (print-unreadable-object (method stream :type t :identity t)
78     (if (slot-boundp method 'generic-function)
79         (let ((generic-function (method-generic-function method)))
80           (format stream "~S, slot:~S, ~:S"
81                   (and generic-function
82                        (generic-function-name generic-function))
83                   (accessor-method-slot-name method)
84                   (unparse-specializers method)))
85         (call-next-method))))
86
87 (defmethod print-object ((mc standard-method-combination) stream)
88   (print-unreadable-object (mc stream :type t :identity t)
89     (format stream
90             "~S ~S"
91             (slot-value-or-default mc 'type)
92             (slot-value-or-default mc 'options))))
93
94 (defun named-object-print-function (instance stream
95                                     &optional (extra nil extra-p))
96   (print-unreadable-object (instance stream :type t)
97     (if extra-p                                 
98         (format stream
99                 "~S ~:S"
100                 (slot-value-or-default instance 'name)
101                 extra)
102         (format stream
103                 "~S"
104                 (slot-value-or-default instance 'name)))))
105
106 (defmethod print-object ((class class) stream)
107   (named-object-print-function class stream))
108
109 (defmethod print-object ((slotd slot-definition) stream)
110   (named-object-print-function slotd stream))
111
112 (defmethod print-object ((generic-function generic-function) stream)
113   (named-object-print-function
114     generic-function
115     stream
116     (if (slot-boundp generic-function 'methods)
117         (list (length (generic-function-methods generic-function)))
118         "?")))
119
120 (defmethod print-object ((constructor constructor) stream)
121   (print-unreadable-object (constructor stream :type t :identity t)
122     (format stream
123             "~S (~S)"
124             (slot-value-or-default constructor 'name)
125             (slot-value-or-default constructor 'code-type))))
126
127 (defmethod print-object ((cache cache) stream)
128   (print-unreadable-object (cache stream :type t :identity t)
129     (format stream
130             "~D ~S ~D"
131             (cache-nkeys cache)
132             (cache-valuep cache)
133             (cache-nlines cache))))
134
135 (defmethod print-object ((wrapper wrapper) stream)
136   (print-unreadable-object (wrapper stream :type t :identity t)
137     (prin1 (wrapper-class wrapper) stream)))
138
139 (defmethod print-object ((dfun-info dfun-info) stream)
140   (declare (type stream stream))
141   (print-unreadable-object (dfun-info stream :type t :identity t)))