+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Computing class precedence lists
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; SOD 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 SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Linearizations.
-
-;; Just for fun, we implement a wide selection. C3 seems to be clearly the
-;; best, with fewer sharp edges for the unwary.
-;;
-;; The extended precedence graph (EPG) is constructed by adding edges to the
-;; superclass graph. If A and B are classes, then write A < B if A is a
-;; (maybe indirect) subclass of B. For every two classes A and B, and for
-;; every /maximal/ subclass of both A and B (i.e., every C for which C < A
-;; and C < B, but there does not exist D such that D < A, D < B and C < D):
-;; if A precedes B in C's direct superclass list, then draw an edge A -> B,
-;; otherwise draw the edge B -> A.
-;;
-;; A linearization respects the EPG if, whenever A precedes B in the
-;; linearization, there is a path from A to B. The EPG can be cyclic; in
-;; that case, we don't care which order the classes in the cycle are
-;; linearized.
-;;
-;; See Barrett, Cassels, Haahr, Moon, Playford, Withington, `A Monotonic
-;; Superclass Linearization for Dylan' for more detail.
-;; http://www.webcom.com/haahr/dylan/linearization-oopsla96.html
-
-(defun clos-tiebreaker (candidates so-far)
- "The CLOS linearization tiebreaker function.
-
- Intended for use with MERGE-LISTS. Returns the member of CANDIDATES which
- has a direct subclass furthest to the right in the list SO-FAR.
-
- This must disambiguate. The SO-FAR list cannot be empty, since the class
- under construction precedes all of the others. If two classes share a
- direct subclass then that subclass's direct superclasses list must order
- them relative to each other."
-
- (let (winner)
- (dolist (class so-far)
- (dolist (candidate candidates)
- (when (member candidate (sod-class-direct-superclasses class))
- (setf winner candidate))))
- (unless winner
- (error "SOD INTERNAL ERROR: Failed to break tie in CLOS."))
- winner))
-
-(defun clos-cpl (class)
- "Compute the class precedence list of CLASS using CLOS linearization rules.
-
- We merge the direct-superclass lists of all of CLASS's superclasses,
- disambiguating using CLOS-TIEBREAKER.
-
- The CLOS linearization preserves local class ordering, but is not
- monotonic, and does not respect the extended precedence graph. CLOS
- linearization will succeed whenever Dylan or C3 linearization succeeds;
- the converse is not true."
-
- (labels ((superclasses (class)
- (let ((direct-supers (sod-class-direct-superclasses class)))
- (remove-duplicates (cons class
- (mappend #'superclasses
- direct-supers))))))
- (merge-lists (mapcar (lambda (class)
- (cons class
- (sod-class-direct-superclasses class)))
- (superclasses class))
- :pick #'clos-tiebreaker)))
-
-(defun dylan-cpl (class)
- "Compute the class precedence list of CLASS using Dylan linearization
- rules.
-
- We merge the direct-superclass list of CLASS with the full class
- precedence lists of its direct superclasses, disambiguating using
- CLOS-TIEBREAKER. (Inductively, these lists will be consistent with the
- CPLs of indirect superclasses, since those CPLs' orderings are reflected
- in the CPLs of the direct superclasses.)
-
- The Dylan linearization preserves local class ordering and is monotonic,
- but does not respect the extended precedence graph.
-
- Note that this will merge the CPLs of superclasses /as they are/, not
- necessarily as Dylan would have computed them. This ensures monotonicity
- assuming that the superclass CPLs are already monotonic. If they aren't,
- you're going to lose anyway."
-
- (let ((direct-supers (sod-class-direct-superclasses class)))
- (merge-lists (cons (cons class direct-supers)
- (mapcar #'sod-class-precedence-list direct-supers))
- :pick #'clos-tiebreaker)))
-
-(defun c3-tiebreaker (candidates cpls)
- "The C3 linearization tiebreaker function.
-
- Intended for use with MERGE-LISTS. Returns the member of CANDIDATES which
- appears in the earliest element of CPLS, which should be the list of the
- class precedence lists of the direct superclasses of the class in
- question, in the order specified in the class declaration.
-
- The only class in the class precedence list which does not appear in one
- of these lists is the new class itself, which must precede all of the
- others.
-
- This must disambiguate, since if two classes are in the same class
- precedence list, then one must appear in it before the other, which
- provides an ordering between them. (In this situation we return the one
- that matches earliest anyway, which would still give the right answer.)
-
- Note that this will merge the CPLs of superclasses /as they are/, not
- necessarily as C3 would have computed them. This ensures monotonicity
- assuming that the superclass CPLs are already monotonic. If they aren't,
- you're going to lose anyway."
-
- (dolist (cpl cpls)
- (dolist (candidate candidates)
- (when (member candidate cpl)
- (return-from c3-tiebreaker candidate))))
- (error "SOD INTERNAL ERROR: Failed to break tie in C3."))
-
-(defun c3-cpl (class)
- "Compute the class precedence list of CLASS using C3 linearization rules.
-
- We merge the direct-superclass list of CLASS with the full class
- precedence lists of its direct superclasses, disambiguating using
- C3-TIEBREAKER.
-
- The C3 linearization preserves local class ordering, is monotonic, and
- respects the extended precedence graph. It is the linearization used in
- Python, Perl 6 and other languages. It is the recommended linearization
- for SOD."
-
- (let* ((direct-supers (sod-class-direct-superclasses class))
- (cpls (mapcar #'sod-class-precedence-list direct-supers)))
- (merge-lists (cons (cons class direct-supers) cpls)
- :pick (lambda (candidates so-far)
- (declare (ignore so-far))
- (c3-tiebreaker candidates cpls)))))
-
-(defun flavors-cpl (class)
- "Compute the class precedence list of CLASS using Flavors linearization
- rules.
-
- We do a depth-first traversal of the superclass graph, ignoring duplicates
- of classes we've already visited. Interestingly, this has the property of
- being able to tolerate cyclic superclass graphs, though defining cyclic
- graphs is syntactically impossible in SOD.
-
- This linearization has few other redeeming features, however. In
- particular, the top class tends not to be at the end of the CPL, despite
- it being unequivocally less specific than any other class."
-
- (let ((done nil))
- (labels ((walk (class)
- (unless (member class done)
- (push class done)
- (dolist (super (sod-class-direct-superclasses class))
- (walk super)))))
- (walk class)
- (nreverse done))))
-
-(defun python-cpl (class)
- "Compute the class precedence list of CLASS using the documented Python 2.2
- linearization rules.
-
- We do a depth-first traversal of the superclass graph, retaining only the
- last occurrence of each class visited.
-
- This linearization has few redeeming features. It was never actually
- implemented; the true Python 2.2 linearization seems closer to (but
- different from) L*LOOPS."
-
- (let ((done nil))
- (labels ((walk (class)
- (push class done)
- (dolist (super (sod-class-direct-superclasses class))
- (walk super))))
- (walk class)
- (delete-duplicates (nreverse done)))))
-
-(defun l*loops-cpl (class)
- "Compute the class precedence list of CLASS using L*LOOPS linearization
- rules.
-
- We merge the class precedence lists of the direct superclasses of CLASS,
- disambiguating by choosing the earliest candidate which appears in a
- depth-first walk of the superclass graph.
-
- The L*LOOPS rules are monotonic and respect the extended precedence
- graph. However (unlike Dylan and CLOS) they don't respect local
- precedence order i.e., the direct-superclasses list orderings."
-
- (let ((dfs (flavors-cpl class)))
- (cons class (merge-lists (mapcar #'sod-class-precedence-list
- (sod-class-direct-superclasses class))
- :pick (lambda (candidates so-far)
- (declare (ignore so-far))
- (dolist (class dfs)
- (when (member class candidates)
- (return class))))))))
-
-;;;--------------------------------------------------------------------------
-;;; Class protocol.
-
-(defgeneric compute-cpl (class)
- (:documentation
- "Returns the class precedence list for CLASS."))
-
-(defmethod compute-cpl ((class sod-class))
- (handler-case (c3-cpl class)
- (inconsistent-merge-error ()
- (error "Failed to compute class precedence list for `~A'"
- (sod-class-name class)))))
-
-;;;--------------------------------------------------------------------------
-;;; Testing.
-
-#+test
-(progn
- (defclass test-class ()
- ((name :initarg :name :accessor sod-class-name)
- (direct-superclasses :initarg :superclasses
- :accessor sod-class-direct-superclasses)
- (class-precedence-list)))
-
- (defmethod print-object ((class test-class) stream)
- (if *print-escape*
- (print-unreadable-object (class stream :type t :identity nil)
- (princ (sod-class-name class) stream))
- (princ (sod-class-name class) stream)))
-
- (defvar *test-linearization*)
-
- (defmethod sod-class-precedence-list ((class test-class))
- (if (slot-boundp class 'class-precedence-list)
- (slot-value class 'class-precedence-list)
- (setf (slot-value class 'class-precedence-list)
- (funcall *test-linearization* class)))))
-
-#+test
-(defun test-cpl (linearization heterarchy)
- (let* ((*test-linearization* linearization)
- (classes (make-hash-table :test #'equal)))
- (dolist (class heterarchy)
- (let ((name (car class)))
- (setf (gethash (car class) classes)
- (make-instance 'test-class :name name))))
- (dolist (class heterarchy)
- (setf (sod-class-direct-superclasses (gethash (car class) classes))
- (mapcar (lambda (super) (gethash super classes)) (cdr class))))
- (mapcar (lambda (class)
- (handler-case
- (mapcar #'sod-class-name
- (sod-class-precedence-list (gethash (car class)
- classes)))
- (inconsistent-merge-error ()
- (list (car class) :error))))
- heterarchy)))
-
-#+test
-(progn
- (defparameter *confused-heterarchy*
- '((object) (grid-layout object)
- (horizontal-grid grid-layout) (vertical-grid grid-layout)
- (hv-grid horizontal-grid vertical-grid)
- (vh-grid vertical-grid horizontal-grid)
- (confused-grid hv-grid vh-grid)))
- (defparameter *boat-heterarchy*
- '((object)
- (boat object)
- (day-boat boat)
- (wheel-boat boat)
- (engine-less day-boat)
- (small-multihull day-boat)
- (pedal-wheel-boat engine-less wheel-boat)
- (small-catamaran small-multihull)
- (pedalo pedal-wheel-boat small-catamaran)))
- (defparameter *menu-heterarchy*
- '((object)
- (choice-widget object)
- (menu choice-widget)
- (popup-mixin object)
- (popup-menu menu popup-mixin)
- (new-popup-menu menu popup-mixin choice-widget)))
- (defparameter *pane-heterarchy*
- '((pane) (scrolling-mixin) (editing-mixin)
- (scrollable-pane pane scrolling-mixin)
- (editable-pane pane editing-mixin)
- (editable-scrollable-pane scrollable-pane editable-pane)))
- (defparameter *baker-nonmonotonic-heterarchy*
- '((z) (x z) (y) (b y) (a b x) (c a b x y)))
- (defparameter *baker-nonassociative-heterarchy*
- '((a) (b) (c a) (ab a b) (ab-c ab c) (bc b c) (a-bc a bc)))
- (defparameter *distinguishing-heterarchy*
- '((object)
- (a object) (b object) (c object)
- (p a b) (q a c)
- (u p) (v q)
- (x u v)
- (y x b c)
- (z x c b)))
- (defparameter *python-heterarchy*
- '((object)
- (a object) (b object) (c object) (d object) (e object)
- (k1 a b c)
- (k2 d b e)
- (k3 d a)
- (z k1 k2 k3))))
-
-;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff