Skip to content
Snippets Groups Projects
Forked from cmucl / cmucl
7412 commits behind the upstream repository.
env.lisp 13.18 KiB
;;;-*-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)))))

(redefine-function 'sys::arglist 'pcl-arglist)

)


;;;
;;;
;;;

(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)))

(defmethod describe-object (object stream)
  #-cmu
    (cond ((or #+kcl (packagep object))
	   (describe-package object stream))
	  (t
	   (funcall (original-definition 'describe) object)))
  #+cmu
  (describe object stream))

#-cmu
(redefine-function 'describe 'pcl-describe)

)

(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 ()))
    (flet ((adjust-slot-name-length (name)
	     (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))))
      ;; Figure out a good width for the slot-name column.
      (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)

      (when instance-slotds
	(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)))))

      (when class-slotds
	(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))))
      (values))))

(defmethod slots-to-inspect ((class slot-class) (object slot-object))
  (class-slots class))

(defvar *describe-metaobjects-as-objects-p* nil)

(defmethod describe-object ((fun standard-generic-function) stream)
  (format stream "~A is a generic function.~%" fun)
  (format stream "Its arguments are:~%  ~S~%"
          (generic-function-pretty-arglist fun))
  (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.~%"
	  class (pretty-class (class-of class)))
      (let ((name (class-name class)))
	(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).~%")))
      (ft "The direct superclasses are: ~:S, and the direct~%~
           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))
  (format stream "~&Its rehash-threshold is ~d."
	  (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)))

(defvar *traced-methods* ())

(defun trace-method (spec &rest options)
  #+copy-&rest-arg (setq options (copy-list options))
  (multiple-value-bind (gf omethod name)
      (parse-method-or-spec spec)
    (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)))

(defun untrace-method (&optional spec)  
  (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)
  (eval `(untrace ,name))
  (setf (symbol-function name) ofunction)
  (eval `(trace ,name ,@options))
  (symbol-function name))




;(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*)

#+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))