X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fprint-object.lisp;h=7711dab7fd336028ec925f4e856645b5fa6c4f09;hb=HEAD;hp=5dd716256bc9da1825ba62e4c442d176a8c9debb;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/pcl/print-object.lisp b/src/pcl/print-object.lisp index 5dd7162..7711dab 100644 --- a/src/pcl/print-object.lisp +++ b/src/pcl/print-object.lisp @@ -29,20 +29,28 @@ ;;;; the PRINT-OBJECT generic function -;;; Blow away the old non-generic function placeholder which was used by the -;;; printer doing bootstrapping, and immediately replace it with some new -;;; printing logic, so that the Lisp printer stays crippled only for the -;;; shortest necessary time. +;;; Blow away the old non-generic function placeholder which was used +;;; by the printer doing bootstrapping, and immediately replace it +;;; with some new printing logic, so that the Lisp printer stays +;;; crippled only for the shortest necessary time. +(/show0 "about to replace placeholder PRINT-OBJECT with DEFGENERIC") (let (;; (If we don't suppress /SHOW printing while the printer is ;; crippled here, it becomes really easy to crash the bootstrap ;; sequence by adding /SHOW statements e.g. to the compiler, ;; which kinda defeats the purpose of /SHOW being a harmless ;; tracing-style statement.) - #+sb-show (sb-int:*/show* nil)) + #+sb-show (*/show* nil) + ;; (another workaround for the problem of debugging while the + ;; printer is disabled here) + (sb-impl::*print-object-is-disabled-p* t)) (fmakunbound 'print-object) (defgeneric print-object (object stream)) (defmethod print-object ((x t) stream) - (print-unreadable-object (x stream :type t :identity t)))) + (if *print-pretty* + (pprint-logical-block (stream nil) + (print-unreadable-object (x stream :type t :identity t))) + (print-unreadable-object (x stream :type t :identity t))))) +(/show0 "done replacing placeholder PRINT-OBJECT with DEFGENERIC") ;;;; a hook called by the printer to take care of dispatching to PRINT-OBJECT ;;;; for appropriate FUNCALLABLE-INSTANCE objects @@ -62,46 +70,46 @@ (defmethod print-object ((method standard-method) stream) (print-unreadable-object (method stream :type t :identity t) - (if (slot-boundp method 'generic-function) - (let ((generic-function (method-generic-function method))) - (format stream "~S ~{~S ~}~:S" - (and generic-function - (generic-function-name generic-function)) - (method-qualifiers method) - (unparse-specializers method))) - ;; FIXME: Why do we do CALL-NEXT-METHOD in this method (and - ;; in the PRINT-OBJECT STANDARD-ACCESSOR-METHOD method too)? - (call-next-method)))) + (if (slot-boundp method '%generic-function) + (let ((generic-function (method-generic-function method))) + (format stream "~S ~{~S ~}~:S" + (and generic-function + (generic-function-name generic-function)) + (method-qualifiers method) + (if generic-function + (unparse-specializers generic-function (method-specializers method)) + (method-specializers method)))) + ;; FIXME: Why do we do CALL-NEXT-METHOD in this method (and + ;; in the PRINT-OBJECT STANDARD-ACCESSOR-METHOD method too)? + (call-next-method)))) (defmethod print-object ((method standard-accessor-method) stream) (print-unreadable-object (method stream :type t :identity t) - (if (slot-boundp method 'generic-function) - (let ((generic-function (method-generic-function method))) - (format stream "~S, slot:~S, ~:S" - (and generic-function - (generic-function-name generic-function)) - (accessor-method-slot-name method) - (unparse-specializers method))) - (call-next-method)))) + (if (slot-boundp method '%generic-function) + (let ((generic-function (method-generic-function method))) + (format stream "~S, slot:~S, ~:S" + (and generic-function + (generic-function-name generic-function)) + (accessor-method-slot-name method) + (if generic-function + (unparse-specializers generic-function (method-specializers method)) + (method-specializers method)))) + (call-next-method)))) (defmethod print-object ((mc standard-method-combination) stream) (print-unreadable-object (mc stream :type t :identity t) (format stream - "~S ~S" - (slot-value-or-default mc 'type) - (slot-value-or-default mc 'options)))) + "~S ~S" + (slot-value-or-default mc 'type-name) + (slot-value-or-default mc 'options)))) (defun named-object-print-function (instance stream - &optional (extra nil extra-p)) - (print-unreadable-object (instance stream :type t) - (if extra-p - (format stream - "~S ~:S" - (slot-value-or-default instance 'name) - extra) - (format stream - "~S" - (slot-value-or-default instance 'name))))) + &optional (extra nil extra-p)) + (let ((name (slot-value-or-default instance 'name))) + (print-unreadable-object (instance stream :type t :identity (not name)) + (if extra-p + (format stream "~S ~:S" name extra) + (format stream "~S" name))))) (defmethod print-object ((class class) stream) (named-object-print-function class stream)) @@ -109,28 +117,27 @@ (defmethod print-object ((slotd slot-definition) stream) (named-object-print-function slotd stream)) -(defmethod print-object ((generic-function generic-function) stream) +(defmethod print-object ((generic-function standard-generic-function) stream) (named-object-print-function generic-function stream (if (slot-boundp generic-function 'methods) - (list (length (generic-function-methods generic-function))) - "?"))) - -(defmethod print-object ((constructor constructor) stream) - (print-unreadable-object (constructor stream :type t :identity t) - (format stream - "~S (~S)" - (slot-value-or-default constructor 'name) - (slot-value-or-default constructor 'code-type)))) + (list (length (generic-function-methods generic-function))) + "?"))) (defmethod print-object ((cache cache) stream) (print-unreadable-object (cache stream :type t :identity t) - (format stream - "~D ~S ~D" - (cache-nkeys cache) - (cache-valuep cache) - (cache-nlines cache)))) + (multiple-value-bind (lines-used lines-total max-depth depth-limit) + (cache-statistics cache) + (format stream + "~D key~P, ~:[no value~;value~], ~D/~D lines, depth ~D/~D" + (cache-key-count cache) + (cache-key-count cache) + (cache-value cache) + lines-used + lines-total + max-depth + depth-limit)))) (defmethod print-object ((wrapper wrapper) stream) (print-unreadable-object (wrapper stream :type t :identity t) @@ -139,3 +146,8 @@ (defmethod print-object ((dfun-info dfun-info) stream) (declare (type stream stream)) (print-unreadable-object (dfun-info stream :type t :identity t))) + +(defmethod print-object ((ctor ctor) stream) + (print-unreadable-object (ctor stream :type t) + (format stream "~S ~:S" (ctor-class-or-name ctor) (ctor-initargs ctor))) + ctor)