Commit | Line | Data |
---|---|---|
dea4d055 MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Computing class precedence lists | |
4 | ;;; | |
5 | ;;; (c) 2009 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
10 | ;;; This file is part of the Simple Object Definition system. | |
11 | ;;; | |
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. | |
16 | ;;; | |
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. | |
21 | ;;; | |
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. | |
25 | ||
26 | (cl:in-package #:sod) | |
27 | ||
28 | ;;;-------------------------------------------------------------------------- | |
29 | ;;; Linearizations. | |
30 | ||
31 | ;;;-------------------------------------------------------------------------- | |
32 | ;;; Class protocol. | |
33 | ||
34 | (defgeneric compute-cpl (class) | |
35 | (:documentation | |
36 | "Returns the class precedence list for CLASS.")) | |
37 | ||
38 | ;;;-------------------------------------------------------------------------- | |
39 | ;;; Testing. | |
40 | ||
41 | #+test | |
42 | (progn | |
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))) | |
48 | ||
49 | (defmethod print-object ((class test-class) stream) | |
50 | (if *print-escape* | |
51 | (print-unreadable-object (class stream :type t :identity nil) | |
52 | (princ (sod-class-name class) stream)) | |
53 | (princ (sod-class-name class) stream))) | |
54 | ||
55 | (defvar *test-linearization*) | |
56 | ||
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))))) | |
62 | ||
63 | #+test | |
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) | |
75 | (handler-case | |
76 | (mapcar #'sod-class-name | |
77 | (sod-class-precedence-list (gethash (car class) | |
78 | classes))) | |
79 | (inconsistent-merge-error () | |
80 | (list (car class) :error)))) | |
81 | heterarchy))) | |
82 | ||
83 | #+test | |
84 | (progn | |
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* | |
92 | '((object) | |
93 | (boat object) | |
94 | (day-boat boat) | |
95 | (wheel-boat boat) | |
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* | |
102 | '((object) | |
103 | (choice-widget object) | |
104 | (menu choice-widget) | |
105 | (popup-mixin 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* | |
118 | '((object) | |
119 | (a object) (b object) (c object) | |
120 | (p a b) (q a c) | |
121 | (u p) (v q) | |
122 | (x u v) | |
123 | (y x b c) | |
124 | (z x c b))) | |
125 | (defparameter *python-heterarchy* | |
126 | '((object) | |
127 | (a object) (b object) (c object) (d object) (e object) | |
128 | (k1 a b c) | |
129 | (k2 d b e) | |
130 | (k3 d a) | |
131 | (z k1 k2 k3)))) | |
132 | ||
133 | ;;;----- That's all, folks -------------------------------------------------- |