;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987 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 Artifical Intelligence Systems
;;;   2400 Hanover St.
;;;   Palo Alto, CA 94303
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
;;; Non-Bootstrap stuff
;;;

(in-package 'pcl)

(defclass forward-referenced-class (class) ())

(defmethod check-super-metaclass-compatibility ((c class)
						(f forward-referenced-class))
  (declare (ignore c f))
  't)

(defmethod class-for-redefinition ((existing-class forward-referenced-class)
				   (proto-class class)
				   name
				   supers
				   slots
				   options)
  (declare (ignore name supers slots options))
  (change-class existing-class (class-of proto-class))
  existing-class)

(defclass obsolete-class (class) ())


(defmethod slot-value-using-class ((class obsolete-class)
				   object
				   slot-name
				   &optional dont-call-slot-missing-p
					     default)
  (change-class object
		(cadr (slot-value class 'class-precedence-list)))
  (slot-value-using-class
    (class-of object) object slot-name dont-call-slot-missing-p default))



;;;
;;;
;;;

(defclass built-in-class (class) ())

(defmethod inform-type-system-about-class ((class built-in-class) name)
  (declare (ignore class name)))

(defmethod allocate-instance ((class built-in-class))
  (error
    "Attempt to make an instance of the built-in class ~S.~%~
     It is not possible to make instance of built-in classes with ~
     allocate-instance."
    class))

(defmethod check-super-metaclass-compatibility ((bic built-in-class)
						(new-super class))
  (or (eq new-super (class-named 't))
      (error "~S cannot have ~S as a super.~%~
              The only meta-class CLASS class that a built-in class can~%~
              have as a super is the class T."
	     bic new-super)))


(defmethod check-super-metaclass-compatibility ((class built-in-class)
						(new-super built-in-class))
  (declare (ignore class new-super))
  't)

(defmethod check-super-metaclass-compatibility
	   ((built-in built-in-class)
	    (new-super forward-referenced-class))
  (declare (ignore built-in new-super))
  't)


;;;
;;;
;;;
(defvar *built-in-class-lattice* ())

(defmacro define-built-in-classes (classes-and-supers &optional reset-p)
  `(eval-when (eval load)
     (when ,reset-p (setq *built-in-class-lattice* ()))
     (dolist (bic ,classes-and-supers)
       (pushnew bic *built-in-class-lattice* :test #'equal))     
     (define-built-in-classes-1)
     (setf (symbol-function 'built-in-class-of)
	   #'(lambda (x)
	       (declare (notinline built-in-class-of))
	       (compile 'built-in-class-of (make-built-in-class-of))
	       (built-in-class-of x)))))

(defun define-built-in-classes-1 ()
  ;; First make sure that all the supers listed in *built-in-class-lattice*
  ;; are themselves defined by *built-in-class-lattice*.  This is just to
  ;; check for typos and other sorts of brainos.
  ;; 
  ;; At the same time make sure the subtype relationship specified here in
  ;; *built-in-class-lattice* agrees with the subtype relationship in this
  ;; Lisp.
  (dolist (e *built-in-class-lattice*)
    (dolist (super (cadr e))
;      (unless (and (eq (subtypep (car e) super) 't)	;*** Lame, should
;		   (eq (subtypep super (car e)) 'nil))	;*** check supers.
;	(warn "*built-in-class-lattice* and this Lisp may disagree about~%~
;               the type relationship between ~S and ~S."
;	       (car e) super))
      (unless (or (eq super 't)
		  (assq super *built-in-class-lattice*))
	(error "In *built-in-class-lattice*: ~S has ~S as a super,~%~
                but ~S is not itself a class in *built-in-class-lattice*."
	       (car e) super super))))

  ;; Now use add-named-class to define the built-in class as specified.
  ;; 
  (let ((proto (class-prototype (class-named 'built-in-class))))
    (dolist (e *built-in-class-lattice*)
      (add-named-class proto (car e) (cadr e) () ())))
  )

(defun make-built-in-class-tree ()
  (let ((tree (list 't)))
    (labels ((insert-subs (node type)
	       (dolist (e *built-in-class-lattice*)
		 (let ((e-type (car e))
		       (e-supers (cadr e)))
		   (when (and (memq type e-supers)
			      (not (member e-type (cdr node) :key #'car)))
		     (let ((new-node (list e-type)))
		       (push new-node (cdr node))
		       (insert-subs new-node e-type)))))))
      (insert-subs tree 't)
      tree)))


(defun make-built-in-class-of ()  
  `(lambda (x) ,(make-built-in-class-of-1 (make-built-in-class-tree) 'x)))

(defun make-built-in-class-of-1 (tree var)
  `(and (typep ,var ',(car tree))
	(or ,@(mapcar #'(lambda (x) (make-built-in-class-of-1 x var))
		      (cdr tree))
	    ,(class-constant-form (class-named (car tree)))
	    )))


(define-built-in-classes  '((array             (t))
			    (bit-vector        (vector))
			    (character         (t))
;     	                    (compiled-function (t))
			    (complex           (number))
			    (cons              (list))
			    (float             (number))
			    (integer           (rational))
			    (list              (sequence))
;	                    (nil               ())            ;*** fix this
			    (null              (list symbol))
			    (number            (t))
			    (ratio             (rational))
			    (rational          (number))
			    (sequence          (t))
			    (string            (vector))
			    (symbol            (t))
			    (vector            (array sequence))))


;;;
;;;
;;;
(defmethod describe-class (class-or-class-name
			  &optional (stream *standard-output*))
  (flet ((pretty-class (class) (or (class-name class) class)))
    (if (symbolp class-or-class-name)
	(describe-class (class-named class-or-class-name) stream)
	(let ((class class-or-class-name))
	  (format stream
		  "~&The class ~S is an instance of class ~S."
		  class
		  (class-of class))
	  (format stream "~&Name:~23T~S~%~
			    Class-Precedence-List:~23T~S~%~
                            Local-Supers:~23T~S~%~
                            Direct-Subclasses:~23T~S"
		  (class-name class)
		  (mapcar #'pretty-class (class-class-precedence-list class))
		  (mapcar #'pretty-class (class-local-supers class))
		  (mapcar #'pretty-class (class-direct-subclasses class)))
	  class))))

(defun describe-instance (object &optional (stream t))
  (let* ((class (class-of object))
         (instance-slots (class-instance-slots class))
         (non-instance-slots (class-non-instance-slots class))
         (dynamic-slots (iwmc-class-dynamic-slots object))
	 (max-slot-name-length 0))
    (macrolet ((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.
      (iterate ((slotd in instance-slots))
	(adjust-slot-name-length (slotd-name slotd)))      
      (iterate ((slotd in non-instance-slots))
	(adjust-slot-name-length (slotd-name slotd)))
      (iterate ((name in dynamic-slots by cddr))
	(adjust-slot-name-length name))
      (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 are allocated in the instance ~
                         (:INSTANCE allocation):")
      (iterate ((slotd in instance-slots))
	(let ((name (slotd-name slotd)))
	  (describe-slot name (slot-value object name))))
      (when (or dynamic-slots
		(iterate ((slotd in non-instance-slots))
		  (when (neq (slotd-allocation slotd) :dynamic) (return t))))
	(format stream
		"~%The following slots have special allocations as shown:")
	(iterate ((slotd in non-instance-slots))
	  (unless (eq (slotd-allocation slotd) :dynamic)
	    (describe-slot (slotd-name slotd)
			   (slot-value object (slotd-name slotd))
			   (slotd-allocation slotd))))
	(iterate ((name in dynamic-slots by cddr)
		  (val in (cdr dynamic-slots) by cddr))
	  (describe-slot name val :dynamic)))))
  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.
;;;

(defvar *traced-methods* ())

(defun trace-method (spec)

  (multiple-value-bind (gf method name)
      (parse-method-or-spec spec)
    (put-slot-always method 'untrace (list name (method-function method)))
    (push method *traced-methods*)
    (trace-method-internal gf method name)
    method))

(defun untrace-method (&optional spec)  
  (flet ((untrace-it (m)
	   (let ((untrace (and (slot-exists-p m 'untrace)
			       (slot-value m 'untrace))))
	     (if untrace
		 (progn
		   (eval `(untrace ,(car untrace)))		   
		   (setf (method-function m) (cadr untrace))
		   (remove-dynamic-slot m 'untrace))
		 (error "~S is not a traced method?" m)))))
    (cond ((not (null spec))
	   (multiple-value-bind (gf method)
	       (parse-method-or-spec spec)
	     (when (method-generic-function method)
	       (untrace-it method)
	       (setq *traced-methods* (delete method *traced-methods*))
	       (list *traced-methods*))))
	  (t
	   (dolist (m *traced-methods*)
	     (untrace-it m))
	   (prog1 *traced-methods*
		  (setq *traced-methods* ()))))))

(defun trace-method-internal (gf method name)
  (let ((function (method-function method)))
    (eval `(untrace ,name))
    (setf (symbol-function name) function)
    (eval `(trace ,name))
    (setf (method-function method) (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)
  (declare (arglist name {method-qualifier}* specializers))
  (multiple-value-bind (gf method)
      (parse-method-or-spec args)
    (remove-method gf method)
    method))

(defmacro undefmethod-setf (&rest args)
  (declare (arglist name {method-qualifier}* specializers setf-specializers))
  (multiple-value-bind (name qualifiers specls setf-specls)
      (parse-defmethod args t)
    (multiple-value-bind (gf method)
	(parse-method-or-spec `((setf ,name)
				,@qualifiers
				(,@specls ,@setf-specls)))
      (remove-method gf method)
      method)))