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