;;;-*-Mode:LISP; Package: PCL; 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.
;;; *************************************************************************
;;;

(in-package 'pcl)

#|

get rid of load-method-1 and friends, replace it with calls to add-method etc.

rename make-method

replace options with qualifiers everywhere

replace specifiers with specializers everywhere

method-class option of gf

hack-method-body option

expand-defmethod and expand-defmethod-setf  
  (have to make make-specializable'd too!!)



would like to be able to construct lexical environments as part of expand-defmethod-body and expand-defmethod-setf-body.

make-method --->> make-std-method

|#

  ;;   
;;;;;; Methods
  ;;

(eval-when (compile load eval)
  (mapcar #'eval *methods-defclass-forms*))

(defun method-p (x) (typep x 'standard-method))

(defmethod-setf method-function ((method standard-method)) (nv)
  (setf (slot-value method 'function) nv)
  (let ((gf (method-generic-function method)))
    (when gf
      (generic-function-changed gf method t))))

;;;
;;; This method has to be defined by hand!  Don't try to define it using
;;; :accessor or :reader.  It can't be an automatically generated reader
;;; method because that would break the way the special discriminator
;;; code which uses this feature works.
;;; 
(defmethod reader/writer-method-slot-name ((m standard-reader/writer-method))
  (slot-value--class m 'slot-name))


(defmethod print-object ((method standard-method) stream depth)
  (declare (ignore depth))
  (printing-random-thing (method stream)
    (let ((generic-function (method-generic-function method))
	  (class-name (capitalize-words (class-name (class-of method)))))
      (format stream "~A ~S ~:S"
	      class-name
	      (and generic-function (generic-function-name generic-function))
	      (unparse-specializers method)))))

(defmethod print-object ((generic-function standard-generic-function) stream depth)
  (named-object-print-function generic-function stream depth))

(defmethod print-object ((generic-function standard-generic-function)
			 stream
			 depth)
  (named-object-print-function
    generic-function
    stream
    depth
    (list (length (generic-function-methods generic-function)))))

(defun generic-function-p (x) (typep x 'standard-generic-function))

(defmethod remove-named-method (generic-function-name argument-specifiers
						      &optional extra)
  (let ((generic-function ())
	(method ()))
    (cond ((or (null (fboundp generic-function-name))
	       (not (generic-function-p
		      (setq generic-function
			    (symbol-function generic-function-name)))))
	   (error "~S does not name a generic-function."
		  generic-function-name))
	  ((null (setq method (get-method generic-function
					  extra
					  (parse-specializers
					    argument-specifiers)
					  nil)))
	   (error "There is no method for the generic-function ~S~%~
                   which matches the argument-specifiers ~S."
		  generic-function
		  argument-specifiers))
	  (t
	   (remove-method generic-function method)))))


(defmethod ADD-METHOD-ON-SPECIALIZER ((method standard-method) specializer)
  (specializer-methods specializer
		       (adjoin method (specializer-methods specializer))))

(defmethod REMOVE-METHOD-ON-SPECIALIZER ((method standard-method) specializer)
  (specializer-methods specializer
		       (delete method (specializer-methods specializer))))


(defvar *individual-specializer-methods* (make-hash-table :test #'eql))

(defun specializer-methods (specializer &optional (new () new-p))
  (cond ((classp specializer)
	 (if new-p
	     (setf (class-direct-methods specializer) new)
	     (class-direct-methods specializer)))
	((eq specializer 't)			;*** I HATE THIS ***
	 (if new-p
	     (specializer-methods (class-named 't) new)
	     (specializer-methods (class-named 't))))
	((and (listp specializer)
	      (eq (car specializer) 'quote)
	      (null (cddr specializer)))
	 (let ((ind (cadr specializer)))
	   (if new-p
	       (setf (gethash ind *individual-specializer-methods*) new)
	       (gethash ind *individual-specializer-methods* ()))))
	(t
	 (error "Internal Error -- don't understand ~S as a specializer."
		specializer))))

	
(defun make-specializable (function-name &key (arglist nil arglistp))
  (cond ((not (null arglistp)))
	((not (fboundp function-name)))
	((fboundp 'function-arglist)
	 ;; function-arglist exists, get the arglist from it.
	 (setq arglist (function-arglist function-name)))
	(t
	 (error
	   "The :arglist argument to make-specializable was not supplied~%~
            and there is no version of FUNCTION-ARGLIST defined for this~%~
            port of Portable CommonLoops.~%~
            You must either define a version of FUNCTION-ARGLIST (which~%~
            should be easy), and send it off to the Portable CommonLoops~%~
            people or you should call make-specializable again with the~%~
            :arglist keyword to specify the arglist.")))
  (let ((original (and (fboundp function-name)
		       (symbol-function function-name)))
	(generic-function (make-instance 'standard-generic-function
					 :name function-name)))
    (setf (symbol-function function-name) generic-function)
    (when arglistp
      (setf (generic-function-pretty-arglist generic-function) arglist))
    (when original
	(add-named-method function-name
			  ()
			  ()
			  arglist
			  original))
    generic-function))

(defun update-pretty-arglist (generic-function method)
  (setf (function-pretty-arglist
	  (or (generic-function-name generic-function)
	      (generic-function-discriminating-function generic-function)))
	(or (slot-value-using-class (class-of generic-function)
				  generic-function
				  'pretty-arglist
				  t
				  ())
	    (method-arglist method))))

(defmethod generic-function-pretty-arglist
	   ((generic-function standard-generic-function))
  (or (slot-value-using-class (class-of generic-function)
			    generic-function
			    'pretty-arglist
			    t
			    ())
      (let ((method (or (generic-function-default-method generic-function)
			(car (generic-function-methods generic-function)))))
	(and method (method-arglist method)))))


(defmethod get-method (generic-function qualifiers specializers
					&optional (errorp t))
  (let ((hit (dolist (method (generic-function-methods generic-function))
	       (when (method-equal method qualifiers specializers)
		 (return method)))))
    (cond (hit hit)
	  ((null errorp) nil)
	  (t
	   (error "No method on ~S with qualifiers ~:S and specializers ~:S."
		  generic-function qualifiers specializers)))))

(defmethod method-equal ((method standard-method) qualifiers specializers)
  (and (equal qualifiers (method-options method))
       (equal specializers (method-type-specifiers method))))


(defmethod generic-function-default-method
	   ((generic-function standard-generic-function))
  (get-method generic-function () () nil))



  ;;   
;;;;;; Generic-Function-Based caching.
  ;;
;;; Methods are cached in a generic-function-based cache.  The cache is an
;;; N-key cache based on the number of specialized arguments the generic
;;; function has.  The size of the cache does not change statically or
;;; dynamically. This makes it possible to compute the mask at compile
;;; time and not even store it in the generic-function.

(defconstant generic-function-cache-size 32)

(defun make-generic-function-cache ()
  (make-memory-block generic-function-cache-size))

(defun make-generic-function-cache-mask (no-of-specialized-args)
  (make-memory-block-mask generic-function-cache-size
                          (+ no-of-specialized-args 1)))

(defmethod flush-generic-function-caches ((generic-function standard-generic-function))
  (let ((cache (generic-function-cache generic-function)))
    (when cache (clear-memory-block cache 0))))

(defmethod initialize-generic-function-cache
	   ((generic-function standard-generic-function) no-of-specialized-args)
  (declare (ignore no-of-specialized-args))
  (unless (generic-function-cache generic-function)
    (setf (generic-function-cache generic-function)
	  (make-generic-function-cache))))

(defmethod make-caching-discriminating-function (generic-function
						 lookup-function
						 cache
						 mask)
  (multiple-value-bind (required restp specialized-positions)
      (compute-discriminating-function-arglist-info generic-function)
    (funcall (get-templated-function-constructor
	       'caching-discriminating-function
	       required
	       restp
	       specialized-positions
	       lookup-function
	       mask)
             generic-function cache)))

(defun make-checking-discriminating-function (generic-function
					      method-function
					      type-specs
					      default-function)
  (multiple-value-bind (required restp)
      (compute-discriminating-function-arglist-info generic-function)
    (let ((check-positions
	    (iterate ((type-spec in type-specs)
		      (pos from 0))
	      (collect (and (neq type-spec 't) pos)))))
      (apply (get-templated-function-constructor
	       'checking-discriminating-function
	       required
	       restp
	       (if default-function t nil)
	       check-positions)
             generic-function method-function default-function type-specs))))


  ;;   
;;;;;; 
  ;;

(defmethod update-discriminator-code ((generic-function standard-generic-function))
  (install-discriminating-function
    generic-function (compute-discriminator-code generic-function)))

(defmethod install-discriminating-function
	   ((generic-function standard-generic-function) function)  
  (when (and (listp function)
	     (eq (car function) 'lambda))
    (setq function (compile nil function)))
  (set-funcallable-instance-function generic-function function))

(defmethod compute-discriminator-code ((generic-function standard-generic-function))
  (let ((default (generic-function-default-method generic-function))
        (methods (generic-function-methods generic-function))
	(std-class (class-named 'standard-class))
	(r/w nil))
    (cond ((null methods)
	   (make-no-methods-dcode generic-function))
	  ((and default (null (cdr methods)))
           (make-default-method-only-dcode generic-function))
	  ((not (dolist (m methods)
		  (let ((spec (car (method-type-specifiers m))))
		    (cond ((or (symbolp spec)	;Bootstrapping!
			       (listp spec)
			       (not (eq (class-of spec) std-class)))
			   (return t))
			  ((and (memq r/w '(nil r))
				(typep m 'standard-reader-method))
			   (setq r/w 'r))
			  ((and (memq r/w '(nil w))
				(typep m 'standard-writer-method))
			   (setq r/w 'w))
			  (t
			   (return t))))))
	   (if (eq r/w 'r)
	       (make-all-std-class-readers-dcode generic-function) 
	       (make-all-std-class-writers-dcode generic-function)))
          ((or (and default (null (cddr methods)))
	       (and (null default) (null (cdr methods))))
           (make-single-method-only-discriminating-function generic-function))
          ((every #'(lambda (m)
                      (classical-type-specifiers-p
			(method-type-specifiers m)))
                  methods)
           (make-classical-methods-only-discriminating-function
	     generic-function))
          (t
           (make-multi-method-discriminating-function generic-function)))))

(defmethod make-no-methods-dcode (generic-function)
  #'(lambda (&rest ignore)
      (declare (ignore ignore))
      (error "There are no methods on the generic-function ~S,~%~
              so it is an error to call it."
	     generic-function)))

(defmethod make-default-method-only-dcode (generic-function)
  (method-function (generic-function-default-method generic-function)))

(defmethod make-single-method-only-discriminating-function
	  ((self standard-generic-function))
  (let* ((methods (generic-function-methods self))
	 (default (generic-function-default-method self))
	 (method (if (eq (car methods) default)
		     (cadr methods)
		     (car methods)))
         (method-type-specifiers (method-type-specifiers method))
         (method-function (method-function method)))
    (make-checking-discriminating-function
      self
      method-function
      method-type-specifiers
      (and default (method-function default)))))

(defmethod make-classical-methods-only-discriminating-function
	  ((self standard-generic-function))
  (initialize-generic-function-cache self 1)
  (let ((default-method (generic-function-default-method self))
	(methods (generic-function-methods self)))
    (setf (generic-function-classical-method-table self)
	  (cons (and default-method (method-function default-method))
		(iterate ((method in methods))
		  (unless (eq method default-method)
		    (collect (cons (car (method-type-specifiers method))
				   (method-function method))))))))
  (let* ((cache (generic-function-cache self))
	 (mask (make-generic-function-cache-mask 1)))
    (make-caching-discriminating-function
      self 'lookup-classical-method cache mask)))

(defun lookup-classical-method (generic-function class)
  ;; There really should be some sort of more sophisticated protocol going
  ;; on here.  Compare type-specifiers and all that.
  (let* ((classical-method-table
	   (slot-value--funcallable-standard-class (class-of generic-function)
						 generic-function
						 'classical-method-table
						 nil
						 nil)))
    (or (iterate ((super in (slot-value--class class 'class-precedence-list)))
          (let ((hit (assq super (cdr classical-method-table))))
            (when hit (return (cdr hit)))))
	(car classical-method-table))))

(defmethod make-multi-method-discriminating-function
	  ((self standard-generic-function))
  (multiple-value-bind (required restp specialized)
      (compute-discriminating-function-arglist-info self)
    (declare (ignore required restp))
    (initialize-generic-function-cache self (length specialized))
    (let* ((cache (generic-function-cache self))
	   (mask (make-generic-function-cache-mask (length specialized))))
      (make-caching-discriminating-function
	self 'lookup-multi-method cache mask))))

(defvar *lookup-multi-method-internal*
	(make-array (min 256. call-arguments-limit)))

(defun lookup-multi-method-internal (generic-function classes)
  (let* ((methods (generic-function-methods generic-function))
	 (cpls *lookup-multi-method-internal*)
	 (order (slot-value--funcallable-standard-class
		  (class-of generic-function)
		  generic-function
		  'dispatch-order
		  ()
		  ()))
         (most-specific-method nil)
         (most-specific-type-specs ())
	 (type-specs ()))
    ;; Put all the class-precedence-lists in a place where we can save
    ;; them as we look through all the methods.
    (without-interrupts
      (iterate ((class in classes)
		(i from 0))
	(setf (svref cpls i)
	      (and class			;NIL when caller knows this
						;argument is not specialized.
		   (slot-value--class class 'class-precedence-list))))
      (dolist (method methods)
	(setq type-specs (slot-value--class method 'type-specifiers))
	(when (iterate ((type-spec in  type-specs)
			(i from 0))
		(or (eq type-spec 't)
		    (memq type-spec (svref cpls i))
		    (return nil))
		(finally (return t)))
	  (if (null most-specific-method)
	      (setq most-specific-method method
		    most-specific-type-specs type-specs)
	      (case (compare-type-specifier-lists
		      most-specific-type-specs type-specs nil
		      () classes order)
		(2 (setq most-specific-method method
			 most-specific-type-specs type-specs))
		(1))))))
    (or most-specific-method
	(generic-function-default-method generic-function))))

(defun lookup-multi-method (generic-function &rest classes)
  (declare (inline lookup-multi-method-internal))
  (let ((method (lookup-multi-method-internal generic-function classes)))
    (and method (method-function method))))

(defun lookup-method (generic-function &rest classes)
  (declare (inline lookup-multi-method-internal))
  (lookup-multi-method-internal generic-function classes))

(defun classical-type-specifiers-p (typespecs)
  (or (null typespecs)
      (and (classp (car typespecs))
           (null (cdr typespecs)))))

;;;
;;; Compute various information about a generic-function's arglist by looking
;;; at the argument lists of the methods.  The hair for trying not to use
;;; &rest arguments lives here.
;;;  The values returned are:
;;;    number-of-required-arguments
;;;       the number of required arguments to this generic-function's
;;;       discriminating function
;;;    &rest-argument-p
;;;       whether or not this generic-function's discriminating
;;;       function takes an &rest argument.
;;;    specialized-argument-positions
;;;       a list of the positions of the arguments this generic-function
;;;       specializes (e.g. for a classical generic-function this is the
;;;       list: (1)).
;;;
;;; As usual, it is legitimate to specialize the -internal function that is
;;; why I put it there, since I certainly could have written this more
;;; efficiently if I didn't want to provide that extensibility.
;;; 
(defmethod compute-discriminating-function-arglist-info
	 ((generic-function standard-generic-function))
  (declare (values number-of-required-arguments
                   &rest-argument-p
                   specialized-argument-postions))
  (let ((number-required nil)
        (restp nil)
        (specialized-positions ())
	(methods (generic-function-methods generic-function)))
    (iterate ((method in methods))
      (multiple-value-setq (number-required restp specialized-positions)
        (compute-discriminating-function-arglist-info-internal
	  generic-function method number-required restp specialized-positions)))
    (values number-required restp (sort specialized-positions #'<))))

(defmethod compute-discriminating-function-arglist-info-internal
	 ((generic-function standard-generic-function)
	  (method standard-method)
	  number-of-requireds restp specialized-argument-positions)
  (declare (ignore generic-function))
  (let ((requireds 0))
    ;; Go through this methods arguments seeing how many are required,
    ;; and whether there is an &rest argument.
    (iterate ((arg in (method-arglist method)))
      (cond ((eq arg '&aux) (return))
            ((memq arg '(&optional &rest &key))
             (return (setq restp t)))
	    ((memq arg lambda-list-keywords))
            (t (incf requireds))))
    ;; Now go through this method's type specifiers to see which
    ;; argument positions are type specified.  Treat T specially
    ;; in the usual sort of way.  For efficiency don't bother to
    ;; keep specialized-argument-positions sorted, rather depend
    ;; on our caller to do that.
    (iterate ((type-spec in (method-type-specifiers method))
              (pos from 0))
      (unless (eq type-spec 't)
	(pushnew pos specialized-argument-positions)))
    ;; Finally merge the values for this method into the values
    ;; for the exisiting methods and return them.  Note that if
    ;; num-of-requireds is NIL it means this is the first method
    ;; and we depend on that.
    (values (min (or number-of-requireds requireds) requireds)
            (or restp
		(and number-of-requireds (/= number-of-requireds requireds)))
            specialized-argument-positions)))

(defun make-discriminating-function-arglist (number-required-arguments restp)
  (iterate ((i from 0 below number-required-arguments))
    (collect (intern (format nil "Discriminating Function Arg ~D" i)))
    (finally (when restp
               (collect '&rest)
               (collect (intern "Discriminating Function &rest Arg"))))))

(defmethod compare-methods (generic-function method-1 method-2)
  (declare (ignore generic-function))
  (let ((compare ()))
    (iterate ((ts-1 in (method-type-specifiers method-1))
	      (ts-2 in (method-type-specifiers method-2)))
      (cond ((eq ts-1 ts-2) (setq compare '=))
	    ((eq ts-1 't)   (setq compare method-2))
	    ((eq ts-2 't)   (setq compare method-1))	    
	    ((memq ts-1 (class-class-precedence-list ts-2))
	     (setq compare method-2))
	    ((memq ts-2 (class-class-precedence-list ts-1))
	     (setq compare method-1))
	    (t (return nil)))
      (finally (return compare)))))

  ;;   
;;;;;; Comparing type-specifiers, statically or wrt an object.
  ;;
;;; compare-type-specifier-lists compares two lists of type specifiers
;;; compare-type-specifiers compare two type specifiers
;;; If static-p it t the comparison is done statically, otherwise it is
;;; done with respect to object(s).  The value returned is:
;;;    1    if type-spec-1 is more specific
;;;    2    if type-spec-2 is more specific
;;;    =    if they are equal
;;;    NIL  if they cannot be disambiguated
;;;
(defun compare-type-specifier-lists (type-spec-list-1
				     type-spec-list-2
				     staticp
				     args
				     classes
				     order)
  (when (or type-spec-list-1 type-spec-list-2)
    (ecase (compare-type-specifiers (or (car type-spec-list-1) t)
                                    (or (car type-spec-list-2) t)
                                    staticp
                                    (car args)
                                    (car classes))
      (1 '1)
      (2 '2)
      (= (if (eq order :default)
	     (compare-type-specifier-lists (cdr type-spec-list-1)
					   (cdr type-spec-list-2)
					   staticp
					   (cdr args)
					   (cdr classes)
					   order)
	     (compare-type-specifier-lists (nth (car order) type-spec-list-1)
					   (nth (car order) type-spec-list-2)
					   staticp
					   (cdr args)
					   (cdr classes)
					   (cdr order))))
	    
      (nil
        (unless staticp
          (error "The type specifiers ~S and ~S can not be disambiguated~
                  with respect to the argument: ~S"
                 (or (car type-spec-list-1) t)
                 (or (car type-spec-list-2) t)
                 (car args)
                 (car classes)))))))

(defun compare-type-specifiers (type-spec-1 type-spec-2 staticp arg class)
  (cond ((equal type-spec-1 type-spec-2) '=)
        ((eq type-spec-2 t) '1)
        ((eq type-spec-1 t) '2)
        ((and (not (listp type-spec-1))
	      (not (listp type-spec-2)))
;        (if staticp
;            (if (common-subs type-spec-1 type-spec-2)
;                nil
;                (let ((supers (common-supers type-spec-1 type-spec-2)))
;                  (cond ((cdr supers) nil)
;                        ((eq (car supers) type-spec-1) '2)
;                        ((eq (car supers) type-spec-2) '1)
;                        (t 'disjoint))))
	 (dolist (super (slot-value--class (or class (class-of arg))
					   'class-precedence-list))
	   (cond ((eq super type-spec-1)
		  (return '1))
		 ((eq super type-spec-2)
		  (return '2)))))
        (t
         (compare-complex-type-specifiers
	   type-spec-1 type-spec-2 staticp arg class))))

(defun compare-complex-type-specifiers (type-spec-1 type-spec-2 static-p arg class)
  (declare (ignore type-spec-1 type-spec-2 static-p arg class))
  (error "Complex type specifiers are not yet supported."))

(defmethod no-matching-method (generic-function)
  (error "No matching method for the generic-function: ~S." generic-function))


;;;
;;;
;;;

(defun real-remove-method (generic-function method)
  (setf (method-generic-function method) nil)
  (setf (generic-function-methods generic-function)
	(delq method (generic-function-methods generic-function)))
  (dolist (specializers (method-type-specifiers method))
    (remove-method-on-specializer method specializers))
  (generic-function-changed generic-function method nil)
  generic-function)

(defun real-add-named-method (generic-function-name
			      qualifiers
			      specializers
			      lambda-list
			      function
			      &rest other-initargs)
  ;; What about changing the class of the generic-function if there is
  ;; one.  Whose job is that anyways.  Do we need something kind of
  ;; like class-for-redefinition?
  (let* ((generic-function
	   (ensure-generic-function generic-function-name
				    :lambda-list lambda-list))
	 (specs (parse-specializers specializers))
	 (existing (get-method generic-function qualifiers specs nil))
	 (proto (method-prototype-for-gf generic-function-name))
	 (new (apply #'make-instance (class-of proto)
				     :options qualifiers
				     :type-specifiers specs
				     :arglist lambda-list
				     :function function
				     other-initargs)))
    (when existing (remove-method generic-function existing))
    (add-method generic-function new)))


(defun real-add-method (generic-function method)
  (let ((type-specs (method-type-specifiers method))
       ;(options (method-options method))
       ;(methods (discriminator-methods discriminator))
	)
    (setf (method-generic-function method) generic-function)
    (pushnew method (generic-function-methods generic-function))
    (dolist (specializer type-specs)
      (add-method-on-specializer method specializer))
    (generic-function-changed generic-function method t)
    (update-pretty-arglist generic-function method)	;NOT part of
						        ;standard protocol.
    method))