Newer
Older
;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
;;; All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted. Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;; CommonLoops Coordinator
;;; Xerox PARC
;;; 3333 Coyote Hill Rd.
;;; Palo Alto, CA 94304
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
;;; Basic environmental stuff.
;;;
(in-package :pcl)
#+Lucid
(progn
(defun pcl-arglist (function &rest other-args)
(let ((defn nil))
(cond ((and (fsc-instance-p function)
(generic-function-p function))
(generic-function-pretty-arglist function))
((and (symbolp function)
(fboundp function)
(setq defn (symbol-function function))
(fsc-instance-p defn)
(generic-function-p defn))
(generic-function-pretty-arglist defn))
(t (apply (original-definition 'sys::arglist)
function other-args)))))
)
;;;
;;;
;;;
(defgeneric describe-object (object stream))
#-Genera
(progn
(defun pcl-describe (object #+Lispm &optional #+Lispm no-complaints)
(let (#+Lispm (*describe-no-complaints* no-complaints))
#+Lispm (declare (special *describe-no-complaints*))
(describe-object object *standard-output*)
(values)))
(cond ((or #+kcl (packagep object))
(describe-package object stream))
(t
(funcall (original-definition 'describe) object)))
#+cmu
(describe object stream))
)
(defmethod describe-object ((object slot-object) stream)
(let* ((class (class-of object))
(slotds (slots-to-inspect class object))
(max-slot-name-length 0)
(instance-slotds ())
(class-slotds ())
(other-slotds ()))
(setq max-slot-name-length
(max max-slot-name-length
(length (the string (symbol-name name))))))
(describe-slot (name value &optional (allocation () alloc-p))
(if alloc-p
(format stream
"~% ~A ~S ~VT ~S"
name allocation (+ max-slot-name-length 7) value)
(format stream
"~% ~A~VT ~S"
name max-slot-name-length value))))
(dolist (slotd slotds)
(adjust-slot-name-length (slot-definition-name slotd))
(case (slot-definition-allocation slotd)
(:instance (push slotd instance-slotds))
(:class (push slotd class-slotds))
(otherwise (push slotd other-slotds))))
(setq max-slot-name-length (min (+ max-slot-name-length 3) 30))
(format stream "~%~S is an instance of class ~S:" object class)
(format stream "~% The following slots have :INSTANCE allocation:")
(dolist (slotd (nreverse instance-slotds))
(describe-slot (slot-definition-name slotd)
(slot-value-or-default object (slot-definition-name slotd)))))
(format stream "~% The following slots have :CLASS allocation:")
(dolist (slotd (nreverse class-slotds))
(describe-slot (slot-definition-name slotd)
(slot-value-or-default object (slot-definition-name slotd)))))
(when other-slotds
(format stream "~% The following slots have allocation as shown:")
(dolist (slotd (nreverse other-slotds))
(describe-slot (slot-definition-name slotd)
(slot-value-or-default object (slot-definition-name slotd))
(slot-definition-allocation slotd))))
(defmethod slots-to-inspect ((class slot-class) (object slot-object))
(class-slots class))
(defmethod describe-object ((fun standard-generic-function) stream)
(format stream "~A is a generic function.~%" fun)
(format stream "Its arguments are:~% ~S~%"
(format stream "Its methods are:")
(dolist (meth (generic-function-methods fun))
(format stream "~2% ~{~S ~}~:S =>~%"
(method-qualifiers meth)
(unparse-specializers meth))
(describe-object (or (method-fast-function meth)
(method-function meth))
stream))
(when *describe-metaobjects-as-objects-p*
(call-next-method)))
;;;
;;;
;;;
(defmethod describe-object ((class class) stream)
(flet ((pretty-class (c) (or (class-name c) c)))
(macrolet ((ft (string &rest args) `(format stream ,string ,@args)))
(ft "~&~S is a class, it is an instance of ~S.~%"
(if name
(if (eq class (find-class name nil))
(ft "Its proper name is ~S.~%" name)
(ft "Its name is ~S, but this is not a proper name.~%" name))
(ft "It has no name (the name is NIL).~%")))
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
subclasses are: ~:S. The class precedence list is:~%~S~%~
There are ~D methods specialized for this class."
(mapcar #'pretty-class (class-direct-superclasses class))
(mapcar #'pretty-class (class-direct-subclasses class))
(mapcar #'pretty-class (class-precedence-list class))
(length (specializer-direct-methods class)))))
(when *describe-metaobjects-as-objects-p*
(call-next-method)))
(defun describe-package (object stream)
(unless (packagep object) (setq object (find-package object)))
(format stream "~&~S is a ~S.~%" object (type-of object))
(let ((nick (package-nicknames object)))
(when nick
(format stream "You can also call it~@[ ~{~S~^, ~} or~] ~S.~%"
(butlast nick) (first (last nick)))))
(let* (#+cmu (internal (lisp::package-internal-symbols object))
(internal-count #+cmu (- (lisp::package-hashtable-size internal)
(lisp::package-hashtable-free internal))
#-cmu 0)
#+cmu (external (lisp::package-external-symbols object))
(external-count #+cmu (- (lisp::package-hashtable-size external)
(lisp::package-hashtable-free external))
#-cmu 0))
#-cmu (do-external-symbols (sym object)
(declare (ignore sym))
(incf external-count))
#-cmu (do-symbols (sym object)
(declare (ignore sym))
(incf internal-count))
#-cmu (decf internal-count external-count)
(format stream "It has ~D internal and ~D external symbols (~D total).~%"
internal-count external-count (+ internal-count external-count)))
(let ((used (package-use-list object)))
(when used
(format stream "It uses the packages ~{~S~^, ~}.~%"
(mapcar #'package-name used))))
(let ((users (package-used-by-list object)))
(when users
(format stream "It is used by the packages ~{~S~^, ~}.~%"
(mapcar #'package-name users)))))
#+cmu
(defmethod describe-object ((object package) stream)
(describe-package object stream))
#+cmu
(defmethod describe-object ((object hash-table) stream)
(format stream "~&~S is an ~a hash table."
object
#-cmu17 (lisp::hash-table-kind object)
#+cmu17 (lisp::hash-table-test object))
(format stream "~&Its size is ~d buckets."
(lisp::hash-table-size object))
(format stream "~&Its rehash-size is ~d."
(lisp::hash-table-rehash-size object))
(hash-table-rehash-threshold object))
(format stream "~&It currently holds ~d entries."
(lisp::hash-table-number-entries object)))
;;;
;;; trace-method and untrace-method accept method specs as arguments. A
;;; method-spec should be a list like:
;;; (<generic-function-spec> qualifiers* (specializers*))
;;; where <generic-function-spec> should be either a symbol or a list
;;; of (SETF <symbol>).
;;;
;;; For example, to trace the method defined by:
;;;
;;; (defmethod foo ((x spaceship)) 'ss)
;;;
;;; You should say:
;;;
;;; (trace-method '(foo (spaceship)))
;;;
;;; You can also provide a method object in the place of the method
;;; spec, in which case that method object will be traced.
;;;
;;; For untrace-method, if an argument is given, that method is untraced.
;;; If no argument is given, all traced methods are untraced.
;;;
(defclass traced-method (method)
((method :initarg :method)
(function :initarg :function
:reader method-function)
(generic-function :initform nil
:accessor method-generic-function)))
(defmethod method-lambda-list ((m traced-method))
(with-slots (method) m (method-lambda-list method)))
(defmethod method-specializers ((m traced-method))
(with-slots (method) m (method-specializers method)))
(defmethod method-qualifiers ((m traced-method))
(with-slots (method) m (method-qualifiers method)))
(defmethod accessor-method-slot-name ((m traced-method))
(with-slots (method) m (accessor-method-slot-name method)))
#+copy-&rest-arg (setq options (copy-list options))
(let* ((tfunction (trace-method-internal (method-function omethod)
name
options))
(tmethod (make-instance 'traced-method
:method omethod
:function tfunction)))
(remove-method gf omethod)
(add-method gf tmethod)
(pushnew tmethod *traced-methods*)
tmethod)))
(flet ((untrace-1 (m)
(let ((gf (method-generic-function m)))
(when gf
(remove-method gf m)
(add-method gf (slot-value m 'method))
(setq *traced-methods* (remove m *traced-methods*))))))
(if (not (null spec))
(multiple-value-bind (gf method)
(parse-method-or-spec spec)
(declare (ignore gf))
(if (memq method *traced-methods*)
(untrace-1 method)
(error "~S is not a traced method?" method)))
(dolist (m *traced-methods*) (untrace-1 m)))))
(defun trace-method-internal (ofunction name options)
;(defun compile-method (spec)
; (multiple-value-bind (gf method name)
; (parse-method-or-spec spec)
; (declare (ignore gf))
; (compile name (method-function method))
; (setf (method-function method) (symbol-function name))))
(defmacro undefmethod (&rest args)
#+(or (not :lucid) :lcl3.0)
(declare (arglist name {method-qualifier}* specializers))
`(undefmethod-1 ',args))
(defun undefmethod-1 (args)
(multiple-value-bind (gf method)
(parse-method-or-spec args)
(when (and gf method)
(remove-method gf method)
method)))
(pushnew :pcl *features*)
(pushnew :portable-commonloops *features*)
(pushnew :pcl-structures *features*)
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
#+cmu
(when (find-package "OLD-PCL")
(setf (symbol-function (find-symbol "PRINT-OBJECT" :old-pcl))
(symbol-function 'pcl::print-object)))
;;;; MAKE-LOAD-FORM
#+cmu17
(export '(cl::make-load-form cl::make-load-form-saving-slots) "CL")
#+cmu17
(progn
(defgeneric make-load-form (object &optional environment))
(defmethod make-load-form ((object structure-object) &optional environment)
(declare (ignore environment))
(kernel:make-structure-load-form object))
(defmethod make-load-form ((object wrapper) &optional env)
(declare (ignore env))
(let ((pname (kernel:class-proper-name (kernel:layout-class object))))
(unless pname
(error "Can't dump wrapper for anonymous class:~% ~S"
(kernel:layout-class object)))
`(kernel:class-layout (lisp:find-class ',pname))))
(defun make-load-form-saving-slots (object &key slot-names environment)
(declare (ignore environment))
(when slot-names
(warn ":SLOT-NAMES MAKE-LOAD-FORM option not implemented, dumping all ~
slots:~% ~S"
object))
:just-dump-it-normally))
;;; The following are hacks to deal with CMU CL having two different CLASS
;;; classes.
;;;
#+cmu17
(defun coerce-to-pcl-class (class)
(if (typep class 'lisp:class)
(or (kernel:class-pcl-class class)
(find-structure-class (lisp:class-name class)))
class))
#+cmu17
(progn
(defmethod make-instance ((class lisp:class) &rest stuff)
(apply #'make-instance (coerce-to-pcl-class class) stuff))
(defmethod change-class (instance (class lisp:class))
(apply #'change-class instance (coerce-to-pcl-class class))))
#+cmu17
(macrolet ((frob (&rest names)
`(progn
,@(mapcar #'(lambda (name)
`(defmethod ,name ((class lisp:class))
(funcall #',name
(coerce-to-pcl-class class))))
names))))
(frob
class-direct-slots
class-prototype
class-precedence-list
class-direct-default-initargs
class-direct-superclasses
compute-class-precedence-list
class-default-initargs class-finalized-p
class-direct-subclasses class-slots
make-instances-obsolete))