path: root/Sacla/clos.lisp

;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
;; ALL RIGHTS RESERVED.
;;
;; $Id: clos.lisp,v 1.28 2004/09/24 07:31:33 yuji Exp $
;; 
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;; 
;;  * Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;;  * Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in
;;    the documentation and/or other materials provided with the
;;    distribution.
;; 
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;; Non conformance points to CLOS.
;; * (defmethod allocate-instance ((class structure-class) &rest initargs))
;;   is not implemented.
;;        
;; Non conformance points to MOP.
;; * 
;;


(defparameter *mop-working-p* nil)
(defparameter *symbol-function-is-funcallable-object-p* t)



(defstruct %standard-object
  class
  (version nil)
  storage)

(defun swap-%standard-object (a b)
  (rotatef (%standard-object-class   a) (%standard-object-class   b))
  (rotatef (%standard-object-version a) (%standard-object-version b))
  (rotatef (%standard-object-storage a) (%standard-object-storage b)))



(defparameter *classes* (make-hash-table)
  "The hash table of all classes in CLOS system.")
(defun find-class (symbol &optional errorp environment) ; clos
  "Return the class object named by SYMBOL in ENVIRONMENT."
  (declare (ignore environment))
  (multiple-value-bind (class presentp) (gethash symbol *classes*)
    (if presentp
        class
        (when errorp (error "Class ~S does not exist." symbol)))))
(defun (setf find-class) (new-class symbol &optional errorp environment) ; clos
  "Set the name of NEW-CLASS to SYMBOL in ENVIRONMENT."
  (declare (ignore environment))
  (if new-class
      (setf (gethash symbol *classes*) new-class)
      (remhash symbol *classes*))
  new-class)



(defun plist-member (key plist)
  (loop for rest on plist by #'cddr
        if (eq key (car rest)) return rest))

(defun plist-keys (plist) (loop for key in plist by #'cddr collect key))



;; AMOP 5.4.2 The defclass Macro http://www.lisp.org/mop/concepts.html#defclass
;; > The relationship between the arguments to the defclass macro and
;; > the arguments received by ensure-generic-function is defined.

(defun qt? (object)
  "Return a quoted form of OBJECT or OBJECT itself if it's self-evaluating."
  (flet ((self-evaluating-object-p (object)
           (typecase object
             ((or number character array) t)
             (symbol (or (keywordp object) (member object '(t nil))))
             (t nil))))
    (if (self-evaluating-object-p object)
        object
        `(quote ,object))))

(defun check-direct-slot-spec-options (slot-spec)
  (let ((reserved-keys '(:name :initargs :initfunction :readers :writers))
        (multiple-keys '(:initarg :reader :writer :accessor))
        (keys '())
        (name (car slot-spec)))
    (dolist (key (plist-keys (cdr slot-spec)))
      (cond
        ((member key reserved-keys)
         (error "Reserved option ~S is wrongly given in slot ~S ." key name))
        ((and (member key keys) (not (member key multiple-keys)))
         (error "Option ~S is given more than once in slot ~S." key name))
        (t (push key keys))))))

(defun direct-slot-initargs-form (slot-spec)
  ;; direct-slot-initargs is a canonicalized slot specification described in
  ;; http://www.lisp.org/mop/concepts.html#defclass .
  (flet ((specified-more-than-once-p (key)
           (< 1 (count key (plist-keys (cdr slot-spec)))))
         (quote-keys (plist)
           (loop for (key value) on plist by #'cddr nconc `(,(qt? key) ,value))))
    (check-direct-slot-spec-options slot-spec)
    (loop for (key value) on (cdr slot-spec) by #'cddr
          if (eq key :initform)
            nconc `(:initform ',value :initfunction #'(lambda () ,value))
            into plist
          else if (eq key :initarg)  collect value          into initargs
          else if (eq key :reader)   collect value          into readers
          else if (eq key :writer)   collect value          into writers
          else if (eq key :accessor) collect value          into readers and
                                     collect `(setf ,value) into writers
          else if (specified-more-than-once-p key)
            if (getf plist key)
              do (setf (cdr (last (getf plist key))) `((quote ,value)))
            else
              nconc `(,key (list ',value)) into plist end
          else nconc `(,key ',value) into plist
          finally
          (return `(list :name ',(car slot-spec) :initargs ',initargs
                    :readers ',readers :writers ',writers
                    ,@(quote-keys `(,@plist :initform 'nil :initfunction 'nil
                                    :documentation 'nil)))))))

(defun class-initargs-form (options)
  ;; See http://www.lisp.org/mop/concepts.html#defclass
  (labels ((check-options (alist)
             (let ((reserved-keys '(:name :direct-default-initargs))
                   (keys '()))
               (dolist (key (mapcar #'first alist))
                 (cond
                   ((member key reserved-keys)
                    (error "Reserved option ~S is wrongly given." key))
                   ((member key keys)
                    (error "Option ~S is given more than once." key))
                   (t (push key keys))))))
           (direct-default-initargs-form (initargs)
               (loop for (key form) on initargs by #'cddr
                     collect `(list ',key ',form #'(lambda () ,form)) into result
                     finally (return `(list ,@result))))
           (value-form (key rest)
             (case key
               (:direct-default-initargs (direct-default-initargs-form rest))
               (:direct-slots `(list ,@(mapcar #'direct-slot-initargs-form rest)))
               ((:metaclass :documentation)
                (destructuring-bind (value) rest (qt? value)))
               (t (qt? rest)))))
    (check-options options)
    (loop for (key . rest) in options
          when (eq key :default-initargs) do (setq key :direct-default-initargs)
          nconc `(,(qt? key) ,(value-form key rest)) into result
          finally (return `(list ,@result)))))

(defun <ensure-class> (name &rest initargs)
  (apply (if *mop-working-p* #'ensure-class #'ensure-system-class)
         name initargs))

(defmacro defclass (name direct-superclasses direct-slots &rest options) ; clos
  "Define a new class named NAME which is a subclass of DIRECT-SUPERCLASSES."
  (let* ((*message-prefix* (format nil "DEFCLASS ~S: " name)))
    `(let ((*message-prefix* ,*message-prefix*))
      (apply #'<ensure-class>
       ',name
       ,(class-initargs-form `((:direct-superclasses ,@direct-superclasses)
                               (:direct-slots ,@direct-slots)
                               ,@options))))))



(defun class-of (object)                ; clos
  "Return the class of which OBJECT is a direct instance."
  ;; 4.3.7 Integrating Types and Classes
  ;; http://www.lispworks.com/reference/HyperSpec/Body/04_cg.htm
  (cond
    ((%standard-object-p object) (%standard-object-class object))
    ((functionp object) (let ((gf (find-generic-function object)))
                          (if gf
                              (class-of gf)
                              (find-class 'function))))
    (t (let ((type (type-of object)))
         (or (and (symbolp type) (find-class type))
             (typecase object
               ((and symbol (not null)) (find-class 'symbol))
               (character (find-class 'character))
               (hash-table (find-class 'hash-table))
               (sequence (class-of-sequence object))
               ((and array (not vector)) (find-class 'array))
               (number (class-of-number object))
               (stream (class-of-stream object))
               (pathname (typecase object
                           (logical-pathname (find-class 'logical-pathname))
                           (t (find-class 'pathname))))
               (package (find-class 'package))
               (random-state (find-class 'random-state))
               (readtable (find-class 'readtable))
               (restart (find-class 'restart))
               (condition (class-of-condition object))
               (t (find-class 't))))))))

(defun frozen-class-instance-p (object)
  (and (%standard-object-p object) (null (%standard-object-version object))))

(defconstant +unbound-state+ (gensym "UNBOUND-STATE-"))

(defun slot-value (object slot-name)    ; clos
  "Return the value of the slot named SLOT-NAME in OBJECT."
  (flet ((slot-is-missing ()
           (slot-missing (class-of object) object slot-name 'slot-value))
         (slot-is-unbound ()
           (slot-unbound (class-of object) object slot-name)))
    (if (frozen-class-instance-p object)
        (let ((binding (assoc slot-name (%standard-object-storage object))))
          (if binding
              (let ((value (second binding)))
                (if (not (eq value +unbound-state+))
                    value
                    (values (slot-is-unbound))))
              (values (slot-is-missing))))
        (let* ((class (class-of object))
               (slot (find-slot class slot-name)))
          (if slot
              (slot-value-using-class class object slot)
              (values (slot-is-missing)))))))

(defun (setf slot-value) (new-value object slot-name) ; clos
  "Set the value of the slot named SLOT-NAME in OBJECT to NEW-VALUE."
  (flet ((slot-is-missing ()
           (slot-missing (class-of object) object slot-name 'setf new-value)))
    (if (frozen-class-instance-p object)
        (let ((binding (assoc slot-name (%standard-object-storage object))))
          (if binding
              (progn
                (assert (typep new-value (third binding)))
                (setf (second binding) new-value))
              (slot-is-missing)))
        (let* ((class (class-of object))
               (slot (find-slot class slot-name)))
          (assert (typep new-value (slot-definition-type slot)))
          (if slot
              (setf (slot-value-using-class class object slot) new-value)
              (slot-is-missing))))
    new-value))

(defun slot-boundp (instance slot-name) ; clos
  "Return true if the slot named SLOT-NAME in INSTANCE is bound."
  (flet ((slot-is-missing ()
           (slot-missing (class-of instance) instance slot-name 'slot-value)))
    (if (frozen-class-instance-p instance)
        (let ((binding (assoc slot-name (%standard-object-storage instance))))
          (if binding
              (not (eq (second binding) +unbound-state+))
              (values (slot-is-missing))))
        (let* ((class (class-of instance))
               (slot (find-slot class slot-name)))
          (if slot
              (slot-boundp-using-class class instance slot)
              (values (slot-is-missing)))))))
(defun find-slot (class slot-name)
  (find slot-name (slot-value class 'slots)
        :key #'(lambda (slot) (slot-value slot 'name))))
(defun local-slot-p (slot) (eq (slot-value slot 'allocation) :instance))



;; for debug
(defmethod print-object ((object %standard-object) stream)
  (flet ((slot (object name)
           (second (assoc name (%standard-object-storage object)))))
    (let ((class (class-of object)))
      (cond
        ((and (%standard-object-p class)
              (assoc 'name (%standard-object-storage class)))
         (if (assoc 'name (%standard-object-storage object))
             (format stream "#<~S:(~S)>" (slot class 'name) (slot object 'name))
             (format stream "#<~S:>" (slot class 'name))))
        ((assoc 'name (%standard-object-storage object))
         (format stream "#<:(~S)>" (slot object 'name)))
        (t
         (format stream "#<(CLOS object)>"))))))



;; 7.1.3 Defaulting of Initialization Arguments
;;         http://www.lispworks.com/reference/HyperSpec/Body/07_ac.htm
;; 7.1.4 Rules for Initialization Arguments
;;         http://www.lispworks.com/reference/HyperSpec/Body/07_ad.htm
(defun compute-standard-default-initargs (class)
  (flet ((default-initargs (class)
           (mapappend #'(lambda (class)
                          (slot-value class 'direct-default-initargs))
                      (slot-value class 'precedence-list))))
    (loop for initarg in (default-initargs class) with args = '()
          for name = (car initarg)
          unless (member name args)
            collect initarg and do (push name args))))

(defun defaulted-initargs (class initargs)
  (append initargs
          (loop for (key form func) in (slot-value class 'default-initargs)
                ;; each key is unique throughout the iteration.
                unless (plist-member key initargs)
                  nconc `(,key ,(funcall func)))))



(defun finalized-p (class)
  (flet ((defclassed-p (class)
             (and (%standard-object-p class) (%standard-object-storage class))))
    (when (symbolp class) (setq class (find-class class)))
    (and (defclassed-p class) (slot-value class 'finalized-p))))

(defun canonicalize-instance (instance)
  (let* ((class (class-of instance))
         (initargs (mapcan #'(lambda (binding)
                               (list (%keyword (first binding)) (second binding)))
                           (%standard-object-storage instance)))
         (defaulted-initargs (defaulted-initargs class initargs))
         (dummy (make-%standard-object
                 :class class
                 :storage (allocate-standard-instance-storage class))))
    (standard-shared-initialize dummy t defaulted-initargs)
    (swap-%standard-object instance dummy))
  instance)

(defun make-system-instance (class &rest initargs)
  (flet ((alist-storage (plist)
           (loop for (key value) on plist by #'cddr
                 collect (list (intern (string key)) value 't))))
    (let ((instance (make-%standard-object
                     :class class
                     :version nil
                     :storage (alist-storage initargs))))
      (when (finalized-p class)
        (canonicalize-instance instance))
      instance)))

(defun ensure-class-object (name &rest initargs)
  (let ((metaclass (let ((metaclass-name (getf initargs :metaclass)))
                     (when metaclass-name
                       (ensure-class-object metaclass-name))))
        (class (find-class name)))
    (if class
        (when initargs
          (let* ((dummy (apply #'make-system-instance metaclass initargs)))
            (swap-%standard-object class dummy)))
        (setf (find-class name)
              (apply #'make-system-instance metaclass initargs)))
    (find-class name)))



(defun allocate-standard-instance-storage (class)
  (let* ((slots (slot-value class 'slots))
         (local-slots (sort (mapcan #'(lambda (slot)
                                        (when (local-slot-p slot)
                                          (list slot)))
                                    slots)
                            #'<
                            :key #'(lambda (slot) (slot-value slot 'location))))
         (shared-slots (mapcan #'(lambda (slot)
                                   (when (not (local-slot-p slot))
                                     (list slot)))
                               slots)))
    (if (frozen-class-instance-p class)
        (let ((local-alist (loop for slot in local-slots
                                 for name = (slot-value slot 'name)
                                 for type = (slot-value slot 'type)
                                 collect `(,name ,+unbound-state+ ,type)))
              (shared-alist (loop for slot in shared-slots
                                  for name = (slot-value slot 'name)
                                  for binding = (slot-value slot 'shared-binding)
                                  collect (cons name binding))))
          (nconc local-alist shared-alist))
        (make-array (length local-slots) :initial-element +unbound-state+))))

(defun class-slot-names (class)
  (mapcar #'(lambda (slot) (slot-value slot 'name)) (slot-value class 'slots)))

(defun standard-shared-initialize (instance slot-names initargs)
  (when (eq slot-names 't)
    (setq slot-names (class-slot-names (class-of instance))))
  (mapc #'(lambda (slot)
            (let ((name (slot-value slot 'name)))
              (multiple-value-bind (key value tail)
                  (get-properties initargs (slot-value slot 'initargs))
                (declare (ignore key))
                (if tail
                    (setf (slot-value instance name) value)
                    (when (and (member name slot-names)
                               (not (slot-boundp instance name))
                               (slot-value slot 'initfunction))
                      (setf (slot-value instance name)
                            (funcall (slot-value slot 'initfunction))))))))
        (slot-value (class-of instance) 'slots)))



;; 4.3.5 Determining the Class Precedence List
;; http://www.lispworks.com/reference/HyperSpec/Body/04_ce.htm
(defun topological-sort (classes pairs)
  (do (next
       (unordered classes (remove next unordered))
       (pairs pairs (remove-if #'(lambda (pair) (eq (first pair) next)) pairs))
       (result nil (cons next result)))
      ((null unordered) (nreverse result))
    (setq next (let ((candidates (remove-if #'(lambda (class)
                                                (find class pairs :key #'second))
                                            unordered)))
                 (assert (not (null candidates)))
                 (if (endp (cdr candidates))
                     (car candidates)
                     (block picker
                       (dolist (class result)
                         (dolist (super (slot-value class 'direct-superclasses))
                           (when (find super candidates)
                             (return-from picker super))))))))))


(defun compute-standard-class-precedence-list (class)
  (labels ((direct-supers (class) (slot-value class 'direct-superclasses))
           (superclasses (class)
             (labels ((supers (class)
                        (unless (eq class (find-class 't 'errorp))
                          (let ((directs (direct-supers class)))
                            (append directs (mapappend #'supers directs))))))
               (remove-duplicates (supers class))))
           (local-precedence-order-pairs (class)
             (unless (eq class (find-class 't 'errorp))
               (let ((directs (direct-supers class)))
                 (mapcar #'list (cons class directs) directs))))
           (pairs (classes)
             (delete-duplicates (mapcan #'local-precedence-order-pairs classes)
                                :test #'equal)))
    (let ((classes (cons class (superclasses class))))
      (topological-sort classes (pairs classes)))))

(defun class-precedence-names (class)   ; for debug
  (when (symbolp class) (setq class (find-class class 'errorp)))
  (mapcar #'(lambda (class) (slot-value class 'name))
          (slot-value class 'precedence-list)))



;; 7.5.3 Inheritance of Slots and Slot Options
;; http://www.lispworks.com/reference/HyperSpec/Body/07_ec.htm
(defun and-types (types)
  (labels ((type-eq (a b) (and (subtypep a b) (subtypep b a)))
           (proper-subtype-p (subtype type)
             (and (not (type-eq subtype type)) (subtypep subtype type))))
    (let ((types (mapcan #'(lambda (type)
                             (when (notany #'(lambda (t1)
                                               (proper-subtype-p t1 type))
                                           types)
                               (list type)))
                         (remove-duplicates types :test #'type-eq))))
      (if (endp (cdr types))
          (car types)
          `(and ,@types)))))

(defun effective-slot-initargs (class name direct-slots)
  (declare (ignorable class))
  (assert (not (null direct-slots)))
  (let* ((most-specific-slot (first direct-slots))
         (allocation (slot-value most-specific-slot 'allocation))
         (type (and-types (mapcar #'(lambda (slot) (slot-value slot 'type))
                                  direct-slots)))
         (shared-binding (slot-value most-specific-slot 'shared-binding)))
    `(:name ,name
      :allocation ,allocation
      ,@(or (loop for slot in direct-slots
                  for initfunction = (slot-value slot 'initfunction)
                  if initfunction
                  return `(:initform     ,(slot-value slot 'initform)
                           :initfunction ,(slot-value slot 'initfunction)))
            '(:initform nil :initfunction nil))
      :type ,type
      :initargs ,(remove-duplicates
                  (mapappend #'(lambda (slot)
                                 (slot-value slot 'initargs))
                             direct-slots))
      :documentation ,(loop for slot in direct-slots
                            for documentation = (slot-value slot 'documentation)
                            if documentation return it)
      :location nil
      :shared-binding ,(prog1 shared-binding
                              (when shared-binding
                                (setf (cdr shared-binding) (list type)))))))

(defun effective-slot-specs (class)
  ;; effective-slot-spec::= (name ([[direct-slot-object*]]))
  (let* ((direct-slots (mapappend #'(lambda (class)
                                      (slot-value class 'direct-slots))
                                  (slot-value class 'precedence-list)))
         (names (remove-duplicates (mapcar #'(lambda (slot)
                                               (slot-value slot 'name))
                                           direct-slots))))
    (mapcar #'(lambda (name)
                (list name (loop for slot in direct-slots
                                 if (eq name (slot-value slot 'name))
                                 collect slot)))
            names)))

(defun standard-direct-slot-definition (slot-spec)
  (setq slot-spec `(:shared-binding ,(when (eq :class
                                               (getf slot-spec :allocation))
                                           (list +unbound-state+))
                    ,@slot-spec :allocation :instance :type t))
  (let ((class (ensure-class-object 'standard-direct-slot-definition)))
    (apply #'make-system-instance class slot-spec)))

(defun assign-slots-locations (slots)
  (loop for slot in slots with location = 0
        if (local-slot-p slot)
        do (setf (slot-value slot 'location) location)
           (incf location))
  slots)

(defun compute-system-class-slots (class)
  (let* ((slot-class (ensure-class-object 'standard-effective-slot-definition))
         (slots (mapcar #'(lambda (initargs)
                            (apply #'make-system-instance slot-class initargs))
                        (mapcar #'(lambda (spec)
                                    (apply #'effective-slot-initargs class spec))
                                (effective-slot-specs class)))))
    (assign-slots-locations slots)
    slots))

(defconstant +funcallable-instance-function-slot-name+
  (gensym "FUNCALLABLE-INSTANCE-FUNCTION-SLOT-NAME-"))
(defconstant +funcallable-instance-function-slot-spec+
  (let ((name +funcallable-instance-function-slot-name+))
    (eval (direct-slot-initargs-form `(,name :initarg ,name)))))

(defun canonicalize-system-class-initargs (name &rest initargs &key
                                           (metaclass 'standard-class)
                                           direct-slots direct-superclasses
                                           &allow-other-keys)
  (when (eq metaclass 'funcallable-standard-class)
    (push +funcallable-instance-function-slot-spec+ direct-slots))
  (assert (not (null direct-superclasses)))
  (setq direct-superclasses (mapcar #'ensure-class-object direct-superclasses)
        direct-slots (mapcar #'standard-direct-slot-definition direct-slots))
  `(:name ,name :version nil :slots nil :precedence-list nil
    :default-initargs nil :finalized-p nil :direct-subclasses nil
    :direct-superclasses ,direct-superclasses :direct-slots ,direct-slots
    :direct-default-initargs nil :metaclass ,metaclass ,@initargs))

(defun subclassp (subclass class)
  (when (symbolp subclass) (setq subclass (find-class subclass 'errorp)))
  (when (symbolp class)    (setq class    (find-class class    'errorp)))
  (member class (slot-value subclass 'precedence-list)))
(defun instancep (object class) (subclassp (class-of object) class))

(defun canonicalize-system-instances (new-class)
  (let ((name (slot-value new-class 'name)))
    (cond
      ((subclassp new-class (ensure-class-object 'base-class))
       (loop for class being the hash-values of *classes*
             do (when (eq (class-of class) new-class)
                  (canonicalize-instance class))))
      ((eq name 'standard-direct-slot-definition)
       (loop for class being the hash-values of *classes*
             do (when (finalized-p class)
                  (dolist (slot (slot-value class 'direct-slots))
                    (canonicalize-instance slot)))))
      ((eq name 'standard-effective-slot-definition)
       (loop for class being the hash-values of *classes*
             do (when (finalized-p class)
                  (dolist (slot (slot-value class 'slots))
                    (canonicalize-instance slot))))))))

(defun finalize-system-class-inheritance (class)
  (setf (slot-value class 'precedence-list)
        (compute-standard-class-precedence-list class))
  (setf (slot-value class 'slots)
        (compute-system-class-slots class))
  (setf (slot-value class 'default-initargs)
        (compute-standard-default-initargs class))
  (setf (slot-value class 'finalized-p) t)
  (dolist (super (slot-value class 'direct-superclasses))
    (pushnew class (slot-value super 'direct-subclasses)))

  (canonicalize-system-instances class))

(defun ensure-system-class (name &rest initargs)
  (format t "~&ensure-system-class: class name = ~S~%" name)
  (let* ((initargs (apply #'canonicalize-system-class-initargs name initargs))
         (class (apply #'ensure-class-object name initargs)))
    (finalize-system-class-inheritance class)
    class))


;;; Inheritance Structure of Metaobject Classes specified by MOP
;;         http://www.lisp.org/mop/concepts.html#inherit-struct-figure
;;
;;   t-+- standard-object
;;     |      +- a class defined by DEFCLASS
;;     |      +- *metaobject -+- *specializer
;;     |      |               |     +- *class -+- standard-class
;;     |      |               |     |          +- funcallable-standard-class
;;     |      |               |     |          +- forward-referenced-class 
;;     |      |               |     |          +- structure-class
;;     |      |               |     |          +- built-in-class
;;     |      |               |     +- eql-specializer
;;     |      |               +- *method - standard-method
;;     |      |               |               +- *standard-accessor-method
;;     |      |               |                    + standard-reader-method
;;     |      |               |                    + standard-writer-method
;;     |      |               +- *method-combination
;;     |      |               +- *slot-definition
;;     |      |               |     +- *effective-slot-definition ---------+
;;     |      |               |     +- *direct-slot-definition --------+   |
;;     |      +------+        |     +- *standard-slot-definition       |   |
;;     |             |        |          + standard-direct-slot-definition |
;;     |             |        |          + standard-effective-slot-definition
;;     |             |        |
;;     |             |        +----------+
;;     +- function   |                   |
;;     |      |      |                   |
;;     |  funcallable-standard-object    |
;;     |      |                          |
;;     |      |      +-------------------+
;;     |      |      |
;;     |  *generic-function
;;     |      |
;;     |  standard-generic-function
;;     |
;;     +- structure-object
;;     |      |
;;     |      +- a structure defined by DEFSTRUCT
;;
;; Each class marked with a ``*'' is an abstract class and is not
;; intended to be instantiated. The results are undefined if an attempt
;; is made to make an instance of one of these classes with make-instance.

;; Current build time DEFCLASS limitations.
;; * superclasses must be defclassed before their subclasses.
;; * shared slots are not supported (partially implemented).

(defclass t (t) ()
  (:documentation "A superclass of every class, including itself.")
  (:metaclass built-in-class))
(defclass standard-object (t) ()
  (:documentation "A superclass of every class that is an instance of standard-class except itself."))
(defclass metaobject (standard-object) ()) ; mop abstract
(defclass specializer (metaobject)      ; mop abstract
  ((direct-methods :reader specializer-direct-methods
                   :initarg :direct-methods :initform nil)
   (direct-generic-functions :reader specializer-direct-generic-functions
                             :initarg :direct-generic-functions :initform nil)))


(defclass class (specializer)           ; clos abstract
  ((name :accessor class-name :initarg :name :initform nil)))
(defclass base-class (class)
  ((version :accessor class-version :initarg :version :initform nil)
   (slots :reader class-slots :initarg :slots :initform nil)
   (direct-slots :reader class-direct-slots :initarg :direct-slots :initform nil)
   (precedence-list :reader class-precedence-list
                    :initarg :precedence-list :initform nil)
   (direct-superclasses :accessor class-direct-superclasses
                        :initarg :direct-superclasses :initform nil)
   (direct-subclasses :accessor class-direct-subclasses
                      :initarg :direct-subclasses :initform nil)
   (default-initargs :reader class-default-initargs
                     :initarg :default-initargs :initform nil)
   (direct-default-initargs :reader class-direct-default-initargs
                            :initarg :direct-default-initargs :initform nil)   
   (finalized-p :reader class-finalized-p :initarg :finalized-p :initform nil)
   (documentation :initform nil :initarg :documentation)))
(defclass standard-base-class (base-class)
  ((version :initform 0)
   (old-classes :reader class-old-classes
                :initform (make-array 1 :adjustable t :fill-pointer 0))
   (dependents :initform nil)))
(defclass standard-class (standard-base-class) ()) ; clos
(defclass funcallable-standard-class (standard-base-class) ; mop
  ((direct-superclasses
    :initform (list (find-class 'funcallable-standard-object)))))
(defclass forward-referenced-class (class) ; mop
  ((direct-subclasses :accessor class-direct-subclasses :initform nil)))
(defclass structure-class (base-class) ; clos
  ()
  (:metaclass structure-class))
(defclass built-in-class (base-class) ()) ; clos
(defclass old-class (class)
  ((version :reader class-version)
   (slots :reader class-slots)))


(defvar *eql-specializers* (make-hash-table))
(defclass eql-specializer (specializer) ; mop
  ((object :initarg :object)))
(defun eql-specializer-object (eql-specializer) ; mop
  (slot-value eql-specializer 'object))
(defun find-eql-specializer (object) (gethash object *eql-specializers*))
(defun intern-eql-specializer (object)  ; mop
  (or (find-eql-specializer object)
      (setf (gethash object *eql-specializers*)
            (make-instance 'eql-specializer :object object))))


(defclass slot-definition (metaobject) ()) ; mop abstract
(defclass standard-slot-definition (slot-definition) ; mop abstract
  ((name :reader slot-definition-name :initarg :name)
   (type :reader slot-definition-type :initarg :type :initform 't)
   (allocation :reader slot-definition-allocation
               :initarg :allocation :initform :instance)
   (initargs :reader slot-definition-initargs :initarg :initargs)
   (initform :reader slot-definition-initform :initarg :initform)
   (initfunction :reader slot-definition-initfunction
                 :initarg :initfunction)
   (shared-binding :reader slot-definition-shared-binding
                   :initarg :shared-binding)
   (documentation :initarg :documentation))
  (:default-initargs :name (error "Slot name must be specified.")))
(defclass direct-slot-definition (slot-definition) ; mop abstract
  ((readers :reader slot-definition-readers :initarg :readers)
   (writers :reader slot-definition-writers :initarg :writers)))
(defclass effective-slot-definition (slot-definition) ; mop abstract
      ((location :reader slot-definition-location :initarg :location)))
(defclass standard-direct-slot-definition (standard-slot-definition
                                           direct-slot-definition) ; mop
  ())
(defclass standard-effective-slot-definition (standard-slot-definition
                                              effective-slot-definition) ; mop
  ())


(defclass method (metaobject) ())       ; clos abstract
(defclass standard-method (method)      ; clos
  ((function :reader method-function :initarg :function)
   (qualifiers :reader method-qualifiers :initarg :qualifiers)
   (specializers :reader method-specializers :initarg :specializers)
   (specialized-lambda-list :reader method-specialized-lambda-list
                            :initarg :specialized-lambda-list)
   (lambda-list :reader method-lambda-list :initarg :lambda-list)
   (generic-function :reader method-generic-function
                     :initarg :generic-function)
   ))
(defclass standard-accessor-method (standard-method) ()) ; mop abstract
(defclass standard-reader-method (standard-accessor-method) ; mop
  ())
(defclass standard-writer-method (standard-accessor-method) ; mop
  ())


(defclass function (t) () (:metaclass built-in-class))
(defclass funcallable-standard-object (standard-object function) ; mop
  ()
  (:metaclass funcallable-standard-class))
(defun funcallable-instance-function (funcallable-instance)
  (slot-value funcallable-instance +funcallable-instance-function-slot-name+))

(defun set-funcallable-instance-function (funcallable-instance function) ; mop
  (setf (slot-value funcallable-instance
                    +funcallable-instance-function-slot-name+)
        function))
(defclass generic-function (metaobject funcallable-standard-object) ()
  ;; clos abstract
  (:metaclass funcallable-standard-class))
(defclass standard-generic-function (generic-function) ; clos
  ((name :reader generic-function-name :initarg :name)
   (lambda-list :reader generic-function-lambda-list
                :initarg :lambda-list)
   (argument-precedence-order :reader generic-function-argument-precedence-order
                              :initarg :argument-precedence-order)
   (declarations :reader generic-function-declarations
                 :initarg :declarations)
   (method-class :reader generic-function-method-class
                 :initarg :method-class)
   (method-combination :reader generic-function-method-combination
                       :initarg :method-combination)
   (methods :reader generic-function-methods :initarg :methods)

   (number-of-required-args :reader number-of-required-args
                            :initarg :number-of-required-args)
   (applicable-methods :reader generic-function-applicable-methods
                       :initform (make-hash-table))
   (effective-methods :reader generic-function-effective-methods
                      :initform (make-hash-table :test #'equal))
   (dependents :initform nil)))


(defclass structure-object (t) ()
  (:documentation "A superclass of every class that is an instance of structure-class except itself.")
  (:metaclass structure-class))


;; Classes that correspond to pre-defined type specifiers
;; http://www.lispworks.com/reference/HyperSpec/Body/04_cg.htm#classtypecorrespondence
(defclass symbol              (t)              () (:metaclass built-in-class))
(defclass character           (t)              () (:metaclass built-in-class))
(defclass hash-table          (t)              () (:metaclass built-in-class))

(defclass sequence            (t)              () (:metaclass built-in-class))
(defclass list                (sequence)       () (:metaclass built-in-class))
(defclass cons                (list)           () (:metaclass built-in-class))
(defclass null                (symbol list)    () (:metaclass built-in-class))
(defclass array               (t)              () (:metaclass built-in-class))
(defclass vector              (array sequence) () (:metaclass built-in-class))
(defclass bit-vector          (vector)         () (:metaclass built-in-class))
(defclass string              (vector)         () (:metaclass built-in-class))

(defclass number              (t)              () (:metaclass built-in-class))
(defclass complex             (number)         () (:metaclass built-in-class))
(defclass real                (number)         () (:metaclass built-in-class))
(defclass float               (real)           () (:metaclass built-in-class))
(defclass rational            (real)           () (:metaclass built-in-class))
(defclass ratio               (rational)       () (:metaclass built-in-class))
(defclass integer             (rational)       () (:metaclass built-in-class))

(defclass stream              (t)              () (:metaclass built-in-class))
(defclass broadcast-stream    (stream)         () (:metaclass built-in-class))
(defclass concatenated-stream (stream)         () (:metaclass built-in-class))
(defclass string-stream       (stream)         () (:metaclass built-in-class))
(defclass echo-stream         (stream)         () (:metaclass built-in-class))
(defclass synonym-stream      (stream)         () (:metaclass built-in-class))
(defclass file-stream         (stream)         () (:metaclass built-in-class))
(defclass two-way-stream      (stream)         () (:metaclass built-in-class))

(defclass pathname            (t)              () (:metaclass built-in-class))
(defclass logical-pathname    (pathname)       () (:metaclass built-in-class))

(defclass package             (t)              () (:metaclass built-in-class))
(defclass random-state        (t)              () (:metaclass built-in-class))
(defclass readtable           (t)              () (:metaclass built-in-class))
(defclass restart             (t)              () (:metaclass built-in-class))



(defclass method-combination (metaobject) ()) ; clos
(defstruct method-combination-type
  (name)
  (lambda-list)
  (group-specifiers)
  (args-lambda-list)
  (generic-function-symbol)
  (documentation)
  (function)
  (short-form-options))
(defclass standard-method-combination (method-combination) ; clos
  ((type :reader method-combination-type :initarg :type)
   (arguments :reader method-combination-arguments :initarg :arguments)))

(defparameter *method-combination-types* (make-hash-table))

(defun define-method-combination-type (name &rest initargs)
  (let ((combination-type (apply #'make-method-combination-type
                                 :allow-other-keys t :name name initargs)))
    (setf (gethash name *method-combination-types*) combination-type)))

(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)))
    `(:name ,name
      :predicate #'(lambda (qualifiers)
                     (loop for item in ',selecters
                           thereis (method-group-p item qualifiers)))
      :description ,description
      :order ,order
      :required ,required-p)))

(defconstant +gf-args-variable+ (gensym "GF-ARGS-VARIABLE-")
  "A Variable name whose value is a list of all arguments to a generic function.")

(defun extract-required-part (lambda-list)
  (flet ((skip (key lambda-list)
           (if (eq (first lambda-list) key)
               (cddr lambda-list)
               lambda-list)))
    (ldiff (skip '&environment (skip '&whole lambda-list))
           (member-if #'(lambda (it) (member it lambda-list-keywords))
                      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-arguments-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 `(,(%keyword key) ,key))
                            ,(car rest)
                            ,@(cdr rest))))
                    keys)
            (mapcar #'(lambda (spec)
                        (if (consp spec)
                            `(,(first spec) ,(second spec))
                            `(,spec nil)))
                    aux))))

(defmacro getk (plist key init-form)
  "Similar to getf except eval and return INIT-FORM if KEY has no value in PLIST."
  (let ((not-exist (gensym))
        (value (gensym)))
    `(let ((,value (getf ,plist ,key ,not-exist)))
      (if (eq ,not-exist ,value) ,init-form ,value))))

(defmacro with-args-lambda-list (args-lambda-list generic-function-symbol
                                 &body forms)
  (let ((gf-lambda-list (gensym))
        (nrequired (gensym))
        (noptional (gensym))
        (rest-args (gensym)))
    (multiple-value-bind (whole required optional rest keys aux)
        (parse-define-method-combination-arguments-lambda-list args-lambda-list)
      `(let* ((,gf-lambda-list (slot-value ,generic-function-symbol 'lambda-list))
              (,nrequired (length (extract-required-part ,gf-lambda-list)))
              (,noptional (length (extract-optional-part ,gf-lambda-list)))
              (,rest-args (subseq ,+gf-args-variable+ (+ ,nrequired ,noptional)))
              ,@(when whole `((,whole ,+gf-args-variable+)))
              ,@(loop for var in required and i upfrom 0
                      collect `(,var (when (< ,i ,nrequired)
                                       (nth ,i ,+gf-args-variable+))))
              ,@(loop for (var init-form) in optional and i upfrom 0
                      collect
                      `(,var (if (< ,i ,noptional)
                                 (nth (+ ,nrequired ,i) ,+gf-args-variable+)
                                 ,init-form)))
              ,@(when rest `((,rest ,rest-args)))
              ,@(loop for ((key var) init-form) in keys and i upfrom 0
                      collect `(,var (getk ,rest-args ',key ,init-form)))
              ,@(loop for (var init-form) in aux and i upfrom 0
                      collect `(,var ,init-form)))
        ,@forms))))

(defun invalid-method-error (method format-control &rest args)
  (declare (ignorable method))
  (apply #'error format-control args))

(defun method-combination-error (format-control &rest args)
  (apply #'error format-control args))

(defmacro with-method-groups (method-group-specs methods-form &body forms)
  (flet ((grouping-form (spec methods-var)
           (let ((predicate (getf spec :predicate))
                 (group (gensym))
                 (leftovers (gensym))
                 (method (gensym)))
             `(let ((,group '())
                    (,leftovers '()))
               (dolist (,method ,methods-var)
                 (if (funcall ,predicate (slot-value ,method 'qualifiers))
                     (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 (slot-value ,method 'qualifiers)))
        ,@forms))))

(defun method-combination-type-lambda
    (&key name lambda-list args-lambda-list generic-function-symbol
     method-group-specs declarations forms &allow-other-keys)
  (let ((methods (gensym)))
    `(lambda (,generic-function-symbol ,methods ,@lambda-list)
      ,@declarations
      (let ((*message-prefix* ,(format nil "METHOD COMBINATION TYPE ~S: " name)))
        (with-method-groups ,method-group-specs
          ,methods
          ,@(if (null args-lambda-list)
                forms
                `((with-args-lambda-list ,args-lambda-list
                    ,generic-function-symbol
                    ,@forms))))))))

(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
                     ,(mapcar #'canonicalize-method-group-spec method-group-specs)
                     ,@(long-form-method-combination-args args)))
         (lambda-expression (apply #'method-combination-type-lambda initargs)))
    ;;(format t "~&~S~%" lambda-expression)
    (apply #'define-method-combination-type name
           `(,@initargs
             :function ,(compile nil lambda-expression)
             :short-form-options nil))))

(defun define-short-form-method-combination
    (name &key identity-with-one-argument (documentation "") (operator name))
  (define-long-form-method-combination name
      '(&optional (order :most-specific-first))
    `((around (:around))
      (primary (,name) :order order :required t))
      documentation
      `(let ((form (if (and ,identity-with-one-argument (null (rest primary)))
                       `(call-method ,(first primary))
                       (cons ',operator (mapcar #'(lambda (method)
                                                    `(call-method ,method))
                                                primary)))))
        (if around
            `(call-method ,(first around) (,@(rest around) (make-method ,form)))
            form)))
  (let ((combination-type (gethash name *method-combination-types*)))
    (setf (method-combination-type-short-form-options combination-type)
          `(:documentation ,documentation
            :operator ,operator
            :identity-with-one-argument ,identity-with-one-argument)))
  name)

(defmacro define-method-combination (name &rest args) ; clos
  "Define new types of method combination."
  (format t "~&define-method-combination: ~S~%" name)
  `(let ((*message-prefix*
          ,(format nil "DEFINE-METHOD-COMBINATION ~S: " name)))
    (apply #',(if (listp (first args))
                  'define-long-form-method-combination
                  'define-short-form-method-combination) ',name ',args)))


;; 7.6.6.4 Built-in Method Combination Types
;; http://www.lispworks.com/reference/HyperSpec/Body/07_ffd.htm
(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 t)
(define-method-combination list   :identity-with-one-argument t)
(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)
(define-method-combination standard ()
  ((around (:around))
   (before (:before))
   (primary () :required t)
   (after (:after)))
  (flet ((call-methods (methods)
           (mapcar #'(lambda (method)
                       `(call-method ,method))
                   methods)))
    (let ((form (if (or before after (rest primary))
                    `(multiple-value-prog1
                      (progn ,@(call-methods before)
                             (call-method ,(first primary)
                                          ,(rest primary)))
                      ,@(call-methods (reverse after)))
                    `(call-method ,(first primary)))))
      (if around
          `(call-method ,(first around)
            (,@(rest around)
             (make-method ,form)))
          form))))


;;;;
;#|

;; AMOP 5.4.5 The defgeneric Macro
;; http://www.lisp.org/mop/concepts.html#defgeneric
;;
;; AMOP 5.4.3 The defmethod Macro
;; http://www.lisp.org/mop/concepts.html#defmethod
;; AMOP 5.4.4 Processing Method Bodies
;; http://www.lisp.org/mop/concepts.html#processing-method-bodies

(defvar *generic-functions* (make-hash-table))
(defun find-generic-function (symbol &optional errorp)
  (let ((symbol-function function))
    (if (instancep function 'generic-function)
        function
        (multiple-value-bind (generic-function presentp)
            (gethash discriminating-function *generic-functions*)
          (if presentp
              generic-function
              (when errorp
                (error "Generic function ~S does not exist." symbol)))))))
(defun install-generic-function (symbol gf)
  (let (discriminating-function (compute-discriminating-function gf))
    (if *symbol-function-is-funcallable-object-p*
        (when symbol (setf (symbol-function symbol) gf))
        (progn
          (remhash (funcallable-instance-function gf) *generic-functions*)
          (setf (gethash discriminating-function *generic-functions*) gf)
          (when symbol (setf (symbol-function symbol) discriminating-function))))
    (set-funcallable-instance-function gf discriminating-function)
    gf))


(defun method-spec (method-description)
  ;; method-description::= (:method method-qualifier* specialized-lambda-list
  ;;                        [[declaration* | documentation]] form*)
  (let ((rest (progn
                (assert (eq :method (car method-description)))
                (cdr method-description))))
    (flet ((qualifier* ()
             (let* ((end (or (position-if #'consp rest)
                             (error "No specialized lambda list found in ~S."
                                    method-description)))
                    (method-qualifiers (subseq rest 0 end)))
               (assert (notany #'listp method-qualifiers))
               (prog1 method-qualifiers (setq rest (nthcdr end rest)))))
           (lambda-list1 ()
             (let ((specialized-lambda-list (car rest)))
               (validate-specialized-lambda-list specialized-lambda-list)
               (prog1 specialized-lambda-list (setq rest (cdr rest)))))
           (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))
      `(:qualifiers ,(qualifier*)
        :specialized-lambda-list ,(lambda-list1)
        ,@(let ((decls (declaration*)))
               `(:documentation ,(documentation?)
                 :declarations ,(mapappend #'cdr `(,@decls ,@(declaration*)))))
        :forms ,(form*)))))

(defun method-spec-to-ensure-generic-function-form (name spec env)
  (let* ((lambda-list (extract-lambda-list (getf spec :specialized-lambda-list)))
         (options (canonicalize-defgeneric-options lambda-list '())))
    `(ensure-generic-function ,name :environment ,env ,@options)))

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

(defun make-system-method-lambda ()
  )

(defun <make-method-lambda>
    (generic-function method lambda-expression environment)
 (funcall (if *mop-working-p* #'make-method-lambda #'make-system-method-lambda)
          generic-function method lambda-expression environment))

(defun <class-prototype> (class)
  (funcall (if *mop-working-p* #'class-prototype #'make-system-instance)
           class))

(defun method-initargs-form (gf-form environment &key initial-method-p
                             null-lexical-environment-p specialized-lambda-list
                             qualifiers documentation declarations forms)
  (let* ((lambda-list (extract-lambda-list specialized-lambda-list))
         (specializer-names (extract-specializer-names specialized-lambda-list))
         (gf (gensym))
         (methods (gensym)) ;; used by make-method-lambda
         (lambda-expression (gensym))
         (initargs (gensym)))
    `(let* ((,gf ,gf-form)
            (,method-class (slot-value ,gf 'method-class)))
      (multiple-value-bind (,lambda-expression ,initargs)
          (<make-method-lambda> ,gf
                                (<class-prototype> ,method-class)
                                '(lambda (,+gf-args-variable+ ,methods)
                                  (apply #'(lambda ,(allow-other-keys lambda-list)
                                             (declare ,@declarations)
                                             ,@forms)
                                   ,+gf-args-variable+))
                                ,environment)
        (append ,initargs
                (list 
                 :qualifiers ',qualifiers
                 :specialized-lambda-list ',specialized-lambda-list
                 :lambda-list ',lambda-list
                 :specializers (mapcar #'find-class ,specializer-names)
                 :documentation ',documentation
                 :function (compile nil ,(if null-lexical-environment-p
                                             `(eval ,lambda-expression)
                                             'lambda-expression))
                 :initial-method-p ,initial-method-p)))))))


(defun check-defgeneric-declarations (declarations)
  
  )

(defun check-singleton-options (options valid-option-names)
  (flet ((redundant-option-error (option-name)
           (error 'simple-program-error
                  :format-control "~AOption ~S is given more than once."
                  :format-arguments (list *message-prefix* option-name)))
         (invalid-option-error (option-name)
           (error 'simple-program-error
                  :format-control "~AInvalid option ~S is given."
                  :format-arguments (list *message-prefix* option-name))))
    (loop for (key . rest) in options with processed = '()
          when (member key processed) do (redundant-option-error key)
          when (not (member key valid-option-names)) do (invalid-option-error key)
          do (push key processed)))

(defvar generic-function-initarg-names
  '(:argument-precedence-order :declare :documentation :environment
    :generic-function-class :lambda-list :method-class :method-combination))

(defun generic-function-initargs-form (options)
  (check-singleton-options options generic-function-initarg-names)
  (flet ((value-form (key rest)
           (case key
             ((:documentation :environment :generic-function-class
               :method-class :lambda-list)
              (destructuring-bind (value) rest (qt? value)))
             (t (qt? rest)))))
    (loop for (key . rest) in options
          when (eq key :declare) do (setq key :declarations)
          nconc `(,(qt? key) ,(value-form key rest)) into result
          finally (return `(list ,@result)))))

(defun ensure-system-generic-function (name &rest initargs)
  
  )

(defun add-system-method (generic-function method)
  )

(defun <ensure-generic-function> (name &rest initargs)
  (apply (if *mop-working-p*
             #'ensure-generic-function
             #'ensure-system-generic-function)
         name initargs))

(defun <make-instance> (name &rest initargs)
  (apply (if *mop-working-p* #'make-instance #'make-system-instance)
         name initargs))

(defun <add-method> (generic-function method)
  (funcall (if *mop-working-p* #'add-method #'add-system-method)
           generic-function method))

(defmacro defgeneric (name lambda-list &body args &environment env) ; clos
  "Define a generic function named NAME."
  (let* ((*message-prefix* (format nil "DEFGENERIC ~S: " name))
         (method-descriptions (loop for spec in args
                                    if (eq (first spec) :method) collect spec))
         (declarations (loop for spec in args
                             if (eq (first spec) 'declare) append (rest spec)))
         (options `((:lambda-list ,lambda-list)
                    (:environment ,env)
                    ,@(when declarations `((:declare ,@declarations)))
                    ,@(loop for spec in args
                            unless (member (first spec) '(:method declare))
                              collect spec)))
         (gf (gensym))
         (method-class (gensym))
         (methods (gensym)))
    (check-defgeneric-declarations declarations)
    `(let* ((*message-prefix* ,*message-prefix*)
            (,gf (apply #'<ensure-generic-function> ',name
                        ,(generic-function-initargs-form options)))
            (,method-class (generic-function-method-class ,gf))
            (,methods (list ,@(mapcar
                               #'(lambda (spec)
                                   `(apply #'<make-instance> ,method-class
                                     :initial-method-p t
                                     ,(apply #'method-initargs-form gf env spec)))
                               (mapcar #'method-spec method-descriptions)))))
      (mapc #'(lambda (method) (<add-method> ,gf method)) ,methods)
      ,gf)))))

(defmacro defmethod (name &rest args &environment env) ; clos
  "Define a method named NAME."
  (let ((spec (method-spec `(:method ,@args)))
        (gf (gensym))
        (method (gensym)))
    `(let* ((,gf (or (find-generic-function name)
                     ,(method-spec-to-ensure-generic-function-form
                       name spec env)))
            (,method (apply #'<make-instance>
                            (generic-function-method-class ,gf)
                            (method-initargs-form ,gf ,env ,@spec))))
      (<add-method> ,gf ,method)
      ,method)))

(defgeneric ensure-class-using-class (class name &key direct-default-initargs direct-slots direct-superclasses metaclass &allow-other-keys)) ; mop

(defmethod ensure-class-using-class ((class class) name &key (metaclass 'standard-class) direct-superclasses &allow-other-keys)
  (check-type class metaclass)
  (apply #'reinitialize-instance class initargs))

(defmethod ensure-class-using-class ((class forward-referenced-class) name &rest initargs &key (metaclass 'standard-class) direct-superclasses &allow-other-keys)
  (apply #'change-class class metaclass initargs))

(defmethod ensure-class-using-class ((class null) name &rest initargs
                                     &key (metaclass 'standard-class)
                                     direct-superclasses &allow-other-keys)
  (setf (find-class name) (apply #'make-instance metaclass initargs)))

(defun ensure-class (name &rest args &key &allow-other-keys) ; mop
  (apply #'ensure-class-using-class (find-class name) name args))



(defgeneric compute-class-precedence-list (class)) ; mop
(defmethod compute-class-precedence-list ((class class))
  (compute-standard-class-precedence-list class))


(defgeneric compute-default-initargs (class)) ; mop
(defmethod compute-default-initargs ((class standard-base-class))
  (compute-standard-default-initargs class))


(defgeneric effective-slot-definition-class (class &rest initargs)) ; mop
(defmethod effective-slot-definition-class ((class standard-base-class)
                                            &rest initargs)
  (find-class 'standard-effective-slot-definition))
(defgeneric compute-effective-slot-definition
    (class name direct-slot-definitions)) ; mop
(defmethod compute-effective-slot-definition ((class standard-base-class)
                                              name direct-slot-definitions)
  (apply #'make-instance
         (apply #'effective-slot-definition-class class initargs)
         (effective-slot-initargs class name direct-slot-definitions)))
(defgeneric compute-slots (class))      ; mop
(defmethod compute-slots :around ((class standard-base-class))
  (let ((slots (call-next-method)))
    (assign-slots-locations slots)
    slots))
(defmethod compute-slots ((class standard-base-class))
  (loop for (name direct-slots) in (effective-slot-specs class)
        collect (compute-effective-slot-definition class name direct-slots)))


(defgeneric finalize-inheritance (class)) ; mop
(defmethod finalize-inheritance ((class standard-base-class))
  ;; see "Class Finalization Protocol"
  ;; http://www.lisp.org/mop/concepts.html#class-finalization-protocol
  (setf (slot-value class 'precedence-list) (compute-class-precedence-list class))
  (setf (slot-value class 'default-initargs) (compute-default-initargs class))
  (setf (slot-value class 'slots) (compute-slots class))
  (setf (slot-value class 'finalized-p) t)

  class)
(defmethod finalize-inheritance ((class forward-referenced-class))
  (error "Cannot finalize inheritance for forward-referenced-class object."))
;; ! write an after method which computes a hash-table of slot-names and
;; slot-definition objects which will be used in find-slot.


(defgeneric allocate-instance (class &rest initargs &key &allow-other-keys)
  (:documentation ;; clos
   "Create and return a new instance of CLASS, without initializing it."))
(defmethod allocate-instance ((class standard-base-class) &rest initargs)
  (make-%standard-object :class class
                         :version (slot-value class 'version)
                         :storage (allocate-standard-instance-storage class)))
(defmethod allocate-instance ((class structure-class) &rest initargs)
  (error "allocate-instance specialized for structure-class is not implemented."))
(defmethod allocate-instance ((class built-in-class) &rest initargs)
  (error "`allocate-instance' is not applicable to built-in-class."))

(defgeneric validate-superclass (class superclass)) ; mop
(defmethod validate-superclass ((class class) (superclass class))
  (let ((class-of-class (class-of class-of))
        (class-of-superclass (class-of superclass))
        (standard-class (find-class 'standard-class))
        (funcallable-standard-class (find-class 'funcallable-standard-class)))
    ;; http://www.lisp.org/mop/dictionary.html#validate-superclass
    (or (eq superclass (find-class 't))
        ;; (i) If the superclass argument is the class named t, 
        (eq class-of-superclass class-of-class)
        ;; (ii) if the class of the class argument is the same as
        ;; the class of the superclass argument or 
        (and (eq class-of-class standard-class)
             (eq class-of-superclass funcallable-standard-class))
        (and (eq class-of-class funcallable-standard-class)
             (eq class-of-superclass standard-class))
        ;; (iii) if the classes one of the arguments is standard-class and
        ;; the class of the other is funcallable-standard-class. 
        )))

(defun canonicalize-direct-superclasses (class direct-superclasses)
  (flet ((superclass (designator)
           (etypecase designator
             (symbol (or (find-class designator)
                         (ensure-class designator
                                       :metaclass 'forward-referenced-class)))
             (class designator))))
    (mapcar #'(lambda (designator)
                (let ((superclass (superclass designator)))
                  (unless (validate-superclass class superclass)
                    (error "~S cannot be a superclass of ~S"
                                superclass class))
                  superclass))
            direct-superclasses)))

(defgeneric shared-initialize  (instance slot-names &rest initargs
                                         &key &allow-other-keys)
  (:documentation ;; clos
   "Fill the slots of INSTANCE using INITARGS and :initform forms."))

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

(defgeneric check-initargs (instance gf-args-pairs initargs))
(defmethod check-initargs ((instance standard-object) gf-args-pairs initargs)
  (unless (getf initargs :allow-other-keys)
    (let* ((class (class-of instance))
           (valid-keys
            (remove-duplicates
             (nconc (mapappend #'function-keywords
                               (mapappend #'(lambda (gf-args-pair)
                                              (apply #'applicable-methods
                                                     gs-args-pair))
                                          gf-args-pairs))
                    (mapappend #'slot-definition-initargs (class-slots class))
                    '(:allow-other-keys))))
           (keys (remove-duplicates (plist-keys initargs)))
           (invalid-keys (set-difference keys valid-keys)))
      (when invalid-keys
        (error "Invalid initialization argument keyword~P: ~S"
               (length invalid-keys) invalid-keys)))))
(defmethod check-initargs ((instance standard-slot-definition)
                           gf-args-pairs initargs)
  (let ((initform-supplied-p (plist-member :initform initargs))
        (initfunction-supplied-p (plist-member :initfunction initargs)))
    (assert (or (and initform-supplied-p initfunction-supplied-p)
                (and (not initform-supplied-p) (not initfunction-supplied-p))))
    (when (and (not initform-supplied-p) (not initfunction-supplied-p))
      (setq initargs `(:initform nil :initfunction nil ,@initargs)))
    (call-next-method instance gf-args-pairs initargs)))

;; ... more check-initargs methods


(defmethod shared-initialize ((instance standard-base-class) slot-names
                              &rest initargs
                              &key (direct-slots "never used" direct-slots-p))
  (flet ((direct-slot (class spec)
           (apply #'make-instance
                  (apply #'direct-slot-definition-class class spec)
                  spec)))
    (when direct-slots-p
      (setq initargs
            `(:direct-slots ,(mapcar #'(lambda (spec) (direct-slot instance spec))
                                     direct-slots)
              ,@initargs)))
    (apply #'call-next-method instance slot-names initargs)
    ;; define readers & writers here using reader-method-class & writer-method-class !
    ))

(defmethod shared-initialize ((instance standard-class) slot-names &rest initargs &key (direct-superclasses "never used" direct-superclasses-p) (metaclass 'standard-class))
  ;; http://www.lispworks.com/reference/HyperSpec/Body/m_defcla.htm
  ;; If the superclass list is empty, then the superclass defaults
  ;; depending on the metaclass, with standard-object being the default
  ;; for standard-class.
  (when direct-superclasses-p
    (setq initargs
          `(:direct-superclasses
            ,(canonicalize-direct-superclasses
              instance (or direct-superclasses (list 'standard-object)))
            ,@initargs)))
  (apply #'call-next-method instance slot-names initargs))

(defmethod shared-initialize ((instance funcallable-standard-class) slot-names &rest initargs &key (direct-superclasses "never used" direct-superclasses-p) (metaclass 'funcallable-standard-class))
  ;; http://www.lisp.org/mop/dictionary.html#class-mo-init
  ;; if the class is an instance of funcallable-standard-class
  ;; or one of its subclasses the default value is list of the class
  ;; funcallable-standard-object.
  (when direct-superclasses-p
    (setq initargs
          `(:direct-superclasses
            ,(canonicalize-direct-superclasses
              instance
              (or direct-superclasses (list 'funcallable-standard-object)))
            ,@initargs)))
  
  (apply #'call-next-method instance slot-names initargs)

  (let ((name (getf initargs :name (generic-function-name instance))))
    (install-generic-function name instance))
  
  instance)


(defgeneric add-direct-subclass (superclass subclass)) ; mop
(defmethod add-direct-subclass ((superclass class) (subclass class))
  (pushnew subclass (class-direct-subclasses superclass)))

(defgeneric remove-direct-subclass (superclass subclass)) ; mop
(defmethod remove-direct-subclass ((superclass class) (subclass class))
  (setf (class-direct-subclasses superclass)
        (remove subclass (class-direct-subclasses superclass))))

(defgeneric reinitialize-instance (instance &rest initargs
                                            &key &allow-other-keys)
  (:documentation ;; clos
   "Change the values of local slots of INSTANCE according to INITARGS."))
(defmethod reinitialize-instance ((instance standard-object) &rest initargs)
  ;; http://www.lispworks.com/reference/HyperSpec/Body/f_reinit.htm
  ;; 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.
  (check-initargs instance
                  `((,#'reinitialize-instance (,instance ,@initargs))
                    (,#'shared-initialize (,instance nil ,@initargs)))
                  initargs)
  (apply #'shared-initialize instance nil initargs))

(defmethod reinitialize-instance :after ((instance standard-generic-function)
                                         &rest initargs)
  (map-dependents instance
                  #'(lambda (dependent)
                      (apply #'update-dependent instance dependent initargs))))

(defgeneric make-instances-obsolete (class) ; clos
  (:documentation "Initiate the process of updating the instances of CLASS."))
(defmethod make-instances-obsolete ((class standard-base-class))
  (vector-push-extend (make-instance 'old-class :current-class class)
                      (class-old-classes class))
  (setf (slot-value class 'finalized-p) nil)
  (incf (slot-value class 'version))
  (mapc #'(lambda (gf) (clear-gf-cache gf))
        (specializer-direct-generic-functions class))
  (mapc #'(lambda (child)
            (when (class-finalized-p child) (make-instances-obsolete child)))
        (class-direct-subclasses class))
  class)
(defmethod make-instances-obsolete ((class symbol))
  (apply #'make-instances-obsolete (find-class class)))

(defmethod reinitialize-instance ((instance standard-base-class) &rest initargs)
  (let ((finalizedp (class-finalized-p instance))
        (previous (class-direct-superclasses instance)))
    (when finalizedp
      (make-instances-obsolete instance))
    (call-next-method)
    (let ((current (class-direct-superclasses instance)))
      (mapc #'(lambda (super) (remove-direct-subclass super instance))
            (set-difference previous current))
      (mapc #'(lambda (super) (add-direct-subclass super instance))
            (set-difference current previous)))
    (when finalizedp
      (finalize-inheritance instance)
      (map-dependents instance
                      #'(lambda (dependent)
                          (apply #'update-dependent
                                 instance dependent initargs))))
    instance))
         

(defgeneric update-instance-for-different-class (previous current &rest initargs &key &allow-other-keys)
  (:documentation ;; clos
   "Called only by change-class. Programmers may write methods for it."))
(defmethod update-instance-for-different-class ((previous standard-object) (current standard-object) &rest initargs)
  ;; http://www.lispworks.com/reference/HyperSpec/Body/f_update.htm
  ;; The system-supplied primary method on update-instance-for-different-class
  ;; checks the validity of initargs and signals an error if an initarg is
  ;; supplied that is not declared as valid. This method then initializes slots
  ;; with values according to the initargs, and initializes the newly added
  ;; slots with values according to their :initform forms. It does this by
  ;; calling the generic function shared-initialize with the following
  ;; arguments: the instance (current), a list of names of the newly added
  ;; slots, and the initargs it received. Newly added slots are those local
  ;; slots for which no slot of the same name exists in the previous class.
  (let ((added-local-slots (set-difference
                            (mapcan #'(lambda (slot)
                                        (when (local-slot-p slot)
                                          (list (slot-definition-name slot))))
                                    (class-slots (class-of current)))
                            (class-slot-names (class-of previous)))))
    (check-initargs current
                    `((,#'update-instance-for-different-class (,previous
                                                               ,current
                                                               ,@initargs))
                      (,#'shared-initialize (,current
                                             ,added-local-slots
                                             ,@initargs)))
                    initargs)
    (apply #'shared-initialize current added-local-slots initargs)))
(defmethod update-instance-for-different-class :after ((previous forward-referenced-class) (current standard-base-class) &rest initargs)
  (mapc #'(lambda (super) (add-direct-subclass super current))
        (class-direct-superclasses current)))

(defgeneric change-class (instance new-class &key &allow-other-keys)
  (:documentation ;; clos
   "Change the class of INSTANCE to NEW-CLASS destructively."))
(defmethod change-class ((instance t) (new-class symbol) &rest initargs)
  (apply #'change-class instance (find-class new-class) initargs))
(defmethod change-class ((instance standard-object) (new-class standard-class) &rest initargs)
  (let ((previous (allocate-instance new-class)))
    (swap-%standard-object instance previous)
    (loop with prev-slot-names = (class-slot-names (class-of previous))
          slot in (mapcan #'(lambda (slot)
                              (when (and (local-slot-p slot)
                                         (member (slot-definition-name slot)
                                                 prev-slot-names))
                                (list slot)))
                          (class-slots new-class))
          name = (slot-definition-name slot)
          if (slot-boundp previous name) do (slot-makunbound instance name)
          else do (setf (slot-value instance name) (slot-value previous name)))
    (apply #'update-instance-for-different-class previous instance initargs)))
    

(defgeneric update-instance-for-redefined-class (instance added-slots discarded-slots property-list &rest initargs &key &allow-other-keys)
  (:documentation ;; clos
   "Called by the mechanism activated by make-instances-obsolete."))
(defmethod update-instance-for-redefined-class ((instance standard-object) added-slots discarded-slots property-list &rest initargs)
  ;; http://www.lispworks.com/reference/HyperSpec/Body/f_upda_1.htm
  ;; The system-supplied primary method on
  ;; update-instance-for-redefined-class checks the validity of initargs
  ;; and signals an error if an initarg is supplied that is not declared as
  ;; valid. This method then initializes slots with values according to the
  ;; initargs, and initializes the newly added-slots with values according
  ;; to their :initform forms. It does this by calling the generic function
  ;; shared-initialize with the following arguments: the instance, a list
  ;; of names of the newly added-slots to instance, and the initargs it
  ;; received. Newly added-slots are those local slots for which no slot of
  ;; the same name exists in the old version of the class.
  (let* ((class (class-of instance))
         (added-local-slots (mapcan #'(lambda (name)
                                        (if (local-slot-p (find-slot class name))
                                            (list name)
                                            nil))
                                    added-slots)))
    (check-initargs instance
                    `((,#'update-instance-for-redefined-class (,instance
                                                               ,added-slots
                                                               ,discarded-slots
                                                               ,property-list
                                                               ,@initargs))
                      (,#'shared-initialize (,instance ,added-local-slots
                                             ,@initargs)))
                    initargs)
    (apply #'shared-initialize instance added-local-slots initargs)))

(defun obsolete-instance-p (instance)
  (/= (%standard-object-version instance)
      (class-version (class-of instance))))

(defun update-obsolete-instance (instance)
  (let* ((class (class-of instance))
         (old-class (aref (class-old-classes class)
                          (%standard-object-version instance)))
         (old-instance (allocate-instance class)))
    (swap-%standard-object instance old-instance)
    (setf (%standard-object-class old-instance) old-class)
    (let* ((old (class-slot-names old-class))
           (new (class-slot-names class))
           (common (intersection old new))
           (discarded (set-difference old new))
           (added (set-difference new old)))
      (mapc #'(lambda (name)
                ;;  slots of the same name
                ;;  old         current    slot value/unbound state
                ;;  local       shared     discarded
                ;;  shared      shared     retained
                ;;  local       local      retained
                ;;  shared      local      retained
                (if (and (local-slot-p (find-slot old-class name))
                         (not (local-slot-p (find-slot class name))))
                    (push name discarded)
                    (if (slot-boundp old-instance name)
                        (setf (slot-value instance name)
                              (slot-value old-instance name))
                        (slot-makunbound instance name))))
            common)
      (let ((plist (loop for name in discarded
                         when (slot-boundp old-instance name)
                         nconc `(,name ,(slot-value old-instance name)))))
        (update-instance-for-redefined-class instance added discarded plist)))))

(defun update-instance-if-obsolete (instance)
  (when (obsolete-instance-p object) (update-obsolete-instance object)))



(defgeneric initialize-instance (instance &key &allow-other-keys)) ; clos
(defmethod initialize-instance ((instance standard-object) &rest initargs)
  (apply #'shared-initialize instance t initargs))
(defmethod initialize-instance :after ((instance class) &rest initargs)
  (mapc #'(lambda (super) (add-direct-subclass super instance))
        (class-direct-superclasses instance)))


(defgeneric make-instance (class &rest initargs &key &allow-other-keys)
  (:documentation "Create and return a new instance of CLASS.")) ; clos
(defmethod make-instance ((class symbol) &rest initargs)
  (apply #'make-instance (find-class class) initargs))
(defmethod make-instance ((class funcallable-standard-class) &rest initargs)
  (push +funcallable-instance-function-slot-spec+ (getf initargs :direct-slots))
  (apply #'call-next-method class ,@initargs))
(defmethod make-instance ((class standard-base-class) &rest initargs)
  (let ((instance (apply #'allocate-instance class initargs))
        (defaulted-initargs (defaulted-initargs class initargs)))
    (check-initargs instance
                    `((,#'allocate-instance (,class ,@defaulted-initargs))
                      (,#'initialize-instance (,instance ,@defaulted-initargs))
                      (,#'shared-initialize (,instance t ,@defaulted-initargs)))
                    defaulted-initargs)
    (apply #'initialize-instance instance defaulted-initargs)))
(defmethod make-instance ((class old-class) &rest initargs
                          &key (current-class (required-argument)))
  (let ((instance (apply #'allocate-instance class initargs)))
    (check-initargs initargs `(,#'make-instance (,class ,@initargs) initargs))
    (setf (slot-value instance 'name)    (slot-value current-class 'name))
    (setf (slot-value instance 'version) (slot-value current-class 'version))
    (setf (slot-value instance 'slots)   (copy-seq (slot-value current-class
                                                               'slots)))
    instance))


(defgeneric class-name (class)          ; clos
  (:documentation "Return the name of CLASS."))
(defgeneric (setf class-name) (name class) ; clos
  (:documentation "Set the name of CLASS to NAME."))
(defgeneric class-direct-slots (class)) ; mop
(defgeneric class-direct-default-initargs (class)) ; mop
(defgeneric class-direct-superclasses (class)) ; mop
(defgeneric class-direct-subclasses (class)) ; mop
(defgeneric class-precedence-list (class)) ; mop
(defgeneric class-default-initargs (class)) ; mop
(defgeneric class-default-initfuncs (class))
(defgeneric class-slots (class))        ; mop
(defgeneric class-finalized-p (class))  ; mop
(defgeneric class-prototype (class))    ; mop

(defmethod class-precedence-list :before ((class standard-base-class))
  (unless (class-finalized-p class) (finalize-inheritance class)))
(defmethod class-slots :before ((class standard-base-class))
  (unless (class-finalized-p class) (finalize-inheritance class)))
(defmethod class-default-initargs :before ((class standard-base-class))
  (unless (class-finalized-p class) (finalize-inheritance class)))
(defmethod class-default-initfuncs :before ((class standard-base-class))
  (unless (class-finalized-p class) (finalize-inheritance class)))


    

(defmethod documentation ((x standard-base-class) (doc-type (eql 't)))
  (slot-value x 'documentation))
(defmethod documentation ((x standard-base-class) (doc-type (eql 'type)))
  (slot-value x 'documentation))




(defgeneric direct-slot-definition-class (class &rest initargs)) ; mop
(defmethod direct-slot-definition-class ((class standard-base-class) &rest initargs)
  (find-class 'standard-direct-slot-definition))



(defgeneric specializer-direct-methods (specializer)) ; mop
(defgeneric specializer-direct-generic-functions (specializer)) ; mop


(defgeneric add-direct-method (specializer method)) ; mop
(defmethod add-direct-method ((specializer specializer) (method method))
  (pushnew method (slot-value specializer 'direct-methods))
  (pushnew (method-generic-function method)
           (slot-value specializer 'direct-generic-functions)))

(defgeneric remove-direct-method (specializer method)) ; mop
(defmethod remove-direct-method ((specializer specializer) (method method))
  (setf (slot-value specializer 'direct-methods)
        (remove method (specializer-direct-methods specializer)))
  (let ((gf (method-generic-function method)))
    (unless (member gf (mapcar #'method-generic-function
                               (specializer-direct-methods specializer)))
      (setf (slot-value specializer 'direct-generic-functions)
            (remove gf (specializer-direct-generic-functions))))))
          

(defgeneric reader-method-class (class direct-slot &rest initargs)) ; mop
(defmethod reader-method-class ((class standard-base-class) (direct-slot standard-direct-slot-definition) &rest initargs)
  (find-class 'standard-reader-method))

(defgeneric writer-method-class (class direct-slot &rest initargs)) ; mop
(defmethod writer-method-class ((class standard-base-class) (direct-slot standard-direct-slot-definition) &rest initargs)
  (find-class 'standard-writer-method))


(defgeneric add-dependent (metaobject dependent)) ; mop
(defmethod add-dependent ((class standard-base-class) dependent)
  (pushnew dependent (slot-value class 'dependents))) 
(defmethod add-dependent ((generic-function standard-generic-function) dependent)
  (pushnew dependent (slot-value generic-function 'dependents)))
(defgeneric remove-dependent (metaobject dependent)) ; mop
(defmethod remove-dependent ((class standard-base-class) dependent)
  (setf (slot-value class 'dependents)
        (remove dependent (slot-value class 'dependents))))
(defmethod remove-dependent
    ((generic-function standard-generic-function) dependent)
  (setf (slot-value generic-function 'dependents)
        (remove dependent (slot-value generic-function 'dependents))))

(defgeneric map-dependents (metaobject function)) ; mop
(defmethod map-dependents ((metaobject standard-base-class) function)
  (mapc function (slot-value metaobject 'dependents)))
(defmethod map-dependents ((metaobject standard-generic-function) function)
  (mapc function (slot-value metaobject 'dependents)))
(defgeneric update-dependent (metaobject dependent &rest initargs)) ; mop



(defgeneric make-load-form (object &optional environment)
  (:documentation ;; clos
   "Return forms to enable load to construct an object equivalent to OBJECT."))
(defmethod make-load-form ((object standard-object) &optional environment)
  )
(defmethod make-load-form ((object structure-object) &optional environment)
  )
(defmethod make-load-form ((object condition) &optional environment)
  )
(defmethod make-load-form ((object class) &optional environment)
  )

(defun make-load-form-saving-slots (object &key slot-names environment) ; clos
  "Return forms that will construct an object equivalent to OBJECT."
  )






(defmacro with-accessors (slot-entries instance &body body) ; clos
  "Make slots accessible like variables through specified accessors."
  (let ((instance (gensym)))
    `(let ((,instance ,instance-form))
      (symbol-macrolet (,@(mapcar
                           #'(lambda (entry)
                               `(,(first entry) (,(second entry) ,instance)))
                           slot-entries))
          ,@body))))

(defmacro with-slots (slot-entries instance-form &body body) ; clos
  "Create a lexical environment where slots are accessible like variables."
  (let ((instance (gensym)))
    `(let ((,instance ,instance-form))
      (symbol-macrolet (,@(mapcar
                           #'(lambda (entry)
                               (if (symbolp entry)
                                   `(,entry (slot-value ,instance ',entry))
                                   `(,(first entry)
                                     (slot-value ,instance ',(second entry)))))
                           slot-entries))
          ,@body))))


(defun standard-instance-access (instance location) ; mop
  (let ((storage (%standard-object-storage instance)))
    (if (frozen-class-instance-p instance)
        (second (nth location storage))
        (aref storage location))))

(defun funcallable-standard-instance-access (instance location)
  (standard-instance-access instance location))

(defun refer-slot-using-class (class object slot)
  (update-instance-if-obsolete object)
  (if (local-slot-p slot)
      (let (location (slot-definition-location slot))
        (aref (%standard-object-storage object) location))
      (car (slot-definition-shared-binding slot))))

(defgeneric slot-value-using-class (class object slot)) ; mop
(defmethod slot-value-using-class ((class standard-base-class) object
                                   (slot standard-effective-slot-definition))
  (let* ((value (refer-slot-using-class class object slot)))
    (if (eq value +unbound-state+)
        (values (slot-unbound class object (slot-definition-name slot)))
        value)))
(defmethod slot-value-using-class ((class built-in-class) object slot)
  (error "slot-value-using-class cannot be used for a built-in-class object."))



(defgeneric (setf slot-value-using-class) (new-value class object slot)) ; mop
(defmethod (setf slot-value-using-class) (new-value (class standard-base-class) object (slot standard-effective-slot-definition))
  (update-instance-if-obsolete object)
  (if (local-slot-p slot)
      (let ((location (slot-definition-location slot)))
        (setf (aref (%standard-object-storage object) location) new-value))
      (setf (car (slot-definition-shared-binding slot)) new-value)))
(defmethod (setf slot-value-using-class)
    (new-value (class built-in-class) object slot)
  (error "(setf slot-value-using-class) cannot be used for ~
          a built-in-class object."))



(defgeneric slot-exists-p-using-class (class object slot-name)) ; mop?
(defmethod slot-exists-p-using-class ((class standard-base-class)
                                      object slot-name)
  (find-slot class slot-name))
(defun slot-exists-p (object slot-name) ; clos
  "Return true if OBJECT has a slot named SLOT-NAME."
  (slot-exists-p-using-class (class-of object) object slot-name))





(defgeneric slot-boundp-using-class (class object slot)) ; mop
(defmethod slot-boundp-using-class ((class standard-base-class) object (slot standard-effective-slot-definition))
  (not (eq (refer-slot-using-class class object slot) +unbound-state+)))

(defmethod slot-boundp-using-class ((class built-in-class) object slot)
  (error "slot-boundp-using-class cannot be used for a built-in-class object."))


(defun directly-accessible-slot-p (slot)
  ;; http://www.lisp.org/mop/concepts.html#instance-structure-protocol
  ;; > In particular, portable programs can control the implementation
  ;; > of, and obtain direct access to, slots with allocation :instance and
  ;; > type t. These are called directly accessible slots.
  (and (eq (slot-definition-allocation slot) :instance)
       (eq (slot-definition-type       slot) 't)))


(defgeneric slot-makunbound-using-class (class object slot)) ; mop
(defmethod slot-makunbound-using-class ((class standard-base-class) object (slot standard-effective-slot-definition))
  (setf (slot-value-using-class class object slot) +unbound-state+))
(defmethod slot-makunbound-using-class ((class built-in-class) object slot)
  (error
   "slot-makunbound-using-class cannot be used for a built-in-class object."))
(defun slot-makunbound (instance slot-name) ; clos
  "Restore a slot of the name SLOT-NAME in INSTANCE to the unbound state."
  (let* ((class (class-of instance))
         (slot (find-slot class slot-name)))
    (if slot
        (slot-makunbound-using-class class instance slot)
        (slot-missing class instance slot-name 'slot-makunbound))
    instance))

(defgeneric slot-missing (class object slot-name operation &optional new-value)
  (:documentation ;; clos
   "Invoked when a slot not defined in CLASS is accessed by SLOT-NAME."))
(defmethod slot-missing ((class t) object slot-name operation &optional new-value)
  (error "The slot ~S is missing in the class ~S."
         slot-name
         (etypecase class (symbol class) (class (class-name class)))))

(defgeneric slot-unbound (class instance slot-name)
  (:documentation ;; clos
   "Called when an unbound slot named SLOT-NAME is read in INSTANCE of CLASS."))
(defmethod slot-unbound ((class t) instance slot-name)
  (error 'unbound-slot :instance instance :name slot-name))






(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)) ; mop
(defmethod ensure-generic-function-using-class ((generic-function generic-function) function-name &rest initargs &key generic-function-class &allow-other-keys)
  (apply #'reinitialize-instance generic-function initargs))
(defmethod ensure-generic-function-using-class ((generic-function null) function-name &rest initargs &key generic-function-class &allow-other-keys)
  (apply #'make-instance generic-function-class initargs))

(defun ensure-generic-function (function-name &rest initargs
                                &key argument-precedence-order declare
                                documentation environment generic-function-class
                                lambda-list method-class method-combination)
  "Define a globally named generic function with no methods." ; clos
  (let ((fdefinition (fdefinition function-name)))
    (when (and fdefinition (not (instancep fdefinition 'generic-function)))
      (error "~S already names an ordinary function or a macro." function-name))
    (loop initially (setq initargs (copy-list initargs))
          while (remf initargs :declare))
    (apply #'ensure-generic-function-using-class fdefinition
           `(:declarations ,declare ,@initargs))))


(defun (setf generic-function-name) (new-name generic-function)
  )



(defun clear-gf-cache (gf)
  (clrhash (generic-function-applicable-methods gf))
  (clrhash (generic-function-effective-methods gf)))


(defgeneric method-qualifiers (method)  ; clos
  (:documentation "Return a list of the qualifiers of METHOD."))




(defun check-specialized-lambda-list (specialized-lambda-list)
  (let ((required-part (extract-required-part specialized-lambda-list)))
    (assert (plusp (length required-part)))
    (dolist (var-spec required-part)
      (etypecase var-spec
        (symbol (check-variable-name var-speck))
        (cons (let ((variable-name (first var-spec))
                    (parameter-specializer-name (second var-spec)))
                (check-variable-name variable-name)
                (assert (or (symbolp parameter-specializer-name)
                            (eq (car parameter-specializer-name) 'eql)))))))))

(defun extract-lambda-list (specialized-lambda-list) ; mop
  (check-specialized-lambda-list specialized-lambda-list)
  (loop for rest on specialized-lambda-list
        for item = (car rest)
        if (member item '(&optional &rest &key &aux))
        append rest and do (loop-finish)
        else collect (if (consp item) (car item) item)))

(defun extract-specializer-names (specialized-lambda-list) ; mop
  (check-specialized-lambda-list specialized-lambda-list)
  (loop for item in specialized-lambda-list
        if (member item '(&optional &rest &key &aux)) do (loop-finish)
        else collect (if (consp item) (second item) 't)))

(defun extract-keyword-names (specialized-lambda-list)
  (check-specialized-lambda-list specialized-lambda-list)
  (let ((allow-other-keys-p nil))
    (values (loop for item in (rest (member '&key specialized-lambda-list))
                  if (eq item '&allow-other-keys)
                  do (setq allow-other-keys-p t) (loop-finish)
                  else if (eq item '&aux) do (loop-finish)
                  else collect (if (consp item)
                                   (if (consp (car item))
                                       (caar item)
                                       (%keyword (car item)))
                                   (%keyword item)))
            allow-other-keys-p)))

(defgeneric function-keywords (method)  ; clos
  (:documentation "Return the keyword parameter specifiers for METHOD."))
(defmethod function-keywords ((method standard-method))
  (extract-keyword-names (method-specialized-lambda-list method)))

(defgeneric no-applicable-method (generic-function &rest function-arguments)
  (:documentation ;; clos
   "Called when GENERIC-FUNCTION is invoked and no method is applicable."))
(defmethod no-applicable-method ((generic-function t) &rest function-arguments)
  )

(defgeneric no-next-method (generic-function method &rest args) ; clos
  (:documentation "Called by call-next-method when there is no next method."))
(defmethod no-next-method ((generic-function standard-generic-function) (method standard-method) &rest args)
  )



(defgeneric find-method-combination     ; mop
    (generic-function method-combination-type-name method-combination-arguments))
(defmethod find-method-combination
    ((gf standard-generic-function) method-combination-type combination-options)
  (multiple-value-bind (type presentp)
      (gethash method-combination-type *method-combination-types*)
    (if presentp
        (make-instance 'standard-method-combination
                       :type type :arguments method-combination-arguments)
        (error "Method combination ~S does not exist." method-combination-type))))

(defun make-method-form-p (object)
  (and (consp object) (eq 'make-method (first object))))

(defun make-method-description (gf form)
  `(:method 'make-method ,(generic-function-lambda-list gf)
    (with-call-method ,gf ,form)))

;; Local Macro CALL-METHOD, MAKE-METHOD
(defmacro with-call-method (gf &body body)
  `(macrolet
    ((call-method (method next-methods &environment env)
      (flet ((method-form (form)
               (apply #'<make-instance>
                      (generic-function-method-class ,gf)
                      (method-initargs-form
                       ',gf env :null-lexical-environment-p t
                       (method-spec (make-method-description ,gf form))))))
        (when (make-method-form-p method)
          (setq method (method-form (second method))))
        (setq next-methods
              (mapcar #'(lambda (method)
                          (if (make-method-form-p method)
                              (method-form (second method))
                              `(quote ,method)))
                      next-methods)))
      `(funcall (method-function ,method)
        ,+gf-args-variable+ (list ,@next-methods))))
    ,@body))

(defgeneric compute-effective-method (generic-function
                                      method-combination methods)) ; mop
(defmethod compute-effective-method ((generic-function standard-generic-function)
                                     method-combination methods)
  (let* ((type (method-combination-type method-combination))
         (type-function (method-combination-type-function type))
         (arguments (method-combination-arguments method-combination))
         (effective-method
          (apply type-function generic-function methods arguments)))
    (values `(with-call-method ,generic-function
              ,effective-method)
            `(:arguments ,(method-combination-type-args-lambda-list type)
              :generic-function
              ,(method-combination-type-generic-function-symbol type)))))


;; Local Function NEXT-METHOD-P
;; Local Function CALL-NEXT-METHOD
(defgeneric make-method-lambda
    (generic-function method lambda-expression environment)) ; mop
(defmethod make-method-lambda ((generic-function standard-generic-function)
                               (method standard-method)
                               lambda-expression environment)
  (let* ((lambda-list (second lambda-expression))
         (gf-args (first lambda-list))
         (next-methods (second lambda-list))
         (name (generic-function-name generic-function))
         (args (gensym)))
    (multiple-value-bind (decls forms)
        (declarations-and-forms (cddr lambda-expression))
      `(lambda ,lambda-list
        ,@decls
        (block ,(if (symbolp name) name (second name))
          (labels ((next-method-p () ,next-methods)
                   (call-next-method (&rest ,args)
                     (unless ,args (setq ,args ,gf-args))
                     (if (next-method-p)
                         (funcall (method-function (car ,next-methods))
                                  ,args (cdr ,next-methods))
                         (apply #'no-next-method ,generic-function ,method
                                ,(first lambda-list)))))
            ,@forms))))))


(defgeneric specializer-satisfied-p (specifier arg))
(defmethod specializer-satisfied-p ((specializer class) arg)
  (member (class-of arg) (class-precedence-list specializer)))
(defmethod specializer-satisfied-p ((specializer eql-specializer) arg)
  (eql arg (eql-specializer-object specializer)))

(defun applicable-method-p (method args)
  (every #'specializer-satisfied-p (method-specializers method) args))

(defun eql-specializer-p (specializer)
  (eq (class-of specializer) (find-class 'eql-specializer)))

(defun more-specific-specializer-p (a b arg)
  (cond
    ((eql-specializer-p a) (not (eql-specializer-p b)))
    ((eql-specializer-p b) nil)
    (t (let ((list (class-precedence-list (class-of arg))))
         (< (position a list) (position b list))))))

(defun sort-methods (gf methods)
  (let ((indeces (loop for arg in (generic-function-argument-precedence-order gf)
                       collect (position arg
                                         (generic-function-lambda-list gf)))))
    (flet ((more-specific-method-p (a b)
             (loop for i in indeces
                   if (more-specific-specializer-p (elt (method-specializers a) i)
                                                   (elt (method-specializers b) i)
                                                   (elt args i))
                   return t)))
      (sort methods #'more-specific-method-p))))

(defgeneric compute-applicable-methods (generic-function function-arguments) ;clos
  (:documentation "Return the set of applicable methods of GENERIC-FUNCTION. "))
(defmethod compute-applicable-methods ((gf standard-generic-function) args)
  (let ((methods (mapcan #'(lambda (method)
                             (when (applicable-method-p method args)
                               (list method)))
                         (generic-function-methods gf))))
    (sort-methods gf methods)))

(defgeneric compute-applicable-methods-using-classes
    (generic-function classes))         ; mop
(defmethod compute-applicable-methods-using-classes
    ((generic-function standard-generic-function) classes)
  (flet ((filter (method)
           (let ((eql-specializer-p nil))
             (when (every #'(lambda (a b)
                              (if (and (eql-specializer-p a)
                                       (eq (class-of (eql-specializer-object a))
                                           b))
                                  (setq eql-specializer-p t)
                                  (subclassp b a)))
                          (method-specializers method)
                          classes)
               (if eql-specializer-p
                   (return-from compute-applicable-methods-using-classes
                     (values nil nil))
                   (list method))))))
    (values (sort-methods gf (mapcan #'filter (generic-function-methods gf)))
            t)))

(defun applicable-methods (gf args)
  (let ((classes (mapcar #'class-of
                         (subseq args 0 (number-of-required-args gf)))))
    (multiple-value-bind (methods presentp)
        (gethash classes (generic-function-applicable-methods gf))
      (if presentp
          methods
          (multiple-value-bind (methods memorablep)
              (compute-applicable-methods-using-classes gf classes)
            (if memorablep
                (setf (gethash classes (generic-function-applicable-methods gf))
                      methods)
                (compute-applicable-methods gf args)))))))

(defgeneric compute-discriminating-function (generic-function)) ; mop
(defmethod compute-discriminating-function ((gf standard-generic-function))
  (let* ((combination (slot-value gf 'method-combination))
         (methods (gensym)))
    (compile
     nil
     `(lambda (&rest ,+gf-args-variable+)
       ;; check args here.

       (let ((,methods (applicable-methods ,gf ,+gf-args-variable+)))
         (if (null ,methods)
             (apply #'no-applicable-method ,gf ,+gf-args-variable+)
             (multiple-value-bind (effective-method-function presentp)
                 (gethash methods (generic-function-effective-methods gf))
               (if presentp
                   (funcall effective-method-function ,+gf-args-variable+)
                   (progn
                     (setq effective-method-function
                           (compile
                            nil
                            (eval '(lambda (,+gf-args-variable+)
                                    ,(compute-effective-method gf
                                                               combination
                                                               methods)))))
                     (setf (gethash methods
                                    (generic-function-effective-methods gf))
                           effective-method-function)
                     (funcall effective-method-function
                              ,+gf-args-variable+))))))))))

(defgeneric find-method
    (generic-function qualifiers specializers &optional errorp)
  (:documentation ;; clos
   "Return the method object that agrees on QUALIFIERS and SPECIALIZERS."))
(defmethod find-method
    ((gf standard-generic-function) qualifiers specializers &optional errorp)
  (when (/= (length specializers) (number-of-required-args gf))
    (error "The lambda list of ~S is ~S, and it doesn't match specializers ~S."
           gf (generic-function-lambda-list gf) specializers))
  (flet ((agreep (a b)
           (if (eql-specializer-p a)
               (and (eql-specializer-p b)
                    (eql (eql-specializer-object a) (eql-specializer-object b)))
               (eq a b))))
    (let ((method (find-if
                   #'(lambda (method)
                       (and (agreep (method-specializers method) specializers)
                            (equal (method-qualifiers method) qualifiers)))
                   (generic-function-methods generic-function))))
      (or method
          (when errorp
            (error "No method for ~S with qualifiers ~S and specializers ~S."
                   gf qualifiers specializers))))))

(defun check-lambda-list-congruence (gf method)
  )

(defgeneric add-method (generic-function method) ; clos
  (:documentation "Add METHOD to GENERIC-FUNCTION."))
(defmethod add-method
    ((generic-function standard-generic-function) (method method))
  (when (method-generic-function method)
    (error "Method ~S is already associated with generic function ~S"
           method (method-generic-function method)))
  (check-lambda-list-congruence generic-function method)

  (let ((old-method (find-method generic-function
                                 (method-qualifiers method)
                                 (method-specializers method))))
    (when old-method
      (remove-method generic-function old-method)))
  (push method (slot-value generic-function 'methods))
  (mapc #'(lambda (specializer) (add-direct-method specializer method))
        (method-specializers method))
  (clear-gf-cache gf)
  (map-dependents generic-function
                  #'(lambda (dependent)
                      (update-dependent generic-function dependent
                                        'add-method method)))
  method)

(defgeneric remove-method (generic-function method) ; clos
  (:documentation "Remove METHOD from GENERIC-FUNCTION by modifying it"))
(defmethod remove-method ((generic-function standard-generic-function) method)
  (let ((gf-methods (generic-function-methods generic-function)))
    (when (member method gf-methods)
      (setf (slot-value generic-function 'methods) (remove method gf-methods))
      (mapc #'(lambda (specializer) (remove-direct-method specializer method))
            (method-specializers method))))
  (clear-gf-cache gf)
  (map-dependents generic-function
                  #'(lambda (dependent)
                      (update-dependent generic-function dependent
                                        'remove-method method)))
  method)



(defun class-of-sequence (sequence)
  (typecase sequence
    (list (typecase sequence
            (null (find-class 'null))
            (cons (find-class 'cons))
            (t    (find-class 'list))))
    (vector (typecase sequence
              (bit-vector (find-class 'bit-vector))
              (string     (find-class 'string))
              (t          (find-class 'vector))))
    (t (find-class 'sequence))))

(defun class-of-number (number)
  (typecase number
    (integer  (find-class 'integer))
    (ratio    (find-class 'ratio))
    (rational (find-class 'rational))
    (float    (find-class 'float))
    (real     (find-class 'real))
    (complex  (find-class 'complex))
    (t        (find-class 'number))))

(defun class-of-stream (stream)
  (typecase stream
    (broadcast-stream    (find-class 'broadcast-stream))
    (concatenated-stream (find-class 'concatenated-stream))
    (string-stream       (find-class 'string-stream))
    (echo-stream         (find-class 'echo-stream))
    (synonym-stream      (find-class 'synonym-stream))
    (file-stream         (find-class 'file-stream))
    (two-way-stream      (find-class 'two-way-stream))
    (t                   (find-class 'stream))))

(defun class-of-condition (condition)
  (typecase condition
    (simple-error      (find-class 'simple-error))
    (simple-type-error (find-class 'simple-type-error))
    (simple-warning    (find-class 'simple-warning))
    (simple-condition  (find-class 'simple-condition))

    (floating-point-inexact           (find-class 'floating-point-inexact))
    (floating-point-invalid-operation (find-class
                                       'floating-point-invalid-operation))
    (floating-point-overflow          (find-class 'floating-point-overflow))
    (floating-point-underflow         (find-class 'floating-point-underflow))
    (division-by-zero                 (find-class 'division-by-zero))
    (arithmetic-error                 (find-class 'arithmetic-error))

    (reader-error (find-class 'reader-error))
    (parse-error  (find-class 'parse-error))

    (end-of-file  (find-class 'end-of-file))
    (stream-error (find-class 'stream-error))

    (unbound-slot       (find-class 'unbound-slot))
    (unbound-variable   (find-class 'unbound-variable))
    (undefined-function (find-class 'undefined-function))
    (cell-error         (find-class 'cell-error))

    (type-error         (find-class 'type-error))
    (package-error      (find-class 'package-error))
    (control-error      (find-class 'control-error))
    (print-not-readable (find-class 'print-not-readable))
    (program-error      (find-class 'program-error))
    (file-error         (find-class 'file-error))
    (error              (find-class 'error))
    
    (storage-condition (find-class 'storage-condition))
    (serious-condition (find-class 'serious-condition))

    (style-warning (find-class 'style-warning))
    (warning       (find-class 'warning))

    (t (find-class 'condition))))


(progn
  (setq *mop-working-p* t))



(defconstant +condition-report-slot-name+
  (gensym "CONDITION-REPORT-SLOT-NAME-"))

(deftype lambda-expression () '(satisfies lambda-expression-p))
(defun lambda-expression-p (object)
  (and (consp object) (eq (first object) 'lambda) (listp (second object))))

(defun condition-initargs-form (options)
  (check-singleton-options options '(:default-initargs :documentation :report
                                     :direct-superclasses :direct-slots))
  (let ((report-option (assoc :report options)))
    (when report-option
      (destructuring-bind (report-name) (cdr report-option)
        (assert (typep report-name (or string symbol lambda-expression)))
        (let ((slot-spec `(,+condition-report-slot-name+ :allocation :class
                           :initform ',report-name)))
          (push slot-spec (cdr (assoc :direct-slots options)))))
      (setq options (remove :report options :key #'car))))
  (class-initargs-form options))

(defmacro define-condition (name parent-types slot-specs &rest options)
  (let ((*message-prefix* (format nil "DEFINE-CONDITION ~S: " name))
        (options `((:direct-superclasses ,@(or parent-types '(condition)))
                   (:direct-slots ,@slot-specs)
                   ,@options)))
    `(let ((*message-prefix* ,*message-prefix*))
      (apply #'ensure-class ',name ,(condition-initargs-form options)))))

;; 9.1.1 Condition Types
;; http://www.lispworks.com/reference/HyperSpec/Body/09_aa.htm
;; > The metaclass of the class condition is not specified.
(define-condition condition (t) ()
  (:report (lambda (condition stream)
             (format stream "Condition ~S is signaled." (class-of condition)))))

(defun make-condition (type &rest slot-initializations)
  )

|#