| 1 | ;;; defclass.lisp |
|---|
| 2 | ;;; |
|---|
| 3 | ;;; Copyright (C) 2003 Peter Graves |
|---|
| 4 | ;;; $Id: defclass.lisp,v 1.4 2003-10-10 17:17:24 piso Exp $ |
|---|
| 5 | ;;; |
|---|
| 6 | ;;; This program is free software; you can redistribute it and/or |
|---|
| 7 | ;;; modify it under the terms of the GNU General Public License |
|---|
| 8 | ;;; as published by the Free Software Foundation; either version 2 |
|---|
| 9 | ;;; of the License, or (at your option) any later version. |
|---|
| 10 | ;;; |
|---|
| 11 | ;;; This program is distributed in the hope that it will be useful, |
|---|
| 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
|---|
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|---|
| 14 | ;;; GNU General Public License for more details. |
|---|
| 15 | ;;; |
|---|
| 16 | ;;; You should have received a copy of the GNU General Public License |
|---|
| 17 | ;;; along with this program; if not, write to the Free Software |
|---|
| 18 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
|---|
| 19 | |
|---|
| 20 | (in-package "SYSTEM") |
|---|
| 21 | |
|---|
| 22 | (defmacro push-on-end (value location) |
|---|
| 23 | `(setf ,location (nconc ,location (list ,value)))) |
|---|
| 24 | |
|---|
| 25 | ;;; (SETF GETF*) is like (SETF GETF) except that it always changes the list, |
|---|
| 26 | ;;; which must be non-nil. |
|---|
| 27 | |
|---|
| 28 | (defun (setf getf*) (new-value plist key) |
|---|
| 29 | (block body |
|---|
| 30 | (do ((x plist (cddr x))) |
|---|
| 31 | ((null x)) |
|---|
| 32 | (when (eq (car x) key) |
|---|
| 33 | (setf (car (cdr x)) new-value) |
|---|
| 34 | (return-from body new-value))) |
|---|
| 35 | (push-on-end key plist) |
|---|
| 36 | (push-on-end new-value plist) |
|---|
| 37 | new-value)) |
|---|
| 38 | |
|---|
| 39 | (defun mapappend (fun &rest args) |
|---|
| 40 | (if (some #'null args) |
|---|
| 41 | () |
|---|
| 42 | (append (apply fun (mapcar #'car args)) |
|---|
| 43 | (apply #'mapappend fun (mapcar #'cdr args))))) |
|---|
| 44 | |
|---|
| 45 | (defun mapplist (fun x) |
|---|
| 46 | (if (null x) |
|---|
| 47 | () |
|---|
| 48 | (cons (funcall fun (car x) (cadr x)) |
|---|
| 49 | (mapplist fun (cddr x))))) |
|---|
| 50 | |
|---|
| 51 | (defsetf class-name %set-class-name) |
|---|
| 52 | (defsetf class-direct-superclasses %set-class-direct-superclasses) |
|---|
| 53 | (defsetf class-direct-subclasses %set-class-direct-subclasses) |
|---|
| 54 | (defsetf class-direct-methods %set-class-direct-methods) |
|---|
| 55 | (defsetf class-direct-slots %set-class-direct-slots) |
|---|
| 56 | (defsetf class-precedence-list %set-class-precedence-list) |
|---|
| 57 | (defsetf class-slots %set-class-slots) |
|---|
| 58 | |
|---|
| 59 | (defun canonicalize-direct-slots (direct-slots) |
|---|
| 60 | `(list ,@(mapcar #'canonicalize-direct-slot direct-slots))) |
|---|
| 61 | |
|---|
| 62 | (defun canonicalize-direct-slot (spec) |
|---|
| 63 | (if (symbolp spec) |
|---|
| 64 | `(list :name ',spec) |
|---|
| 65 | (let ((name (car spec)) |
|---|
| 66 | (initfunction nil) |
|---|
| 67 | (initform nil) |
|---|
| 68 | (initargs ()) |
|---|
| 69 | (readers ()) |
|---|
| 70 | (writers ()) |
|---|
| 71 | (other-options ())) |
|---|
| 72 | (do ((olist (cdr spec) (cddr olist))) |
|---|
| 73 | ((null olist)) |
|---|
| 74 | (case (car olist) |
|---|
| 75 | (:initform |
|---|
| 76 | (setq initfunction |
|---|
| 77 | `(function (lambda () ,(cadr olist)))) |
|---|
| 78 | (setq initform `',(cadr olist))) |
|---|
| 79 | (:initarg |
|---|
| 80 | (push-on-end (cadr olist) initargs)) |
|---|
| 81 | (:reader |
|---|
| 82 | (push-on-end (cadr olist) readers)) |
|---|
| 83 | (:writer |
|---|
| 84 | (push-on-end (cadr olist) writers)) |
|---|
| 85 | (:accessor |
|---|
| 86 | (push-on-end (cadr olist) readers) |
|---|
| 87 | (push-on-end `(setf ,(cadr olist)) writers)) |
|---|
| 88 | (otherwise |
|---|
| 89 | (push-on-end `',(car olist) other-options) |
|---|
| 90 | (push-on-end `',(cadr olist) other-options)))) |
|---|
| 91 | `(list |
|---|
| 92 | :name ',name |
|---|
| 93 | ,@(when initfunction |
|---|
| 94 | `(:initform ,initform |
|---|
| 95 | :initfunction ,initfunction)) |
|---|
| 96 | ,@(when initargs `(:initargs ',initargs)) |
|---|
| 97 | ,@(when readers `(:readers ',readers)) |
|---|
| 98 | ,@(when writers `(:writers ',writers)) |
|---|
| 99 | ,@other-options)))) |
|---|
| 100 | |
|---|
| 101 | (defun canonicalize-direct-superclasses (direct-superclasses) |
|---|
| 102 | `(list ,@(mapcar #'canonicalize-direct-superclass direct-superclasses))) |
|---|
| 103 | |
|---|
| 104 | (defun canonicalize-direct-superclass (class-name) |
|---|
| 105 | `(find-class ',class-name)) |
|---|
| 106 | |
|---|
| 107 | (defun canonicalize-defclass-options (options) |
|---|
| 108 | (mapappend #'canonicalize-defclass-option options)) |
|---|
| 109 | |
|---|
| 110 | (defun canonicalize-defclass-option (option) |
|---|
| 111 | (case (car option) |
|---|
| 112 | (:metaclass |
|---|
| 113 | (list ':metaclass |
|---|
| 114 | `(find-class ',(cadr option)))) |
|---|
| 115 | (:default-initargs |
|---|
| 116 | (list |
|---|
| 117 | ':direct-default-initargs |
|---|
| 118 | `(list ,@(mapappend |
|---|
| 119 | #'(lambda (x) x) |
|---|
| 120 | (mapplist |
|---|
| 121 | #'(lambda (key value) |
|---|
| 122 | `(',key ,value)) |
|---|
| 123 | (cdr option)))))) |
|---|
| 124 | (t (list `',(car option) `',(cadr option))))) |
|---|
| 125 | |
|---|
| 126 | ;;; Slot definition metaobjects |
|---|
| 127 | |
|---|
| 128 | ;;; N.B. Quietly retain all unknown slot options (rather than signaling an |
|---|
| 129 | ;;; error), so that it's easy to add new ones. |
|---|
| 130 | |
|---|
| 131 | (defun make-direct-slot-definition |
|---|
| 132 | (&rest properties |
|---|
| 133 | &key name (initargs ()) (initform nil) (initfunction nil) |
|---|
| 134 | (readers ()) (writers ()) (allocation :instance) |
|---|
| 135 | &allow-other-keys) |
|---|
| 136 | (let ((slot (copy-list properties))) ; Don't want to side effect &rest list |
|---|
| 137 | (setf (getf* slot ':name) name) |
|---|
| 138 | (setf (getf* slot ':initargs) initargs) |
|---|
| 139 | (setf (getf* slot ':initform) initform) |
|---|
| 140 | (setf (getf* slot ':initfunction) initfunction) |
|---|
| 141 | (setf (getf* slot ':readers) readers) |
|---|
| 142 | (setf (getf* slot ':writers) writers) |
|---|
| 143 | (setf (getf* slot ':allocation) allocation) |
|---|
| 144 | slot)) |
|---|
| 145 | |
|---|
| 146 | (defun make-effective-slot-definition |
|---|
| 147 | (&rest properties |
|---|
| 148 | &key name (initargs ()) (initform nil) (initfunction nil) |
|---|
| 149 | (allocation :instance) |
|---|
| 150 | &allow-other-keys) |
|---|
| 151 | (let ((slot (copy-list properties))) ; Don't want to side effect &rest list |
|---|
| 152 | (setf (getf* slot ':name) name) |
|---|
| 153 | (setf (getf* slot ':initargs) initargs) |
|---|
| 154 | (setf (getf* slot ':initform) initform) |
|---|
| 155 | (setf (getf* slot ':initfunction) initfunction) |
|---|
| 156 | (setf (getf* slot ':allocation) allocation) |
|---|
| 157 | slot)) |
|---|
| 158 | |
|---|
| 159 | (defun slot-definition-name (slot) |
|---|
| 160 | (getf slot ':name)) |
|---|
| 161 | (defun (setf slot-definition-name) (new-value slot) |
|---|
| 162 | (setf (getf* slot ':name) new-value)) |
|---|
| 163 | |
|---|
| 164 | (defun slot-definition-initfunction (slot) |
|---|
| 165 | (getf slot ':initfunction)) |
|---|
| 166 | (defun (setf slot-definition-initfunction) (new-value slot) |
|---|
| 167 | (setf (getf* slot ':initfunction) new-value)) |
|---|
| 168 | |
|---|
| 169 | (defun slot-definition-initform (slot) |
|---|
| 170 | (getf slot ':initform)) |
|---|
| 171 | (defun (setf slot-definition-initform) (new-value slot) |
|---|
| 172 | (setf (getf* slot ':initform) new-value)) |
|---|
| 173 | |
|---|
| 174 | (defun slot-definition-initargs (slot) |
|---|
| 175 | (getf slot ':initargs)) |
|---|
| 176 | (defun (setf slot-definition-initargs) (new-value slot) |
|---|
| 177 | (setf (getf* slot ':initargs) new-value)) |
|---|
| 178 | |
|---|
| 179 | (defun slot-definition-readers (slot) |
|---|
| 180 | (getf slot ':readers)) |
|---|
| 181 | (defun (setf slot-definition-readers) (new-value slot) |
|---|
| 182 | (setf (getf* slot ':readers) new-value)) |
|---|
| 183 | |
|---|
| 184 | (defun slot-definition-writers (slot) |
|---|
| 185 | (getf slot ':writers)) |
|---|
| 186 | (defun (setf slot-definition-writers) (new-value slot) |
|---|
| 187 | (setf (getf* slot ':writers) new-value)) |
|---|
| 188 | |
|---|
| 189 | (defun slot-definition-allocation (slot) |
|---|
| 190 | (getf slot ':allocation)) |
|---|
| 191 | (defun (setf slot-definition-allocation) (new-value slot) |
|---|
| 192 | (setf (getf* slot ':allocation) new-value)) |
|---|
| 193 | |
|---|
| 194 | ;;; finalize-inheritance |
|---|
| 195 | |
|---|
| 196 | (defun std-finalize-inheritance (class) |
|---|
| 197 | (setf (class-precedence-list class) |
|---|
| 198 | (funcall (if (eq (class-of class) the-class-standard-class) |
|---|
| 199 | #'std-compute-class-precedence-list |
|---|
| 200 | #'compute-class-precedence-list) |
|---|
| 201 | class)) |
|---|
| 202 | (setf (class-slots class) |
|---|
| 203 | (funcall (if (eq (class-of class) the-class-standard-class) |
|---|
| 204 | #'std-compute-slots |
|---|
| 205 | #'compute-slots) |
|---|
| 206 | class)) |
|---|
| 207 | (values)) |
|---|
| 208 | |
|---|
| 209 | ;;; Class precedence lists |
|---|
| 210 | |
|---|
| 211 | (defun std-compute-class-precedence-list (class) |
|---|
| 212 | (let ((classes-to-order (collect-superclasses* class))) |
|---|
| 213 | (topological-sort classes-to-order |
|---|
| 214 | (remove-duplicates |
|---|
| 215 | (mapappend #'local-precedence-ordering |
|---|
| 216 | classes-to-order)) |
|---|
| 217 | #'std-tie-breaker-rule))) |
|---|
| 218 | |
|---|
| 219 | ;;; topological-sort implements the standard algorithm for topologically |
|---|
| 220 | ;;; sorting an arbitrary set of elements while honoring the precedence |
|---|
| 221 | ;;; constraints given by a set of (X,Y) pairs that indicate that element |
|---|
| 222 | ;;; X must precede element Y. The tie-breaker procedure is called when it |
|---|
| 223 | ;;; is necessary to choose from multiple minimal elements; both a list of |
|---|
| 224 | ;;; candidates and the ordering so far are provided as arguments. |
|---|
| 225 | |
|---|
| 226 | (defun topological-sort (elements constraints tie-breaker) |
|---|
| 227 | (let ((remaining-constraints constraints) |
|---|
| 228 | (remaining-elements elements) |
|---|
| 229 | (result ())) |
|---|
| 230 | (loop |
|---|
| 231 | (let ((minimal-elements |
|---|
| 232 | (remove-if |
|---|
| 233 | #'(lambda (class) |
|---|
| 234 | (member class remaining-constraints |
|---|
| 235 | :key #'cadr)) |
|---|
| 236 | remaining-elements))) |
|---|
| 237 | (when (null minimal-elements) |
|---|
| 238 | (if (null remaining-elements) |
|---|
| 239 | (return-from topological-sort result) |
|---|
| 240 | (error "Inconsistent precedence graph."))) |
|---|
| 241 | (let ((choice (if (null (cdr minimal-elements)) |
|---|
| 242 | (car minimal-elements) |
|---|
| 243 | (funcall tie-breaker |
|---|
| 244 | minimal-elements |
|---|
| 245 | result)))) |
|---|
| 246 | (setq result (append result (list choice))) |
|---|
| 247 | (setq remaining-elements |
|---|
| 248 | (remove choice remaining-elements)) |
|---|
| 249 | (setq remaining-constraints |
|---|
| 250 | (remove choice |
|---|
| 251 | remaining-constraints |
|---|
| 252 | :test #'member))))))) |
|---|
| 253 | |
|---|
| 254 | ;;; In the event of a tie while topologically sorting class precedence lists, |
|---|
| 255 | ;;; the CLOS Specification says to "select the one that has a direct subclass |
|---|
| 256 | ;;; rightmost in the class precedence list computed so far." The same result |
|---|
| 257 | ;;; is obtained by inspecting the partially constructed class precedence list |
|---|
| 258 | ;;; from right to left, looking for the first minimal element to show up among |
|---|
| 259 | ;;; the direct superclasses of the class precedence list constituent. |
|---|
| 260 | ;;; (There's a lemma that shows that this rule yields a unique result.) |
|---|
| 261 | |
|---|
| 262 | (defun std-tie-breaker-rule (minimal-elements cpl-so-far) |
|---|
| 263 | (dolist (cpl-constituent (reverse cpl-so-far)) |
|---|
| 264 | (let* ((supers (class-direct-superclasses cpl-constituent)) |
|---|
| 265 | (common (intersection minimal-elements supers))) |
|---|
| 266 | (when (not (null common)) |
|---|
| 267 | (return-from std-tie-breaker-rule (car common)))))) |
|---|
| 268 | |
|---|
| 269 | ;;; This version of collect-superclasses* isn't bothered by cycles in the class |
|---|
| 270 | ;;; hierarchy, which sometimes happen by accident. |
|---|
| 271 | |
|---|
| 272 | (defun collect-superclasses* (class) |
|---|
| 273 | (labels ((all-superclasses-loop (seen superclasses) |
|---|
| 274 | (let ((to-be-processed |
|---|
| 275 | (set-difference superclasses seen))) |
|---|
| 276 | (if (null to-be-processed) |
|---|
| 277 | superclasses |
|---|
| 278 | (let ((class-to-process |
|---|
| 279 | (car to-be-processed))) |
|---|
| 280 | (all-superclasses-loop |
|---|
| 281 | (cons class-to-process seen) |
|---|
| 282 | (union (class-direct-superclasses |
|---|
| 283 | class-to-process) |
|---|
| 284 | superclasses))))))) |
|---|
| 285 | (all-superclasses-loop () (list class)))) |
|---|
| 286 | |
|---|
| 287 | ;;; The local precedence ordering of a class C with direct superclasses C_1, |
|---|
| 288 | ;;; C_2, ..., C_n is the set ((C C_1) (C_1 C_2) ...(C_n-1 C_n)). |
|---|
| 289 | |
|---|
| 290 | (defun local-precedence-ordering (class) |
|---|
| 291 | (mapcar #'list |
|---|
| 292 | (cons class |
|---|
| 293 | (butlast (class-direct-superclasses class))) |
|---|
| 294 | (class-direct-superclasses class))) |
|---|
| 295 | |
|---|
| 296 | ;;; Slot inheritance |
|---|
| 297 | |
|---|
| 298 | (defun std-compute-slots (class) |
|---|
| 299 | (let* ((all-slots (mapappend #'class-direct-slots |
|---|
| 300 | (class-precedence-list class))) |
|---|
| 301 | (all-names (remove-duplicates |
|---|
| 302 | (mapcar #'slot-definition-name all-slots)))) |
|---|
| 303 | (mapcar #'(lambda (name) |
|---|
| 304 | (funcall |
|---|
| 305 | (if (eq (class-of class) the-class-standard-class) |
|---|
| 306 | #'std-compute-effective-slot-definition |
|---|
| 307 | #'compute-effective-slot-definition) |
|---|
| 308 | class |
|---|
| 309 | (remove name all-slots |
|---|
| 310 | :key #'slot-definition-name |
|---|
| 311 | :test-not #'eq))) |
|---|
| 312 | all-names))) |
|---|
| 313 | |
|---|
| 314 | (defun std-compute-effective-slot-definition (class direct-slots) |
|---|
| 315 | (declare (ignore class)) |
|---|
| 316 | (let ((initer (find-if-not #'null direct-slots |
|---|
| 317 | :key #'slot-definition-initfunction))) |
|---|
| 318 | (make-effective-slot-definition |
|---|
| 319 | :name (slot-definition-name (car direct-slots)) |
|---|
| 320 | :initform (if initer |
|---|
| 321 | (slot-definition-initform initer) |
|---|
| 322 | nil) |
|---|
| 323 | :initfunction (if initer |
|---|
| 324 | (slot-definition-initfunction initer) |
|---|
| 325 | nil) |
|---|
| 326 | :initargs (remove-duplicates |
|---|
| 327 | (mapappend #'slot-definition-initargs |
|---|
| 328 | direct-slots)) |
|---|
| 329 | :allocation (slot-definition-allocation (car direct-slots))))) |
|---|
| 330 | |
|---|
| 331 | ;;; Simple vectors are used for slot storage. |
|---|
| 332 | |
|---|
| 333 | (defun allocate-slot-storage (size initial-value) |
|---|
| 334 | (make-array size :initial-element initial-value)) |
|---|
| 335 | |
|---|
| 336 | ;;; Standard instance allocation |
|---|
| 337 | |
|---|
| 338 | (defvar the-class-standard-class (find-class 'standard-class)) |
|---|
| 339 | |
|---|
| 340 | (defparameter secret-unbound-value (list "slot unbound")) |
|---|
| 341 | |
|---|
| 342 | (defun instance-slot-p (slot) |
|---|
| 343 | (eq (slot-definition-allocation slot) ':instance)) |
|---|
| 344 | |
|---|
| 345 | (defun std-allocate-instance (class) |
|---|
| 346 | (allocate-std-instance |
|---|
| 347 | class |
|---|
| 348 | (allocate-slot-storage (count-if #'instance-slot-p (class-slots class)) |
|---|
| 349 | secret-unbound-value))) |
|---|
| 350 | |
|---|
| 351 | (defun allocate-instance (class) |
|---|
| 352 | (std-allocate-instance class)) |
|---|
| 353 | |
|---|
| 354 | (defun make-instance-standard-class (metaclass &key name direct-superclasses direct-slots |
|---|
| 355 | &allow-other-keys) |
|---|
| 356 | (declare (ignore metaclass)) |
|---|
| 357 | ;; (format t "name = ~S~%" name) |
|---|
| 358 | ;; (format t "direct-superclasses = ~S~%" direct-superclasses) |
|---|
| 359 | ;; (format t "direct-slots = ~S~%" direct-slots) |
|---|
| 360 | (let ((class (std-allocate-instance (find-class 'standard-class)))) |
|---|
| 361 | (setf (class-name class) name) |
|---|
| 362 | (setf (class-direct-subclasses class) ()) |
|---|
| 363 | (setf (class-direct-methods class) ()) |
|---|
| 364 | (std-after-initialization-for-classes class |
|---|
| 365 | :direct-slots direct-slots |
|---|
| 366 | :direct-superclasses direct-superclasses) |
|---|
| 367 | class)) |
|---|
| 368 | |
|---|
| 369 | ;; FIXME |
|---|
| 370 | (defun std-after-initialization-for-classes (class |
|---|
| 371 | &key direct-superclasses direct-slots |
|---|
| 372 | &allow-other-keys) |
|---|
| 373 | (let ((supers |
|---|
| 374 | (or direct-superclasses |
|---|
| 375 | (list (find-class 'standard-object))))) |
|---|
| 376 | (setf (class-direct-superclasses class) supers) |
|---|
| 377 | (dolist (superclass supers) |
|---|
| 378 | (push class (class-direct-subclasses superclass)))) |
|---|
| 379 | (let ((slots |
|---|
| 380 | (mapcar #'(lambda (slot-properties) |
|---|
| 381 | (apply #'make-direct-slot-definition |
|---|
| 382 | slot-properties)) |
|---|
| 383 | direct-slots))) |
|---|
| 384 | (setf (class-direct-slots class) slots) |
|---|
| 385 | ;; (dolist (direct-slot slots) |
|---|
| 386 | ;; (dolist (reader (slot-definition-readers direct-slot)) |
|---|
| 387 | ;; (add-reader-method |
|---|
| 388 | ;; class reader (slot-definition-name direct-slot))) |
|---|
| 389 | ;; (dolist (writer (slot-definition-writers direct-slot)) |
|---|
| 390 | ;; (add-writer-method |
|---|
| 391 | ;; class writer (slot-definition-name direct-slot)))) |
|---|
| 392 | ) |
|---|
| 393 | (funcall (if (eq (class-of class) (find-class 'standard-class)) |
|---|
| 394 | #'std-finalize-inheritance |
|---|
| 395 | #'finalize-inheritance) |
|---|
| 396 | class) |
|---|
| 397 | (values)) |
|---|
| 398 | |
|---|
| 399 | (defun ensure-class (name &rest all-keys &allow-other-keys) |
|---|
| 400 | (let ((class (find-class name nil))) |
|---|
| 401 | (unless class |
|---|
| 402 | (setf class (apply #'make-instance-standard-class (find-class 'standard-class) :name name all-keys)) |
|---|
| 403 | (add-class class)) |
|---|
| 404 | class)) |
|---|
| 405 | |
|---|
| 406 | (defmacro defclass (name direct-superclasses direct-slots |
|---|
| 407 | &rest options) |
|---|
| 408 | `(ensure-class ',name |
|---|
| 409 | :direct-superclasses |
|---|
| 410 | ,(canonicalize-direct-superclasses direct-superclasses) |
|---|
| 411 | :direct-slots |
|---|
| 412 | ,(canonicalize-direct-slots direct-slots) |
|---|
| 413 | ,@(canonicalize-defclass-options options))) |
|---|
