X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/a07d8d005f69c0f9f5da2e09c6ee39cb1e1801aa..dea4d05507e59ab779ed4bb209e05971d87e260c:/cpl.lisp

diff --git a/cpl.lisp b/cpl.lisp
deleted file mode 100644
index 041e8e7..0000000
--- a/cpl.lisp
+++ /dev/null
@@ -1,333 +0,0 @@
-;;; -*-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 --------------------------------------------------