3 ;;; Computing class precedence lists
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Simple Object Definition system.
12 ;;; SOD is free software; you can redistribute it and/or modify
13 ;;; it under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 2 of the License, or
15 ;;; (at your option) any later version.
17 ;;; SOD is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with SOD; if not, write to the Free Software Foundation,
24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
28 ;;;--------------------------------------------------------------------------
31 ;;;--------------------------------------------------------------------------
34 (defgeneric compute-cpl (class)
36 "Returns the class precedence list for CLASS."))
38 ;;;--------------------------------------------------------------------------
43 (defclass test-class ()
44 ((name :initarg :name :accessor sod-class-name)
45 (direct-superclasses :initarg :superclasses
46 :accessor sod-class-direct-superclasses)
47 (class-precedence-list)))
49 (defmethod print-object ((class test-class) stream)
51 (print-unreadable-object (class stream :type t :identity nil)
52 (princ (sod-class-name class) stream))
53 (princ (sod-class-name class) stream)))
55 (defvar *test-linearization*)
57 (defmethod sod-class-precedence-list ((class test-class))
58 (if (slot-boundp class 'class-precedence-list)
59 (slot-value class 'class-precedence-list)
60 (setf (slot-value class 'class-precedence-list)
61 (funcall *test-linearization* class)))))
64 (defun test-cpl (linearization heterarchy)
65 (let* ((*test-linearization* linearization)
66 (classes (make-hash-table :test #'equal)))
67 (dolist (class heterarchy)
68 (let ((name (car class)))
69 (setf (gethash (car class) classes)
70 (make-instance 'test-class :name name))))
71 (dolist (class heterarchy)
72 (setf (sod-class-direct-superclasses (gethash (car class) classes))
73 (mapcar (lambda (super) (gethash super classes)) (cdr class))))
74 (mapcar (lambda (class)
76 (mapcar #'sod-class-name
77 (sod-class-precedence-list (gethash (car class)
79 (inconsistent-merge-error ()
80 (list (car class) :error))))
85 (defparameter *confused-heterarchy*
86 '((object) (grid-layout object)
87 (horizontal-grid grid-layout) (vertical-grid grid-layout)
88 (hv-grid horizontal-grid vertical-grid)
89 (vh-grid vertical-grid horizontal-grid)
90 (confused-grid hv-grid vh-grid)))
91 (defparameter *boat-heterarchy*
96 (engine-less day-boat)
97 (small-multihull day-boat)
98 (pedal-wheel-boat engine-less wheel-boat)
99 (small-catamaran small-multihull)
100 (pedalo pedal-wheel-boat small-catamaran)))
101 (defparameter *menu-heterarchy*
103 (choice-widget object)
106 (popup-menu menu popup-mixin)
107 (new-popup-menu menu popup-mixin choice-widget)))
108 (defparameter *pane-heterarchy*
109 '((pane) (scrolling-mixin) (editing-mixin)
110 (scrollable-pane pane scrolling-mixin)
111 (editable-pane pane editing-mixin)
112 (editable-scrollable-pane scrollable-pane editable-pane)))
113 (defparameter *baker-nonmonotonic-heterarchy*
114 '((z) (x z) (y) (b y) (a b x) (c a b x y)))
115 (defparameter *baker-nonassociative-heterarchy*
116 '((a) (b) (c a) (ab a b) (ab-c ab c) (bc b c) (a-bc a bc)))
117 (defparameter *distinguishing-heterarchy*
119 (a object) (b object) (c object)
125 (defparameter *python-heterarchy*
127 (a object) (b object) (c object) (d object) (e object)
133 ;;;----- That's all, folks --------------------------------------------------