Re: Yet another multiple inheritence problem
Jan Moringen <[email protected]> Wed, 16 Dec 2009 03:15:44 +0100
| Newsgroups | gmane.emacs.eieio |
|---|---|
| Message-ID | <3562_1260929752_ZZg0M1vc2XPd5.00_1260929744.6359.20.camel@localhost.localdomain> |
--Boundary_(ID_VxsP2Yg04EZr0nAcV24iGQ)
Content-type: text/plain; charset=UTF-8
Content-transfer-encoding: 7BIT
> > I hope to get the code for generic class precedence orders working
> > within a few days. Could we delay the decision until then?
> >
>
> That is fine with me.
I got to fixing my patch. The updated version (no extra -c3 file, unit
tests) is attached.
What do you think?
Jan
--Boundary_(ID_VxsP2Yg04EZr0nAcV24iGQ)
Content-type: text/x-patch; name=cedet-eieio-c3.diff; charset=UTF-8
Content-transfer-encoding: 7BIT
Content-disposition: attachment; filename=cedet-eieio-c3.diff
diff -ur cedet/eieio/eieio.el /home/jan/code/emacs/cedet/eieio/eieio.el
--- cedet/eieio/eieio.el 2009-11-19 01:17:46.000000000 +0100
+++ cedet.mine/eieio/eieio.el 2009-12-16 02:43:31.923583708 +0100
@@ -37,6 +37,11 @@
;; Emacs running environment.
;;
;; See eieio.texi for complete documentation on using this package.
+;;
+;; Note: the implementation of the c3 algorithm is based on:
+;; Kim Barrett et al.: A Monotonic Superclass Linearization for Dylan
+;; Retrieved from:
+;; http://192.220.96.201/dylan/linearization-oopsla96.html
;; There is funny stuff going on with typep and deftype. This
;; is the only way I seem to be able to make this stuff load properly.
@@ -283,7 +288,7 @@
"Return the invocation order of CLASS.
Abstract classes cannot be instantiated."
`(or (class-option ,class :method-invocation-order)
- :breadth-first))
+ :c3))
;;; Defining a new class
@@ -539,7 +544,7 @@
;; Make sure the method invocation order is a valid value.
(let ((io (class-option-assoc options :method-invocation-order)))
- (when (and io (not (member io '(:depth-first :breadth-first))))
+ (when (and io (not (member io '(:depth-first :breadth-first :c3))))
(error "Method invocation order %s is not allowed" io)
))
@@ -1645,6 +1650,106 @@
(if (not (class-p class)) (signal 'wrong-type-argument (list 'class-p class)))
(class-children-fast class))
+(defun eieio-c3-candidate (class remaining-inputs)
+ "Returns CLASS if it can go in the result now, otherwise nil"
+ ;; Ensure CLASS is not in any position but the first in any of the
+ ;; element lists of REMAINING-INPUTS.
+ (and (not (some (lambda (l) (member class (rest l)))
+ remaining-inputs))
+ class))
+
+(defun eieio-c3-merge-lists (reversed-partial-result remaining-inputs)
+ "Merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order, if possible.
+If a consistent order does not exist, signal an error."
+ (if (every #'null remaining-inputs)
+ ;; If all remaining inputs are empty lists, we are done.
+ (nreverse reversed-partial-result)
+ ;; Otherwise, we try to find the next element of the result. This
+ ;; is achieved by considering the first element of each
+ ;; (non-empty) input list and accepting a candidate if it is
+ ;; consistent with the rests of the input lists.
+ (let ((next (some (lambda (c) (eieio-c3-candidate c remaining-inputs))
+ (mapcar #'first
+ (remove-if #'null remaining-inputs)))))
+ (if next
+ ;; The graph is consistent so far, add NEXT to result and
+ ;; merge input lists, dropping NEXT from their heads where
+ ;; applicable.
+ (eieio-c3-merge-lists
+ (cons next reversed-partial-result)
+ (mapcar (lambda (l) (if (eq (first l) next) (rest l) l))
+ remaining-inputs))
+ ;; The graph is inconsistent, give up
+ (error "Inconsistent precedence graph"))))
+ )
+
+(defun eieio-class-all-parents-dfs (class)
+ "Return all parents of CLASS with direct ones in depth-first order.
+The order of the elements in the returned list is undefined if
+any descendant of CLASS has a method invocation order different
+from :depth-first."
+ (let ((parents (or (class-parents-fast class)
+ '(eieio-default-superclass))))
+ (remove-duplicates
+ (apply #'append
+ (list class)
+ (mapcar
+ (lambda (parent)
+ (cons parent (class-all-parents parent)))
+ parents))
+ :from-end t))
+ )
+
+(defun eieio-class-all-parents-bfs (class)
+ "Return all parents of CLASS with direct ones in breadth-first order.
+The order of the elements in the returned list is undefined if
+any descendant of CLASS has a method invocation order different
+from :breadth-first."
+ (let ((result)
+ (queue (or (class-parents-fast class)
+ '(eieio-default-superclass))))
+ (while queue
+ (let ((head (pop queue)))
+ (when (not (member head result))
+ (push head result)
+ (when (not (eq head 'eieio-default-superclass))
+ (setq queue (append queue (or (class-parents-fast head)
+ '(eieio-default-superclass))))))))
+ (cons class (nreverse result)))
+ )
+
+(defun eieio-class-all-parents-c3 (class)
+ "Return all parents of CLASS with direct ones in c3 order."
+ (let ((parents (or (class-parents-fast class)
+ '(eieio-default-superclass))))
+ (eieio-c3-merge-lists
+ (list class)
+ (append
+ (mapcar
+ (lambda (x)
+ (cons x (class-all-parents x)))
+ parents)
+ (list parents))))
+ )
+
+(defun class-all-parents (class)
+ "Return (transitively closed) list of parents of CLASS.
+The order, in which the parents are returned depends on the
+method invocation orders of the involved classes."
+ (if (eq class 'eieio-default-superclass)
+ nil
+ (or (let ((mro (class-method-invocation-order class)))
+ (rest
+ (case mro
+ (:depth-first
+ (eieio-class-all-parents-dfs class))
+ (:breadth-first
+ (eieio-class-all-parents-bfs class))
+ (:c3
+ (eieio-class-all-parents-c3 class)))))
+ '(eieio-default-superclass)))
+ )
+
;; Official CLOS functions.
(defalias 'class-direct-superclasses 'class-parents)
(defalias 'class-direct-subclasses 'class-children)
@@ -2110,40 +2215,27 @@
If CLASS is nil, then an empty list of methods should be returned."
;; Note: eieiomt - the MT means MethodTree. See more comments below
;; for the rest of the eieiomt methods.
- (let ((lambdas nil)
- (mclass (list class)))
- (while mclass
- ;; Note: a nil can show up in the class list once we start
- ;; searching through the method tree.
- (when (car mclass)
- ;; lookup the form to use for the PRIMARY object for the next level
- (let ((tmpl (eieio-generic-form method key (car mclass))))
- (when (or (not lambdas)
- ;; This prevents duplicates coming out of the
- ;; class method optimizer. Perhaps we should
- ;; just not optimize before/afters?
- (not (member tmpl lambdas)))
- (setq lambdas (cons tmpl lambdas))
- (if (null (car lambdas))
- (setq lambdas (cdr lambdas))))))
- ;; Add new classes to mclass. Since our input might not be a class
- ;; protect against that.
- (if (car mclass)
- ;; If there is a class, append any methods it may provide
- ;; to the remainder of the class list.
- (let ((io (class-method-invocation-order (car mclass))))
- (if (eq io :depth-first)
- ;; Depth first.
- (setq mclass (append (eieiomt-next (car mclass)) (cdr mclass)))
- ;; Breadth first.
- (setq mclass (append (cdr mclass) (eieiomt-next (car mclass)))))
- )
- ;; Advance to next entry in mclass if it is nil.
- (setq mclass (cdr mclass)))
- )
+
+ ;; Collect lambda expressions stored for the class and its parent
+ ;; classes.
+ (let (lambdas)
+ (dolist (ancestor (cons class (class-all-parents class)))
+ ;; Lookup the form to use for the PRIMARY object for the next level
+ (let ((tmpl (eieio-generic-form method key ancestor)))
+ (when (and tmpl
+ (or (not lambdas)
+ ;; This prevents duplicates coming out of the
+ ;; class method optimizer. Perhaps we should
+ ;; just not optimize before/afters?
+ (not (member tmpl lambdas))))
+ (push tmpl lambdas))))
+
+ ;; Return collected lambda. For :after methods, return in current
+ ;; order (most general class last); Otherwise, reverse order.
(if (eq key method-after)
lambdas
- (nreverse lambdas))))
+ (nreverse lambdas)))
+ )
(defun next-method-p ()
"Non-nil if there is a next method.
@@ -2267,32 +2359,19 @@
(defun eieiomt-sym-optimize (s)
"Find the next class above S which has a function body for the optimizer."
- ;; (message "Optimizing %S" s)
- (let* ((es (intern-soft (symbol-name s))) ;external symbol of class
- (io (class-method-invocation-order es))
- (ov nil)
- (cont t))
- ;; This converts ES from a single symbol to a list of parent classes.
- (setq es (eieiomt-next es))
- ;; Loop over ES, then it's children individually.
- ;; We can have multiple hits only at one level of the parent tree.
- (while (and es cont)
- (setq ov (intern-soft (symbol-name (car es)) eieiomt-optimizing-obarray))
- (if (fboundp ov)
- (progn
- (set s ov) ;store ov as our next symbol
- (setq cont nil))
- (if (eq io :depth-first)
- ;; Pre-pend the subclasses of (car es) so we get
- ;; DEPTH FIRST optimization.
- (setq es (append (eieiomt-next (car es)) (cdr es)))
- ;; Else, we are breadth first.
- ;; (message "Class %s is breadth first" es)
- (setq es (append (cdr es) (eieiomt-next (car es))))
- )))
- ;; If there is no nearest call, then set our value to nil
- (if (not es) (set s nil))
- ))
+ ;; Set the value to nil in case there is no nearest cell.
+ (set s nil)
+ ;; Find the nearest cell that has a function body. If we find one,
+ ;; we replace the nil from above.
+ (let ((external-symbol (intern-soft (symbol-name s))))
+ (catch 'done
+ (dolist (ancestor (class-all-parents external-symbol))
+ (let ((ov (intern-soft (symbol-name ancestor)
+ eieiomt-optimizing-obarray)))
+ (when (fboundp ov)
+ (set s ov) ;; store ov as our next symbol
+ (throw 'done ancestor))))))
+ )
(defun eieio-generic-form (method key class)
"Return the lambda form belonging to METHOD using KEY based upon CLASS.
diff -ur cedet/eieio/Project.ede /home/jan/code/emacs/cedet/eieio/Project.ede
--- cedet/eieio/Project.ede 2009-10-16 05:53:46.000000000 +0200
+++ cedet.mine/eieio/Project.ede 2009-12-16 01:59:31.418711726 +0100
@@ -38,7 +38,7 @@
(ede-proj-target-elisp "test"
:name "test"
:path ""
- :source '("eieio-tests.el" "eieio-test-methodinvoke.el" "eieio-perftest.el")
+ :source '("eieio-tests.el" "eieio-test-methodinvoke.el" "eieio-perftest.el" "eieio-test-mro.el")
:partofall 'nil
)
(ede-proj-target-makefile-miscelaneous "Misc"
diff -Nur cedet/eieio/eieio-test-mro.el /home/jan/code/emacs/cedet/eieio/eieio-test-mro.el
--- cedet/eieio/eieio-test-mro.el 1970-01-01 01:00:00.000000000 +0100
+++ cedet.mine/eieio/eieio-test-mro.el 2009-12-16 02:59:02.182515163 +0100
@@ -0,0 +1,280 @@
+;;; eieio-test-mro.el --- eieio method resolution order tests
+;;
+;; Copyright (C) 2009 Jan Moringen
+;;
+;; Author: Jan Moringen <[email protected]>
+;; X-RCS: $Id$
+;; Keywords: oop, lisp, tools
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+;;
+;; Please send bug reports, etc. to [email protected]
+
+
+;;; Commentary:
+;;
+;; Tests for the various method resolution orders.
+
+
+;;; History:
+;;
+
+
+;;; Code:
+;;
+
+(require 'eieio)
+
+
+;;; Grid Case
+;;
+
+(dolist (fixture '((:breadth-first
+ . (hv-grid vh-grid
+ horizontal-grid vertical-grid
+ grid-layout
+ eieio-default-superclass))
+ (:depth-first
+ . (hv-grid horizontal-grid
+ grid-layout eieio-default-superclass
+ vertical-grid vh-grid))
+ (:c3 . error)))
+ (let ((mro (first fixture))
+ (expected (rest fixture)))
+ (eval
+ `(progn
+ (defclass grid-layout ()
+ ()
+ ""
+ :method-invocation-order ,mro)
+
+ (defclass horizontal-grid (grid-layout)
+ ()
+ ""
+ :method-invocation-order ,mro)
+
+ (defclass vertical-grid (grid-layout)
+ ()
+ ""
+ :method-invocation-order ,mro)
+
+ (defclass hv-grid (horizontal-grid vertical-grid)
+ ()
+ ""
+ :method-invocation-order ,mro)
+
+ (defclass vh-grid (vertical-grid horizontal-grid)
+ ()
+ ""
+ :method-invocation-order ,mro)
+
+ (defclass confused-grid (hv-grid vh-grid)
+ ()
+ ""
+ :method-invocation-order ,mro)))
+
+ (let ((result
+ (condition-case err
+ (class-all-parents 'confused-grid)
+ (error 'error))))
+ (assert (equal result expected)))))
+
+
+;;; Boat Case
+;;
+
+(dolist (fixture '((:breadth-first
+ . (pedal-wheel-boat small-catamaran
+ engine-less wheel-boat small-multihull
+ day-boat boat eieio-default-superclass))
+ (:depth-first
+ . (pedal-wheel-boat engine-less day-boat boat
+ eieio-default-superclass
+ wheel-boat small-catamaran small-multihull))
+ (:c3
+ . (pedal-wheel-boat engine-less
+ small-catamaran small-multihull
+ day-boat wheel-boat boat
+ eieio-default-superclass))))
+ (let ((mro (first fixture))
+ (expected (rest fixture)))
+ (eval
+ `(progn
+ (defclass boat ()
+ ()
+ ""
+ :method-invocation-order ,mro)
+
+ (defclass day-boat (boat)
+ ()
+ ""
+ :method-invocation-order ,mro)
+
+ (defclass wheel-boat (boat)
+ ()
+ ""
+ :method-invocation-order ,mro)
+
+ (defclass engine-less (day-boat)
+ ()
+ ""
+ :method-invocation-order ,mro)
+
+ (defclass small-multihull (day-boat)
+ ()
+ ""
+ :method-invocation-order ,mro)
+
+ (defclass pedal-wheel-boat (engine-less wheel-boat)
+ ()
+ ""
+ :method-invocation-order ,mro)
+
+ (defclass small-catamaran (small-multihull)
+ ()
+ ""
+ :method-invocation-order ,mro)
+
+ (defclass pedalo (pedal-wheel-boat small-catamaran)
+ ()
+ ""
+ :method-invocation-order ,mro)))
+
+ (let ((result
+ (condition-case err
+ (class-all-parents 'pedalo)
+ (error 'error))))
+ (assert (equal result expected)))))
+
+
+;;; Widget Case
+;;
+
+(dolist (fixture '((:breadth-first
+ (menu popup-mixin choice-widget
+ eieio-default-superclass)
+ (menu popup-mixin choice-widget
+ eieio-default-superclass))
+ (:depth-first
+ (menu choice-widget eieio-default-superclass
+ popup-mixin)
+ (menu choice-widget eieio-default-superclass
+ popup-mixin))
+ (:c3
+ (menu choice-widget popup-mixin
+ eieio-default-superclass)
+ (menu popup-mixin choice-widget
+ eieio-default-superclass))))
+ (let ((mro (first fixture))
+ (expected-1 (second fixture))
+ (expected-2 (third fixture)))
+ (eval
+ `(progn
+ (defclass choice-widget ()
+ ()
+ ""
+ :method-invocation-order ,mro)
+
+ (defclass popup-mixin ()
+ ()
+ ""
+ :method-invocation-order ,mro)
+
+ (defclass menu (choice-widget)
+ ()
+ ""
+ :method-invocation-order ,mro)
+
+ (defclass popup-menu (menu popup-mixin)
+ ()
+ ""
+ :method-invocation-order ,mro)
+
+ (defclass new-popup-menu (menu popup-mixin choice-widget)
+ ()
+ ""
+ :method-invocation-order ,mro)))
+
+ (let ((result
+ (condition-case err
+ (class-all-parents 'popup-menu)
+ (error 'error))))
+ (assert (equal result expected-1)))
+
+ (let ((result
+ (condition-case err
+ (class-all-parents 'new-popup-menu)
+ (error 'error))))
+ (assert (equal result expected-2))))
+ )
+
+
+;;; Another Widget Case
+;;
+
+(dolist (fixture '((:breadth-first
+ . (scrollable-pane editable-pane
+ pane scrolling-mixin editing-mixin
+ eieio-default-superclass))
+ (:depth-first
+ . (scrollable-pane pane eieio-default-superclass
+ scrolling-mixin editable-pane editing-mixin))
+ (:c3
+ . (scrollable-pane editable-pane
+ pane scrolling-mixin editing-mixin
+ eieio-default-superclass))))
+ (let ((mro (first fixture))
+ (expected (rest fixture)))
+ (eval
+ `(progn
+ (defclass pane ()
+ ()
+ ""
+ :method-invocation-order ,mro)
+
+ (defclass scrolling-mixin ()
+ ()
+ ""
+ :method-invocation-order ,mro)
+
+ (defclass editing-mixin ()
+ ()
+ ""
+ :method-invocation-order ,mro)
+
+ (defclass scrollable-pane (pane scrolling-mixin)
+ ()
+ ""
+ :method-invocation-order ,mro)
+
+ (defclass editable-pane (pane editing-mixin)
+ ()
+ ""
+ :method-invocation-order ,mro)
+
+ (defclass editable-scrollable-pane (scrollable-pane editable-pane)
+ ()
+ ""
+ :method-invocation-order ,mro)))
+
+ (let ((result
+ (condition-case err
+ (class-all-parents 'editable-scrollable-pane)
+ (error 'error))))
+ (assert (equal result expected)))))
+
+(provide 'eieio-test-mro)
+;;; eieio-test-mro.el ends here
--Boundary_(ID_VxsP2Yg04EZr0nAcV24iGQ)
Content-Type: text/plain; charset="us-ascii"
MIME-Version: 1.0
Content-Transfer-Encoding: 7bit
Content-Disposition: inline
------------------------------------------------------------------------------
This SF.Net email is sponsored by the Verizon Developer Community
Take advantage of Verizon's best-in-class app development support
A streamlined, 14 day to market process makes app distribution fast and easy
Join now and get one step closer to millions of Verizon customers
http://p.sf.net/sfu/verizon-dev2dev
--Boundary_(ID_VxsP2Yg04EZr0nAcV24iGQ)
Content-Type: text/plain; charset="us-ascii"
MIME-Version: 1.0
Content-Transfer-Encoding: 7bit
Content-Disposition: inline
_______________________________________________
cedet-eieio mailing list
[email protected]
https://lists.sourceforge.net/lists/listinfo/cedet-eieio
--Boundary_(ID_VxsP2Yg04EZr0nAcV24iGQ)--