;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; Patch-File: Yes -*-
;;;
;;; *************************************************************************
;;; 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)

(eval-when (compile load eval)
  (fix-early-generic-functions))


  ;;   
;;;;;; Pending defmeths which I couldn't do before.
  ;;

(eval-when (load eval)
  (setf (symbol-function 'print-instance)
	(symbol-function 'print-object)))



(eval-when (load)

(define-meta-class essential-class (lambda (x) (%instance-ref x 0)))

(defmethod class-slots ((class essential-class))
  (declare (ignore class))
  ())

(defmethod allocate-instance ((class essential-class))
  (let ((primitive-instance
	  (%allocate-instance (class-named 'essential-class)
			      (1+ (length (class-slots class))))))
    (setf (%instance-ref primitive-instance 0) class)
    primitive-instance))

(defmethod slot-value-using-class ((class essential-class) object slot-name)
  (let ((pos (position slot-name (class-slots class) :key #'slotd-name)))
    (if pos
	(%instance-ref object (1+ pos))
	(slot-missing ;class
	  object slot-name))))

(defmethod put-slot-using-class ((class essential-class)
			       object
			       slot-name
			       new-value)
  (let ((pos (position slot-name (class-slots class) :key #'slotd-name)))
    (if pos
	(setf (%instance-ref object (1+ pos)) new-value)
	(slot-missing ;class
		      object slot-name))))

(defmethod optimize-slot-value (class form)	;This lossage ha to go away
  (declare (ignore class))			;now that we know that
  form)						;standard class is it.

(defmethod optimize-setf-of-slot-value (class form)
  (declare (ignore class))
  form)

(defmethod make-slotd ((class essential-class) &rest keywords-and-options)
  (declare (ignore class))
  (apply #'make-slotd--essential-class keywords-and-options))

;(defmethod add-named-class ((proto-class essential-class) name
;			  local-supers
;			  local-slot-slotds
;			  extra)
;  ;; First find out if there is already a class with this name.
;  ;; If there is, call class-for-redefinition to get the class
;  ;; object to use for the new definition.  If there is no exisiting
;  ;; class we just make a new instance.
;  (let* ((existing (class-named name t))
;	 (class (if existing
;		    (class-for-redefinition existing proto-class name 
;					    local-supers local-slot-slotds
;					    extra)
;		    (make-instance (class-of proto-class)))))
;
;    (setq local-supers
;	  (mapcar
;	    #'(lambda (ls)
;		(or (class-named ls t)
;		    (error "~S was specified as the name of a local-super~%~
;                            for the class named ~S.  But there is no class~%~
;                            class named ~S." ls name ls)))
;	    local-supers))
;    
;    (setf (class-name class) name)
;;   (setf (class-ds-options class) extra)	;This is NOT part of the
;;						;standard protocol.
;   
;    (add-class class local-supers local-slot-slotds extra)
;    
;    (setf (class-named name) class)
;    name))

(defmethod supers-changed ((class essential-class)
			 old-local-supers
			 old-local-slots
			 extra
			 top-p)
  (declare (ignore old-local-supers old-local-slots top-p))
  (let ((cpl (compute-class-precedence-list class)))
    (setf (class-class-precedence-list class) cpl)
;   (update-slots--class class cpl)		         ;This is NOT part of
;						         ;the essential-class
;						         ;protocol.
    (dolist (sub-class (class-direct-subclasses class))
      (supers-changed sub-class
		      (class-local-supers sub-class)
		      (class-local-slots sub-class)
		      extra
		      nil))
;   (when top-p                                          ;This is NOT part of
;     (update-method-inheritance class old-local-supers));the essential-class
; 					                 ;protocol.
    ))

(defmethod slots-changed ((class essential-class)
			old-local-slots
			extra
			top-p)
  (declare (ignore top-p old-local-slots))
  ;; When this is called, class should have its local-supers and
  ;; local-slots slots filled in properly.
; (update-slots--class class (class-class-precedence-list class))
  (dolist (sub-class (class-direct-subclasses class))
    (slots-changed sub-class (class-local-slots sub-class) extra nil)))

;(defmethod method-equal (method argument-specifiers options)
;  (declare (ignore options))
;  (equal argument-specifiers (method-type-specifiers method)))

(defmethod methods-combine-p ((d generic-function))
  (declare (ignore d))
  nil)

)

  ;;   
;;;;;; 
  ;;

(define-method-body-macro call-next-method ()
  :global :error
  :method (expand-call-next-method
	    (macroexpand-time-method macroexpand-time-environment)
	    nil
	    macroexpand-time-environment))

(defmethod expand-call-next-method ((mex-method method) args mti)
  (declare (ignore args))
  (let* ((arglist (method-arglist mex-method))
	 (uid (macroexpand-time-method-uid mti))
	 (applyp nil))
    (multiple-value-setq (arglist applyp) (make-call-arguments arglist))
    (cond ((null (method-type-specifiers mex-method))
	   (warn "Using call-next-method in a default method.~%~
                  At run time this will generate an error.")
	   `(error "Using call-next-method in a default method."))
	  (applyp
	   `(apply #'call-next-method-internal ,uid . ,arglist))
	  (t
	   `(call-next-method-internal ,uid . ,arglist)))))

(defun call-next-method-internal (current-method &rest args)
  (let* ((generic-function (method-generic-function current-method))
	 (type-specifiers (method-type-specifiers current-method))
	 (most-specific nil)
	 (most-specific-type-specifiers ())
	 (dispatch-order (slot-value--funcallable-standard-class
			   (class-of generic-function)
			   generic-function
			   'dispatch-order
			   nil
			   nil)))
    (iterate ((method in (generic-function-methods generic-function)))
      (let ((method-type-specifiers (method-type-specifiers method))
            (temp ()))
        (and (every #'(lambda (arg type-spec)
			(or (eq type-spec 't)
			    (memq type-spec
				  (slot-value--class
				    (class-of arg) 'class-precedence-list))))
                    args method-type-specifiers)
             (eql 1 (setq temp (compare-type-specifier-lists
				 type-specifiers
				 method-type-specifiers
				 ()
				 args
				 ()
				 dispatch-order)))
             (or (null most-specific)
                 (eql 1 (setq temp (compare-type-specifier-lists
                                     method-type-specifiers
                                     most-specific-type-specifiers
                                     ()
                                     args
                                     ()
				     dispatch-order))))
             (setq most-specific method
                   most-specific-type-specifiers method-type-specifiers))))
    (if (or most-specific
            (setq most-specific (generic-function-default-method
				  generic-function)))
        (apply (method-function most-specific) args)
        (error "no super method found"))))

;;;
;;; This is kind of bozoid because it always copies the lambda-list even
;;; when it doesn't need to.  It also doesn't remember things it could
;;; remember, causing it to call memq more than it should.  Fix this one
;;; day when there is nothing else to do.
;;; 
(defun make-call-arguments (lambda-list &aux applyp)
  (setq lambda-list (reverse lambda-list))
  (when (memq '&aux lambda-list)
    (setq lambda-list (cdr (memq '&aux lambda-list))))
  (setq lambda-list (nreverse lambda-list))
  (let ((optional (memq '&optional lambda-list)))
    (when optional
      ;; The &optional keyword appears in the lambda list.
      ;; Get rid of it, by moving the rest of the lambda list
      ;; up, then go through the optional arguments, replacing
      ;; them with the real symbol.
      (setf (car optional) (cadr optional)
	    (cdr optional) (cddr optional))
      (iterate ((loc on optional))
	(when (memq (car loc) lambda-list-keywords)
	  (unless (memq (car loc) '(&rest &key &allow-other-keys))
	    (error
	      "The non-standard lambda list keyword ~S appeared in the~%~
               lambda list of a method in which CALL-NEXT-METHOD is used.~%~
               PCL can only deal with standard lambda list keywords."))
	  (when (listp (car loc)) (setf (car loc) (caar loc)))))))
  (let ((rest (memq '&rest lambda-list)))
    (cond ((not (null rest))
	   ;; &rest appears in the lambda list. This means we
	   ;; have to do an apply. We ignore the rest of the
	   ;; lambda list, just grab the &rest var and set applyp.
	   (setf (car rest) (if (listp (cadr rest))
				(caadr rest)
				(cadr rest))
		 (cdr rest) ())
	   (setq applyp t))
	  (t
	   (let ((key (memq '&key lambda-list)))
	     (when key
	       ;; &key appears in the lambda list.  Remove &key from the
	       ;; lambda list then replace all the keywords with pairs of
	       ;; the actual keyword followed by the value variable.
	       ;; Have to parse the hairy triple case of &key.
	       (let ((key-args
		       (iterate ((arg in (cdr key)))
			 (until (eq arg '&allow-other-keys))
			 (cond ((symbolp arg)
				(collect (make-keyword arg))
				(collect arg))
			       ((cddr arg)
				(collect (caddr arg))
				(collect (car arg)))
			       (t
				(collect (make-keyword (car arg)))
				(collect (car arg)))))))
		 (if key-args
		     (setf (car key) (car key-args)
			   (cdr key) (cdr key-args))
		     (setf (cdr key) nil
			   lambda-list (remove '&key lambda-list)))))))))
  (values lambda-list applyp))