anchor.diff:          (setf (mop-find-class name) class)
           class)))
   
  -(defmacro mop-defclass (name direct-superclasses direct-slots &rest options)
  -  `(mop-ensure-class ',name
  -     :direct-superclasses ,(mop-canonicalize-direct-superclasses direct-superclasses)
  -     :direct-slots ,(mop-canonicalize-direct-slots direct-slots)
  -     ,@(mop-canonicalize-defclass-options options)))
  -
  -;-------------------------------------------------------------------------------
  -; defgeneric
  -;-------------------------------------------------------------------------------
  -
  -(let ((mop-generic-function-table (make-hash-table :test #'equal)))
  -
  -  (defun mop-find-generic-function (symbol &optional (errorp t))
  -    (let ((gf (gethash symbol mop-generic-function-table nil)))
  -      (if (and (null gf) errorp)
  -          (error "No generic function named ~S." symbol)
  -          gf)))
  -
  -  (defun (setf mop-find-generic-function) (new-value symbol)
  -    (setf (gethash symbol mop-generic-function-table) new-value))
  -
  -  (defun mop-forget-all-generic-functions ()
  -    (clrhash mop-generic-function-table)
  -    (values))
  -
  -)
  +(defun mop-make-instance-standard-class (metaclass
  +                                         &key name direct-superclasses direct-slots
  +                                         &allow-other-keys)
  +  (declare (ignore metaclass))
  +  (let ((class (mop-std-allocate-instance mop-the-class-standard-class)))
  +    (setf (mop-class-name class) name)
  +    (setf (mop-class-direct-subclasses class) ())
  +    (setf (mop-class-direct-methods class) ())
  +    (mop-std-after-initialization-for-classes class
  +                                              :direct-slots direct-slots
  +                                              :direct-superclasses direct-superclassess)
  +    class))
  +
  +(defun mop-std-after-initialization-for-classes (class
  +                                                 &key direct-superclasses direct-slots
  +                                                 &allow-other-keys)
  +  (let ((supers (or direct-superclasses (list (mop-find-class 'mop-standard-object)))))
  +    (setf (mop-class-direct-superclasses class) supers)
  +    (dolist (superclass supers)
  +      (push class (mop-class-direct-subclasses superclass))))
  +  (let ((slots (mapcar #'(lambda (slot-properties)
  +                           (apply #'mop-make-direct-slot-definition slot-properties))
  +                           direct-slots)))
  +    (setf (mop-class-direct-slots class) slots)
  +    (dolist (direct-slot slots)
  +      (dolist (reader (mop-slot-definition-readers direct-slot))
  +        (mop-add-reader-method class reader (mop-slot-definition-name direct-slot)))
  +      (dolist (writer (mop-slot-definition-writers direct-slot))
  +        (mop-add-writer-method class writer (mop-slot-definition-name direct-slot)))))
  +  (funcall (if (eq (mop-class-of class) mop-the-standard-class)
  +               #'mop-std-finalize-inheritance
  +               #'mop-finalize-inheritance)
  +           class)
  +  (values))
  +
  +(defun mop-make-direct-slot-definition (&rest properties
  +                                        &key name
  +                                             (initargs ())
  +                                             (initform nil)
  +                                             (initfunction nil)
  +                                             (readers ())
  +                                             (writers ())
  +                                             (allocation :instance)
  +                                        &allow-other-keys)
  +  (let ((slot (copy-list properties)))
  +    (setf (getf* slot ':name) name)
  +    (setf (getf* slot ':initargs) initargs)
  +    (setf (getf* slot ':initform) initform)
  +    (setf (getf* slot ':initfunction) initfunction)
  +    (setf (getf* slot ':readers) readers)
  +    (setf (getf* slot ':writers) writers)
  +    (setf (getf* slot ':allocation) allocation)
  +    slot))
  +
  +(defun mop-make-effective-slot-definition (&rest properties
  +                                           &key name
  +                                                (initargs ())
  +                                                (initform nil)
  +                                                (initfunction nil)
  +                                                (allocation :instance)
  +                                           &allow-other-keys)
  +  (let ((slot (copy-list properties)))
  +    (setf (getf* slot ':name) name)
  +    (setf (getf* slot ':initargs) initargs)
  +    (setf (getf* slot ':initform) initform)
  +    (setf (getf* slot ':initfunction) initfunction)
  +    (setf (getf* slot ':allocation) allocation)
  +    slot))
  +
  +(defun mop-slot-definition-name (slot)
  +  (getf slot ':name))
  +(defun (setf mop-slot-definition-name) (new-value slot)
  +  (setf (getf* slot ':name) new-value))
  +
  +(defun mop-slot-definition-initfunction (slot)
  +  (getf slot ':initfunction))
  +(defun (setf mop-slot-definition-initfunction) (new-value slot)
  +  (setf (getf* slot ':initfunction) new-value))
  +
  +(defun mop-slot-definition-initform (slot)
  +  (getf slot ':initform))
  +(defun (setf mop-slot-definition-initform) (new-value slot)
  +  (setf (getf* slot ':initform) new-value))
  +
  +(defun mop-slot-definition-initargs (slot)
  +  (getf slot ':initargs))
  +(defun (setf mop-slot-definition-initargs) (new-value slot)
  +  (setf (getf* slot ':initargs) new-value))
  +
  +(defun mop-slot-definition-readers (slot)
  +  (getf slot ':readers))
  +(defun (setf mop-slot-definition-readers) (new-value slot)
  +  (setf (getf* slot ':readers) new-value))
  +
  +(defun mop-slot-definition-writers (slot)
  +  (getf slot ':writers))
  +(defun (setf mop-slot-definition-writers) (new-value slot)
  +  (setf (getf* slot ':writers) new-value))
  +
  +(defun mop-slot-definition-allocation (slot)
  +  (getf slot ':allocation))
  +(defun (setf mop-slot-definition-allocation) (new-value slot)
  +  (setf (getf* slot ':allocation) new-value))
  +
  +(defun mop-std-finalize-inheritance (class)
  +  (setf (mop-class-precedence-list class)
  +        (funcall (if (eq (mop-class-of class) mop-the-class-standard-class)
  +                     #'mop-std-compute-class-precedence-list
  +                     #'mop-compute-class-precedence-list)
  +                 class))
  +  (setf (mop-class-slots class)
  +        (funcall (if (eq (mop-class-of class) mop-the-class-standard-class)
  +                     #'mop-std-compute-slots
  +                     #'mop-compute-slots)
  +                 class))
  +  (values))
  +
  +(defun mop-std-compute-class-precedence-list (class)
  +  (let ((classes-to-order (mop-collect-superclasses* class)))
  +    (mop-topological-sort classes-to-order
  +                          (remove-duplicates
  +                           (mop-mapappand #'mop-local-precedence-order classes-to-order))
  +                          #'mop-std-tie-breaker-rule)))
  +
  +(defun mop-topological-sort (elements constraints tie-breaker)
  +  (let ((remaining-constraints constraints)
  +        (remaining-elements elements)
  +        (result ()))
  +    (loop (let ((minimal-elements (remove-if #'(lambda (class)
  +                                                 (member class remaining-constraints
  +                                                         :key #'cadr))
  +                                             remaining-elements)))
  +            (when (null minimal-elements)
  +              (if (null remaining-elements)
  +                  (return-from mop-topological-sort result)
  +                  (error "Inconsistent precedence graph.")))
  +            (let ((choice (if (null (cdr minimal-elements))
  +                              (car minimal-elements)
  +                              (funcall tie-breaker minimal-elements result))))
  +              (setq result (append result (list choice)))
  +              (setq remaining-elements (remove choice remaining-elements))
  +              (setq remaining-constraints (remove choice remaining-constraints :test #'member)))))))
  +
  +(defun mop-std-tie-breaker-rule (minimal-elements cpl-so-far)
  +  (dolist (cpl-constituent (reverse cpl-so-far))
  +    (let* ((supers (mop-class-direct-superclasses cpl-constituent))
  +           (common (intersection minimal-elements cpl-constituent)))
  +      (when (not (null common))
  +        (return-from mop-std-tie-breaker-rule (car common))))))
  +
  +(defun mop-collect-superclasses* (class)
  +  (labels ((all-superclasses-loop (seen superclasses)
  +             (let ((to-be-processed (set-difference superclasses seen)))
  +               (if (null to-be-processed)
  +                   superclasses
  +                   (let ((class-to-process (car to-be-processed)))
  +                     (all-superclasses-loop
  +                      (cons class-to-process seen)
  +                      (union (mop-class-direct-superclasses class-to-process)
  +                             superclasses)))))))
  +    (all-superclasses-loop () (list class))))
  +
  +(defun mop-local-precedence-order (class)
  +  (mapcar #'list
  +          (cons class (butlast (mop-class-direct-superclasses class)))
  +          (mop-class-direct-superclasses class)))
  +
  +(defun mop-std-compute-slots (class)
  +  (let* ((all-slots (mop-mapappend #'mop-class-direct-slots (mop-class-precedence-list class)))
  +         (all-names (remove-duplicates (mapcar #'mop-slot-definition-name all-slots))))
  +    (mapcar #'(lambda (name)
  +                (funcall (if (eq (mop-class-of class) mop-the-class-standard-class)
  +                             #'mop-std-compute-effective-slot-definition
  +                             #'std-compute-effective-slot-definition)
  +                         class
  +                         (remove name all-slots :key #'mop-slot-definition-name :test-not #'eq)))
  +            all-names)))
  +
  +(defun mop-std-compute-effective-slot-definition (class direct-slots)
  +  (declare (ignore class))
  +  (let ((initer (find-if-not #'null direct-slots :key #'mop-slot-definition-initfunction)))
  +    (mop-make-effective-slot-definition
  +     :name (mop-slot-definition-name (car direct-slots))
  +     :initform (if initer (mop-slot-definition-iniform initer) nil)
  +     :initfunction (if initer (mop-slot-definition-initfunction initer) nil)
  +     :initargs (remove-duplicates (mop-mapappend #'mop-slot-definition-initargs direct-slots))
  +     :allocation (mop-slot-definition-allocation (car direct-slots)))))
  +
  +(defparameter mop-the-defclass-standard-generic-function
  +  `(defclass mop-standard-generic-function ()
  +     ((name :initarg :name)
  +      (lambda-list :initarg :lambda-list)
  +      (methods :initform ())
  +      (method-class :initarg :method-class)
  +      (discriminating-function)
  +      (classes-to-emf-table :initform (make-hash-table :test #'equal)))))
  +
  +(defvar mop-the-class-standard-gf)
  +
  +(defun mop-generic-function-name (gf)
  +  (mop-slot-value gf 'name))
  +(defun (setf mop-generic-function-name) (new-value gf)
  +  (setf (mop-slot-value gf 'name) new-value))
  +
  +(defun mop-generic-function-lambda-list (gf)
  +  (mop-slot-value gf 'lambda-list))
  +(defun (setf mop-generic-function-lambda-list) (new-value gf)
  +  (setf (mop-slot-value gf 'lambda-list) new-value))
  +
  +(defun mop-generic-function-methods (gf)
  +  (mop-slot-value gf 'methods))
  +(defun (setf mop-generic-function-methods) (new-value gf)
  +  (setf (mop-slot-value gf 'methods) new-value))
  +
  +(defun mop-generic-function-discriminating-function (gf)
  +  (mop-slot-value gf 'discriminating-function))
  +(defun (setf mop-generic-function-discriminating-function) (new-value gf)
  +  (setf (mop-slot-value gf 'discriminating-function) new-value))
  +
  +(defun mop-generic-function-method-class (gf)
  +  (mop-slot-value gf 'method-class))
  +(defun (setf mop-generic-function-method-class) (new-value gf)
  +  (setf (mop-slot-value gf 'method-class) new-value))
  +
  +(defun mop-classes-to-emf-table (gf)
  +  (mop-slot-value gf 'classes-to-emf-table))
  +(defun (setf mop-classes-to-emf-table) (new-value gf)
  +  (setf (mop-slot-value gf 'classes-to-emf-table) new-value))
   
   (defparameter mop-the-defclass-standard-method
     '(defclass mop-standard-method ()
  
positive.code:         (setf (mop-find-generic-function function-name) gf)
          gf)))
  
  (defun finalize-generic-function (gf)
    (setf (mop-generic-function-discriminating-function gf)
          (funcall (if (eq (mop-class-of gf) mop-the-class-standard-gf)
                       #'mop-std-compute-discriminating-function
  
negative.code: (defun mop-canonicalize-defclass-options (options)
    (mop-mapappend #'mop-canonicalize-defclass-option options))
  
  ; Stub
  (defun mop-make-instance (class-name &rest all-keys)
    (list class-name all-keys))
  
  (let ((mop-class-table (make-hash-table :test #'eq)))
  
    (defun mop-find-class (symbol &optional (errorp t))
      (let ((class (gethash symbol mop-class-table nil)))
        (if (and (null class) errorp)
            (error "No class named ~S." symbol)
            class)))
  
    (defun (setf mop-find-class) (new-value symbol)
      (setf (gethash symbol mop-class-table) new-value))
  
    (defun mop-forget-all-classes ()
      (clrhash mop-class-table)
      (values))
  
  )
  
  (defun mop-ensure-class (name &rest all-keys)
    (if (mop-find-class name nil)
        (error "Can't redefine the class named ~S." name)
  