source: branches/1.1.x/src/org/armedbear/lisp/clos.lisp

;;; clos.lisp
;;;
;;; Copyright (C) 2003-2007 Peter Graves
;;; Copyright (C) 2010-2013 Mark Evenson
;;; $Id: clos.lisp 14378 2013-02-13 19:54:49Z mevenson $
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
;;;
;;; As a special exception, the copyright holders of this library give you
;;; permission to link this library with independent modules to produce an
;;; executable, regardless of the license terms of these independent
;;; modules, and to copy and distribute the resulting executable under
;;; terms of your choice, provided that you also meet, for each linked
;;; independent module, the terms and conditions of the license of that
;;; module.  An independent module is a module which is not derived from
;;; or based on this library.  If you modify this library, you may extend
;;; this exception to your version of the library, but you are not
;;; obligated to do so.  If you do not wish to do so, delete this
;;; exception statement from your version.

;;; Originally based on Closette.

;;; Closette Version 1.0 (February 10, 1991)
;;;
;;; Copyright (c) 1990, 1991 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.
;;;
;;; Closette is an implementation of a subset of CLOS with a metaobject
;;; protocol as described in "The Art of The Metaobject Protocol",
;;; MIT Press, 1991.

(in-package #:mop)

(export '(%defgeneric canonicalize-direct-superclasses))


;;
;;
;;
;; In order to bootstrap CLOS, first implement the required API as
;; normal functions which only apply to the "root" metaclass
;; STANDARD-CLASS.
;;
;; After putting the normal functions in place, the building blocks
;; are in place to gradually swap the normal functions with
;; generic functions and methods.
;;
;; Some functionality implemented in the temporary regular functions
;; needs to be available later as a method definition to be dispatched
;; to for the standard case, e.g. with arguments of type STANDARD-CLASS
;; or STANDARD-GENERIC-FUNCTION.  To prevent repeated code, the
;; functions are implemented in functions by the same name as the API
;; functions, but with the STD- prefix.  These functions are sometimes
;; used in regular code as well, either in a "fast path" or to break a
;; circularity (e.g., within compute-discriminating-function when the
;; user adds a method to compute-discriminating-function).
;;
;; When hacking this file, note that some important parts are implemented
;; in the Java world. These Java bits can be found in the files
;;
;; * LispClass.java
;; * SlotClass.java
;; * StandardClass.java
;; * BuiltInClass.java
;; * StandardObject.java
;; * StandardObjectFunctions.java
;; * FuncallableStandardObject.java
;; * Layout.java
;;
;; In case of function names, those defined on the Java side can be
;; recognized by their prefixed percent (%) sign.
;;
;; The API functions need to be declaimed NOTINLINE explicitly, because
;; that prevents inlining in the current FASL (which is allowed by the
;; CLHS without the declaration); this is a hard requirement to in order
;; to be able to swap the symbol's function slot with a generic function
;; later on - with it actually being used.
;;
;;
;;
;; ### Note that the "declares all API functions as regular functions"
;; isn't true when I write the above, but it's definitely the target.
;;
;; A note about AMOP: the first chapters (and the sample Closette
;; implementation) of the book sometimes deviate from the specification.
;; For example, in the examples slot-value-using-class has the slot name
;; as third argument where in the specification it is the effective slot
;; definition.  When in doubt, we aim to follow the specification, the
;; MOP test suite at http://common-lisp.net/project/closer/features.html
;; and the behavior of other CL implementations in preference to
;; chapters 1-4 and appendix D.

(defconstant +the-standard-class+ (find-class 'standard-class))
(defconstant +the-funcallable-standard-class+
  (find-class 'funcallable-standard-class))
(defconstant +the-structure-class+ (find-class 'structure-class))
(defconstant +the-standard-object-class+ (find-class 'standard-object))
(defconstant +the-funcallable-standard-object-class+
  (find-class 'funcallable-standard-object))
(defconstant +the-standard-method-class+ (find-class 'standard-method))
(defconstant +the-forward-referenced-class+
  (find-class 'forward-referenced-class))
(defconstant +the-standard-generic-function-class+
  (find-class 'standard-generic-function))
(defconstant +the-T-class+ (find-class 'T))
(defconstant +the-standard-slot-definition-class+ (find-class 'standard-slot-definition))
(defconstant +the-standard-direct-slot-definition-class+ (find-class 'standard-direct-slot-definition))
(defconstant +the-standard-effective-slot-definition-class+ (find-class 'standard-effective-slot-definition))

;; Don't use DEFVAR, because that disallows loading clos.lisp
;; after compiling it: the binding won't get assigned to T anymore
(defparameter *clos-booting* t)

(defmacro define-class->%class-forwarder (name)
  (let* (($name (if (consp name) (cadr name) name))
         (%name (intern (concatenate 'string
                                     "%"
                                     (if (consp name)
                                         (symbol-name 'set-) "")
                                     (symbol-name $name))
                        (symbol-package $name))))
    `(progn
       (declaim (notinline ,name))
       (defun ,name (&rest args)
         (apply #',%name args)))))

;;
;;  DEFINE PLACE HOLDER FUNCTIONS
;;

(define-class->%class-forwarder class-name)
(define-class->%class-forwarder (setf class-name))
(define-class->%class-forwarder class-slots)
(define-class->%class-forwarder (setf class-slots))
(define-class->%class-forwarder class-direct-slots)
(define-class->%class-forwarder (setf class-direct-slots))
(define-class->%class-forwarder class-layout)
(define-class->%class-forwarder (setf class-layout))
(define-class->%class-forwarder class-direct-superclasses)
(define-class->%class-forwarder (setf class-direct-superclasses))
(define-class->%class-forwarder class-direct-subclasses)
(define-class->%class-forwarder (setf class-direct-subclasses))
(define-class->%class-forwarder class-direct-methods)
(define-class->%class-forwarder (setf class-direct-methods))
(define-class->%class-forwarder class-precedence-list)
(define-class->%class-forwarder (setf class-precedence-list))
(define-class->%class-forwarder class-finalized-p)
(define-class->%class-forwarder (setf class-finalized-p))
(define-class->%class-forwarder class-default-initargs)
(define-class->%class-forwarder (setf class-default-initargs))
(define-class->%class-forwarder class-direct-default-initargs)
(define-class->%class-forwarder (setf class-direct-default-initargs))

(declaim (notinline add-direct-subclass remove-direct-subclass))
(defun add-direct-subclass (superclass subclass)
  (setf (class-direct-subclasses superclass)
        (adjoin subclass (class-direct-subclasses superclass))))
(defun remove-direct-subclass (superclass subclass)
  (setf (class-direct-subclasses superclass)
        (remove subclass (class-direct-subclasses superclass))))

(defun fixup-standard-class-hierarchy ()
  ;; Make the result of class-direct-subclasses for the pre-built
  ;; classes agree with AMOP Table 5.1 (pg. 141).  This could be done in
  ;; StandardClass.java where these classes are defined, but it's less
  ;; painful to do it Lisp-side.
  (flet ((add-subclasses (class subclasses)
           (when (atom subclasses) (setf subclasses (list subclasses)))
           (setf (class-direct-subclasses (find-class class))
                 (union (class-direct-subclasses (find-class class))
                        (mapcar #'find-class subclasses)))))
    (add-subclasses t 'standard-object)
    (add-subclasses 'function 'funcallable-standard-object)
    (add-subclasses 'standard-object '(funcallable-standard-object metaobject))
    (add-subclasses 'metaobject
                    '(generic-function method slot-definition specializer))
    (add-subclasses 'specializer '(class))
    (add-subclasses 'funcallable-standard-object 'generic-function)
    (add-subclasses 'generic-function 'standard-generic-function)
    (add-subclasses 'method 'standard-method)
    (add-subclasses 'slot-definition
                    '(direct-slot-definition effective-slot-definition
                      standard-slot-definition))
    (add-subclasses 'standard-slot-definition
                    '(standard-direct-slot-definition
                      standard-effective-slot-definition))
    (add-subclasses 'direct-slot-definition 'standard-direct-slot-definition)
    (add-subclasses 'effective-slot-definition
                    'standard-effective-slot-definition)
    (add-subclasses 'class
                    '(built-in-class forward-referenced-class standard-class
                      funcallable-standard-class))))
(fixup-standard-class-hierarchy)

(defun no-applicable-method (generic-function &rest args)
  (error "There is no applicable method for the generic function ~S when called with arguments ~S."
         generic-function
         args))

(defun function-keywords (method)
  (std-function-keywords method))

(declaim (notinline map-dependents))
(defun map-dependents (metaobject function)
  ;; stub, will be redefined later
  (declare (ignore metaobject function))
  nil)

(defmacro push-on-end (value location)
  `(setf ,location (nconc ,location (list ,value))))

;;; (SETF GETF*) is like (SETF GETF) except that it always changes the list,
;;; which must be non-nil.

(defun (setf getf*) (new-value plist key)
  (block body
    (do ((x plist (cddr x)))
        ((null x))
      (when (eq (car x) key)
        (setf (car (cdr x)) new-value)
        (return-from body new-value)))
    (push-on-end key plist)
    (push-on-end new-value plist)
    new-value))

(defun mapappend (fun &rest args)
  (if (some #'null args)
      ()
      (append (apply fun (mapcar #'car args))
              (apply #'mapappend fun (mapcar #'cdr args)))))

(defun mapplist (fun x)
  (if (null x)
      ()
      (cons (funcall fun (car x) (cadr x))
            (mapplist fun (cddr x)))))

(defsetf std-instance-layout %set-std-instance-layout)
(defsetf standard-instance-access %set-standard-instance-access)
(defun funcallable-standard-instance-access (instance location)
  (standard-instance-access instance location))
(defsetf funcallable-standard-instance-access %set-standard-instance-access)

(defun (setf find-class) (new-value symbol &optional errorp environment)
  (declare (ignore errorp environment))
  (%set-find-class symbol new-value))

(defun canonicalize-direct-slots (direct-slots)
  `(list ,@(mapcar #'canonicalize-direct-slot direct-slots)))

(defun canonicalize-direct-slot (spec)
  (if (symbolp spec)
      `(list :name ',spec)
      (let ((name (car spec))
            (initfunction nil)
            (initform nil)
            (initargs ())
            (type nil)
            (allocation nil)
            (documentation nil)
            (readers ())
            (writers ())
            (other-options ())
            (non-std-options ()))
        (do ((olist (cdr spec) (cddr olist)))
            ((null olist))
          (case (car olist)
            (:initform
             (when initform
               (error 'program-error
                      "duplicate slot option :INITFORM for slot named ~S"
                      name))
             (setq initfunction t)
             (setq initform (cadr olist)))
            (:initarg
             (push-on-end (cadr olist) initargs))
            (:allocation
             (when allocation
               (error 'program-error
                      "duplicate slot option :ALLOCATION for slot named ~S"
                      name))
             (setf allocation (cadr olist))
             (push-on-end (car olist) other-options)
             (push-on-end (cadr olist) other-options))
            (:type
             (when type
               (error 'program-error
                      "duplicate slot option :TYPE for slot named ~S"
                      name))
             (setf type (cadr olist)))
            (:documentation
             (when documentation
               (error 'program-error
                      "duplicate slot option :DOCUMENTATION for slot named ~S"
                      name))
             (setf documentation (cadr olist)))
            (:reader
             (maybe-note-name-defined (cadr olist))
             (push-on-end (cadr olist) readers))
            (:writer
             (maybe-note-name-defined (cadr olist))
             (push-on-end (cadr olist) writers))
            (:accessor
             (maybe-note-name-defined (cadr olist))
             (push-on-end (cadr olist) readers)
             (push-on-end `(setf ,(cadr olist)) writers))
            (t
             (push-on-end (cadr olist) (getf non-std-options (car olist))))))
        `(list
          :name ',name
          ,@(when initfunction
              `(:initform ',initform
                :initfunction ,(if (eq allocation :class)
                                   ;; CLHS specifies the initform for a
                                   ;; class allocation level slot needs
                                   ;; to be evaluated in the dynamic
                                   ;; extent of the DEFCLASS form
                                   (let ((var (gensym)))
                                     `(let ((,var ,initform))
                                        (lambda () ,var)))
                                 `(lambda () ,initform))))
          ,@(when initargs `(:initargs ',initargs))
          ,@(when readers `(:readers ',readers))
          ,@(when writers `(:writers ',writers))
          ,@(when type `(:type ',type))
          ,@(when documentation `(:documentation ',documentation))
          ,@other-options
          ,@(mapcar #'(lambda (opt) (if (or (atom opt) (/= 1 (length opt)))
                                        `',opt
                                        `',(car opt)))
                    non-std-options)))))

(defun maybe-note-name-defined (name)
  (when (fboundp 'note-name-defined)
    (note-name-defined name)))

(defun canonicalize-defclass-options (options)
  (mapappend #'canonicalize-defclass-option options))

(defun canonicalize-defclass-option (option)
  (case (car option)
    (:metaclass
     (list ':metaclass
           `(find-class ',(cadr option))))
    (:default-initargs
     (list
      ':direct-default-initargs
      `(list ,@(mapplist
                #'(lambda (key value)
                    `(list ',key ',value ,(make-initfunction value)))
                (cdr option)))))
    ((:documentation :report)
     (list (car option) `',(cadr option)))
    (t (list `(quote ,(car option)) `(quote ,(cdr option))))))

(defun make-initfunction (initform)
  `(function (lambda () ,initform)))

(defun slot-definition-allocation (slot-definition)
  (%slot-definition-allocation slot-definition))

(declaim (notinline (setf slot-definition-allocation)))
(defun (setf slot-definition-allocation) (value slot-definition)
  (set-slot-definition-allocation slot-definition value))

(defun slot-definition-initargs (slot-definition)
  (%slot-definition-initargs slot-definition))

(declaim (notinline (setf slot-definition-initargs)))
(defun (setf slot-definition-initargs) (value slot-definition)
  (set-slot-definition-initargs slot-definition value))

(defun slot-definition-initform (slot-definition)
  (%slot-definition-initform slot-definition))

(declaim (notinline (setf slot-definition-initform)))
(defun (setf slot-definition-initform) (value slot-definition)
  (set-slot-definition-initform slot-definition value))

(defun slot-definition-initfunction (slot-definition)
  (%slot-definition-initfunction slot-definition))

(declaim (notinline (setf slot-definition-initfunction)))
(defun (setf slot-definition-initfunction) (value slot-definition)
  (set-slot-definition-initfunction slot-definition value))

(defun slot-definition-name (slot-definition)
  (%slot-definition-name slot-definition))

(declaim (notinline (setf slot-definition-name)))
(defun (setf slot-definition-name) (value slot-definition)
  (set-slot-definition-name slot-definition value))

(defun slot-definition-readers (slot-definition)
  (%slot-definition-readers slot-definition))

(declaim (notinline (setf slot-definition-readers)))
(defun (setf slot-definition-readers) (value slot-definition)
  (set-slot-definition-readers slot-definition value))

(defun slot-definition-writers (slot-definition)
  (%slot-definition-writers slot-definition))

(declaim (notinline (setf slot-definition-writers)))
(defun (setf slot-definition-writers) (value slot-definition)
  (set-slot-definition-writers slot-definition value))

(defun slot-definition-allocation-class (slot-definition)
  (%slot-definition-allocation-class slot-definition))

(declaim (notinline (setf slot-definition-allocation-class)))
(defun (setf slot-definition-allocation-class) (value slot-definition)
  (set-slot-definition-allocation-class slot-definition value))

(defun slot-definition-location (slot-definition)
  (%slot-definition-location slot-definition))

(declaim (notinline (setf slot-definition-location-class)))
(defun (setf slot-definition-location) (value slot-definition)
  (set-slot-definition-location slot-definition value))

(defun slot-definition-type (slot-definition)
  (%slot-definition-type slot-definition))

(declaim (notinline (setf slot-definition-type)))
(defun (setf slot-definition-type) (value slot-definition)
  (set-slot-definition-type slot-definition value))

(defun slot-definition-documentation (slot-definition)
  (%slot-definition-documentation slot-definition))

(declaim (notinline (setf slot-definition-documentation)))
(defun (setf slot-definition-documentation) (value slot-definition)
  (set-slot-definition-documentation slot-definition value))

(defun init-slot-definition (slot &key name
                                    (initargs ())
                                    (initform nil)
                                    (initfunction nil)
                                    (readers ())
                                    (writers ())
                                    (allocation :instance)
                                    (allocation-class nil)
                                    (type t)
                                    (documentation nil))
  (setf (slot-definition-name slot) name)
  (setf (slot-definition-initargs slot) initargs)
  (setf (slot-definition-initform slot) initform)
  (setf (slot-definition-initfunction slot) initfunction)
  (setf (slot-definition-readers slot) readers)
  (setf (slot-definition-writers slot) writers)
  (setf (slot-definition-allocation slot) allocation)
  (setf (slot-definition-allocation-class slot) allocation-class)
  (setf (slot-definition-type slot) type)
  (setf (slot-definition-documentation slot) documentation)
  slot)

(declaim (notinline direct-slot-definition-class))
(defun direct-slot-definition-class (class &rest args)
  (declare (ignore class args))
  +the-standard-direct-slot-definition-class+)

(defun make-direct-slot-definition (class &rest args)
  (let ((slot-class (apply #'direct-slot-definition-class class args)))
    (if (eq slot-class +the-standard-direct-slot-definition-class+)
        (let ((slot (make-slot-definition +the-standard-direct-slot-definition-class+)))
          (apply #'init-slot-definition slot :allocation-class class args)
          slot)
        (progn
          (let ((slot (apply #'make-instance slot-class :allocation-class class
                             args)))
            slot)))))

(declaim (notinline effective-slot-definition-class))
(defun effective-slot-definition-class (class &rest args)
  (declare (ignore class args))
  +the-standard-effective-slot-definition-class+)

(defun make-effective-slot-definition (class &rest args)
  (let ((slot-class (apply #'effective-slot-definition-class class args)))
    (if (eq slot-class +the-standard-effective-slot-definition-class+)
        (let ((slot (make-slot-definition +the-standard-effective-slot-definition-class+)))
          (apply #'init-slot-definition slot args)
          slot)
        (progn
          (let ((slot (apply #'make-instance slot-class args)))
            slot)))))

;;; finalize-inheritance

(declaim (notinline compute-default-initargs))
(defun compute-default-initargs (class)
  (std-compute-default-initargs class))

(defun std-compute-default-initargs (class)
  (delete-duplicates
   (mapcan #'(lambda (c)
               (copy-list
                (class-direct-default-initargs c)))
           (class-precedence-list class))
   :key #'car :from-end t))

(defun std-finalize-inheritance (class)
  ;; In case the class is already finalized, return
  ;; immediately, as per AMOP.
  (when (class-finalized-p class)
    (return-from std-finalize-inheritance))
  (setf (class-precedence-list class)
   (funcall (if (eq (class-of class) +the-standard-class+)
                #'std-compute-class-precedence-list
                #'compute-class-precedence-list)
            class))
  (setf (class-slots class)
        (funcall (if (eq (class-of class) +the-standard-class+)
                     #'std-compute-slots
                     #'compute-slots) class))
  (let ((old-layout (class-layout class))
        (length 0)
        (instance-slots '())
        (shared-slots '()))
    (dolist (slot (class-slots class))
      (case (slot-definition-allocation slot)
        (:instance
         (setf (slot-definition-location slot) length)
         (incf length)
         (push (slot-definition-name slot) instance-slots))
        (:class
         (unless (slot-definition-location slot)
           (let ((allocation-class (slot-definition-allocation-class slot)))
             (if (eq allocation-class class)
                 ;; We initialize class slots here so they can be
                 ;; accessed without creating a dummy instance.
                 (let ((initfunction (slot-definition-initfunction slot)))
                   (setf (slot-definition-location slot)
                         (cons (slot-definition-name slot)
                               (if initfunction
                                   (funcall initfunction)
                                   +slot-unbound+))))
                 (setf (slot-definition-location slot)
                       (slot-location allocation-class (slot-definition-name slot))))))
         (push (slot-definition-location slot) shared-slots))))
    (when old-layout
      ;; Redefined class: initialize added shared slots.
      (dolist (location shared-slots)
        (let* ((slot-name (car location))
               (old-location (layout-slot-location old-layout slot-name)))
          (unless old-location
            (let* ((slot-definition (find slot-name (class-slots class) :key 'slot-definition-name))
                   (initfunction (slot-definition-initfunction slot-definition)))
              (when initfunction
                (setf (cdr location) (funcall initfunction))))))))
    (setf (class-layout class)
          (make-layout class (nreverse instance-slots) (nreverse shared-slots))))
  (setf (class-default-initargs class)
        (compute-default-initargs class))
  (setf (class-finalized-p class) t))

(declaim (notinline finalize-inheritance))
(defun finalize-inheritance (class)
  (std-finalize-inheritance class))


;;; Class precedence lists

(defun std-compute-class-precedence-list (class)
  (let ((classes-to-order (collect-superclasses* class)))
    (dolist (super classes-to-order)
      (when (typep super 'forward-referenced-class)
        (error "Can't compute class precedence list for class ~A ~
                which depends on forward referenced class ~A." class super)))
    (topological-sort classes-to-order
                      (remove-duplicates
                       (mapappend #'local-precedence-ordering
                                  classes-to-order))
                      #'std-tie-breaker-rule)))

;;; topological-sort implements the standard algorithm for topologically
;;; sorting an arbitrary set of elements while honoring the precedence
;;; constraints given by a set of (X,Y) pairs that indicate that element
;;; X must precede element Y.  The tie-breaker procedure is called when it
;;; is necessary to choose from multiple minimal elements; both a list of
;;; candidates and the ordering so far are provided as arguments.

(defun topological-sort (elements constraints tie-breaker)
  (let ((remaining-constraints constraints)
        (remaining-elements elements)
        (result ()))
    (loop
      (let ((minimal-elements
             (remove-if
              #'(lambda (class)
                 (member class remaining-constraints
                         :key #'cadr))
              remaining-elements)))
        (when (null minimal-elements)
          (if (null remaining-elements)
              (return-from topological-sort result)
              (error "Inconsistent precedence graph.")))
        (let ((choice (if (null (cdr minimal-elements))
                          (car minimal-elements)
                          (funcall tie-breaker
                                   minimal-elements
                                   result))))
          (setq result (append result (list choice)))
          (setq remaining-elements
                (remove choice remaining-elements))
          (setq remaining-constraints
                (remove choice
                        remaining-constraints
                        :test #'member)))))))

;;; In the event of a tie while topologically sorting class precedence lists,
;;; the CLOS Specification says to "select the one that has a direct subclass
;;; rightmost in the class precedence list computed so far."  The same result
;;; is obtained by inspecting the partially constructed class precedence list
;;; from right to left, looking for the first minimal element to show up among
;;; the direct superclasses of the class precedence list constituent.
;;; (There's a lemma that shows that this rule yields a unique result.)

(defun std-tie-breaker-rule (minimal-elements cpl-so-far)
  (dolist (cpl-constituent (reverse cpl-so-far))
    (let* ((supers (class-direct-superclasses cpl-constituent))
           (common (intersection minimal-elements supers)))
      (when (not (null common))
        (return-from std-tie-breaker-rule (car common))))))

;;; This version of collect-superclasses* isn't bothered by cycles in the class
;;; hierarchy, which sometimes happen by accident.

(defun collect-superclasses* (class)
  (labels ((all-superclasses-loop (seen superclasses)
                                  (let ((to-be-processed
                                         (set-difference superclasses seen)))
                                    (if (null to-be-processed)
                                        superclasses
                                        (let ((class-to-process
                                               (car to-be-processed)))
                                          (all-superclasses-loop
                                           (cons class-to-process seen)
                                           (union (class-direct-superclasses
                                                   class-to-process)
                                                  superclasses)))))))
          (all-superclasses-loop () (list class))))

;;; The local precedence ordering of a class C with direct superclasses C_1,
;;; C_2, ..., C_n is the set ((C C_1) (C_1 C_2) ...(C_n-1 C_n)).

(defun local-precedence-ordering (class)
  (mapcar #'list
          (cons class
                (butlast (class-direct-superclasses class)))
          (class-direct-superclasses class)))

;;; Slot inheritance

(defun std-compute-slots (class)
  (let* ((all-slots (mapappend #'(lambda (c) (class-direct-slots c))
                               ;; Slots of base class must come first
                               (reverse (class-precedence-list class))))
         (all-names (delete-duplicates
                     (mapcar 'slot-definition-name all-slots)
                     :from-end t)))
    (mapcar #'(lambda (name)
               (funcall
                (if (eq (class-of class) +the-standard-class+)
                    #'std-compute-effective-slot-definition
                    #'compute-effective-slot-definition)
                class
                name
                ;; Slot of inherited class must override initfunction,
                ;; documentation of base class
                (nreverse
                 (remove name all-slots
                         :key 'slot-definition-name
                         :test-not #'eq))))
            all-names)))

(defun std-compute-effective-slot-definition (class name direct-slots)
  (let ((initer (find-if-not #'null direct-slots
                             :key 'slot-definition-initfunction))
        (documentation-slot (find-if-not #'null direct-slots
                                         :key 'slot-definition-documentation))
        (types (delete-duplicates
                (delete t (mapcar #'slot-definition-type direct-slots))
                :test #'equal)))
    (make-effective-slot-definition
     class
     :name name
     :initform (if initer
                   (slot-definition-initform initer)
                   nil)
     :initfunction (if initer
                       (slot-definition-initfunction initer)
                       nil)
     :initargs (remove-duplicates
                (mapappend 'slot-definition-initargs
                           direct-slots))
     :allocation (slot-definition-allocation (car direct-slots))
     :allocation-class (when (slot-boundp (car direct-slots)
                                          'sys::allocation-class)
                         ;;for some classes created in Java
                         ;;(e.g. SimpleCondition) this slot is unbound
                         (slot-definition-allocation-class (car direct-slots)))
     :type (cond ((null types) t)
                 ((= 1 (length types)) types)
                 (t (list* 'and types)))
     :documentation (if documentation-slot
                        (documentation documentation-slot t)
                        nil))))

;;; Standard instance slot access

;;; N.B. The location of the effective-slots slots in the class metaobject for
;;; standard-class must be determined without making any further slot
;;; references.

(defun find-slot-definition (class slot-name)
  (dolist (slot (class-slots class) nil)
    (when (eq slot-name (slot-definition-name slot))
      (return slot))))

(defun slot-location (class slot-name)
  (let ((slot (find-slot-definition class slot-name)))
    (if slot
        (slot-definition-location slot)
        nil)))

(defun instance-slot-location (instance slot-name)
  (let ((layout (std-instance-layout instance)))
    (and layout (layout-slot-location layout slot-name))))

(defun slot-value (object slot-name)
  (let* ((class (class-of object))
         (metaclass (class-of class)))
    (if (or (eq metaclass +the-standard-class+)
            (eq metaclass +the-structure-class+)
            (eq metaclass +the-funcallable-standard-class+))
        (std-slot-value object slot-name)
        (slot-value-using-class class object
                                (find-slot-definition class slot-name)))))

(defsetf std-slot-value set-std-slot-value)

(defun %set-slot-value (object slot-name new-value)
  (let* ((class (class-of object))
         (metaclass (class-of class)))
    (if (or (eq metaclass +the-standard-class+)
            (eq metaclass +the-structure-class+)
            (eq metaclass +the-funcallable-standard-class+))
        (setf (std-slot-value object slot-name) new-value)
        (setf (slot-value-using-class class object
                                      (find-slot-definition class slot-name))
              new-value))))

(defsetf slot-value %set-slot-value)

(defun slot-boundp (object slot-name)
  (let* ((class (class-of object))
         (metaclass (class-of class)))
    (if (or (eq metaclass +the-standard-class+) 
            (eq metaclass +the-funcallable-standard-class+))
        (std-slot-boundp object slot-name)
        (slot-boundp-using-class class object
                                 (find-slot-definition class slot-name)))))

(defun std-slot-makunbound (instance slot-name)
  (let ((location (instance-slot-location instance slot-name)))
    (cond ((fixnump location)
           (setf (standard-instance-access instance location) +slot-unbound+))
          ((consp location)
           (setf (cdr location) +slot-unbound+))
          (t
           (slot-missing (class-of instance) instance slot-name 'slot-makunbound))))
  instance)

(defun slot-makunbound (object slot-name)
  (let* ((class (class-of object))
         (metaclass (class-of class)))
    (if (or (eq metaclass +the-standard-class+)
            (eq metaclass +the-funcallable-standard-class+))
        (std-slot-makunbound object slot-name)
        (slot-makunbound-using-class class object
                                     (find-slot-definition class slot-name)))))

(defun std-slot-exists-p (instance slot-name)
  (not (null (find slot-name (class-slots (class-of instance))
                   :key 'slot-definition-name))))

(defun slot-exists-p (object slot-name)
  (if (eq (class-of (class-of object)) +the-standard-class+)
      (std-slot-exists-p object slot-name)
      (slot-exists-p-using-class (class-of object) object slot-name)))

(defun instance-slot-p (slot)
  (eq (slot-definition-allocation slot) :instance))

(defun std-allocate-instance (class)
  (sys::%std-allocate-instance class))

(defun allocate-funcallable-instance (class)
  (let ((instance (sys::%allocate-funcallable-instance class)))
    (set-funcallable-instance-function
     instance
     #'(lambda (&rest args)
         (declare (ignore args))
         (error 'program-error "Called a funcallable-instance with unset function.")))
    instance))

(declaim (notinline class-prototype))
(defun class-prototype (class)
  (unless (class-finalized-p class) (error "Class ~A not finalized" (class-name class)))
  (std-allocate-instance class))

(defun maybe-finalize-class-subtree (class)
  (when (every #'class-finalized-p (class-direct-superclasses class))
    (finalize-inheritance class)
    (dolist (subclass (class-direct-subclasses class))
      (maybe-finalize-class-subtree subclass))))

(defun make-instance-standard-class (metaclass
                                     &rest initargs
                                     &key name direct-superclasses direct-slots
                                       direct-default-initargs
                                       documentation)
  (declare (ignore metaclass))
  (let ((class (std-allocate-instance +the-standard-class+)))
    (unless *clos-booting*
      (check-initargs (list #'allocate-instance #'initialize-instance)
                      (list* class initargs)
                      class t initargs
                      *make-instance-initargs-cache* 'make-instance))
    (%set-class-name name class)
    ;; KLUDGE: necessary in define-primordial-class, otherwise
    ;; StandardClass.getClassLayout() throws an error
    (unless *clos-booting* (%set-class-layout nil class))
    (%set-class-direct-subclasses ()  class)
    (%set-class-direct-methods ()  class)
    (%set-class-documentation class documentation)
    (std-after-initialization-for-classes class
                                          :direct-superclasses direct-superclasses
                                          :direct-slots direct-slots
                                          :direct-default-initargs direct-default-initargs)
    class))

;(defun convert-to-direct-slot-definition (class canonicalized-slot)
;  (apply #'make-instance
;         (apply #'direct-slot-definition-class
;                class canonicalized-slot)
;         canonicalized-slot))

(defun canonicalize-direct-superclass-list (class direct-superclasses)
  (cond (direct-superclasses)
        ((subtypep (class-of class) +the-funcallable-standard-class+)
         (list +the-funcallable-standard-object-class+))
        ((subtypep (class-of class) +the-standard-class+)
         (list +the-standard-object-class+))))

(defun std-after-initialization-for-classes (class
                                             &key direct-superclasses direct-slots
                                             direct-default-initargs
                                             &allow-other-keys)
  (let ((supers (canonicalize-direct-superclass-list class direct-superclasses)))
    (setf (class-direct-superclasses class) supers)
    (dolist (superclass supers)
      (add-direct-subclass superclass class)))
  (let ((slots (mapcar #'(lambda (slot-properties)
                          (apply #'make-direct-slot-definition class slot-properties))
                       direct-slots)))
    (setf (class-direct-slots class) slots)
    (dolist (direct-slot slots)
      (dolist (reader (slot-definition-readers direct-slot))
        (add-reader-method class reader direct-slot))
      (dolist (writer (slot-definition-writers direct-slot))
        (add-writer-method class writer direct-slot))))
  (setf (class-direct-default-initargs class) direct-default-initargs)
  (maybe-finalize-class-subtree class)
  (values))

;;; Bootstrap the lower parts of the metaclass hierarchy.

(defmacro define-primordial-class (name superclasses direct-slots)
  "Primitive class definition tool.
No non-standard metaclasses, accessor methods, duplicate slots,
non-existent superclasses, default initargs, or other complicated stuff.
Handle with care."
  (let ((class (gensym)))
    `(let ((,class (make-instance-standard-class
                    nil
                    :name ',name
                    :direct-superclasses ',(mapcar #'find-class superclasses)
                    :direct-slots ,(canonicalize-direct-slots direct-slots))))
       (%set-find-class ',name ,class)
       ,class)))

(define-primordial-class eql-specializer (specializer)
  ((object :initform nil)
   (direct-methods :initform nil)))

(define-primordial-class method-combination (metaobject)
  ((sys::name :initarg :name :initform nil)
   (sys::%documentation :initarg :documentation :initform nil)
   (options :initarg :options :initform nil)))

(define-primordial-class short-method-combination (method-combination)
  ((operator :initarg :operator)
   (identity-with-one-argument :initarg :identity-with-one-argument)))

(define-primordial-class long-method-combination (method-combination)
  ((sys::lambda-list :initarg :lambda-list)
   (method-group-specs :initarg :method-group-specs)
   (args-lambda-list :initarg :args-lambda-list)
   (generic-function-symbol :initarg :generic-function-symbol)
   (function :initarg :function)
   (arguments :initarg :arguments)
   (declarations :initarg :declarations)
   (forms :initarg :forms)))

(define-primordial-class standard-accessor-method (standard-method)
  ((sys::%slot-definition :initarg :slot-definition :initform nil)))

(define-primordial-class standard-reader-method (standard-accessor-method)
  ())
(defconstant +the-standard-reader-method-class+
  (find-class 'standard-reader-method))

(define-primordial-class standard-writer-method (standard-accessor-method)
  ())
(defconstant +the-standard-writer-method-class+
  (find-class 'standard-writer-method))


(defvar *extensible-built-in-classes*
  (list (find-class 'sequence)
        (find-class 'java:java-object)))

(defvar *make-instance-initargs-cache*
  (make-hash-table :test #'eq)
  "Cached sets of allowable initargs, keyed on the class they belong to.")
(defvar *reinitialize-instance-initargs-cache*
  (make-hash-table :test #'eq)
  "Cached sets of allowable initargs, keyed on the class they belong to.")

(defun expand-long-defcombin (name args)
  (destructuring-bind (lambda-list method-groups &rest body) args
    `(apply #'define-long-form-method-combination
            ',name
            ',lambda-list
            (list ,@(mapcar #'canonicalize-method-group-spec method-groups))
            ',body)))

;;; The class method-combination and its subclasses are defined in
;;; StandardClass.java, but we cannot use make-instance and slot-value
;;; yet.

(defun %make-long-method-combination (&key name documentation lambda-list
                                       method-group-specs args-lambda-list
                                       generic-function-symbol function
                                       arguments declarations forms)
  (let ((instance (std-allocate-instance (find-class 'long-method-combination))))
    (setf (std-slot-value instance 'sys::name) name)
    (setf (std-slot-value instance 'sys:%documentation) documentation)
    (setf (std-slot-value instance 'sys::lambda-list) lambda-list)
    (setf (std-slot-value instance 'method-group-specs) method-group-specs)
    (setf (std-slot-value instance 'args-lambda-list) args-lambda-list)
    (setf (std-slot-value instance 'generic-function-symbol)
          generic-function-symbol)
    (setf (std-slot-value instance 'function) function)
    (setf (std-slot-value instance 'arguments) arguments)
    (setf (std-slot-value instance 'declarations) declarations)
    (setf (std-slot-value instance 'forms) forms)
    (setf (std-slot-value instance 'options) nil)
    instance))

(defun method-combination-name (method-combination)
  (check-type method-combination method-combination)
  (std-slot-value method-combination 'sys::name))

(defun method-combination-documentation (method-combination)
  (check-type method-combination method-combination)
  (std-slot-value method-combination 'sys:%documentation))

(defun short-method-combination-operator (method-combination)
  (check-type method-combination short-method-combination)
  (std-slot-value method-combination 'operator))

(defun short-method-combination-identity-with-one-argument (method-combination)
  (check-type method-combination short-method-combination)
  (std-slot-value method-combination 'identity-with-one-argument))

(defun long-method-combination-lambda-list (method-combination)
  (check-type method-combination long-method-combination)
  (std-slot-value method-combination 'sys::lambda-list))

(defun long-method-combination-method-group-specs (method-combination)
  (check-type method-combination long-method-combination)
  (std-slot-value method-combination 'method-group-specs))

(defun long-method-combination-args-lambda-list (method-combination)
  (check-type method-combination long-method-combination)
  (std-slot-value method-combination 'args-lambda-list))

(defun long-method-combination-generic-function-symbol (method-combination)
  (check-type method-combination long-method-combination)
  (std-slot-value method-combination 'generic-function-symbol))

(defun long-method-combination-function (method-combination)
  (check-type method-combination long-method-combination)
  (std-slot-value method-combination 'function))

(defun long-method-combination-arguments (method-combination)
  (check-type method-combination long-method-combination)
  (std-slot-value method-combination 'arguments))

(defun long-method-combination-declarations (method-combination)
  (check-type method-combination long-method-combination)
  (std-slot-value method-combination 'declarations))

(defun long-method-combination-forms (method-combination)
  (check-type method-combination long-method-combination)
  (std-slot-value method-combination 'forms))


(defun expand-short-defcombin (whole)
  (let* ((name (cadr whole))
         (documentation
          (getf (cddr whole) :documentation ""))
         (identity-with-one-arg
          (getf (cddr whole) :identity-with-one-argument nil))
         (operator
          (getf (cddr whole) :operator name)))
    `(progn
       (let ((instance (std-allocate-instance
                        (find-class 'short-method-combination))))
         (setf (std-slot-value instance 'sys::name) ',name)
         (setf (std-slot-value instance 'sys:%documentation) ',documentation)
         (setf (std-slot-value instance 'operator) ',operator)
         (setf (std-slot-value instance 'identity-with-one-argument)
               ',identity-with-one-arg)
         (setf (std-slot-value instance 'options) nil)
         (setf (get ',name 'method-combination-object) instance)
         ',name))))

(defmacro define-method-combination (&whole form name &rest args)
  (if (and (cddr form)
           (listp (caddr form)))
      (expand-long-defcombin name args)
      (expand-short-defcombin form)))

(define-method-combination +      :identity-with-one-argument t)
(define-method-combination and    :identity-with-one-argument t)
(define-method-combination append :identity-with-one-argument nil)
(define-method-combination list   :identity-with-one-argument nil)
(define-method-combination max    :identity-with-one-argument t)
(define-method-combination min    :identity-with-one-argument t)
(define-method-combination nconc  :identity-with-one-argument t)
(define-method-combination or     :identity-with-one-argument t)
(define-method-combination progn  :identity-with-one-argument t)

;;;
;;; long form of define-method-combination (from Sacla and XCL)
;;;
(defun method-group-p (selecter qualifiers)
  ;; selecter::= qualifier-pattern | predicate
  (etypecase selecter
    (list (or (equal selecter qualifiers)
              (let ((last (last selecter)))
                (when (eq '* (cdr last))
                  (let* ((prefix `(,@(butlast selecter) ,(car last)))
                         (pos (mismatch prefix qualifiers)))
                    (or (null pos) (= pos (length prefix))))))))
    ((eql *) t)
    (symbol (funcall (symbol-function selecter) qualifiers))))

(defun check-variable-name (name)
  (flet ((valid-variable-name-p (name)
                                (and (symbolp name) (not (constantp name)))))
    (assert (valid-variable-name-p name))))

(defun canonicalize-method-group-spec (spec)
  ;; spec ::= (name {qualifier-pattern+ | predicate} [[long-form-option]])
  ;; long-form-option::= :description description | :order order |
  ;;                     :required required-p
  ;; a canonicalized-spec is a simple plist.
  (let* ((rest spec)
         (name (prog2 (check-variable-name (car rest))
                 (car rest)
                 (setq rest (cdr rest))))
         (option-names '(:description :order :required))
         (selecters (let ((end (or (position-if #'(lambda (it)
                                                   (member it option-names))
                                                rest)
                                   (length rest))))
                      (prog1 (subseq rest 0 end)
                        (setq rest (subseq rest end)))))
         (description (getf rest :description ""))
         (order (getf rest :order :most-specific-first))
         (required-p (getf rest :required)))
    `(list :name ',name
           :predicate (lambda (qualifiers)
                        (loop for item in ',selecters
                          thereis (method-group-p item qualifiers)))
           :description ',description
           :order ',order
           :required ',required-p
           :*-selecter ,(equal selecters '(*)))))

(defun extract-required-part (lambda-list)
  (flet ((skip (key lambda-list)
               (if (eq (first lambda-list) key)
                   (cddr lambda-list)
                   lambda-list)))
    (let* ((trimmed-lambda-list
            (skip '&environment (skip '&whole lambda-list)))
           (after-required-lambda-list
            (member-if #'(lambda (it) (member it lambda-list-keywords))
                       trimmed-lambda-list)))
      (if after-required-lambda-list
        (ldiff trimmed-lambda-list after-required-lambda-list)
        trimmed-lambda-list))))

(defun extract-specified-part (key lambda-list)
  (case key
    ((&eval &whole)
     (list (second (member key lambda-list))))
    (t
     (let ((here (cdr (member key lambda-list))))
       (ldiff here
              (member-if #'(lambda (it) (member it lambda-list-keywords))
                         here))))))

(defun extract-optional-part (lambda-list)
  (extract-specified-part '&optional lambda-list))

(defun parse-define-method-combination-args-lambda-list (lambda-list)
  ;; Define-method-combination Arguments Lambda Lists
  ;; http://www.lispworks.com/reference/HyperSpec/Body/03_dj.htm
  (let ((required (extract-required-part lambda-list))
        (whole    (extract-specified-part '&whole    lambda-list))
        (optional (extract-specified-part '&optional lambda-list))
        (rest     (extract-specified-part '&rest     lambda-list))
        (keys     (extract-specified-part '&key      lambda-list))
        (aux      (extract-specified-part '&aux      lambda-list)))
    (values (first whole)
            required
            (mapcar #'(lambda (spec)
                       (if (consp spec)
                           `(,(first spec) ,(second spec) ,@(cddr spec))
                           `(,spec nil)))
                    optional)
            (first rest)
            (mapcar #'(lambda (spec)
                       (let ((key (if (consp spec) (car spec) spec))
                             (rest (when (consp spec) (rest spec))))
                         `(,(if (consp key) key `(,(make-keyword key) ,key))
                           ,(car rest)
                           ,@(cdr rest))))
                    keys)
            (mapcar #'(lambda (spec)
                       (if (consp spec)
                           `(,(first spec) ,(second spec))
                           `(,spec nil)))
                    aux))))

(defun wrap-with-call-method-macro (gf args-var emf-form)
  `(macrolet
       ((call-method (method &optional next-method-list)
          `(funcall
            ,(cond
              ((listp method)
               (assert (eq (first method) 'make-method))
               ;; by generating an inline expansion we prevent allocation
               ;; of a method instance which will be discarded immediately
               ;; after reading the METHOD-FUNCTION slot
               (compute-method-function
                    `(lambda (&rest ,(gensym))
                       ;; the MAKE-METHOD body form gets evaluated in
                       ;; the null lexical environment augmented
                       ;; with a binding for CALL-METHOD
                       ,(wrap-with-call-method-macro ,gf
                                                     ',args-var
                                                     (second method)))))
              (t (method-function method)))
            ,',args-var
            ,(unless (null next-method-list)
                     ;; by not generating an emf when there are no next methods,
                     ;; we ensure next-method-p returns NIL
                     (compute-effective-method
                      ,gf (generic-function-method-combination ,gf)
                      (process-next-method-list next-method-list))))))
     ,emf-form))

(defun assert-unambiguous-method-sorting (group-name methods)
  (let ((specializers (make-hash-table :test 'equal)))
    (dolist (method methods)
      (push method (gethash (method-specializers method) specializers)))
    (loop for specializer-methods being each hash-value of specializers
       using (hash-key method-specializers)
       unless (= 1 (length specializer-methods))
       do (error "Ambiguous method sorting in method group ~A due to multiple ~
                  methods with specializers ~S: ~S"
                 group-name method-specializers specializer-methods))))

(defmacro with-method-groups (method-group-specs methods-form &body forms)
  (flet ((grouping-form (spec methods-var)
           (let ((predicate (coerce-to-function (getf spec :predicate)))
                 (group (gensym))
                 (leftovers (gensym))
                 (method (gensym)))
             `(let ((,group '())
                    (,leftovers '()))
                (dolist (,method ,methods-var)
                  (if (funcall ,predicate (method-qualifiers ,method))
                      (push ,method ,group)
                      (push ,method ,leftovers)))
                (ecase ,(getf spec :order)
                  (:most-specific-last )
                  (:most-specific-first (setq ,group (nreverse ,group))))
                ,@(when (getf spec :required)
                        `((when (null ,group)
                            (error "Method group ~S must not be empty."
                                   ',(getf spec :name)))))
                (setq ,methods-var (nreverse ,leftovers))
                ,group))))
    (let ((rest (gensym))
          (method (gensym)))
      `(let* ((,rest ,methods-form)
              ,@(mapcar #'(lambda (spec)
                           `(,(getf spec :name) ,(grouping-form spec rest)))
                        method-group-specs))
         (dolist (,method ,rest)
           (invalid-method-error ,method
                                 "Method ~S with qualifiers ~S does not belong to any method group."
                                 ,method (method-qualifiers ,method)))
         ,@(unless (and (= 1 (length method-group-specs))
                        (getf (car method-group-specs) :*-selecter))
             (mapcar #'(lambda (spec)
                         `(assert-unambiguous-method-sorting ',(getf spec :name) ,(getf spec :name)))
                     method-group-specs))
         ,@forms))))

(defun method-combination-type-lambda-with-args-emf
    (&key args-lambda-list generic-function-symbol forms &allow-other-keys)
  (multiple-value-bind
        (whole required optional rest keys aux)
      (parse-define-method-combination-args-lambda-list args-lambda-list)
    (unless rest
      (when keys
        (setf rest (gensym))))
    (let* ((gf-lambda-list (gensym))
           (args-var (gensym))
           (args-len-var (gensym))
           (binding-forms (gensym))
           (needs-args-len-var (gensym))
           (emf-form (gensym)))
      `(let* ((,gf-lambda-list (slot-value ,generic-function-symbol
                                           'sys::lambda-list))
              (nreq (length (extract-required-part ,gf-lambda-list)))
              (nopt (length (extract-optional-part ,gf-lambda-list)))
              (,binding-forms)
              (,needs-args-len-var)
              (,emf-form
               (let* (,@(when whole
                              `((,whole (progn
                                          (push `(,',whole ,',args-var)
                                                ,binding-forms)
                                          ',args-var))))
                      ,@(when rest
                              ;; ### TODO: use a fresh symbol for the rest
                              ;;   binding being generated and pushed into binding-forms
                              `((,rest (progn
                                         (push `(,',rest
                                                 (subseq ,',args-var
                                                          ,(+ nreq nopt)))
                                               ,binding-forms)
                                         ',rest))))
                        ,@(loop for var in required and i upfrom 0
                               for var-binding = (gensym)
                             collect `(,var (when (< ,i nreq)
                                              (push `(,',var-binding
                                                      (nth ,,i ,',args-var))
                                                    ,binding-forms)
                                              ',var-binding)))
                        ,@(loop for (var initform supplied-var) in optional
                             and i upfrom 0
                             for supplied-binding = (or supplied-var (gensym))
                             for var-binding = (gensym)
                             ;; check for excess parameters
                             ;; only assign initform if the parameter
                             ;; isn't in excess: the spec says explicitly
                             ;; to bind parameters in excess to forms evaluating
                             ;; to nil.
                             ;; This leaves initforms to be used with
                             ;; parameters not supplied in excess, but
                             ;; not available in the arguments list
                             ;;
                             ;; Also, if specified, bind "supplied-p"
                             collect `(,supplied-binding
                                       (when (< ,i nopt)
                                         (setq ,needs-args-len-var t)
                              ;; ### TODO: use a fresh symbol for the supplied binding
                              ;;   binding being generated and pushed into binding-forms
                                         (push `(,',supplied-binding
                                                 (< ,(+ ,i nreq) ,',args-len-var))
                                               ,binding-forms)
                                         ',supplied-binding))
                             collect `(,var (when (< ,i nopt)
                                              (push `(,',var-binding
                                                      (if ,',supplied-binding
                                                          (nth ,(+ ,i nreq)
                                                               ,',args-var)
                                                          ,',initform))
                                                    ,binding-forms)
                                              ',var-binding)))
                        ,@(loop for ((key var) initform supplied-var) in keys
                             for supplied-binding = (or supplied-var (gensym))
                             for var-binding = (gensym)
                             ;; Same as optional parameters:
                             ;; even though keywords can't be supplied in
                             ;; excess, we should bind "supplied-p" in case
                             ;; the key isn't supplied in the arguments list
                             collect `(,supplied-binding
                                       (progn
                              ;; ### TODO: use a fresh symbol for the rest
                              ;;   binding being generated and pushed into binding-forms
                                         (push `(,',supplied-binding
                                                 (member ,',key ,',rest))
                                               ,binding-forms)
                                         ',supplied-binding))
                             collect `(,var (progn
                                              (push `(,',var-binding
                                                      (if ,',supplied-binding
                                                          (cadr ,',supplied-binding)
                                                          ,',initform))
                                                    ,binding-forms)
                                              ',var-binding)))
                        ,@(loop for (var initform) in aux
                             for var-binding = (gensym)
                             collect `(,var (progn
                                              (push '(,var-binding ,initform)
                                                    ,binding-forms)
                                              ',var-binding))))
                 ,@forms)))
         `(lambda (,',args-var)
            ;; set up bindings to ensure the expressions to which the
            ;; variables of the arguments option have been bound are
            ;; evaluated exactly once.
            (let* (,@(when ,needs-args-len-var
                           `((,',args-len-var (length ,',args-var))))
                   ,@(reverse ,binding-forms))
              ;; This is the lambda which *is* the effective method
              ;; hence gets called on every method invocation
              ;; be as efficient in this method as we can be
              ,(wrap-with-call-method-macro ,generic-function-symbol
                                            ',args-var ,emf-form)))))))

(defun method-combination-type-lambda
  (&rest all-args
   &key name lambda-list args-lambda-list generic-function-symbol
        method-group-specs declarations forms &allow-other-keys)
  (declare (ignore name))
  (let ((methods (gensym))
        (args-var (gensym))
        (emf-form (gensym)))
    `(lambda (,generic-function-symbol ,methods ,@lambda-list)
       ;; This is the lambda which computes the effective method
       ,@declarations
       (with-method-groups ,method-group-specs
           ,methods
         ,(if (null args-lambda-list)
              `(let ((,emf-form (progn ,@forms)))
                 `(lambda (,',args-var)
                    ;; This is the lambda which *is* the effective method
                    ;; hence gets called on every method invocation
                    ;; be as efficient in this method as we can be
                    ,(wrap-with-call-method-macro ,generic-function-symbol
                                                  ',args-var ,emf-form)))
              (apply #'method-combination-type-lambda-with-args-emf all-args))))))

(defun declarationp (expr)
  (and (consp expr) (eq (car expr) 'DECLARE)))

(defun long-form-method-combination-args (args)
  ;; define-method-combination name lambda-list (method-group-specifier*) args
  ;; args ::= [(:arguments . args-lambda-list)]
  ;;          [(:generic-function generic-function-symbol)]
  ;;          [[declaration* | documentation]] form*
  (let ((rest args))
    (labels ((nextp (key) (and (consp (car rest)) (eq key (caar rest))))
             (args-lambda-list ()
               (when (nextp :arguments)
                 (prog1 (cdr (car rest)) (setq rest (cdr rest)))))
             (generic-function-symbol ()
                (if (nextp :generic-function)
                    (prog1 (second (car rest)) (setq rest (cdr rest)))
                    (gensym)))
             (declaration* ()
               (let ((end (position-if-not #'declarationp rest)))
                 (when end
                   (prog1 (subseq rest 0 end) (setq rest (nthcdr end rest))))))
             (documentation? ()
               (when (stringp (car rest))
                 (prog1 (car rest) (setq rest (cdr rest)))))
             (form* () rest))
      (let ((declarations '()))
        `(:args-lambda-list ,(args-lambda-list)
                            :generic-function-symbol ,(generic-function-symbol)
                            :documentation ,(prog2 (setq declarations (declaration*))
                                              (documentation?))
                            :declarations (,@declarations ,@(declaration*))
                            :forms ,(form*))))))

(defun define-long-form-method-combination (name lambda-list method-group-specs
                                                 &rest args)
  (let* ((initargs `(:name ,name
                     :lambda-list ,lambda-list
                     :method-group-specs ,method-group-specs
                     ,@(long-form-method-combination-args args)))
         (lambda-expression (apply #'method-combination-type-lambda initargs)))
    (setf (get name 'method-combination-object)
          (apply '%make-long-method-combination
                 :function (coerce-to-function lambda-expression) initargs))
    name))

(defun std-find-method-combination (gf name options)
  (declare (ignore gf))
  (when (and (eql name 'standard) options)
    ;; CLHS DEFGENERIC
    (error "The standard method combination does not accept any arguments."))
  (let ((mc (get name 'method-combination-object)))
    (cond
      ((null mc) (error "Method combination ~S not found" name))
      ((null options) mc)
      ((typep mc 'short-method-combination)
       (make-instance
        'short-method-combination
        :name name
        :documentation (method-combination-documentation mc)
        :operator (short-method-combination-operator mc)
        :identity-with-one-argument
        (short-method-combination-identity-with-one-argument mc)
        :options options))
      ((typep mc 'long-method-combination)
       (make-instance
        'long-method-combination
        :name name
        :documentation (method-combination-documentation mc)
        :lambda-list (long-method-combination-lambda-list mc)
        :method-group-specs (long-method-combination-method-group-specs mc)
        :args-lambda-list (long-method-combination-args-lambda-list mc)
        :generic-function-symbol (long-method-combination-generic-function-symbol mc)
        :function (long-method-combination-function mc)
        :arguments (long-method-combination-arguments mc)
        :declarations (long-method-combination-declarations mc)
        :forms (long-method-combination-forms mc)
        :options options)))))

(declaim (notinline find-method-combination))
(defun find-method-combination (gf name options)
  (std-find-method-combination gf name options))

(defconstant +the-standard-method-combination+
  (let ((instance (std-allocate-instance (find-class 'method-combination))))
    (setf (std-slot-value instance 'sys::name) 'standard)
    (setf (std-slot-value instance 'sys:%documentation)
          "The standard method combination.")
    (setf (std-slot-value instance 'options) nil)
    instance)
  "The standard method combination.
Do not use this object for identity since it changes between
compile-time and run-time.  To detect the standard method combination,
compare the method combination name to the symbol 'standard.")
(setf (get 'standard 'method-combination-object) +the-standard-method-combination+)

(defparameter *eql-specializer-table* (make-hash-table :test 'eql))

(defun intern-eql-specializer (object)
  (or (gethash object *eql-specializer-table*)
      (setf (gethash object *eql-specializer-table*)
            ;; we will be called during generic function invocation
            ;; setup, so have to rely on plain functions here.
            (let ((instance (std-allocate-instance (find-class 'eql-specializer))))
              (setf (std-slot-value instance 'object) object)
              (setf (std-slot-value instance 'direct-methods) nil)
              instance))))

(defun eql-specializer-object (eql-specializer)
  (check-type eql-specializer eql-specializer)
  (std-slot-value eql-specializer 'object))

;;; Initial versions of some method metaobject readers.  Defined on
;;; AMOP pg. 218ff, will be redefined when generic functions are set up.

(defun std-method-function (method)
  (std-slot-value method 'sys::%function))

(defun std-method-generic-function (method)
  (std-slot-value method 'sys::%generic-function))

(defun std-method-specializers (method)
  (std-slot-value method 'sys::specializers))

(defun std-method-qualifiers (method)
  (std-slot-value method 'sys::qualifiers))

(defun std-accessor-method-slot-definition (accessor-method)
  (std-slot-value accessor-method 'sys::%slot-definition))

;;; Additional method readers
(defun std-method-fast-function (method)
  (std-slot-value method 'sys::fast-function))

(defun std-function-keywords (method)
  (values (std-slot-value method 'sys::keywords)
          (std-slot-value method 'sys::other-keywords-p)))

;;; Preliminary accessor definitions, will be redefined as generic
;;; functions later in this file

(declaim (notinline method-generic-function))
(defun method-generic-function (method)
  (std-method-generic-function method))

(declaim (notinline method-function))
(defun method-function (method)
  (std-method-function method))

(declaim (notinline method-specializers))
(defun method-specializers (method)
  (std-method-specializers method))

(declaim (notinline method-qualifiers))
(defun method-qualifiers (method)
  (std-method-qualifiers method))



;; MOP (p. 216) specifies the following reader generic functions:
;;   generic-function-argument-precedence-order
;;   generic-function-declarations
;;   generic-function-lambda-list
;;   generic-function-method-class
;;   generic-function-method-combination
;;   generic-function-methods
;;   generic-function-name

;;; These are defined with % in package SYS, defined as functions here
;;; and redefined as generic functions once we're all set up.

(defun generic-function-name (gf)
  (%generic-function-name gf))

(defun generic-function-lambda-list (gf)
  (%generic-function-lambda-list gf))
(defsetf generic-function-lambda-list %set-generic-function-lambda-list)

(defun (setf generic-function-documentation) (new-value gf)
  (set-generic-function-documentation gf new-value))

(defun (setf generic-function-initial-methods) (new-value gf)
  (set-generic-function-initial-methods gf new-value))

(defun generic-function-methods (gf)
  (sys:%generic-function-methods gf))
(defun (setf generic-function-methods) (new-value gf)
  (set-generic-function-methods gf new-value))

(defun generic-function-method-class (gf)
  (sys:%generic-function-method-class gf))
(defun (setf generic-function-method-class) (new-value gf)
  (set-generic-function-method-class gf new-value))

(defun generic-function-method-combination (gf)
  (sys:%generic-function-method-combination gf))
(defun (setf generic-function-method-combination) (new-value gf)
  (assert (typep new-value 'method-combination))
  (set-generic-function-method-combination gf new-value))

(defun generic-function-argument-precedence-order (gf)
  (sys:%generic-function-argument-precedence-order gf))
(defun (setf generic-function-argument-precedence-order) (new-value gf)
  (set-generic-function-argument-precedence-order gf new-value))

(declaim (ftype (function * t) classes-to-emf-table))
(defun classes-to-emf-table (gf)
  (generic-function-classes-to-emf-table gf))

(defun (setf classes-to-emf-table) (new-value gf)
  (set-generic-function-classes-to-emf-table gf new-value))

(defun (setf method-lambda-list) (new-value method)
  (setf (std-slot-value method 'sys::lambda-list) new-value))

(defun (setf method-qualifiers) (new-value method)
  (setf (std-slot-value method 'sys::qualifiers) new-value))

(defun method-documentation (method)
  (std-slot-value method 'sys:%documentation))

(defun (setf method-documentation) (new-value method)
  (setf (std-slot-value method 'sys:%documentation) new-value))

;;; defgeneric

(defmacro defgeneric (function-name lambda-list
                                    &rest options-and-method-descriptions)
  (let ((options ())
        (methods ())
        (declarations ())
        (documentation nil))
    (dolist (item options-and-method-descriptions)
      (case (car item)
        (declare
         (setf declarations (append declarations (cdr item))))
        (:documentation
         (when documentation
           (error 'program-error
                  :format-control "Documentation option was specified twice for generic function ~S."
                  :format-arguments (list function-name)))
         (setf documentation t)
         (push item options))
        (:method
         (push
          `(push (defmethod ,function-name ,@(cdr item))
                 (generic-function-initial-methods (fdefinition ',function-name)))
          methods))
        (t
         (push item options))))
    (when declarations (push (list :declarations declarations) options))
    (setf options (nreverse options)
          methods (nreverse methods))
    ;;; Since DEFGENERIC currently shares its argument parsing with
    ;;; DEFMETHOD, we perform this check here.
    (when (find '&aux lambda-list)
      (error 'program-error
             :format-control "&AUX is not allowed in a generic function lambda list: ~S"
             :format-arguments (list lambda-list)))
    `(prog1
       (%defgeneric
        ',function-name
        :lambda-list ',lambda-list
        ,@(canonicalize-defgeneric-options options))
       ,@methods)))

(defun canonicalize-defgeneric-options (options)
  (mapappend #'canonicalize-defgeneric-option options))

(defun canonicalize-defgeneric-option (option)
  (case (car option)
    (:generic-function-class
     (list :generic-function-class `(find-class ',(cadr option))))
    (:method-class
     (list :method-class `(find-class ',(cadr option))))
    (:method-combination
     (list :method-combination `',(cdr option)))
    (:argument-precedence-order
     (list :argument-precedence-order `',(cdr option)))
    (t
     (list `',(car option) `',(cadr option)))))

;; From OpenMCL (called canonicalize-argument-precedence-order there,
;; but AMOP specifies argument-precedence-order to return a permutation
;; of the required arguments, not a list of indices, so we calculate
;; them on demand).
(defun argument-precedence-order-indices (apo req)
  (cond ((equal apo req) nil)
        ((not (eql (length apo) (length req)))
         (error 'program-error
                :format-control "Specified argument precedence order ~S does not match lambda list."
                :format-arguments (list apo)))
        (t (let ((res nil))
             (dolist (arg apo (nreverse res))
               (let ((index (position arg req)))
                 (if (or (null index) (memq index res))
                     (error 'program-error
                            :format-control "Specified argument precedence order ~S does not match lambda list."
                            :format-arguments (list apo)))
                 (push index res)))))))

(defun find-generic-function (name &optional (errorp t))
  (let ((function (and (fboundp name) (fdefinition name))))
    (when function
      (when (typep function 'generic-function)
        (return-from find-generic-function function))
      (when (and *traced-names* (find name *traced-names* :test #'equal))
        (setf function (untraced-function name))
        (when (typep function 'generic-function)
          (return-from find-generic-function function)))))
  (if errorp
      (error "There is no generic function named ~S." name)
      nil))

(defun lambda-lists-congruent-p (lambda-list1 lambda-list2)
  (let* ((plist1 (analyze-lambda-list lambda-list1))
         (args1 (getf plist1 :required-args))
         (plist2 (analyze-lambda-list lambda-list2))
         (args2 (getf plist2 :required-args)))
    (= (length args1) (length args2))))

(defun %defgeneric (function-name &rest all-keys)
  (when (fboundp function-name)
    (let ((gf (fdefinition function-name)))
      (when (typep gf 'generic-function)
        ;; Remove methods defined by previous DEFGENERIC forms, as
        ;; specified by CLHS, 7.7 (Macro DEFGENERIC).
        (dolist (method (generic-function-initial-methods gf))
          (if (eq  (class-of gf) +the-standard-generic-function-class+)
              (progn
                (std-remove-method gf method)
                (map-dependents gf
                                #'(lambda (dep)
                                    (update-dependent gf dep
                                                      'remove-method method))))
              (remove-method gf method)))
        (setf (generic-function-initial-methods gf) '()))))
  (apply 'ensure-generic-function function-name all-keys))

;;; Bootstrap version of ensure-generic-function, handling only
;;; standard-generic-function.  This function is replaced later.
(declaim (notinline ensure-generic-function))
(defun ensure-generic-function (function-name
                                &rest all-keys
                                &key
                                (lambda-list nil lambda-list-supplied-p)
                                (generic-function-class +the-standard-generic-function-class+)
                                (method-class +the-standard-method-class+)
                                (method-combination +the-standard-method-combination+ mc-p)
                                argument-precedence-order
                                (documentation nil documentation-supplied-p)
                                &allow-other-keys)
  (setf all-keys (copy-list all-keys))  ; since we modify it
  (remf all-keys :generic-function-class)
  (let ((gf (find-generic-function function-name nil)))
    (if gf
        (progn
          (when lambda-list-supplied-p
            (unless (or (null (generic-function-methods gf))
                        (lambda-lists-congruent-p lambda-list
                                                  (generic-function-lambda-list gf)))
              (error 'simple-error
                     :format-control "The lambda list ~S is incompatible with the existing methods of ~S."
                     :format-arguments (list lambda-list gf)))
            (setf (generic-function-lambda-list gf) lambda-list)
            (let* ((plist (analyze-lambda-list lambda-list))
                   (required-args (getf plist ':required-args)))
              (%set-gf-required-args gf required-args)
              (%set-gf-optional-args gf (getf plist :optional-args))))
          (setf (generic-function-argument-precedence-order gf)
                (or argument-precedence-order (gf-required-args gf)))
          (when documentation-supplied-p
            (setf (generic-function-documentation gf) documentation))
          (finalize-standard-generic-function gf)
          gf)
        (progn
          (when (and (null *clos-booting*)
                     (and (fboundp function-name)
                          ;; since we're overwriting an autoloader,
                          ;; we're probably meant to redefine it,
                          ;; so throwing an error here might be a bad idea.
                          ;; also, resolving the symbol isn't
                          ;; a good option either: we've seen that lead to
                          ;; recursive loading of the same file
                          (and (not (autoloadp function-name))
                               (and (consp function-name)
                                    (eq 'setf (first function-name))
                                    (not (autoload-ref-p (second function-name)))))))
            (error 'program-error
                   :format-control "~A already names an ordinary function, macro, or special operator."
                   :format-arguments (list function-name)))
          (when mc-p
            (error "Preliminary ensure-method does not support :method-combination argument."))
          (setf gf (apply (if (eq generic-function-class
                                  +the-standard-generic-function-class+)
                              #'make-instance-standard-generic-function
                              #'make-instance)
                          generic-function-class
                          :name function-name
                          :method-class method-class
                          :method-combination method-combination
                          all-keys))
          gf))))

(defun collect-eql-specializer-objects (generic-function)
  (let ((result nil))
    (dolist (method (generic-function-methods generic-function))
      (dolist (specializer (method-specializers method))
        (when (typep specializer 'eql-specializer)
          (pushnew (eql-specializer-object specializer)
                   result
                   :test 'eql))))
    result))

(defun finalize-standard-generic-function (gf)
  (%finalize-generic-function gf)
  (unless (generic-function-classes-to-emf-table gf)
    (set-generic-function-classes-to-emf-table gf (make-hash-table :test #'equal)))
  (clrhash (generic-function-classes-to-emf-table gf))
  (%init-eql-specializations gf (collect-eql-specializer-objects gf))
  (set-funcallable-instance-function
   gf
   (if (eq (class-of gf) +the-standard-generic-function-class+)
       (std-compute-discriminating-function gf)
       (compute-discriminating-function gf)))
  ;; FIXME Do we need to warn on redefinition somewhere else?
  (let ((*warn-on-redefinition* nil))
    (setf (fdefinition (%generic-function-name gf)) gf))
  (values))

(defun make-instance-standard-generic-function (generic-function-class
                                                &key name lambda-list
                                                (method-class +the-standard-method-class+)
                                                (method-combination +the-standard-method-combination+)
                                                argument-precedence-order
                                                declarations
                                                documentation)
  ;; to avoid circularities, we do not call generic functions in here.
  (declare (ignore generic-function-class))
  (check-argument-precedence-order lambda-list argument-precedence-order)
  (let ((gf (std-allocate-instance +the-standard-generic-function-class+)))
    (unless (classp method-class) (setf method-class (find-class method-class)))
    (unless (typep method-combination 'method-combination)
      (setf method-combination
            (find-method-combination
             gf (car method-combination) (cdr method-combination))))
    (%set-generic-function-name gf name)
    (%set-generic-function-lambda-list gf lambda-list)
    (set-generic-function-initial-methods gf ())
    (set-generic-function-methods gf ())
    (set-generic-function-method-class gf method-class)
    (set-generic-function-method-combination gf method-combination)
    (set-generic-function-declarations gf declarations)
    (set-generic-function-documentation gf documentation)
    (set-generic-function-classes-to-emf-table gf nil)
    (let* ((plist (analyze-lambda-list (generic-function-lambda-list gf)))
           (required-args (getf plist ':required-args)))
      (%set-gf-required-args gf required-args)
      (%set-gf-optional-args gf (getf plist :optional-args))
      (set-generic-function-argument-precedence-order
       gf (or argument-precedence-order required-args)))
    (finalize-standard-generic-function gf)
    gf))

(defun canonicalize-specializers (specializers)
  (mapcar #'canonicalize-specializer specializers))

(defun canonicalize-specializer (specializer)
  (cond ((classp specializer)
         specializer)
        ((typep specializer 'eql-specializer)
         specializer)
        ((symbolp specializer)
         (find-class specializer))
        ((and (consp specializer)
              (eq (car specializer) 'eql))
         (let ((object (cadr specializer)))
           (when (and (consp object)
                      (eq (car object) 'quote))
             (setf object (cadr object)))
           (intern-eql-specializer object)))
        ((and (consp specializer)
              (eq (car specializer) 'java:jclass))
         (let ((jclass (eval specializer)))
           (java::ensure-java-class jclass)))
        (t
         (error "Unknown specializer: ~S" specializer))))

(defun parse-defmethod (args)
  (let ((function-name (car args))
        (qualifiers ())
        (specialized-lambda-list ())
        (body ())
        (parse-state :qualifiers))
    (dolist (arg (cdr args))
      (ecase parse-state
        (:qualifiers
         (if (and (atom arg) (not (null arg)))
             (push arg qualifiers)
             (progn
               (setf specialized-lambda-list arg)
               (setf parse-state :body))))
        (:body (push arg body))))
    (setf qualifiers (nreverse qualifiers)
          body (nreverse body))
    (multiple-value-bind (real-body declarations documentation)
        (parse-body body)
      (values function-name
              qualifiers
              (extract-lambda-list specialized-lambda-list)
              (extract-specializer-names specialized-lambda-list)
              documentation
              declarations
              (list* 'block
                     (fdefinition-block-name function-name)
                     real-body)))))

(defun required-portion (gf args)
  (let ((number-required (length (gf-required-args gf))))
    (when (< (length args) number-required)
      (error 'program-error
             :format-control "Not enough arguments for generic function ~S."
             :format-arguments (list (%generic-function-name gf))))
    (subseq args 0 number-required)))

(defun extract-lambda-list (specialized-lambda-list)
  (let* ((plist (analyze-lambda-list specialized-lambda-list))
         (requireds (getf plist :required-names))
         (rv (getf plist :rest-var))
         (ks (getf plist :key-args))
         (keysp (getf plist :keysp))
         (aok (getf plist :allow-other-keys))
         (opts (getf plist :optional-args))
         (auxs (getf plist :auxiliary-args)))
    `(,@requireds
      ,@(if opts `(&optional ,@opts) ())
      ,@(if rv `(&rest ,rv) ())
      ,@(if (or ks keysp aok) `(&key ,@ks) ())
      ,@(if aok '(&allow-other-keys) ())
      ,@(if auxs `(&aux ,@auxs) ()))))

(defun extract-specializer-names (specialized-lambda-list)
  (let ((plist (analyze-lambda-list specialized-lambda-list)))
    (getf plist ':specializers)))

(defun get-keyword-from-arg (arg)
  (if (listp arg)
      (if (listp (car arg))
          (caar arg)
          (make-keyword (car arg)))
      (make-keyword arg)))

(defun analyze-lambda-list (lambda-list)
  (let ((keys ())           ; Just the keywords
        (key-args ())       ; Keywords argument specs
        (keysp nil)         ;
        (required-names ()) ; Just the variable names
        (required-args ())  ; Variable names & specializers
        (specializers ())   ; Just the specializers
        (rest-var nil)
        (optionals ())
        (auxs ())
        (allow-other-keys nil)
        (state :required))
    (dolist (arg lambda-list)
      (if (member arg lambda-list-keywords)
          (ecase arg
            (&optional
             (unless (eq state :required)
               (error 'program-error
                      :format-control "~A followed by &OPTIONAL not allowed ~
                                       in lambda list ~S"
                      :format-arguments (list state lambda-list)))
             (setq state '&optional))
            (&rest
             (unless (or (eq state :required)
                         (eq state '&optional))
               (error 'program-error
                      :format-control "~A followed by &REST not allowed ~
                                       in lambda list ~S"
                      :format-arguments (list state lambda-list)))
             (setq state '&rest))
            (&key
             (unless (or (eq state :required)
                         (eq state '&optional)
                         (eq state '&rest))
               (error 'program-error
                      :format-control "~A followed by &KEY not allowed
                                       in lambda list ~S"
                      :format-arguments (list state lambda-list)))
             (setq keysp t)
             (setq state '&key))
            (&allow-other-keys
             (unless (eq state '&key)
               (error 'program-error
                      :format-control "&ALLOW-OTHER-KEYS not allowed while
                                       parsing ~A in lambda list ~S"
                      :format-arguments (list state lambda-list)))
             (setq allow-other-keys 't))
            (&aux
             ;; &aux comes last; any other previous state is fine
             (setq state '&aux)))
          (case state
            (:required
             (push-on-end arg required-args)
             (if (listp arg)
                 (progn (push-on-end (car arg) required-names)
                   (push-on-end (cadr arg) specializers))
                 (progn (push-on-end arg required-names)
                   (push-on-end 't specializers))))
            (&optional (push-on-end arg optionals))
            (&rest (setq rest-var arg))
            (&key
             (push-on-end (get-keyword-from-arg arg) keys)
             (push-on-end arg key-args))
            (&aux (push-on-end arg auxs)))))
    (list  :required-names required-names
           :required-args required-args
           :specializers specializers
           :rest-var rest-var
           :keywords keys
           :key-args key-args
           :keysp keysp
           :auxiliary-args auxs
           :optional-args optionals
           :allow-other-keys allow-other-keys)))

#+nil
(defun check-method-arg-info (gf arg-info method)
  (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
      (analyze-lambda-list (if (consp method)
                               (early-method-lambda-list method)
                               (method-lambda-list method)))
    (flet ((lose (string &rest args)
                 (error 'simple-program-error
                        :format-control "~@<attempt to add the method~2I~_~S~I~_~
                        to the generic function~2I~_~S;~I~_~
                        but ~?~:>"
                        :format-arguments (list method gf string args)))
           (comparison-description (x y)
                                   (if (> x y) "more" "fewer")))
      (let ((gf-nreq (arg-info-number-required arg-info))
            (gf-nopt (arg-info-number-optional arg-info))
            (gf-key/rest-p (arg-info-key/rest-p arg-info))
            (gf-keywords (arg-info-keys arg-info)))
        (unless (= nreq gf-nreq)
          (lose
           "the method has ~A required arguments than the generic function."
           (comparison-description nreq gf-nreq)))
        (unless (= nopt gf-nopt)
          (lose
           "the method has ~A optional arguments than the generic function."
           (comparison-description nopt gf-nopt)))
        (unless (eq (or keysp restp) gf-key/rest-p)
          (lose
           "the method and generic function differ in whether they accept~_~
            &REST or &KEY arguments."))
        (when (consp gf-keywords)
          (unless (or (and restp (not keysp))
                      allow-other-keys-p
                      (every (lambda (k) (memq k keywords)) gf-keywords))
            (lose "the method does not accept each of the &KEY arguments~2I~_~
            ~S."
                  gf-keywords)))))))

(defun check-method-lambda-list (name method-lambda-list gf-lambda-list)
  (let* ((gf-restp (not (null (memq '&rest gf-lambda-list))))
         (gf-plist (analyze-lambda-list gf-lambda-list))
         (gf-keysp (getf gf-plist :keysp))
         (gf-keywords (getf gf-plist :keywords))
         (method-plist (analyze-lambda-list method-lambda-list))
         (method-restp (not (null (memq '&rest method-lambda-list))))
         (method-keysp (getf method-plist :keysp))
         (method-keywords (getf method-plist :keywords))
         (method-allow-other-keys-p (getf method-plist :allow-other-keys)))
    (unless (= (length (getf gf-plist :required-args))
               (length (getf method-plist :required-args)))
      (error "The method-lambda-list ~S ~
              has the wrong number of required arguments ~
              for the generic function ~S." method-lambda-list name))
    (unless (= (length (getf gf-plist :optional-args))
               (length (getf method-plist :optional-args)))
      (error "The method-lambda-list ~S ~
              has the wrong number of optional arguments ~
              for the generic function ~S." method-lambda-list name))
    (unless (eq (or gf-restp gf-keysp) (or method-restp method-keysp))
      (error "The method-lambda-list ~S ~
              and the generic function ~S ~
              differ in whether they accept &REST or &KEY arguments."
             method-lambda-list name))
    (when (consp gf-keywords)
      (unless (or (and method-restp (not method-keysp))
                  method-allow-other-keys-p
                  (every (lambda (k) (memq k method-keywords)) gf-keywords))
        (error "The method-lambda-list ~S does not accept ~
                all of the keyword arguments defined for the ~
                generic function." method-lambda-list name)))))

(defun check-argument-precedence-order (lambda-list argument-precedence-order)
  (when argument-precedence-order
    (if lambda-list
        ;; raising the required program-errors is a side-effect of
        ;; calculating the given permutation of apo vs req
        (argument-precedence-order-indices
         argument-precedence-order
         (getf (analyze-lambda-list lambda-list) :required-args))
        ;; AMOP pg. 198
        (error 'program-error "argument precedence order specified without lambda list"))))

(defvar *gf-initialize-instance* nil
  "Cached value of the INITIALIZE-INSTANCE generic function.
Initialized with the true value near the end of the file.")
(defvar *gf-allocate-instance* nil
  "Cached value of the ALLOCATE-INSTANCE generic function.
Initialized with the true value near the end of the file.")
(defvar *gf-shared-initialize* nil
  "Cached value of the SHARED-INITIALIZE generic function.
Initialized with the true value near the end of the file.")
(defvar *gf-reinitialize-instance* nil
  "Cached value of the REINITIALIZE-INSTANCE generic function.
Initialized with the true value near the end of the file.")

(declaim (ftype (function * method) ensure-method))
(defun ensure-method (name &rest all-keys)
  (let ((method-lambda-list (getf all-keys :lambda-list))
        (gf (find-generic-function name nil)))
    (when (or (eq gf *gf-initialize-instance*)
              (eq gf *gf-allocate-instance*)
              (eq gf *gf-shared-initialize*)
              (eq gf *gf-reinitialize-instance*))
      ;; ### Clearly, this can be targeted much more exact
      ;; as we only need to remove the specializing class and all
      ;; its subclasses from the hash.
      (clrhash *make-instance-initargs-cache*)
      (clrhash *reinitialize-instance-initargs-cache*))
    (if gf
        (check-method-lambda-list name method-lambda-list
                                  (generic-function-lambda-list gf))
        (setf gf (ensure-generic-function name :lambda-list method-lambda-list)))
    (let ((method
           (if (eq (generic-function-method-class gf) +the-standard-method-class+)
               (apply #'make-instance-standard-method gf all-keys)
               (apply #'make-instance (generic-function-method-class gf) all-keys))))
      (if (and
           (eq (generic-function-method-class gf) +the-standard-method-class+)
           (eq (class-of gf) +the-standard-generic-function-class+))
          (progn
            (std-add-method gf method)
            (map-dependents gf
                            #'(lambda (dep)
                                (update-dependent gf dep 'add-method method))))
          (add-method gf method))
      method)))

(defun make-instance-standard-method (gf
                                      &key
                                      lambda-list
                                      qualifiers
                                      specializers
                                      documentation
                                      function
                                      fast-function)
  (declare (ignore gf))
  (let ((method (std-allocate-instance +the-standard-method-class+))
        (analyzed-args (analyze-lambda-list lambda-list)))
    (setf (method-lambda-list method) lambda-list)
    (setf (method-qualifiers method) qualifiers)
    (setf (std-slot-value method 'sys::specializers)
          (canonicalize-specializers specializers))
    (setf (method-documentation method) documentation)
    (setf (std-slot-value method 'sys::%generic-function) nil) ; set by add-method
    (setf (std-slot-value method 'sys::%function) function)
    (setf (std-slot-value method 'sys::fast-function) fast-function)
    (setf (std-slot-value method 'sys::keywords) (getf analyzed-args :keywords))
    (setf (std-slot-value method 'sys::other-keywords-p)
          (getf analyzed-args :allow-other-keys))
    method))

;;; To be redefined as generic functions later
(declaim (notinline add-direct-method))
(defun add-direct-method (specializer method)
  (if (typep specializer 'eql-specializer)
      (pushnew method (std-slot-value specializer 'direct-methods))
      (pushnew method (class-direct-methods specializer))))

(declaim (notinline remove-direct-method))
(defun remove-direct-method (specializer method)
  (if (typep specializer 'eql-specializer)
      (setf (std-slot-value specializer 'direct-methods)
            (remove method (std-slot-value specializer 'direct-methods)))
      (setf (class-direct-methods specializer)
            (remove method (class-direct-methods specializer)))))

(defun std-add-method (gf method)
  ;; calls sites need to make sure that method is either a method of the
  ;; given gf or does not have a gf.
  (let ((old-method (%find-method gf (std-method-qualifiers method)
                                 (method-specializers method) nil)))
    (when old-method
      (if (and (eq (class-of gf) +the-standard-generic-function-class+)
               (eq (class-of old-method) +the-standard-method-class+))
          (std-remove-method gf old-method)
          (remove-method gf old-method))))
  (setf (std-slot-value method 'sys::%generic-function) gf)
  (push method (generic-function-methods gf))
  (dolist (specializer (method-specializers method))
    (add-direct-method specializer method))
  (finalize-standard-generic-function gf)
  gf)

(defun std-remove-method (gf method)
  (setf (generic-function-methods gf)
        (remove method (generic-function-methods gf)))
  (setf (std-slot-value method 'sys::%generic-function) nil)
  (dolist (specializer (method-specializers method))
    (remove-direct-method specializer method))
  (finalize-standard-generic-function gf)
  gf)

(defun %find-method (gf qualifiers specializers &optional (errorp t))
  ;; "If the specializers argument does not correspond in length to the number
  ;; of required arguments of the generic-function, an an error of type ERROR
  ;; is signaled."
  (unless (= (length specializers) (length (gf-required-args gf)))
    (error "The specializers argument has length ~S, but ~S has ~S required parameters."
           (length specializers)
           gf
           (length (gf-required-args gf))))
  (let* ((canonical-specializers (canonicalize-specializers specializers))
         (method
          (find-if #'(lambda (method)
                      (and (equal qualifiers
                                  (method-qualifiers method))
                           (equal canonical-specializers
                                  (method-specializers method))))
                   (generic-function-methods gf))))
    (if (and (null method) errorp)
        (error "No such method for ~S." (%generic-function-name gf))
        method)))

(defun fast-callable-p (gf)
  (and (eq (method-combination-name (generic-function-method-combination gf))
           'standard)
       (null (intersection (%generic-function-lambda-list gf)
                           '(&rest &optional &key &allow-other-keys &aux)))))

(declaim (ftype (function * t) slow-method-lookup-1))

(declaim (ftype (function (t t t) t) slow-reader-lookup))
(defun slow-reader-lookup (gf layout slot-name)
  (let ((location (layout-slot-location layout slot-name)))
    (cache-slot-location gf layout location)
    location))

(defun std-compute-discriminating-function (gf)
  ;; In this function, we know that gf is of class
  ;; standard-generic-function, so we call various
  ;; sys:%generic-function-foo readers to break circularities.
  (cond
    ((and (= (length (sys:%generic-function-methods gf)) 1)
          (eq (type-of (car (sys:%generic-function-methods gf))) 'standard-reader-method)
          (eq (type-of (car (std-method-specializers (%car (sys:%generic-function-methods gf))))) 'standard-class))
     ;; we are standard and can elide slot-value(-using-class)
     (let* ((method (%car (sys:%generic-function-methods gf)))
            (class (car (std-method-specializers method)))
            (slot-name (slot-definition-name (accessor-method-slot-definition method))))
       #'(lambda (arg)
           (declare (optimize speed))
           (let* ((layout (std-instance-layout arg))
                  (location (get-cached-slot-location gf layout)))
             (unless location
               (unless (simple-typep arg class)
                 ;; FIXME no applicable method
                 (error 'simple-type-error
                        :datum arg
                        :expected-type class))
               (setf location (slow-reader-lookup gf layout slot-name)))
             (let ((value (if (consp location)
                              (cdr location) ; :allocation :class
                              (funcallable-standard-instance-access arg location))))
               (if (eq value +slot-unbound+)
                   ;; fix SLOT-UNBOUND.5 from ansi test suite
                   (nth-value 0 (slot-unbound class arg slot-name))
                   value))))))

    (t
     (let* ((emf-table (classes-to-emf-table gf))
            (number-required (length (gf-required-args gf)))
            (lambda-list (%generic-function-lambda-list gf))
            (exact (null (intersection lambda-list
                                       '(&rest &optional &key
                                         &allow-other-keys))))
            (no-aux (null (some 
                           (lambda (method) 
                             (find '&aux (std-slot-value method 'sys::lambda-list)))
                           (sys:%generic-function-methods gf)))))
       (if (and exact
                no-aux)
           (cond
             ((= number-required 1)
              (cond
                ((and (eq (method-combination-name (sys:%generic-function-method-combination gf)) 'standard)
                      (= (length (sys:%generic-function-methods gf)) 1)
                      (std-method-fast-function (%car (sys:%generic-function-methods gf))))
                 (let* ((method (%car (sys:%generic-function-methods gf)))
                        (specializer (car (std-method-specializers method)))
                        (function (std-method-fast-function method)))
                   (if (typep specializer 'eql-specializer)
                       (let ((specializer-object (eql-specializer-object specializer)))
                         #'(lambda (arg)
                             (declare (optimize speed))
                             (if (eql arg specializer-object)
                                 (funcall function arg)
                                 (no-applicable-method gf (list arg)))))
                       #'(lambda (arg)
                           (declare (optimize speed))
                           (unless (simple-typep arg specializer)
                             ;; FIXME no applicable method
                             (error 'simple-type-error
                                    :datum arg
                                    :expected-type specializer))
                           (funcall function arg)))))
                (t
                 #'(lambda (arg)
                     (declare (optimize speed))
                     (let* ((specialization
                             (%get-arg-specialization gf arg))
                            (emfun (or (gethash1 specialization
                                                 emf-table)
                                       (slow-method-lookup-1
                                        gf arg specialization))))
                       (if emfun
                           (funcall emfun (list arg))
                           (apply #'no-applicable-method gf (list arg))))))))
             ((= number-required 2)
              #'(lambda (arg1 arg2)
                  (declare (optimize speed))
                  (let* ((args (list arg1 arg2))
                         (emfun (get-cached-emf gf args)))
                    (if emfun
                        (funcall emfun args)
                        (slow-method-lookup gf args)))))
             ((= number-required 3)
              #'(lambda (arg1 arg2 arg3)
                  (declare (optimize speed))
                  (let* ((args (list arg1 arg2 arg3))
                         (emfun (get-cached-emf gf args)))
                    (if emfun
                        (funcall emfun args)
                        (slow-method-lookup gf args)))))
             (t
              #'(lambda (&rest args)
                  (declare (optimize speed))
                  (let ((len (length args)))
                    (unless (= len number-required)
                      (error 'program-error
                             :format-control "Not enough arguments for generic function ~S."
                             :format-arguments (list (%generic-function-name gf)))))
                  (let ((emfun (get-cached-emf gf args)))
                    (if emfun
                        (funcall emfun args)
                        (slow-method-lookup gf args))))))
           ;;           (let ((non-key-args (+ number-required
           ;;                                  (length (gf-optional-args gf))))))
           #'(lambda (&rest args)
               (declare (optimize speed))
               (let ((len (length args)))
                 (unless (>= len number-required)
                   (error 'program-error
                          :format-control "Not enough arguments for generic function ~S."
                          :format-arguments (list (%generic-function-name gf)))))
               (let ((emfun (get-cached-emf gf args)))
                 (if emfun
                     (funcall emfun args)
                     (slow-method-lookup gf args)))))))))

(defun sort-methods (methods gf required-classes)
  (if (or (null methods) (null (%cdr methods)))
      methods
      (sort methods
            (if (eq (class-of gf) +the-standard-generic-function-class+)
                (let ((method-indices
                       (argument-precedence-order-indices
                        (generic-function-argument-precedence-order gf)
                        (getf (analyze-lambda-list (generic-function-lambda-list gf))
                              ':required-args))))
                  #'(lambda (m1 m2)
                      (std-method-more-specific-p
                       m1 m2 required-classes method-indices)))
                #'(lambda (m1 m2)
                    (method-more-specific-p gf m1 m2 required-classes))))))

(defun method-applicable-p (method args)
  (do* ((specializers (method-specializers method) (cdr specializers))
        (args args (cdr args)))
       ((null specializers) t)
    (let ((specializer (car specializers)))
      (if (typep specializer 'eql-specializer)
          (unless (eql (car args) (eql-specializer-object specializer))
            (return nil))
          (unless (subclassp (class-of (car args)) specializer)
            (return nil))))))

(defun std-compute-applicable-methods (gf args)
  (let ((required-classes (mapcar #'class-of (required-portion gf args)))
        (methods '()))
    (dolist (method (generic-function-methods gf))
      (when (method-applicable-p method args)
        (push method methods)))
    (sort-methods methods gf required-classes)))

(declaim (notinline compute-applicable-methods))
(defun compute-applicable-methods (gf args)
  (std-compute-applicable-methods gf args))

;;; METHOD-APPLICABLE-USING-CLASSES-P
;;;
;;; If the first return value is T, METHOD is definitely applicable to
;;; arguments that are instances of CLASSES.  If the first value is
;;; NIL and the second value is T, METHOD is definitely not applicable
;;; to arguments that are instances of CLASSES; if the second value is
;;; NIL the applicability of METHOD cannot be determined by inspecting
;;; the classes of its arguments only.
;;;
(defun method-applicable-using-classes-p (method classes)
  (do* ((specializers (method-specializers method) (cdr specializers))
        (classes classes (cdr classes))
        (knownp t))
       ((null specializers)
        (if knownp (values t t) (values nil nil)))
    (let ((specializer (car specializers)))
      (if (typep specializer 'eql-specializer)
          (if (eql (class-of (eql-specializer-object specializer)) 
                   (car classes))
              (setf knownp nil)
              (return (values nil t)))
          (unless (subclassp (car classes) specializer)
            (return (values nil t)))))))

(defun check-applicable-method-keyword-args (gf args
                                             keyword-args
                                             applicable-keywords)
  (when (oddp (length keyword-args))
    (error 'program-error
           :format-control "Odd number of keyword arguments in call to ~S ~
with arguments list ~S"
           :format-arguments (list gf args)))
  (unless (getf keyword-args :allow-other-keys)
    (loop for key in keyword-args by #'cddr
       unless (or (member key applicable-keywords)
                  (eq key :allow-other-keys))
       do (error 'program-error
                 :format-control "Invalid keyword argument ~S in call ~
to ~S with argument list ~S."
                 :format-arguments (list key gf args)))))

(defun compute-applicable-keywords (gf applicable-methods)
  (let ((applicable-keywords
         (getf (analyze-lambda-list (generic-function-lambda-list gf))
               :keywords)))
    (loop for method in applicable-methods
       do (multiple-value-bind
                (keywords allow-other-keys)
              (function-keywords method)
            (when allow-other-keys
              (setf applicable-keywords :any)
              (return))
            (setf applicable-keywords
                  (union applicable-keywords keywords))))
    applicable-keywords))

(defun wrap-emfun-for-keyword-args-check (gf emfun non-keyword-args
                                          applicable-keywords)
  #'(lambda (args)
      (check-applicable-method-keyword-args
         gf args
         (nthcdr non-keyword-args args) applicable-keywords)
      (funcall emfun args)))

(defun slow-method-lookup (gf args)
  (let ((applicable-methods
          (if (eq (class-of gf) +the-standard-generic-function-class+)
              (std-compute-applicable-methods gf args)
              (or (compute-applicable-methods-using-classes gf (mapcar #'class-of args))
                  (compute-applicable-methods gf args)))))
    (if applicable-methods
        (let* ((emfun (funcall (if (eq (class-of gf)
                                       +the-standard-generic-function-class+)
                                   #'std-compute-effective-method
                                   #'compute-effective-method)
                               gf (generic-function-method-combination gf)
                               applicable-methods))
               (non-keyword-args (+ (length (gf-required-args gf))
                                    (length (gf-optional-args gf))))
               (gf-lambda-list (generic-function-lambda-list gf))
               (checks-required (and (member '&key gf-lambda-list)
                                     (not (member '&allow-other-keys
                                                  gf-lambda-list))))
              (applicable-keywords
               (when checks-required
                 ;; Don't do applicable keyword checks when this is
                 ;; one of the 'exceptional four' or when the gf allows
                 ;; other keywords.
                 (compute-applicable-keywords gf applicable-methods))))
          (when (and checks-required
                     (not (eq applicable-keywords :any)))
            (setf emfun
                  (wrap-emfun-for-keyword-args-check gf emfun non-keyword-args
                                                     applicable-keywords)))
          (cache-emf gf args emfun)
          (funcall emfun args))
        (apply #'no-applicable-method gf args))))

(defun slow-method-lookup-1 (gf arg arg-specialization)
  (let ((applicable-methods
          (if (eq (class-of gf) +the-standard-generic-function-class+)
              (std-compute-applicable-methods gf (list arg))
              (or (compute-applicable-methods-using-classes gf (list (class-of arg)))
                  (compute-applicable-methods gf (list arg))))))
    (if applicable-methods
        (let ((emfun (funcall (if (eq (class-of gf)
                                      +the-standard-generic-function-class+)
                                  #'std-compute-effective-method
                                  #'compute-effective-method)
                              gf (generic-function-method-combination gf)
                              applicable-methods)))
          (when emfun
            (setf (gethash arg-specialization (classes-to-emf-table gf)) emfun))
          emfun))))

(defun sub-specializer-p (c1 c2 c-arg)
  (find c2 (cdr (memq c1 (%class-precedence-list c-arg)))))

(defun std-method-more-specific-p (method1 method2 required-classes argument-precedence-order)
  (if argument-precedence-order
      (let ((specializers-1 (std-method-specializers method1))
            (specializers-2 (std-method-specializers method2)))
        (dolist (index argument-precedence-order)
          (let ((spec1 (nth index specializers-1))
                (spec2 (nth index specializers-2)))
            (unless (eq spec1 spec2)
              (cond ((typep spec1 'eql-specializer)
                     (return t))
                    ((typep spec2 'eql-specializer)
                     (return nil))
                    (t
                     (return (sub-specializer-p spec1 spec2
                                                (nth index required-classes)))))))))
      (do ((specializers-1 (std-method-specializers method1) (cdr specializers-1))
           (specializers-2 (std-method-specializers method2) (cdr specializers-2))
           (classes required-classes (cdr classes)))
          ((null specializers-1) nil)
        (let ((spec1 (car specializers-1))
              (spec2 (car specializers-2)))
          (unless (eq spec1 spec2)
            (cond ((typep spec1 'eql-specializer)
                   (return t))
                  ((typep spec2 'eql-specializer)
                   (return nil))
                  (t
                   (return (sub-specializer-p spec1 spec2 (car classes))))))))))

(defun primary-method-p (method)
  (null (intersection '(:before :after :around) (method-qualifiers method))))

(defun before-method-p (method)
  (equal '(:before) (method-qualifiers method)))

(defun after-method-p (method)
  (equal '(:after) (method-qualifiers method)))

(defun around-method-p (method)
  (equal '(:around) (method-qualifiers method)))

(defun process-next-method-list (next-method-list)
  (mapcar #'(lambda (next-method-form)
              (cond
                ((listp next-method-form)
                 (assert (eq (first next-method-form) 'make-method))
                 (let* ((rest-sym (gensym)))
                   (make-instance-standard-method
                    nil ;; ignored
                    :lambda-list (list '&rest rest-sym)
                    :function (compute-method-function `(lambda (&rest ,rest-sym)
                                                          ,(second next-method-form))))))
                (t
                 (assert (typep next-method-form 'method))
                 next-method-form)))
          next-method-list))

(defun std-compute-effective-method (gf method-combination methods)
  (assert (typep method-combination 'method-combination))
  (let* ((mc-name (method-combination-name method-combination))
         (options (slot-value method-combination 'options))
         (order (car options))
         (primaries '())
         (arounds '())
         around
         emf-form
         (long-method-combination-p
          (typep method-combination 'long-method-combination)))
    (unless long-method-combination-p
      (dolist (m methods)
        (let ((qualifiers (method-qualifiers m)))
          (cond ((null qualifiers)
                 (if (eq mc-name 'standard)
                     (push m primaries)
                     (error "Method combination type mismatch: missing qualifier for method combination ~S." method-combination)))
                ((cdr qualifiers)
                 (error "Invalid method qualifiers."))
                ((eq (car qualifiers) :around)
                 (push m arounds))
                ((eq (car qualifiers) mc-name)
                 (push m primaries))
                ((memq (car qualifiers) '(:before :after)))
                (t
                 (error "Invalid method qualifiers."))))))
    (unless (eq order :most-specific-last)
      (setf primaries (nreverse primaries)))
    (setf arounds (nreverse arounds))
    (setf around (car arounds))
    (when (and (null primaries) (not long-method-combination-p))
      (error "No primary methods for the generic function ~S." gf))
    (cond
      (around
       (let ((next-emfun
              (funcall
               (if (eq (class-of gf) +the-standard-generic-function-class+)
                   #'std-compute-effective-method
                   #'compute-effective-method)
               gf method-combination (remove around methods))))
         (setf emf-form
               (generate-emf-lambda (method-function around) next-emfun))))
      ((eq mc-name 'standard)
       (let* ((next-emfun (compute-primary-emfun (cdr primaries)))
              (befores (remove-if-not #'before-method-p methods))
              (reverse-afters
               (reverse (remove-if-not #'after-method-p methods))))
         (setf emf-form
               (cond
                 ((and (null befores) (null reverse-afters))
                  (let ((fast-function (std-method-fast-function (car primaries))))
                    (if fast-function
                        (ecase (length (gf-required-args gf))
                          (1
                           #'(lambda (args)
                               (declare (optimize speed))
                               (funcall fast-function (car args))))
                          (2
                           #'(lambda (args)
                               (declare (optimize speed))
                               (funcall fast-function (car args) (cadr args)))))
                        (generate-emf-lambda (std-method-function (car primaries))
                                             next-emfun))))
                 (t
                  (let ((method-function (method-function (car primaries))))
                    #'(lambda (args)
                        (declare (optimize speed))
                        (dolist (before befores)
                          (funcall (method-function before) args nil))
                        (multiple-value-prog1
                            (funcall method-function args next-emfun)
                          (dolist (after reverse-afters)
                            (funcall (method-function after) args nil))))))))))
      (long-method-combination-p
       (let ((function (long-method-combination-function method-combination))
             (arguments (slot-value method-combination 'options)))
         (assert function)
         (setf emf-form
               (if arguments
                   (apply function gf methods arguments)
                   (funcall function gf methods)))))
      (t
       (unless (typep method-combination 'short-method-combination)
         (error "Unsupported method combination type ~A." mc-name))
       (let ((operator (short-method-combination-operator method-combination))
             (ioa (short-method-combination-identity-with-one-argument method-combination)))
         (setf emf-form
               (if (and ioa (null (cdr primaries)))
                   (generate-emf-lambda (method-function (car primaries)) nil)
                   `(lambda (args)
                      (,operator ,@(mapcar
                                    (lambda (primary)
                                      `(funcall ,(method-function primary) args nil))
                                    primaries))))))))
    (assert (not (null emf-form)))
    (or #+nil (ignore-errors (autocompile emf-form))
        (coerce-to-function emf-form))))

(defun generate-emf-lambda (method-function next-emfun)
  #'(lambda (args)
      (declare (optimize speed))
      (funcall method-function args next-emfun)))

;;; compute an effective method function from a list of primary methods:

(defun compute-primary-emfun (methods)
  (if (null methods)
      nil
      (let ((next-emfun (compute-primary-emfun (cdr methods))))
        #'(lambda (args)
           (funcall (std-method-function (car methods)) args next-emfun)))))

(defvar *call-next-method-p*)
(defvar *next-method-p-p*)

(defun walk-form (form)
  (cond ((atom form)
         (cond ((eq form 'call-next-method)
                (setf *call-next-method-p* t))
               ((eq form 'next-method-p)
                (setf *next-method-p-p* t))))
        (t
         (walk-form (%car form))
         (walk-form (%cdr form)))))

(defun compute-method-function (lambda-expression)
  (let ((lambda-list (allow-other-keys (cadr lambda-expression)))
        (body (cddr lambda-expression))
        (*call-next-method-p* nil)
        (*next-method-p-p* nil))
    (multiple-value-bind (body declarations) (parse-body body)
      (let ((ignorable-vars '()))
        (dolist (var lambda-list)
          (if (memq var lambda-list-keywords)
              (return)
              (push var ignorable-vars)))
        (push `(declare (ignorable ,@ignorable-vars)) declarations))
      (walk-form body)
      (cond ((or *call-next-method-p* *next-method-p-p*)
             `(lambda (args next-emfun)
                (flet ((call-next-method (&rest cnm-args)
                         (if (null next-emfun)
                             (error "No next method for generic function.")
                             (funcall next-emfun (or cnm-args args))))
                       (next-method-p ()
                         (not (null next-emfun))))
                  (declare (ignorable (function call-next-method)
                                      (function next-method-p)))
                  (apply #'(lambda ,lambda-list ,@declarations ,@body) args))))
            ((null (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux)))
             ;; Required parameters only.
             (case (length lambda-list)
               (1
                `(lambda (args next-emfun)
                   (declare (ignore next-emfun))
                   (let ((,(%car lambda-list) (%car args)))
                     (declare (ignorable ,(%car lambda-list)))
                     ,@declarations ,@body)))
               (2
                `(lambda (args next-emfun)
                   (declare (ignore next-emfun))
                   (let ((,(%car lambda-list) (%car args))
                         (,(%cadr lambda-list) (%cadr args)))
                     (declare (ignorable ,(%car lambda-list)
                                         ,(%cadr lambda-list)))
                     ,@declarations ,@body)))
               (3
                `(lambda (args next-emfun)
                   (declare (ignore next-emfun))
                   (let ((,(%car lambda-list) (%car args))
                         (,(%cadr lambda-list) (%cadr args))
                         (,(%caddr lambda-list) (%caddr args)))
                     (declare (ignorable ,(%car lambda-list)
                                         ,(%cadr lambda-list)
                                         ,(%caddr lambda-list)))
                     ,@declarations ,@body)))
               (t
                `(lambda (args next-emfun)
                   (declare (ignore next-emfun))
                   (apply #'(lambda ,lambda-list ,@declarations ,@body) args)))))
            (t
             `(lambda (args next-emfun)
                (declare (ignore next-emfun))
                (apply #'(lambda ,lambda-list ,@declarations ,@body) args)))))))

(defun compute-method-fast-function (lambda-expression)
  (let ((lambda-list (allow-other-keys (cadr lambda-expression))))
    (when (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux))
      (return-from compute-method-fast-function nil))
    ;; Only required args.
    (let ((body (cddr lambda-expression))
          (*call-next-method-p* nil)
          (*next-method-p-p* nil))
      (multiple-value-bind (body declarations) (parse-body body)
        (walk-form body)
        (when (or *call-next-method-p* *next-method-p-p*)
          (return-from compute-method-fast-function nil))
        (let ((decls `(declare (ignorable ,@lambda-list))))
          (setf lambda-expression
                (list* (car lambda-expression)
                       (cadr lambda-expression)
                       decls
                       (cddr lambda-expression))))
        (case (length lambda-list)
          (1
;;            `(lambda (args next-emfun)
;;               (let ((,(%car lambda-list) (%car args)))
;;                 (declare (ignorable ,(%car lambda-list)))
;;                 ,@declarations ,@body)))
           lambda-expression)
          (2
;;            `(lambda (args next-emfun)
;;               (let ((,(%car lambda-list) (%car args))
;;                     (,(%cadr lambda-list) (%cadr args)))
;;                 (declare (ignorable ,(%car lambda-list)
;;                                     ,(%cadr lambda-list)))
;;                 ,@declarations ,@body)))
           lambda-expression)
;;           (3
;;            `(lambda (args next-emfun)
;;               (let ((,(%car lambda-list) (%car args))
;;                     (,(%cadr lambda-list) (%cadr args))
;;                     (,(%caddr lambda-list) (%caddr args)))
;;                 (declare (ignorable ,(%car lambda-list)
;;                                     ,(%cadr lambda-list)
;;                                     ,(%caddr lambda-list)))
;;                 ,@declarations ,@body)))
          (t
           nil))))))

(declaim (notinline make-method-lambda))
(defun make-method-lambda (generic-function method lambda-expression env)
  (declare (ignore generic-function method env))
  (values (compute-method-function lambda-expression) nil))


;; From CLHS section 7.6.5:
;; "When a generic function or any of its methods mentions &key in a lambda
;; list, the specific set of keyword arguments accepted by the generic function
;; varies according to the applicable methods. The set of keyword arguments
;; accepted by the generic function for a particular call is the union of the
;; keyword arguments accepted by all applicable methods and the keyword
;; arguments mentioned after &key in the generic function definition, if any."
;; Adapted from Sacla.
(defun allow-other-keys (lambda-list)
  (if (and (member '&key lambda-list)
           (not (member '&allow-other-keys lambda-list)))
      (let* ((key-end (or (position '&aux lambda-list) (length lambda-list)))
             (aux-part (subseq lambda-list key-end)))
        `(,@(subseq lambda-list 0 key-end) &allow-other-keys ,@aux-part))
      lambda-list))

(defmacro defmethod (&rest args &environment env)
  (multiple-value-bind
      (function-name qualifiers lambda-list specializers documentation declarations body)
      (parse-defmethod args)
    (let* ((specializers-form '())
           (lambda-expression `(lambda ,lambda-list ,@declarations ,body))
           (gf (or (find-generic-function function-name nil)
                   (class-prototype (find-class 'standard-generic-function))))
           (method-function
             (make-method-lambda gf (class-prototype (generic-function-method-class gf))
                                 lambda-expression env))
           (fast-function (compute-method-fast-function lambda-expression))
           )
      (dolist (specializer specializers)
        (cond ((and (consp specializer) (eq (car specializer) 'eql))
               (push `(list 'eql ,(cadr specializer)) specializers-form))
              (t
               (push `',specializer specializers-form))))
      (setf specializers-form `(list ,@(nreverse specializers-form)))
      `(progn
         (ensure-method ',function-name
                        :lambda-list ',lambda-list
                        :qualifiers ',qualifiers
                        :specializers (canonicalize-specializers ,specializers-form)
                        ,@(if documentation `(:documentation ,documentation))
                        :function (function ,method-function)
                        ,@(if fast-function `(:fast-function (function ,fast-function)))
                        )))))

;;; Reader and writer methods

(defun make-instance-standard-accessor-method (method-class
                                               &key
                                               lambda-list
                                               qualifiers
                                               specializers
                                               documentation
                                               function
                                               fast-function
                                               slot-definition)
  (let ((method (std-allocate-instance method-class)))
    (setf (method-lambda-list method) lambda-list)
    (setf (method-qualifiers method) qualifiers)
    (setf (std-slot-value method 'sys::specializers)
          (canonicalize-specializers specializers))
    (setf (method-documentation method) documentation)
    (setf (std-slot-value method 'sys::%generic-function) nil)
    (setf (std-slot-value method 'sys::%function) function)
    (setf (std-slot-value method 'sys::fast-function) fast-function)
    (setf (std-slot-value method 'sys::%slot-definition) slot-definition)
    (setf (std-slot-value method 'sys::keywords) nil)
    (setf (std-slot-value method 'sys::other-keywords-p) nil)
    method))

(defun add-reader-method (class function-name slot-definition)
  (let* ((slot-name (slot-definition-name slot-definition))
         (lambda-expression
          (if (eq (class-of class) +the-standard-class+)
              `(lambda (object) (std-slot-value object ',slot-name))
              `(lambda (object) (slot-value object ',slot-name))))
         (method-function (compute-method-function lambda-expression))
         (fast-function (compute-method-fast-function lambda-expression))
         (method-lambda-list '(object))
         (gf (find-generic-function function-name nil))
         (initargs `(:lambda-list ,method-lambda-list
                     :qualifiers ()
                     :specializers (,class)
                     :function ,(if (autoloadp 'compile)
                                    method-function
                                    (autocompile method-function))
                     :fast-function ,(if (autoloadp 'compile)
                                         fast-function
                                         (autocompile fast-function))
                     :slot-definition ,slot-definition))
         (method-class (if (eq class +the-standard-class+)
                           +the-standard-reader-method-class+
                           (apply #'reader-method-class class slot-definition
                                  initargs))))
    ;; required by AMOP pg. 225
    (assert (subtypep method-class +the-standard-reader-method-class+))
    (if gf
        (check-method-lambda-list function-name
                                  method-lambda-list
                                  (generic-function-lambda-list gf))
        (setf gf (ensure-generic-function function-name
                                          :lambda-list method-lambda-list)))
    (let ((method
           (if (eq method-class +the-standard-reader-method-class+)
               (apply #'make-instance-standard-accessor-method method-class
                      initargs)
               (apply #'make-instance method-class
                      :generic-function nil ; handled by add-method
                      initargs))))
      (if (eq (class-of gf) +the-standard-generic-function-class+)
          (progn
            (std-add-method gf method)
            (map-dependents gf
                            #'(lambda (dep)
                                (update-dependent gf dep 'add-method method))))
          (add-method gf method))
      method)))

(defun add-writer-method (class function-name slot-definition)
  (let* ((slot-name (slot-definition-name slot-definition))
         (lambda-expression
          (if (eq (class-of class) +the-standard-class+)
              `(lambda (new-value object)
                 (setf (std-slot-value object ',slot-name) new-value))
              `(lambda (new-value object)
                 (setf (slot-value object ',slot-name) new-value))))
         (method-function (compute-method-function lambda-expression))
         (fast-function (compute-method-fast-function lambda-expression))
         (method-lambda-list '(new-value object))
         (gf (find-generic-function function-name nil))
         (initargs `(:lambda-list ,method-lambda-list
                     :qualifiers ()
                     :specializers (,+the-T-class+ ,class)
                     :function ,(if (autoloadp 'compile)
                                    method-function
                                    (autocompile method-function))
                     :fast-function ,(if (autoloadp 'compile)
                                         fast-function
                                         (autocompile fast-function))
                     :slot-definition ,slot-definition))
         (method-class (if (eq class +the-standard-class+)
                           +the-standard-writer-method-class+
                           (apply #'writer-method-class class slot-definition
                                  initargs))))
    ;; required by AMOP pg. 242
    (assert (subtypep method-class +the-standard-writer-method-class+))
    (if gf
        (check-method-lambda-list function-name
                                  method-lambda-list
                                  (generic-function-lambda-list gf))
        (setf gf (ensure-generic-function function-name
                                          :lambda-list method-lambda-list)))
    (let ((method
           (if (eq method-class +the-standard-writer-method-class+)
               (apply #'make-instance-standard-accessor-method method-class
                      initargs)
               (apply #'make-instance method-class
                      :generic-function nil ; handled by add-method
                      initargs))))
      (if (eq (class-of gf) +the-standard-generic-function-class+)
          (progn
            (std-add-method gf method)
            (map-dependents gf
                            #'(lambda (dep)
                                (update-dependent gf dep 'add-method method))))
          (add-method gf method))
      method)))

(defmacro atomic-defgeneric (function-name &rest rest)
  "Macro to define a generic function and 'swap it into place' after
it's been fully defined with all its methods.

Note: the user should really use the (:method ..) method description
way of defining methods; there's not much use in atomically defining
generic functions without providing sensible behaviour."
  (let ((temp-sym (gensym)))
    `(progn
       (defgeneric ,temp-sym ,@rest)
       (let ((gf (symbol-function ',temp-sym)))
         ;; FIXME (rudi 2012-07-08): fset gets the source location info
         ;; to charpos 23 always (but (setf fdefinition) leaves the
         ;; outdated source position in place, which is even worse).
         (fset ',function-name gf)
         (%set-generic-function-name gf ',function-name)
         (fmakunbound ',temp-sym)
         gf))))

(defmacro redefine-class-forwarder (name slot &optional body-alist)
  "Define a generic function on a temporary symbol as an accessor
for the slot `slot'. Then, when definition is complete (including
allocation of methods), swap the definition in place.

`body-alist' can be used to override the default method bodies for given
metaclasses.  In substitute method bodies, `class' names the class
instance and, for setters, `new-value' the new value."
  (let* ((setterp (consp name))
         (%name
          (intern (concatenate 'string
                               "%"
                               (if setterp (symbol-name 'set-) "")
                               (symbol-name (if setterp (cadr name) name)))
                  (find-package "SYS")))
         (bodies
          (append body-alist
                  (if setterp
                      `((built-in-class . (,%name new-value class))
                        (forward-referenced-class . (,%name new-value class))
                        (structure-class . (,%name new-value class))
                        (standard-class . (setf (slot-value class ',slot)
                                                new-value))
                        (funcallable-standard-class . (setf (slot-value class ',slot)
                                                            new-value)))
                      `((built-in-class . (,%name class))
                        (forward-referenced-class . (,%name class))
                        (structure-class . (,%name class))
                        (standard-class . (slot-value class ',slot))
                        (funcallable-standard-class . (slot-value class ',slot)))))))
    `(atomic-defgeneric ,name (,@(when setterp (list 'new-value)) class)
        ,@(mapcar #'(lambda (class-name)
                      `(:method (,@(when setterp (list 'new-value))
                                 (class ,class-name))
                         ,(cdr (assoc class-name bodies))))
                  '(built-in-class forward-referenced-class structure-class
                    standard-class funcallable-standard-class)))))


(redefine-class-forwarder class-name name)
;;; AMOP pg. 230
(redefine-class-forwarder (setf class-name) name
   ((standard-class . (progn (reinitialize-instance class :name new-value) new-value))
    (funcallable-standard-class . (progn (reinitialize-instance class :name new-value) new-value))))
(redefine-class-forwarder class-slots slots)
(redefine-class-forwarder (setf class-slots) slots)
(redefine-class-forwarder class-direct-slots direct-slots)
(redefine-class-forwarder (setf class-direct-slots) direct-slots)
(redefine-class-forwarder class-layout layout)
(redefine-class-forwarder (setf class-layout) layout)
(redefine-class-forwarder class-direct-superclasses direct-superclasses)
(redefine-class-forwarder (setf class-direct-superclasses) direct-superclasses)
(redefine-class-forwarder class-direct-subclasses direct-subclasses)
(redefine-class-forwarder (setf class-direct-subclasses) direct-subclasses)
(redefine-class-forwarder class-direct-methods direct-methods)
(redefine-class-forwarder (setf class-direct-methods) direct-methods)
(redefine-class-forwarder class-precedence-list precedence-list)
(redefine-class-forwarder (setf class-precedence-list) precedence-list)
(redefine-class-forwarder class-finalized-p finalized-p)
(redefine-class-forwarder (setf class-finalized-p) finalized-p)
(redefine-class-forwarder class-default-initargs default-initargs)
(redefine-class-forwarder (setf class-default-initargs) default-initargs)
(redefine-class-forwarder class-direct-default-initargs direct-default-initargs)
(redefine-class-forwarder (setf class-direct-default-initargs) direct-default-initargs)

;;; Class definition

(defun check-duplicate-slots (slots)
  (flet ((canonical-slot-name (canonical-slot)
           (getf canonical-slot :name)))
    (dolist (s1 slots)
      (let ((name1 (canonical-slot-name s1)))
        (dolist (s2 (cdr (memq s1 slots)))
          (when (eq name1 (canonical-slot-name s2))
            (error 'program-error "Duplicate slot ~S" name1)))))))

(defun check-duplicate-default-initargs (initargs)
  (let ((names ()))
    (dolist (initarg initargs)
      (push (car initarg) names))
    (do* ((names names (cdr names))
          (name (car names) (car names)))
         ((null names))
      (when (memq name (cdr names))
        (error 'program-error
               :format-control "Duplicate initialization argument name ~S in :DEFAULT-INITARGS."
               :format-arguments (list name))))))

(defun canonicalize-direct-superclasses (direct-superclasses)
  (let ((classes '()))
    (dolist (class-specifier direct-superclasses)
      (let ((class (if (classp class-specifier)
                       class-specifier
                       (find-class class-specifier nil))))
        (unless class
          (setf class (make-instance +the-forward-referenced-class+
                                     :name class-specifier))
          (setf (find-class class-specifier) class))
        (when (and (typep class 'built-in-class)
                   (not (member class *extensible-built-in-classes*)))
          (error "Attempt to define a subclass of built-in-class ~S."
                 class-specifier))
        (push class classes)))
    (nreverse classes)))

(atomic-defgeneric add-direct-subclass (superclass subclass)
  (:method ((superclass class) (subclass class))
    (setf (class-direct-subclasses superclass)
          (adjoin subclass (class-direct-subclasses superclass)))))

(atomic-defgeneric remove-direct-subclass (superclass subclass)
  (:method ((superclass class) (subclass class))
    (setf (class-direct-subclasses superclass)
          (remove subclass (class-direct-subclasses superclass)))))

 ;;; AMOP pg. 182
(defun ensure-class (name &rest all-keys &key &allow-other-keys)
  (let ((class (find-class name nil)))
    ;; CLHS DEFCLASS: "If a class with the same proper name already
    ;; exists [...] the existing class is redefined."  Ansi-tests
    ;; CLASS-0309 and CLASS-0310.1 demand this behavior.
    (if (and class (eql (class-name class) name))
        (apply #'ensure-class-using-class class name all-keys)
        (apply #'ensure-class-using-class nil name all-keys))))

;;; AMOP pg. 183ff.
(defgeneric ensure-class-using-class (class name &key direct-default-initargs
                                      direct-slots direct-superclasses
                                      metaclass &allow-other-keys))

(defmethod ensure-class-using-class :before (class name  &key direct-slots
                                             direct-default-initargs 
                                             &allow-other-keys)
  (check-duplicate-slots direct-slots)
  (check-duplicate-default-initargs direct-default-initargs))

(defmethod ensure-class-using-class ((class null) name &rest all-keys
                                     &key (metaclass +the-standard-class+)
                                     direct-superclasses
                                     &allow-other-keys)
  (setf all-keys (copy-list all-keys))  ; since we modify it
  (remf all-keys :metaclass)
  (unless (classp metaclass) (setf metaclass (find-class metaclass)))
  (let ((class (apply (if (eq metaclass +the-standard-class+)
                          #'make-instance-standard-class
                          #'make-instance)
                      metaclass :name name
                      :direct-superclasses (canonicalize-direct-superclasses
                                            direct-superclasses)
                      all-keys)))
    (%set-find-class name class)
    class))

(defmethod ensure-class-using-class ((class built-in-class) name &rest all-keys
                                     &key &allow-other-keys)
  (declare (ignore all-keys))
  (error "The symbol ~S names a built-in class." name))

(defmethod ensure-class-using-class ((class forward-referenced-class) name
                                     &rest all-keys
                                     &key (metaclass +the-standard-class+)
                                     direct-superclasses &allow-other-keys)
  (setf all-keys (copy-list all-keys))  ; since we modify it
  (remf all-keys :metaclass)
  (unless (classp metaclass) (setf metaclass (find-class metaclass)))
  (apply #'change-class class metaclass all-keys)
  (apply #'reinitialize-instance class
         :name name
         :direct-superclasses (canonicalize-direct-superclasses
                               direct-superclasses)
         all-keys)
  class)

(defmethod ensure-class-using-class ((class class) name
                                     &rest all-keys
                                     &key (metaclass +the-standard-class+ metaclassp)
                                     direct-superclasses
                                     &allow-other-keys)
  (declare (ignore name))
  (setf all-keys (copy-list all-keys))  ; since we modify it
  (remf all-keys :metaclass)
  (unless (classp metaclass) (setf metaclass (find-class metaclass)))
  (when (and metaclassp (not (eq (class-of class) metaclass)))
    (error 'program-error
           "Trying to redefine class ~S with different metaclass."
           (class-name class)))
  (apply #'reinitialize-instance class
         :direct-superclasses (canonicalize-direct-superclasses direct-superclasses)
         all-keys)
  class)

(defmacro defclass (&whole form name direct-superclasses direct-slots &rest options)
  (unless (>= (length form) 3)
    (error 'program-error "Wrong number of arguments for DEFCLASS."))
  (check-declaration-type name)
  `(ensure-class ',name
                 :direct-superclasses
                 (canonicalize-direct-superclasses ',direct-superclasses)
                 :direct-slots
                 ,(canonicalize-direct-slots direct-slots)
                 ,@(canonicalize-defclass-options options)))


;;; AMOP pg. 180
(defgeneric direct-slot-definition-class (class &rest initargs))

(defmethod direct-slot-definition-class ((class class) &rest initargs)
  (declare (ignore initargs))
  +the-standard-direct-slot-definition-class+)

;;; AMOP pg. 181
(defgeneric effective-slot-definition-class (class &rest initargs))

(defmethod effective-slot-definition-class ((class class) &rest initargs)
  (declare (ignore initargs))
  +the-standard-effective-slot-definition-class+)

;;; AMOP pg. 224
(defgeneric reader-method-class (class direct-slot &rest initargs))

(defmethod reader-method-class ((class standard-class)
                                (direct-slot standard-direct-slot-definition)
                                &rest initargs)
  (declare (ignore initargs))
  +the-standard-reader-method-class+)

(defmethod reader-method-class ((class funcallable-standard-class)
                                (direct-slot standard-direct-slot-definition)
                                &rest initargs)
  (declare (ignore initargs))
  +the-standard-reader-method-class+)

;;; AMOP pg. 242
(defgeneric writer-method-class (class direct-slot &rest initargs))

(defmethod writer-method-class ((class standard-class)
                                (direct-slot standard-direct-slot-definition)
                                &rest initargs)
  (declare (ignore initargs))
  +the-standard-writer-method-class+)

(defmethod writer-method-class ((class funcallable-standard-class)
                                (direct-slot standard-direct-slot-definition)
                                &rest initargs)
  (declare (ignore initargs))
  +the-standard-writer-method-class+)

;;; Applicable methods

(atomic-defgeneric compute-applicable-methods (gf args)
  (:method ((gf standard-generic-function) args)
    (std-compute-applicable-methods gf args)))

(defgeneric compute-applicable-methods-using-classes (gf classes)
  (:method ((gf standard-generic-function) classes)
    (let ((methods '()))
      (dolist (method (generic-function-methods gf))
  (multiple-value-bind (applicable knownp)
      (method-applicable-using-classes-p method classes)
    (cond (applicable
     (push method methods))
    ((not knownp)
     (return-from compute-applicable-methods-using-classes
       (values nil nil))))))
      (values (sort-methods methods gf classes)
        t))))


;;; Slot access
;;; 
;;; See AMOP pg. 156ff. for an overview.
;;; 
;;; AMOP specifies these generic functions to dispatch on slot objects
;;; (with the exception of slot-exists-p-using-class), although its
;;; sample implementation Closette dispatches on slot names.  We let
;;; slot-value and friends call their gf counterparts with the effective
;;; slot definition, but leave the definitions dispatching on slot name
;;; in place for user convenience.

;;; AMOP pg. 235
(defgeneric slot-value-using-class (class instance slot))

(defmethod slot-value-using-class ((class standard-class) instance (slot symbol))
  (std-slot-value instance slot))
(defmethod slot-value-using-class ((class standard-class) instance
                                   (slot standard-effective-slot-definition))
  (let* ((location (slot-definition-location slot))
         (value (if (consp location)
                    (cdr location)      ; :allocation :class
                    (standard-instance-access instance location))))
    (if (eq value +slot-unbound+)
        ;; fix SLOT-UNBOUND.5 from ansi test suite
        (nth-value 0 (slot-unbound class instance (slot-definition-name slot)))
        value)))

(defmethod slot-value-using-class ((class funcallable-standard-class)
                                   instance (slot symbol))
  (std-slot-value instance slot))
(defmethod slot-value-using-class ((class funcallable-standard-class) instance
                                   (slot standard-effective-slot-definition))
  (let* ((location (slot-definition-location slot))
         (value (if (consp location)
                    (cdr location)      ; :allocation :class
                    (funcallable-standard-instance-access instance location))))
    (if (eq value +slot-unbound+)
        ;; fix SLOT-UNBOUND.5 from ansi test suite
        (nth-value 0 (slot-unbound class instance (slot-definition-name slot)))
        value)))

(defmethod slot-value-using-class ((class structure-class) instance
                                   (slot symbol))
  (std-slot-value instance slot))
(defmethod slot-value-using-class ((class structure-class) instance
                                   (slot standard-effective-slot-definition))
  (std-slot-value instance (slot-definition-name slot)))

;;; AMOP pg. 231
(defgeneric (setf slot-value-using-class) (new-value class instance slot))

(defmethod (setf slot-value-using-class) (new-value
                                          (class standard-class)
                                          instance
                                          (slot symbol))
  (setf (std-slot-value instance slot) new-value))
(defmethod (setf slot-value-using-class) (new-value
                                          (class standard-class)
                                          instance
                                          (slot standard-effective-slot-definition))
  (let ((location (slot-definition-location slot)))
    (if (consp location)                ; :allocation :class
        (setf (cdr location) new-value)
        (setf (standard-instance-access instance location) new-value))))

(defmethod (setf slot-value-using-class) (new-value
                                          (class funcallable-standard-class)
                                          instance
                                          (slot symbol))
  (setf (std-slot-value instance slot) new-value))
(defmethod (setf slot-value-using-class) (new-value
                                          (class funcallable-standard-class)
                                          instance
                                          (slot standard-effective-slot-definition))
  (let ((location (slot-definition-location slot)))
    (if (consp location)                ; :allocation :class
        (setf (cdr location) new-value)
        (setf (funcallable-standard-instance-access instance location)
              new-value))))

(defmethod (setf slot-value-using-class) (new-value
                                          (class structure-class)
                                          instance
                                          (slot symbol))
  (setf (std-slot-value instance slot) new-value))
(defmethod (setf slot-value-using-class) (new-value
                                          (class structure-class)
                                          instance
                                          (slot standard-effective-slot-definition))
  (setf (std-slot-value instance (slot-definition-name slot)) new-value))

;;; slot-exists-p-using-class is not specified by AMOP, and obviously
;;; cannot be specialized on the slot type.  Hence, its implementation
;;; differs from slot-(boundp|makunbound|value)-using-class
(defgeneric slot-exists-p-using-class (class instance slot-name))

(defmethod slot-exists-p-using-class (class instance slot-name)
  nil)

(defmethod slot-exists-p-using-class ((class standard-class) instance slot-name)
  (std-slot-exists-p instance slot-name))
(defmethod slot-exists-p-using-class ((class funcallable-standard-class) instance slot-name)
  (std-slot-exists-p instance slot-name))

(defmethod slot-exists-p-using-class ((class structure-class) instance slot-name)
  (dolist (dsd (class-slots class))
    (when (eq (sys::dsd-name dsd) slot-name)
      (return-from slot-exists-p-using-class t)))
  nil)


(defgeneric slot-boundp-using-class (class instance slot))
(defmethod slot-boundp-using-class ((class standard-class) instance (slot symbol))
  (std-slot-boundp instance slot))
(defmethod slot-boundp-using-class ((class standard-class) instance
                                    (slot standard-effective-slot-definition))
  (let ((location (slot-definition-location slot)))
    (if (consp location)
        (not (eq (cdr location) +slot-unbound+)) ; :allocation :class
        (not (eq (standard-instance-access instance location) +slot-unbound+)))))

(defmethod slot-boundp-using-class ((class funcallable-standard-class) instance
                                    (slot symbol))
  (std-slot-boundp instance slot))
(defmethod slot-boundp-using-class ((class funcallable-standard-class) instance
                                    (slot standard-effective-slot-definition))
  (let ((location (slot-definition-location slot)))
    (if (consp location)
        (not (eq (cdr location) +slot-unbound+)) ; :allocation :class
        (not (eq (funcallable-standard-instance-access instance location)
                 +slot-unbound+)))))

(defmethod slot-boundp-using-class ((class structure-class) instance slot)
  "Structure slots can't be unbound, so this method always returns T."
  (declare (ignore class instance slot))
  t)

(defgeneric slot-makunbound-using-class (class instance slot))
(defmethod slot-makunbound-using-class ((class standard-class)
                                        instance
                                        (slot symbol))
  (std-slot-makunbound instance slot))
(defmethod slot-makunbound-using-class ((class standard-class)
                                        instance
                                        (slot standard-effective-slot-definition))
  (let ((location (slot-definition-location slot)))
    (if (consp location)
        (setf (cdr location) +slot-unbound+)
        (setf (standard-instance-access instance location) +slot-unbound+))))

(defmethod slot-makunbound-using-class ((class funcallable-standard-class)
                                        instance
                                        (slot symbol))
  (std-slot-makunbound instance slot))
(defmethod slot-makunbound-using-class ((class funcallable-standard-class)
                                        instance
                                        (slot symbol))
  (let ((location (slot-definition-location slot)))
    (if (consp location)
        (setf (cdr location) +slot-unbound+)
        (setf (funcallable-standard-instance-access instance location)
              +slot-unbound+))))

(defmethod slot-makunbound-using-class ((class structure-class)
                                        instance
                                        slot)
  (declare (ignore class instance slot))
  (error "Structure slots can't be unbound"))

(defgeneric slot-missing (class instance slot-name operation &optional new-value))

(defmethod slot-missing ((class t) instance slot-name operation &optional new-value)
  (declare (ignore new-value))
  (error "The slot ~S is missing from the class ~S." slot-name class))

(defgeneric slot-unbound (class instance slot-name))

(defmethod slot-unbound ((class t) instance slot-name)
  (error 'unbound-slot :instance instance :name slot-name))

;;; Instance creation and initialization

;;; AMOP pg. 168ff.
(defgeneric allocate-instance (class &rest initargs &key &allow-other-keys))

(defmethod allocate-instance ((class standard-class) &rest initargs)
  (declare (ignore initargs))
  (std-allocate-instance class))

(defmethod allocate-instance ((class funcallable-standard-class) &rest initargs)
  (declare (ignore initargs))
  (allocate-funcallable-instance class))

(defmethod allocate-instance ((class structure-class) &rest initargs)
  (declare (ignore initargs))
  (%make-structure (class-name class)
                   (make-list (length (class-slots class))
                              :initial-element +slot-unbound+)))

(defmethod allocate-instance ((class built-in-class) &rest initargs)
  (declare (ignore initargs))
  (error "Cannot allocate instances of a built-in class: ~S" class))

(defmethod allocate-instance :before ((class class) &rest initargs)
  (declare (ignore initargs))
  (unless (class-finalized-p class)
    (finalize-inheritance class)))

;; "The set of valid initialization arguments for a class is the set of valid
;; initialization arguments that either fill slots or supply arguments to
;; methods, along with the predefined initialization argument :ALLOW-OTHER-KEYS."
;; 7.1.2

(defun calculate-allowable-initargs (gf-list args instance
                                             shared-initialize-param
                                             initargs)
  (let* ((methods
          (nconc
             (std-compute-applicable-methods #'shared-initialize
                                             (list* instance
                                                    shared-initialize-param
                                                    initargs))
             (mapcan #'(lambda (gf)
                         (if (eq (class-of gf)
                                 +the-standard-generic-function-class+)
                             (std-compute-applicable-methods gf args)
                             (compute-applicable-methods gf args)))
                     gf-list)))
         (method-keyword-args
          (reduce #'merge-initargs-sets
                  (mapcar #'method-lambda-list methods)
                  :key #'extract-lambda-list-keywords
                  :initial-value nil))
         (slots-initargs
          (mapappend #'slot-definition-initargs
                     (class-slots (class-of instance)))))
    (merge-initargs-sets
     (merge-initargs-sets slots-initargs method-keyword-args)
     '(:allow-other-keys))))  ;; allow-other-keys is always allowed

(defun check-initargs (gf-list args instance
                       shared-initialize-param initargs
                       cache call-site)
  "Checks the validity of `initargs' for the generic functions in `gf-list'
when called with `args' by calculating the applicable methods for each gf.
The applicable methods for SHARED-INITIALIZE based on `instance',
`shared-initialize-param' and `initargs' are added to the list of
applicable methods."
  (when (oddp (length initargs))
    (error 'program-error
           :format-control "Odd number of keyword arguments."))
  (unless (getf initargs :allow-other-keys)
    (multiple-value-bind (allowable-initargs present-p)
                         (when cache
                           (gethash (class-of instance) cache))
       (unless present-p
         (setf allowable-initargs
               (calculate-allowable-initargs gf-list args instance
                                             shared-initialize-param initargs))
         (when cache
           (setf (gethash (class-of instance) cache)
                 allowable-initargs)))
       (unless (eq t allowable-initargs)
         (do* ((tail initargs (cddr tail))
               (initarg (car tail) (car tail)))
              ((null tail))
              (unless (memq initarg allowable-initargs)
                (error 'program-error
                       :format-control "Invalid initarg ~S in call to ~S with arglist ~S."
                       :format-arguments (list initarg call-site args))))))))

(defun merge-initargs-sets (list1 list2)
  (cond
   ((eq list1 t)  t)
   ((eq list2 t)  t)
   (t             (union list1 list2))))

(defun extract-lambda-list-keywords (lambda-list)
  "Returns a list of keywords acceptable as keyword arguments,
or T when any keyword is acceptable due to presence of
&allow-other-keys."
  (when (member '&allow-other-keys lambda-list)
    (return-from extract-lambda-list-keywords t))
  (loop with keyword-args = (cdr (memq '&key lambda-list))
        for key in keyword-args
        when (eq key '&aux) do (loop-finish)
        when (eq key '&allow-other-keys) do (return t)
        when (listp key) do (setq key (car key))
        collect (if (symbolp key)
                    (make-keyword key)
                  (car key))))


(defgeneric make-instance (class &rest initargs &key &allow-other-keys))

(defmethod make-instance :before ((class class) &rest initargs)
  (when (oddp (length initargs))
    (error 'program-error :format-control "Odd number of keyword arguments."))
  (unless (class-finalized-p class)
    (finalize-inheritance class)))

(defun augment-initargs-with-defaults (class initargs)
  (let ((default-initargs '()))
    (dolist (initarg (class-default-initargs class))
      (let ((key (first initarg))
            (fn (third initarg)))
        (when (eq (getf initargs key +slot-unbound+) +slot-unbound+)
          (push key default-initargs)
          (push (funcall fn) default-initargs))))
    (append initargs (nreverse default-initargs))))

(defmethod make-instance ((class standard-class) &rest initargs)
  (setf initargs (augment-initargs-with-defaults class initargs))
  (let ((instance (std-allocate-instance class)))
    (check-initargs (list #'allocate-instance #'initialize-instance)
                    (list* instance initargs)
                    instance t initargs
                    *make-instance-initargs-cache* 'make-instance)
    (apply #'initialize-instance instance initargs)
    instance))

(defmethod make-instance ((class funcallable-standard-class) &rest initargs)
  (setf initargs (augment-initargs-with-defaults class initargs))
  (let ((instance (allocate-funcallable-instance class)))
    (check-initargs (list #'allocate-instance #'initialize-instance)
                    (list* instance initargs)
                    instance t initargs
                    *make-instance-initargs-cache* 'make-instance)
    (apply #'initialize-instance instance initargs)
    instance))

(defmethod make-instance ((class symbol) &rest initargs)
  (apply #'make-instance (find-class class) initargs))

(defgeneric initialize-instance (instance &rest initargs
                                          &key &allow-other-keys))

(defmethod initialize-instance ((instance standard-object) &rest initargs)
  (apply #'shared-initialize instance t initargs))

(defgeneric reinitialize-instance (instance &rest initargs
                                            &key &allow-other-keys))

;; "The system-supplied primary method for REINITIALIZE-INSTANCE checks the
;; validity of initargs and signals an error if an initarg is supplied that is
;; not declared as valid. The method then calls the generic function SHARED-
;; INITIALIZE with the following arguments: the instance, nil (which means no
;; slots should be initialized according to their initforms), and the initargs
;; it received."
(defmethod reinitialize-instance ((instance standard-object) &rest initargs)
  (check-initargs (list #'reinitialize-instance) (list* instance initargs)
                  instance () initargs
                  *reinitialize-instance-initargs-cache* 'reinitialize-instance)
  (apply #'shared-initialize instance () initargs))

(defun std-shared-initialize (instance slot-names all-keys)
  (when (oddp (length all-keys))
    (error 'program-error :format-control "Odd number of keyword arguments."))
  ;; do a quick scan of the arguments list to see if it's a real
  ;; 'initialization argument list' (which is not the same as
  ;; checking initarg validity
  (do* ((tail all-keys (cddr tail))
        (initarg (car tail) (car tail)))
      ((null tail))
    (unless (symbolp initarg)
      (error 'program-error
             :format-control "Initarg ~S not a symbol."
             :format-arguments (list initarg))))
  (dolist (slot (class-slots (class-of instance)))
    (let ((slot-name (slot-definition-name slot)))
      (multiple-value-bind (init-key init-value foundp)
          (get-properties all-keys (slot-definition-initargs slot))
        (if foundp
            (setf (std-slot-value instance slot-name) init-value)
            (unless (std-slot-boundp instance slot-name)
              (let ((initfunction (slot-definition-initfunction slot)))
                (when (and initfunction (or (eq slot-names t)
                                            (memq slot-name slot-names)))
                  (setf (std-slot-value instance slot-name)
                        (funcall initfunction)))))))))
  instance)

(defgeneric shared-initialize (instance slot-names
                                        &rest initargs
                                        &key &allow-other-keys))

(defmethod shared-initialize ((instance standard-object) slot-names
                              &rest initargs)
  (std-shared-initialize instance slot-names initargs))

(defmethod shared-initialize ((slot slot-definition) slot-names
                              &rest args
                              &key name initargs initform initfunction
                              readers writers allocation
                              &allow-other-keys)
  ;;Keyword args are duplicated from init-slot-definition only to have
  ;;them checked.
  (declare (ignore slot-names)) ;;TODO?
  (declare (ignore name initargs initform initfunction readers writers allocation))
  ;;For built-in slots
  (apply #'init-slot-definition slot :allow-other-keys t args)
  ;;For user-defined slots
  (call-next-method))

;;; change-class

(defgeneric change-class (instance new-class &key &allow-other-keys))

(defmethod change-class ((old-instance standard-object) (new-class standard-class)
                         &rest initargs)
  (let ((old-slots (class-slots (class-of old-instance)))
        (new-slots (class-slots new-class))
        (new-instance (allocate-instance new-class)))
    ;; "The values of local slots specified by both the class CTO and the class
    ;; CFROM are retained. If such a local slot was unbound, it remains
    ;; unbound."
    (dolist (new-slot new-slots)
      (when (instance-slot-p new-slot)
        (let* ((slot-name (slot-definition-name new-slot))
               (old-slot (find slot-name old-slots :key 'slot-definition-name)))
          ;; "The values of slots specified as shared in the class CFROM and as
          ;; local in the class CTO are retained."
          (when (and old-slot (slot-boundp old-instance slot-name))
            (setf (slot-value new-instance slot-name)
                  (slot-value old-instance slot-name))))))
    (swap-slots old-instance new-instance)
    (rotatef (std-instance-layout new-instance)
             (std-instance-layout old-instance))
    (apply #'update-instance-for-different-class
           new-instance old-instance initargs)
    old-instance))

(defmethod change-class ((instance standard-object) (new-class symbol) &rest initargs)
  (apply #'change-class instance (find-class new-class) initargs))

(defgeneric update-instance-for-different-class (old new
                                                     &rest initargs
                                                     &key &allow-other-keys))

(defmethod update-instance-for-different-class
  ((old standard-object) (new standard-object) &rest initargs)
  (let ((added-slots
         (remove-if #'(lambda (slot-name)
                       (slot-exists-p old slot-name))
                    (mapcar 'slot-definition-name
                            (class-slots (class-of new))))))
    (check-initargs (list #'update-instance-for-different-class)
                    (list old new initargs)
                    new added-slots initargs
                    nil 'update-instance-for-different-class)
    (apply #'shared-initialize new added-slots initargs)))

;;; make-instances-obsolete

(defgeneric make-instances-obsolete (class))

(defmethod make-instances-obsolete ((class standard-class))
  (%make-instances-obsolete class))
(defmethod make-instances-obsolete ((class funcallable-standard-class))
  (%make-instances-obsolete class))
(defmethod make-instances-obsolete ((class symbol))
  (make-instances-obsolete (find-class class))
  class)

;;; update-instance-for-redefined-class

(defgeneric update-instance-for-redefined-class (instance
                                                 added-slots
                                                 discarded-slots
                                                 property-list
                                                 &rest initargs
                                                 &key
                                                 &allow-other-keys))

(defmethod update-instance-for-redefined-class ((instance standard-object)
            added-slots
            discarded-slots
            property-list
            &rest initargs)
  (check-initargs (list #'update-instance-for-redefined-class)
                  (list* instance added-slots discarded-slots
                         property-list initargs)
                  instance added-slots initargs
                  nil 'update-instance-for-redefined-class)
  (apply #'shared-initialize instance added-slots initargs))

;;;  Methods having to do with class metaobjects.

(defmethod initialize-instance :after ((class standard-class) &rest args)
  (apply #'std-after-initialization-for-classes class args))

(defmethod initialize-instance :after ((class funcallable-standard-class)
                                       &rest args)
  (apply #'std-after-initialization-for-classes class args))

(defmethod reinitialize-instance :before ((class standard-class)
                                          &rest all-keys
                                          &key direct-superclasses)
  (check-initargs (list #'allocate-instance
                        #'initialize-instance)
                  (list* class all-keys)
                  class t all-keys
                  nil 'reinitialize-instance)
  (dolist (superclass (set-difference (class-direct-superclasses class)
                                      direct-superclasses))
    (remove-direct-subclass superclass class))
  (dolist (superclass (set-difference direct-superclasses
                                      (class-direct-superclasses class)))
    (add-direct-subclass superclass class)))

(defmethod reinitialize-instance :before ((class funcallable-standard-class)
                                          &rest all-keys
                                          &key direct-superclasses)
  (check-initargs (list #'allocate-instance
                        #'initialize-instance)
                  (list* class all-keys)
                  class t all-keys
                  nil 'reinitialize-instance)
  (dolist (superclass (set-difference (class-direct-superclasses class)
                                      direct-superclasses))
    (remove-direct-subclass superclass class))
  (dolist (superclass (set-difference direct-superclasses
                                      (class-direct-superclasses class)))
    (add-direct-subclass superclass class)))

(defun std-after-reinitialization-for-classes (class
                                               &rest all-keys
                                               &key (direct-superclasses nil direct-superclasses-p)
                                               (direct-slots nil direct-slots-p)
                                               (direct-default-initargs nil direct-default-initargs-p)
                                               &allow-other-keys)
  (remhash class *make-instance-initargs-cache*)
  (remhash class *reinitialize-instance-initargs-cache*)
  (%make-instances-obsolete class)
  (setf (class-finalized-p class) nil)
  (when direct-superclasses-p
    (let* ((old-supers (class-direct-superclasses class))
           (new-supers (canonicalize-direct-superclass-list
                        class direct-superclasses)))
      (setf (class-direct-superclasses class) new-supers)
      (dolist (old-superclass (set-difference old-supers new-supers))
        (remove-direct-subclass old-superclass class))
      (dolist (new-superclass (set-difference new-supers old-supers))
        (add-direct-subclass new-superclass class))))
  (when direct-slots-p
    ;; FIXME: maybe remove old reader and writer methods?
    (let ((slots (mapcar #'(lambda (slot-properties)
                             (apply #'make-direct-slot-definition class slot-properties))
                         direct-slots)))
      (setf (class-direct-slots class) slots)
      (dolist (direct-slot slots)
        (dolist (reader (slot-definition-readers direct-slot))
          (add-reader-method class reader direct-slot))
        (dolist (writer (slot-definition-writers direct-slot))
          (add-writer-method class writer direct-slot)))))
  (when direct-default-initargs-p
    (setf (class-direct-default-initargs class) direct-default-initargs))
  (maybe-finalize-class-subtree class)
  (map-dependents class #'(lambda (dep) (update-dependent class dep all-keys))))

(defmethod reinitialize-instance :after ((class standard-class)
                                         &rest all-keys)
  (apply #'std-after-reinitialization-for-classes class all-keys))

(defmethod reinitialize-instance :after ((class funcallable-standard-class)
                                         &rest all-keys)
  (apply #'std-after-reinitialization-for-classes class all-keys))

(defmethod reinitialize-instance :before ((gf standard-generic-function)
                                          &key
                                            (lambda-list nil lambda-list-supplied-p)
                                          &allow-other-keys)
  (when lambda-list-supplied-p
    (unless (or (null (generic-function-methods gf))
                (lambda-lists-congruent-p lambda-list
                                          (generic-function-lambda-list gf)))
      (error "The lambda list ~S is incompatible with the existing methods of ~S."
             lambda-list gf))))

(defmethod reinitialize-instance :after ((gf standard-generic-function)
                                         &rest all-keys)
  (map-dependents gf #'(lambda (dep) (update-dependent gf dep all-keys))))

;;; Finalize inheritance

(atomic-defgeneric finalize-inheritance (class)
    (:method ((class standard-class))
       (std-finalize-inheritance class))
    (:method ((class funcallable-standard-class))
       (std-finalize-inheritance class)))

;;; Default initargs

;;; AMOP pg. 174
(atomic-defgeneric compute-default-initargs (class)
  (:method ((class standard-class))
    (std-compute-default-initargs class))
  (:method ((class funcallable-standard-class))
    (std-compute-default-initargs class)))

;;; Class precedence lists

(defgeneric compute-class-precedence-list (class))
(defmethod compute-class-precedence-list ((class standard-class))
  (std-compute-class-precedence-list class))
(defmethod compute-class-precedence-list ((class funcallable-standard-class))
  (std-compute-class-precedence-list class))

;;; Slot inheritance

(defgeneric compute-slots (class))
(defmethod compute-slots ((class standard-class))
  (std-compute-slots class))
(defmethod compute-slots ((class funcallable-standard-class))
  (std-compute-slots class))

(defgeneric compute-effective-slot-definition (class name direct-slots))
(defmethod compute-effective-slot-definition
  ((class standard-class) name direct-slots)
  (std-compute-effective-slot-definition class name direct-slots))
(defmethod compute-effective-slot-definition
  ((class funcallable-standard-class) name direct-slots)
  (std-compute-effective-slot-definition class name direct-slots))

;;; Methods having to do with generic function invocation.

(defgeneric compute-discriminating-function (gf))
(defmethod compute-discriminating-function ((gf standard-generic-function))
  (std-compute-discriminating-function gf))

(defgeneric method-more-specific-p (gf method1 method2 required-classes))

(defmethod method-more-specific-p ((gf standard-generic-function)
                                   method1 method2 required-classes)
  (let ((method-indices
         (argument-precedence-order-indices
          (generic-function-argument-precedence-order gf)
          (getf (analyze-lambda-list (generic-function-lambda-list gf))
                ':required-args))))
    (std-method-more-specific-p method1 method2 required-classes method-indices)))

;;; AMOP pg. 176
(defgeneric compute-effective-method (gf method-combination methods))
(defmethod compute-effective-method ((gf standard-generic-function) method-combination methods)
  (std-compute-effective-method gf method-combination methods))

(defgeneric compute-applicable-methods (gf args))
(defmethod compute-applicable-methods ((gf standard-generic-function) args)
  (std-compute-applicable-methods gf args))

;;; AMOP pg. 207
(atomic-defgeneric make-method-lambda (generic-function method lambda-expression environment)
  (:method ((generic-function standard-generic-function)
            (method standard-method)
            lambda-expression environment)
    (declare (ignore environment))
    (values (compute-method-function lambda-expression) nil)))


;;; Slot definition accessors

(defmacro slot-definition-dispatch (slot-definition std-form generic-form)
  `(let (($cl (class-of ,slot-definition)))
     (case $cl
       ((+the-standard-slot-definition-class+
         +the-standard-direct-slot-definition-class+
         +the-standard-effective-slot-definition-class+)
        ,std-form)
       (t ,generic-form))))

(atomic-defgeneric slot-definition-allocation (slot-definition)
  (:method ((slot-definition slot-definition))
    (slot-definition-dispatch slot-definition
      (%slot-definition-allocation slot-definition)
      (slot-value slot-definition 'sys::allocation))))

(atomic-defgeneric (setf slot-definition-allocation) (value slot-definition)
  (:method (value (slot-definition slot-definition))
    (slot-definition-dispatch slot-definition
      (set-slot-definition-allocation slot-definition value)
      (setf (slot-value slot-definition 'sys::allocation) value))))

(atomic-defgeneric slot-definition-initargs (slot-definition)
  (:method ((slot-definition slot-definition))
    (slot-definition-dispatch slot-definition
      (%slot-definition-initargs slot-definition)
      (slot-value slot-definition 'sys::initargs))))

(atomic-defgeneric slot-definition-initform (slot-definition)
  (:method ((slot-definition slot-definition))
    (slot-definition-dispatch slot-definition
      (%slot-definition-initform slot-definition)
      (slot-value slot-definition 'sys::initform))))

(atomic-defgeneric (setf slot-definition-initform) (value slot-definition)
  (:method (value (slot-definition slot-definition))
    (slot-definition-dispatch slot-definition
      (set-slot-definition-initform slot-definition value)
      (setf (slot-value slot-definition 'sys::initform) value))))

(atomic-defgeneric slot-definition-initfunction (slot-definition)
  (:method ((slot-definition slot-definition))
    (slot-definition-dispatch slot-definition
      (%slot-definition-initfunction slot-definition)
      (slot-value slot-definition 'sys::initfunction))))

(atomic-defgeneric (setf slot-definition-initfunction) (value slot-definition)
  (:method (value (slot-definition slot-definition))
    (slot-definition-dispatch slot-definition
      (set-slot-definition-initfunction slot-definition value)
      (setf (slot-value slot-definition 'sys::initfunction) value))))

(atomic-defgeneric slot-definition-name (slot-definition)
  (:method ((slot-definition slot-definition))
    (slot-definition-dispatch slot-definition
      (%slot-definition-name slot-definition)
      (slot-value slot-definition 'sys::name))))

(atomic-defgeneric (setf slot-definition-name) (value slot-definition)
  (:method (value (slot-definition slot-definition))
    (slot-definition-dispatch slot-definition
      (set-slot-definition-name slot-definition value)
      (setf (slot-value slot-definition 'sys::name) value))))

(atomic-defgeneric slot-definition-readers (slot-definition)
  (:method ((slot-definition slot-definition))
    (slot-definition-dispatch slot-definition
      (%slot-definition-readers slot-definition)
      (slot-value slot-definition 'sys::readers))))

(atomic-defgeneric (setf slot-definition-readers) (value slot-definition)
  (:method (value (slot-definition slot-definition))
    (slot-definition-dispatch slot-definition
      (set-slot-definition-readers slot-definition value)
      (setf (slot-value slot-definition 'sys::readers) value))))

(atomic-defgeneric slot-definition-writers (slot-definition)
  (:method ((slot-definition slot-definition))
    (slot-definition-dispatch slot-definition
      (%slot-definition-writers slot-definition)
      (slot-value slot-definition 'sys::writers))))

(atomic-defgeneric (setf slot-definition-writers) (value slot-definition)
  (:method (value (slot-definition slot-definition))
    (slot-definition-dispatch slot-definition
      (set-slot-definition-writers slot-definition value)
      (setf (slot-value slot-definition 'sys::writers) value))))

(atomic-defgeneric slot-definition-allocation-class (slot-definition)
  (:method ((slot-definition slot-definition))
    (slot-definition-dispatch slot-definition
      (%slot-definition-allocation-class slot-definition)
      (slot-value slot-definition 'sys::allocation-class))))

(atomic-defgeneric (setf slot-definition-allocation-class)
                       (value slot-definition)
  (:method (value (slot-definition slot-definition))
    (slot-definition-dispatch slot-definition
      (set-slot-definition-allocation-class slot-definition value)
      (setf (slot-value slot-definition 'sys::allocation-class) value))))

(atomic-defgeneric slot-definition-location (slot-definition)
  (:method ((slot-definition slot-definition))
    (slot-definition-dispatch slot-definition
      (%slot-definition-location slot-definition)
      (slot-value slot-definition 'sys::location))))

(atomic-defgeneric (setf slot-definition-location) (value slot-definition)
  (:method (value (slot-definition slot-definition))
    (slot-definition-dispatch slot-definition
      (set-slot-definition-location slot-definition value)
      (setf (slot-value slot-definition 'sys::location) value))))

(atomic-defgeneric slot-definition-type (slot-definition)
  (:method ((slot-definition slot-definition))
    (slot-definition-dispatch slot-definition
      (%slot-definition-type slot-definition)
      (slot-value slot-definition 'sys::%type))))

(atomic-defgeneric (setf slot-definition-type) (value slot-definition)
  (:method (value (slot-definition slot-definition))
    (slot-definition-dispatch slot-definition
      (set-slot-definition-type slot-definition value)
      (setf (slot-value slot-definition 'sys::%type) value))))

(atomic-defgeneric slot-definition-documentation (slot-definition)
  (:method ((slot-definition slot-definition))
    (slot-definition-dispatch slot-definition
      (%slot-definition-documentation slot-definition)
      (slot-value slot-definition 'sys:%documentation))))

(atomic-defgeneric (setf slot-definition-documentation) (value slot-definition)
  (:method (value (slot-definition slot-definition))
    (slot-definition-dispatch slot-definition
      (set-slot-definition-documentation slot-definition value)
      (setf (slot-value slot-definition 'sys:%documentation) value))))


;;; Conditions.

(defmacro define-condition (name (&rest parent-types) (&rest slot-specs) &body options)
  (let ((parent-types (or parent-types '(condition)))
        (report nil))
    (dolist (option options)
      (when (eq (car option) :report)
        (setf report (cadr option))
  (setf options (delete option options :test #'equal))
        (return)))
    (typecase report
      (null
       `(progn
          (defclass ,name ,parent-types ,slot-specs ,@options)
          ',name))
      (string
       `(progn
          (defclass ,name ,parent-types ,slot-specs ,@options)
          (defmethod print-object ((condition ,name) stream)
            (if *print-escape*
                (call-next-method)
                (progn (write-string ,report stream) condition)))
          ',name))
      (t
       `(progn
          (defclass ,name ,parent-types ,slot-specs ,@options)
          (defmethod print-object ((condition ,name) stream)
            (if *print-escape*
                (call-next-method)
                (funcall #',report condition stream)))
          ',name)))))

(defun make-condition (type &rest initargs)
  (or (%make-condition type initargs)
      (let ((class (if (symbolp type) (find-class type) type)))
        (apply #'make-instance class initargs))))

;; Adapted from SBCL.
;; Originally defined in signal.lisp. Redefined here now that we have MAKE-CONDITION.
(defun coerce-to-condition (datum arguments default-type fun-name)
  (cond ((typep datum 'condition)
         (when arguments
           (error 'simple-type-error
                  :datum arguments
                  :expected-type 'null
                  :format-control "You may not supply additional arguments when giving ~S to ~S."
                  :format-arguments (list datum fun-name)))
         datum)
        ((symbolp datum)
         (apply #'make-condition datum arguments))
        ((or (stringp datum) (functionp datum))
         (make-condition default-type
                         :format-control datum
                         :format-arguments arguments))
        (t
         (error 'simple-type-error
                :datum datum
                :expected-type '(or symbol string)
                :format-control "Bad argument to ~S: ~S."
                :format-arguments (list fun-name datum)))))

(defgeneric make-load-form (object &optional environment))

(defmethod make-load-form ((object t) &optional environment)
  (declare (ignore environment))
  (apply #'no-applicable-method #'make-load-form (list object)))

(defmethod make-load-form ((class class) &optional environment)
  (declare (ignore environment))
  (let ((name (class-name class)))
    (unless (and name (eq (find-class name nil) class))
      (error 'simple-type-error
             :format-control "Can't use anonymous or undefined class as a constant: ~S."
             :format-arguments (list class)))
    `(find-class ',name)))

(defun invalid-method-error (method format-control &rest args)
  (let ((message (apply #'format nil format-control args)))
    (error "Invalid method error for ~S:~%    ~A" method message)))

(defun method-combination-error (format-control &rest args)
  (let ((message (apply #'format nil format-control args)))
    (error "Method combination error in CLOS dispatch:~%    ~A" message)))


(atomic-defgeneric no-applicable-method (generic-function &rest args)
  (:method (generic-function &rest args)
      (error "There is no applicable method for the generic function ~S ~
              when called with arguments ~S."
             generic-function
             args)))


;;; FIXME (rudi 2012-01-28): this can be a function, it only needs to
;;; use standard accessor functions
(defgeneric find-method (generic-function
                         qualifiers
                         specializers
                         &optional errorp))

(defmethod find-method ((generic-function standard-generic-function)
                        qualifiers specializers &optional (errorp t))
  (%find-method generic-function qualifiers specializers errorp))

(defgeneric find-method ((generic-function symbol)
                         qualifiers specializers &optional (errorp t))
  (find-method (find-generic-function generic-function errorp)
               qualifiers specializers errorp))

;;; AMOP pg. 167
(defgeneric add-method (generic-function method))

(defmethod add-method :before ((generic-function generic-function)
                               (method method))
  (when (and (method-generic-function method)
             (not (eql generic-function (method-generic-function method))))
    (error 'simple-error
           :format-control "~S is already a method of ~S, cannot add to ~S."
           :format-arguments (list method (method-generic-function method)
                                   generic-function)))
  (check-method-lambda-list (generic-function-name generic-function)
                            (method-lambda-list method)
                            (generic-function-lambda-list generic-function)))

(defmethod add-method ((generic-function standard-generic-function)
                       (method standard-method))
  (std-add-method generic-function method))

(defmethod add-method :after ((generic-function generic-function)
                              (method method))
  (map-dependents generic-function
                  #'(lambda (dep) (update-dependent generic-function dep
                                                    'add-method method))))

(defgeneric remove-method (generic-function method))

(defmethod remove-method ((generic-function standard-generic-function)
                          (method standard-method))
  (std-remove-method generic-function method))

(defmethod remove-method :after ((generic-function generic-function)
                                 (method method))
  (map-dependents generic-function
                  #'(lambda (dep) (update-dependent generic-function dep
                                                    'remove-method method))))

;; See describe.lisp.
(defgeneric describe-object (object stream))

;; FIXME
(defgeneric no-next-method (generic-function method &rest args))

(atomic-defgeneric function-keywords (method)
  (:method ((method standard-method))
    (std-function-keywords method)))

(setf *gf-initialize-instance* (symbol-function 'initialize-instance))
(setf *gf-allocate-instance* (symbol-function 'allocate-instance))
(setf *gf-shared-initialize* (symbol-function 'shared-initialize))
(setf *gf-reinitialize-instance* (symbol-function 'reinitialize-instance))
(setf *clos-booting* nil)

(atomic-defgeneric class-prototype (class)
  (:method ((class standard-class))
    (allocate-instance class))
  (:method ((class funcallable-standard-class))
    (allocate-instance class))
  (:method ((class structure-class))
    (allocate-instance class))
  (:method :before (class)
    (unless (class-finalized-p class)
      (error "~@<~S is not finalized.~:@>" class))))





(defmethod shared-initialize :before ((instance generic-function)
                                      slot-names
                                      &key lambda-list argument-precedence-order
                                      &allow-other-keys)
  (check-argument-precedence-order lambda-list argument-precedence-order))

(defmethod shared-initialize :after ((instance standard-generic-function)
                                     slot-names
                                     &key lambda-list argument-precedence-order
                                       (method-combination '(standard))
                                     &allow-other-keys)
  (let* ((plist (analyze-lambda-list lambda-list))
         (required-args (getf plist ':required-args)))
    (%set-gf-required-args instance required-args)
    (%set-gf-optional-args instance (getf plist :optional-args))
    (set-generic-function-argument-precedence-order
     instance (or argument-precedence-order required-args)))
  (unless (typep (generic-function-method-combination instance)
                 'method-combination)
    ;; this fixes (make-instance 'standard-generic-function) -- the
    ;; constructor of StandardGenericFunction sets this slot to '(standard)
    (setf (generic-function-method-combination instance)
          (find-method-combination
           instance (car method-combination) (cdr method-combination))))
  (finalize-standard-generic-function instance))

;;; Readers for generic function metaobjects
;;; AMOP pg. 216ff.
(atomic-defgeneric generic-function-argument-precedence-order (generic-function)
  (:method ((generic-function standard-generic-function))
    (sys:%generic-function-argument-precedence-order generic-function)))

(atomic-defgeneric generic-function-declarations (generic-function)
  (:method ((generic-function standard-generic-function))
    (sys:%generic-function-declarations generic-function)))

(atomic-defgeneric generic-function-lambda-list (generic-function)
  (:method ((generic-function standard-generic-function))
    (sys:%generic-function-lambda-list generic-function)))

(atomic-defgeneric generic-function-method-class (generic-function)
  (:method ((generic-function standard-generic-function))
    (sys:%generic-function-method-class generic-function)))

(atomic-defgeneric generic-function-method-combination (generic-function)
  (:method ((generic-function standard-generic-function))
    (sys:%generic-function-method-combination generic-function)))

(atomic-defgeneric generic-function-methods (generic-function)
  (:method ((generic-function standard-generic-function))
    (sys:%generic-function-methods generic-function)))

(atomic-defgeneric generic-function-name (generic-function)
  (:method ((generic-function standard-generic-function))
    (sys:%generic-function-name generic-function)))

;;; AMOP pg. 231
(defgeneric (setf generic-function-name) (new-value gf)
  (:method (new-value (gf generic-function))
    (reinitialize-instance gf :name new-value)))

;;; Readers for Method Metaobjects
;;; AMOP pg. 218ff.

(atomic-defgeneric method-function (method)
  (:method ((method standard-method))
    (std-method-function method)))

(atomic-defgeneric method-generic-function (method)
  (:method ((method standard-method))
    (std-method-generic-function method)))

(atomic-defgeneric method-lambda-list (method)
  (:method ((method standard-method))
    (std-slot-value method 'sys::lambda-list)))

(atomic-defgeneric method-specializers (method)
  (:method ((method standard-method))
    (std-method-specializers method)))

(atomic-defgeneric method-qualifiers (method)
  (:method ((method standard-method))
    (std-method-qualifiers method)))

(atomic-defgeneric accessor-method-slot-definition (method)
  (:method ((method standard-accessor-method))
    (std-accessor-method-slot-definition method)))


;;; find-method-combination

;;; AMOP pg. 191
(atomic-defgeneric find-method-combination (gf name options)
  (:method (gf (name symbol) options)
    (std-find-method-combination gf name options)))

;;; specializer-direct-method and friends.

;;; AMOP pg. 237
(defgeneric specializer-direct-generic-functions (specializer))

(defmethod specializer-direct-generic-functions ((specializer class))
  (delete-duplicates (mapcar #'method-generic-function
                             (class-direct-methods specializer))))

(defmethod specializer-direct-generic-functions ((specializer eql-specializer))
  (delete-duplicates (mapcar #'method-generic-function
                             (slot-value specializer 'direct-methods))))

;;; AMOP pg. 238
(defgeneric specializer-direct-methods (specializer))

(defmethod specializer-direct-methods ((specializer class))
  (class-direct-methods specializer))

(defmethod specializer-direct-methods ((specializer eql-specializer))
  (slot-value specializer 'direct-methods))

;;; AMOP pg. 165
(atomic-defgeneric add-direct-method (specializer method)
  (:method ((specializer class) (method method))
    (pushnew method (class-direct-methods specializer)))
  (:method ((specializer eql-specializer) (method method))
    (pushnew method (slot-value specializer 'direct-methods))))


;;; AMOP pg. 227
(atomic-defgeneric remove-direct-method (specializer method)
  (:method ((specializer class) (method method))
    (setf (class-direct-methods specializer)
          (remove method (class-direct-methods specializer))))
  (:method ((specializer eql-specializer) (method method))
    (setf (slot-value specializer 'direct-methods)
          (remove method (slot-value specializer 'direct-methods)))))

;;; The Dependent Maintenance Protocol (AMOP pg. 160ff.)

(defvar *dependents* (make-hash-table :test 'eq :weakness :key))

;;; AMOP pg. 164
(defgeneric add-dependent (metaobject dependent))
(defmethod add-dependent ((metaobject standard-class) dependent)
  (pushnew dependent (gethash metaobject *dependents* nil)))
(defmethod add-dependent ((metaobject funcallable-standard-class) dependent)
  (pushnew dependent (gethash metaobject *dependents* nil)))
(defmethod add-dependent ((metaobject standard-generic-function) dependent)
  (pushnew dependent (gethash metaobject *dependents* nil)))

;;; AMOP pg. 225
(defgeneric remove-dependent (metaobject dependent))
(defmethod remove-dependent ((metaobject standard-class) dependent)
  (setf (gethash metaobject *dependents*)
        (delete dependent (gethash metaobject *dependents* nil) :test #'eq)))
(defmethod remove-dependent ((metaobject funcallable-standard-class) dependent)
  (setf (gethash metaobject *dependents*)
        (delete dependent (gethash metaobject *dependents* nil) :test #'eq)))
(defmethod remove-dependent ((metaobject standard-generic-function) dependent)
  (setf (gethash metaobject *dependents*)
        (delete dependent (gethash metaobject *dependents* nil) :test #'eq)))

;;; AMOP pg. 210
(atomic-defgeneric map-dependents (metaobject function)
  (:method ((metaobject standard-class) function)
    (dolist (dependent (gethash metaobject *dependents* nil))
      (funcall function dependent)))
  (:method ((metaobject funcallable-standard-class) function)
    (dolist (dependent (gethash metaobject *dependents* nil))
      (funcall function dependent)))
  (:method ((metaobject standard-generic-function) function)
    (dolist (dependent (gethash metaobject *dependents* nil))
      (funcall function dependent))))

;;; AMOP pg. 239
(defgeneric update-dependent (metaobject dependent &rest initargs))


;;; ensure-generic-function(-using-class), AMOP pg. 185ff.
(defgeneric ensure-generic-function-using-class (generic-function function-name
                                                 &key
                                                   argument-precedence-order
                                                   declarations documentation
                                                   generic-function-class
                                                   lambda-list method-class
                                                   method-combination
                                                   name
                                                 &allow-other-keys))

(defmethod ensure-generic-function-using-class
    ((generic-function generic-function)
     function-name
     &rest all-keys
     &key (generic-function-class (class-of generic-function))
     (method-class (generic-function-method-class generic-function))
     (method-combination (generic-function-method-combination generic-function))
     &allow-other-keys)
  (setf all-keys (copy-list all-keys))  ; since we modify it
  (remf all-keys :generic-function-class)
  (unless (classp generic-function-class)
    (setf generic-function-class (find-class generic-function-class)))
  (unless (classp method-class) (setf method-class (find-class method-class)))
  (unless (eq generic-function-class (class-of generic-function))
    (error "The class ~S is incompatible with the existing class (~S) of ~S."
           generic-function-class (class-of generic-function) generic-function))
  ;; We used to check for changes in method class here, but CLHS says:
  ;; "If function-name specifies a generic function that has a different
  ;; value for the :method-class argument, the value is changed, but any
  ;; existing methods are not changed."
  (unless (typep method-combination 'method-combination)
    (setf method-combination
          (find-method-combination generic-function
                                   (car method-combination)
                                   (cdr method-combination))))
  (apply #'reinitialize-instance generic-function
         :method-combination method-combination
         :method-class method-class
         all-keys)
  generic-function)

(defmethod ensure-generic-function-using-class ((generic-function null)
                                                function-name
                                                &rest all-keys
                                                &key (generic-function-class +the-standard-generic-function-class+)
                                                &allow-other-keys)
  (setf all-keys (copy-list all-keys))  ; since we modify it
  (remf all-keys :generic-function-class)
  (unless (classp generic-function-class)
    (setf generic-function-class (find-class generic-function-class)))
  (when (and (null *clos-booting*) (fboundp function-name))
    (if (or (autoloadp function-name)
            (and (consp function-name)
                 (eq 'setf (first function-name))
                 (autoload-ref-p (second function-name))))
        (fmakunbound function-name)
        (error 'program-error
               :format-control "~A already names an ordinary function, macro, or special operator."
               :format-arguments (list function-name))))
  (apply (if (eq generic-function-class +the-standard-generic-function-class+)
             #'make-instance-standard-generic-function
             #'make-instance)
         generic-function-class :name function-name all-keys))

(defun ensure-generic-function (function-name &rest all-keys
                                &key
                                  lambda-list generic-function-class
                                  method-class
                                  method-combination
                                  argument-precedence-order
                                  declarations
                                  documentation
                                &allow-other-keys)
  (declare (ignore lambda-list generic-function-class method-class
                   method-combination argument-precedence-order declarations
                   documentation))
  (apply #'ensure-generic-function-using-class
         (find-generic-function function-name nil)
         function-name all-keys))

;;; SLIME compatibility functions.

(defun %method-generic-function (method)
  (method-generic-function method))

(defun %method-function (method)
  (method-function method))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require "MOP"))

(provide "CLOS")