| 1 | ;;; -*-lisp-*- |
| 2 | ;;; |
| 3 | ;;; Class finalization implementation |
| 4 | ;;; |
| 5 | ;;; (c) 2009 Straylight/Edgeware |
| 6 | ;;; |
| 7 | |
| 8 | ;;;----- Licensing notice --------------------------------------------------- |
| 9 | ;;; |
| 10 | ;;; This file is part of the Sensible Object Design, an object system for C. |
| 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 | ;;; Class precedence lists. |
| 30 | |
| 31 | ;; Just for fun, we implement a wide selection of precedence list algorithms. |
| 32 | ;; C3 seems to be clearly the best, with fewer sharp edges for the unwary. |
| 33 | ;; |
| 34 | ;; The extended precedence graph (EPG) is constructed by adding edges to the |
| 35 | ;; superclass graph. If A and B are classes, then write A < B if A is a |
| 36 | ;; (maybe indirect) subclass of B. For every two classes A and B, and for |
| 37 | ;; every /maximal/ subclass of both A and B (i.e., every C for which C < A |
| 38 | ;; and C < B, but there does not exist D such that D < A, D < B and C < D): |
| 39 | ;; if A precedes B in C's direct superclass list, then draw an edge A -> B, |
| 40 | ;; otherwise draw the edge B -> A. |
| 41 | ;; |
| 42 | ;; A linearization respects the EPG if, whenever A precedes B in the |
| 43 | ;; linearization, there is a path from A to B. The EPG can be cyclic; in |
| 44 | ;; that case, we don't care which order the classes in the cycle are |
| 45 | ;; linearized. |
| 46 | ;; |
| 47 | ;; See Barrett, Cassels, Haahr, Moon, Playford, Withington, `A Monotonic |
| 48 | ;; Superclass Linearization for Dylan' for more detail. |
| 49 | ;; http://www.webcom.com/haahr/dylan/linearization-oopsla96.html |
| 50 | |
| 51 | ;;; Utilities. |
| 52 | |
| 53 | (export 'report-class-list-merge-error) |
| 54 | (defun report-class-list-merge-error (class lists error) |
| 55 | "Report a failure to merge superclasseses. |
| 56 | |
| 57 | Here, CLASS is the class whose class precedence list we're trying to |
| 58 | compute; the LISTS are the individual superclass orderings being merged; |
| 59 | and ERROR is an `inconsistent-merge-error' describing the problem that was |
| 60 | encountered. |
| 61 | |
| 62 | Each of the LISTS is assumed to begin with the class from which the |
| 63 | corresponding constraint originates; see `merge-class-lists'." |
| 64 | |
| 65 | (let* ((state (make-inheritance-path-reporter-state class)) |
| 66 | (candidates (merge-error-candidates error)) |
| 67 | (focus (remove-duplicates |
| 68 | (remove nil |
| 69 | (mapcar (lambda (list) |
| 70 | (cons (car list) |
| 71 | (remove-if-not |
| 72 | (lambda (item) |
| 73 | (member item candidates)) |
| 74 | list))) |
| 75 | lists) |
| 76 | :key #'cddr) |
| 77 | :test #'equal :key #'cdr))) |
| 78 | |
| 79 | (cerror*-with-location class "Ill-formed superclass graph: ~ |
| 80 | can't construct class precedence list ~ |
| 81 | for `~A'" |
| 82 | class) |
| 83 | (dolist (offenders focus) |
| 84 | (let ((super (car offenders))) |
| 85 | (info-with-location super |
| 86 | "~{Class `~A' orders `~A' before ~ |
| 87 | ~#[<BUG>~;`~A'~;`~A' and `~A'~:;~ |
| 88 | ~@{`~A', ~#[~;and `~A'~]~}~]~}" |
| 89 | offenders) |
| 90 | (report-inheritance-path state super))))) |
| 91 | |
| 92 | (export 'merge-class-lists) |
| 93 | (defun merge-class-lists (class lists pick) |
| 94 | "Merge the LISTS of superclasses of CLASS, using PICK to break ties. |
| 95 | |
| 96 | This is a convenience wrapper around the main `merge-lists' function. |
| 97 | Given that class linearizations (almost?) always specify a custom |
| 98 | tiebreaker function, this isn't a keyword argument. |
| 99 | |
| 100 | If a merge error occurs, this function translates it into a rather more |
| 101 | useful form, and tries to provide helpful notes. |
| 102 | |
| 103 | For error reporting purposes, it's assumed that each of the LISTS begins |
| 104 | with the class from which the corresponding constraint originates. This |
| 105 | initial class does double-duty: it is also considered to be part of the |
| 106 | list for the purpose of the merge." |
| 107 | |
| 108 | (handler-case (merge-lists lists :pick pick) |
| 109 | (inconsistent-merge-error (error) |
| 110 | (report-class-list-merge-error class lists error) |
| 111 | (continue error)))) |
| 112 | |
| 113 | ;;; Tiebreaker functions. |
| 114 | |
| 115 | (defun clos-tiebreaker (candidates so-far) |
| 116 | "The CLOS linearization tiebreaker function. |
| 117 | |
| 118 | Intended for use with `merge-lists'. Returns the member of CANDIDATES |
| 119 | which has a direct subclass furthest to the right in the list SO-FAR. |
| 120 | |
| 121 | This must disambiguate. The SO-FAR list cannot be empty, since the class |
| 122 | under construction precedes all of the others. If two classes share a |
| 123 | direct subclass then that subclass's direct superclasses list must order |
| 124 | them relative to each other." |
| 125 | |
| 126 | (dolist (class (reverse so-far)) |
| 127 | (dolist (candidate candidates) |
| 128 | (when (member candidate (sod-class-direct-superclasses class)) |
| 129 | (return-from clos-tiebreaker candidate)))) |
| 130 | (error "SOD INTERNAL ERROR: Failed to break tie in CLOS")) |
| 131 | |
| 132 | (defun c3-tiebreaker (candidates cpls) |
| 133 | "The C3 linearization tiebreaker function. |
| 134 | |
| 135 | Intended for use with `merge-lists'. Returns the member of CANDIDATES |
| 136 | which appears in the earliest element of CPLS, which should be the list of |
| 137 | the class precedence lists of the direct superclasses of the class in |
| 138 | question, in the order specified in the class declaration. |
| 139 | |
| 140 | The only class in the class precedence list which does not appear in one |
| 141 | of these lists is the new class itself, which must precede all of the |
| 142 | others. |
| 143 | |
| 144 | This must disambiguate, since if two classes are in the same class |
| 145 | precedence list, then one must appear in it before the other, which |
| 146 | provides an ordering between them. (In this situation we return the one |
| 147 | that matches earliest anyway, which would still give the right answer.) |
| 148 | |
| 149 | Note that this will merge the CPLs of superclasses /as they are/, not |
| 150 | necessarily as C3 would have computed them. This ensures monotonicity |
| 151 | assuming that the superclass CPLs are already monotonic. If they aren't, |
| 152 | you're going to lose anyway." |
| 153 | |
| 154 | (dolist (cpl cpls) |
| 155 | (dolist (candidate candidates) |
| 156 | (when (member candidate cpl) |
| 157 | (return-from c3-tiebreaker candidate)))) |
| 158 | (error "SOD INTERNAL ERROR: Failed to break tie in C3")) |
| 159 | |
| 160 | ;;; Linearization functions. |
| 161 | |
| 162 | (export 'clos-cpl) |
| 163 | (defun clos-cpl (class) |
| 164 | "Compute the class precedence list of CLASS using CLOS linearization rules. |
| 165 | |
| 166 | We merge the direct-superclass lists of all of CLASS's superclasses, |
| 167 | disambiguating using `clos-tiebreaker'. |
| 168 | |
| 169 | The CLOS linearization preserves local class ordering, but is not |
| 170 | monotonic, and does not respect the extended precedence graph. CLOS |
| 171 | linearization will succeed whenever Dylan or C3 linearization succeeds; |
| 172 | the converse is not true." |
| 173 | |
| 174 | (labels ((superclasses (class) |
| 175 | (let ((direct-supers (sod-class-direct-superclasses class))) |
| 176 | (remove-duplicates (cons class |
| 177 | (mappend #'superclasses |
| 178 | direct-supers)))))) |
| 179 | (merge-class-lists class |
| 180 | (mapcar (lambda (c) |
| 181 | (cons c (sod-class-direct-superclasses c))) |
| 182 | (superclasses class)) |
| 183 | #'clos-tiebreaker))) |
| 184 | |
| 185 | (export 'dylan-cpl) |
| 186 | (defun dylan-cpl (class) |
| 187 | "Compute the class precedence list of CLASS using Dylan linearization |
| 188 | rules. |
| 189 | |
| 190 | We merge the direct-superclass list of CLASS with the full class |
| 191 | precedence lists of its direct superclasses, disambiguating using |
| 192 | `clos-tiebreaker'. (Inductively, these lists will be consistent with the |
| 193 | CPLs of indirect superclasses, since those CPLs' orderings are reflected |
| 194 | in the CPLs of the direct superclasses.) |
| 195 | |
| 196 | The Dylan linearization preserves local class ordering and is monotonic, |
| 197 | but does not respect the extended precedence graph. |
| 198 | |
| 199 | Note that this will merge the CPLs of superclasses /as they are/, not |
| 200 | necessarily as Dylan would have computed them. This ensures monotonicity |
| 201 | assuming that the superclass CPLs are already monotonic. If they aren't, |
| 202 | you're going to lose anyway." |
| 203 | |
| 204 | (let* ((direct-supers (sod-class-direct-superclasses class)) |
| 205 | (cpls (mapcar #'sod-class-precedence-list direct-supers))) |
| 206 | (merge-class-lists class |
| 207 | (cons (cons class direct-supers) cpls) |
| 208 | #'clos-tiebreaker))) |
| 209 | |
| 210 | (export 'c3-cpl) |
| 211 | (defun c3-cpl (class) |
| 212 | "Compute the class precedence list of CLASS using C3 linearization rules. |
| 213 | |
| 214 | We merge the direct-superclass list of CLASS with the full class |
| 215 | precedence lists of its direct superclasses, disambiguating using |
| 216 | `c3-tiebreaker'. |
| 217 | |
| 218 | The C3 linearization preserves local class ordering, is monotonic, and |
| 219 | respects the extended precedence graph. It is the linearization used in |
| 220 | Python, Perl 6 and other languages. It is the recommended linearization |
| 221 | for SOD." |
| 222 | |
| 223 | (let* ((direct-supers (sod-class-direct-superclasses class)) |
| 224 | (cpls (mapcar #'sod-class-precedence-list direct-supers))) |
| 225 | (merge-class-lists class |
| 226 | (cons (cons class direct-supers) cpls) |
| 227 | (lambda (candidates so-far) |
| 228 | (declare (ignore so-far)) |
| 229 | (c3-tiebreaker candidates cpls))))) |
| 230 | |
| 231 | (export 'flavors-cpl) |
| 232 | (defun flavors-cpl (class) |
| 233 | "Compute the class precedence list of CLASS using Flavors linearization |
| 234 | rules. |
| 235 | |
| 236 | We do a depth-first traversal of the superclass graph, ignoring duplicates |
| 237 | of classes we've already visited. Interestingly, this has the property of |
| 238 | being able to tolerate cyclic superclass graphs, though defining cyclic |
| 239 | graphs is syntactically impossible in SOD. |
| 240 | |
| 241 | This linearization has few other redeeming features, however. In |
| 242 | particular, the top class tends not to be at the end of the CPL, despite |
| 243 | it being unequivocally less specific than any other class." |
| 244 | |
| 245 | (let ((done nil)) |
| 246 | (labels ((walk (class) |
| 247 | (unless (member class done) |
| 248 | (push class done) |
| 249 | (dolist (super (sod-class-direct-superclasses class)) |
| 250 | (walk super))))) |
| 251 | (walk class) |
| 252 | (nreverse done)))) |
| 253 | |
| 254 | (export 'python-cpl) |
| 255 | (defun python-cpl (class) |
| 256 | "Compute the class precedence list of CLASS using the documented Python 2.2 |
| 257 | linearization rules. |
| 258 | |
| 259 | We do a depth-first traversal of the superclass graph, retaining only the |
| 260 | last occurrence of each class visited. |
| 261 | |
| 262 | This linearization has few redeeming features. It was never actually |
| 263 | implemented; the true Python 2.2 linearization seems closer to (but |
| 264 | different from) L*LOOPS." |
| 265 | |
| 266 | (let ((done nil)) |
| 267 | (labels ((walk (class) |
| 268 | (push class done) |
| 269 | (dolist (super (sod-class-direct-superclasses class)) |
| 270 | (walk super)))) |
| 271 | (walk class) |
| 272 | (delete-duplicates (nreverse done))))) |
| 273 | |
| 274 | (export 'l*loops-cpl) |
| 275 | (defun l*loops-cpl (class) |
| 276 | "Compute the class precedence list of CLASS using L*LOOPS linearization |
| 277 | rules. |
| 278 | |
| 279 | We merge the class precedence lists of the direct superclasses of CLASS, |
| 280 | disambiguating by choosing the earliest candidate which appears in a |
| 281 | depth-first walk of the superclass graph. |
| 282 | |
| 283 | The L*LOOPS rules are monotonic and respect the extended precedence |
| 284 | graph. However (unlike Dylan and CLOS) they don't respect local |
| 285 | precedence order i.e., the direct-superclasses list orderings." |
| 286 | |
| 287 | (let ((dfs (flavors-cpl class))) |
| 288 | (cons class |
| 289 | (merge-class-lists class |
| 290 | (mapcar #'sod-class-precedence-list |
| 291 | (sod-class-direct-superclasses class)) |
| 292 | (lambda (candidates so-far) |
| 293 | (declare (ignore so-far)) |
| 294 | (dolist (class dfs) |
| 295 | (when (member class candidates) |
| 296 | (return class)))))))) |
| 297 | |
| 298 | ;;; Default function. |
| 299 | |
| 300 | (defmethod compute-cpl ((class sod-class)) |
| 301 | (c3-cpl class)) |
| 302 | |
| 303 | ;;;-------------------------------------------------------------------------- |
| 304 | ;;; Chains. |
| 305 | |
| 306 | (defmethod compute-chains ((class sod-class)) |
| 307 | (with-default-error-location (class) |
| 308 | (with-slots (chain-link class-precedence-list) class |
| 309 | (let* ((head (if chain-link |
| 310 | (sod-class-chain-head chain-link) |
| 311 | class)) |
| 312 | (chain (cons class (and chain-link |
| 313 | (sod-class-chain chain-link)))) |
| 314 | (state (make-inheritance-path-reporter-state class)) |
| 315 | (table (make-hash-table))) |
| 316 | |
| 317 | ;; Check the chains. We work through each superclass, maintaining a |
| 318 | ;; hash table keyed by class. If we encounter a class C which links |
| 319 | ;; to L, then we store C as L's value; if L already has a value then |
| 320 | ;; we've found an error. By the end of all of this, the classes |
| 321 | ;; which don't have an entry are the chain tails. |
| 322 | (dolist (super class-precedence-list) |
| 323 | (let* ((link (sod-class-chain-link super)) |
| 324 | (found (and link (gethash link table)))) |
| 325 | (cond ((not found) (setf (gethash link table) super)) |
| 326 | (t |
| 327 | (cerror* "Conflicting chains in class `~A': ~ |
| 328 | (`~A' and `~A' both link to `~A')" |
| 329 | class super found link) |
| 330 | (report-inheritance-path state super) |
| 331 | (report-inheritance-path state found))))) |
| 332 | |
| 333 | ;; Done. |
| 334 | (values head chain |
| 335 | (cons chain |
| 336 | (mapcar #'sod-class-chain |
| 337 | (remove-if (lambda (super) |
| 338 | (gethash super table)) |
| 339 | (cdr class-precedence-list))))))))) |
| 340 | |
| 341 | ;;;-------------------------------------------------------------------------- |
| 342 | ;;; Sanity checking. |
| 343 | |
| 344 | (defmethod check-class-initializer ((slot effective-slot) (class sod-class)) |
| 345 | (finalization-error (:missing-class-initializer) |
| 346 | (unless (find-class-initializer slot class) |
| 347 | (let ((dslot (effective-slot-direct-slot slot))) |
| 348 | (cerror* "Missing initializer for class slot `~A', ~ |
| 349 | defined by meta-superclass `~A' of `~A'" |
| 350 | dslot (sod-slot-class dslot) class))))) |
| 351 | |
| 352 | (defmethod check-class-initializer |
| 353 | ((slot sod-class-effective-slot) (class sod-class)) |
| 354 | ;; The programmer shouldn't set an explicit initializer here. |
| 355 | (finalization-error (:invalid-class-initializer) |
| 356 | (let ((init (find-class-initializer slot class)) |
| 357 | (dslot (effective-slot-direct-slot slot))) |
| 358 | (when init |
| 359 | (cerror* "Initializers not permitted for class slot `~A', ~ |
| 360 | defined by meta-superclass `~A' of `~A'" |
| 361 | dslot (sod-slot-class dslot) class) |
| 362 | (info-with-location init "Offending initializer defined here"))))) |
| 363 | |
| 364 | (defmethod check-sod-class ((class sod-class)) |
| 365 | |
| 366 | ;; Check the names of things are valid. |
| 367 | (flet ((check-list (list what namefunc) |
| 368 | (dolist (item list) |
| 369 | (let ((name (funcall namefunc item))) |
| 370 | (unless (valid-name-p name) |
| 371 | (cerror*-with-location item |
| 372 | "Invalid ~A name `~A' in class `~A'" |
| 373 | what name class)))))) |
| 374 | (unless (valid-name-p (sod-class-name class)) |
| 375 | (cerror* "Invalid class name `~A'" class)) |
| 376 | (unless (valid-name-p (sod-class-nickname class)) |
| 377 | (cerror* "Invalid class nickname `~A' for class `~A'" |
| 378 | (sod-class-nickname class) class)) |
| 379 | (check-list (sod-class-messages class) "message" #'sod-message-name) |
| 380 | (check-list (sod-class-slots class) "slot" #'sod-slot-name)) |
| 381 | |
| 382 | ;; Check that the class doesn't define conflicting things. |
| 383 | (labels ((simple-previous (previous) |
| 384 | (info-with-location previous "Previous definition was here")) |
| 385 | (simple-complain (what namefunc) |
| 386 | (lambda (item previous) |
| 387 | (cerror*-with-location item |
| 388 | "Duplicate ~A `~A' in class `~A'" |
| 389 | what (funcall namefunc item) class) |
| 390 | (simple-previous previous)))) |
| 391 | |
| 392 | ;; Make sure direct slots have distinct names. |
| 393 | (find-duplicates (simple-complain "slot name" #'sod-slot-name) |
| 394 | (sod-class-slots class) |
| 395 | :key #'sod-slot-name |
| 396 | :test #'equal) |
| 397 | |
| 398 | ;; Make sure there's at most one initializer for each slot. |
| 399 | (flet ((check-initializer-list (list kind) |
| 400 | (find-duplicates (lambda (initializer previous) |
| 401 | (let ((slot |
| 402 | (sod-initializer-slot initializer))) |
| 403 | (cerror*-with-location initializer |
| 404 | "Duplicate ~ |
| 405 | initializer ~ |
| 406 | for ~A slot `~A' ~ |
| 407 | in class `~A'" |
| 408 | kind slot class) |
| 409 | (simple-previous previous))) |
| 410 | list |
| 411 | :key #'sod-initializer-slot))) |
| 412 | (check-initializer-list (sod-class-instance-initializers class) |
| 413 | "instance") |
| 414 | (check-initializer-list (sod-class-class-initializers class) |
| 415 | "class")) |
| 416 | |
| 417 | ;; Make sure messages have distinct names. |
| 418 | (find-duplicates (simple-complain "message name" #'sod-message-name) |
| 419 | (sod-class-messages class) |
| 420 | :key #'sod-message-name |
| 421 | :test #'equal) |
| 422 | |
| 423 | ;; Make sure methods are sufficiently distinct. |
| 424 | (find-duplicates (lambda (method previous) |
| 425 | (cerror*-with-location method |
| 426 | "Duplicate ~A direct method ~ |
| 427 | for message `~A' ~ |
| 428 | in classs `~A'" |
| 429 | (sod-method-description method) |
| 430 | (sod-method-message method) |
| 431 | class) |
| 432 | (simple-previous previous)) |
| 433 | (sod-class-methods class) |
| 434 | :key #'sod-method-function-name |
| 435 | :test #'equal) |
| 436 | |
| 437 | ;; Make sure superclasses have distinct nicknames. |
| 438 | (let ((state (make-inheritance-path-reporter-state class))) |
| 439 | (find-duplicates (lambda (super previous) |
| 440 | (cerror*-with-location class |
| 441 | "Duplicate nickname `~A' ~ |
| 442 | in superclasses of `~A': ~ |
| 443 | used by `~A' and `~A'" |
| 444 | (sod-class-nickname super) |
| 445 | class super previous) |
| 446 | (report-inheritance-path state super) |
| 447 | (report-inheritance-path state previous)) |
| 448 | (sod-class-precedence-list class) |
| 449 | :key #'sod-class-nickname :test #'equal))) |
| 450 | |
| 451 | ;; Check that the CHAIN-TO class is actually a proper superclass. (This |
| 452 | ;; eliminates hairy things like a class being its own link.) |
| 453 | (let ((link (sod-class-chain-link class))) |
| 454 | (unless (or (not link) |
| 455 | (member link (cdr (sod-class-precedence-list class)))) |
| 456 | (cerror* "In `~A', chain-to class `~A' is not a proper superclass" |
| 457 | class link))) |
| 458 | |
| 459 | ;; Check that the initargs declare compatible types. Duplicate entries, |
| 460 | ;; even within a class, are harmless, but at most one initarg in any |
| 461 | ;; class should declare a default value. |
| 462 | (let ((seen (make-hash-table :test #'equal)) |
| 463 | (state (make-inheritance-path-reporter-state class))) |
| 464 | (dolist (super (sod-class-precedence-list class)) |
| 465 | (dolist (initarg (reverse (sod-class-initargs super))) |
| 466 | (let* ((initarg-name (sod-initarg-name initarg)) |
| 467 | (initarg-type (sod-initarg-type initarg)) |
| 468 | (initarg-default (sod-initarg-default initarg)) |
| 469 | (found (gethash initarg-name seen)) |
| 470 | (found-type (and found (sod-initarg-type found))) |
| 471 | (found-default (and found (sod-initarg-default found))) |
| 472 | (found-class (and found (sod-initarg-class found))) |
| 473 | (found-location (and found (file-location found)))) |
| 474 | (with-default-error-location (initarg) |
| 475 | (cond ((not found) |
| 476 | (setf (gethash initarg-name seen) initarg)) |
| 477 | ((not (c-type-equal-p initarg-type found-type)) |
| 478 | (cerror* "Inititalization argument `~A' defined ~ |
| 479 | with incompatible types: ~ |
| 480 | ~A in class `~A', but ~A in class `~A'" |
| 481 | initarg-name initarg-type super |
| 482 | found-type found-class found-location) |
| 483 | (report-inheritance-path state super)) |
| 484 | ((and initarg-default found-default |
| 485 | (eql super found-class)) |
| 486 | (cerror* "Initialization argument `~A' redefined ~ |
| 487 | with default value" |
| 488 | initarg-name) |
| 489 | (info-with-location found-location |
| 490 | "Previous definition is here")) |
| 491 | (initarg-default |
| 492 | (setf (gethash initarg-name seen) initarg)))))))) |
| 493 | |
| 494 | ;; Check for circularity in the superclass graph. Since the superclasses |
| 495 | ;; should already be acyclic, it suffices to check that our class is not |
| 496 | ;; a superclass of any of its own direct superclasses. |
| 497 | (let ((circle (find-if (lambda (super) |
| 498 | (sod-subclass-p super class)) |
| 499 | (sod-class-direct-superclasses class)))) |
| 500 | (when circle |
| 501 | (cerror* "`~A' is already a superclass of `~A'" class circle) |
| 502 | (report-inheritance-path (make-inheritance-path-reporter-state class) |
| 503 | circle))) |
| 504 | |
| 505 | ;; Check that the class has a unique root superclass. |
| 506 | (find-root-superclass class) |
| 507 | |
| 508 | ;; Check that the metaclass is a subclass of each direct superclass's |
| 509 | ;; metaclass. |
| 510 | (finalization-error (:bad-metaclass) |
| 511 | (let ((meta (sod-class-metaclass class))) |
| 512 | (dolist (super (sod-class-direct-superclasses class)) |
| 513 | (let ((supermeta (sod-class-metaclass super))) |
| 514 | (unless (sod-subclass-p meta supermeta) |
| 515 | (cerror* "Metaclass `~A' of `~A' isn't a subclass of `~A'" |
| 516 | meta class supermeta) |
| 517 | (info-with-location super |
| 518 | "Direct superclass `~A' defined here ~ |
| 519 | has metaclass `~A'" |
| 520 | super supermeta)))))) |
| 521 | |
| 522 | ;; Check that all of the messages we can be sent have coherent collections |
| 523 | ;; of applicable methods. This can go wrong, for example, if we inherit |
| 524 | ;; methods with differently typed keyword arguments. |
| 525 | (finalization-error (:mismatched-applicable-methods) |
| 526 | (dolist (super (sod-class-precedence-list class)) |
| 527 | (dolist (message (sod-class-messages super)) |
| 528 | (let ((methods (sod-message-applicable-methods message class))) |
| 529 | (sod-message-check-methods message class methods))))) |
| 530 | |
| 531 | ;; Check that an initializer is available for every slot in the class's |
| 532 | ;; metaclass. Skip this and trust the caller if the metaclass isn't |
| 533 | ;; finalized yet: in that case, we must be bootstrapping, and we must hope |
| 534 | ;; that the caller knows what they're doing. |
| 535 | (let* ((meta (sod-class-metaclass class)) |
| 536 | (ilayout (and (eq (sod-class-state meta) :finalized) |
| 537 | (sod-class-ilayout meta)))) |
| 538 | (dolist (ichain (and ilayout (ilayout-ichains ilayout))) |
| 539 | (dolist (item (cdr (ichain-body ichain))) |
| 540 | (when (typep item 'islots) |
| 541 | (dolist (slot (islots-slots item)) |
| 542 | (check-class-initializer slot class))))))) |
| 543 | |
| 544 | ;;;-------------------------------------------------------------------------- |
| 545 | ;;; Finalization. |
| 546 | |
| 547 | (defmethod finalize-sod-class :around ((class sod-class)) |
| 548 | "Common functionality for `finalize-sod-class'. |
| 549 | |
| 550 | * If an attempt to finalize the CLASS has been made before, then we |
| 551 | don't try again. Similarly, attempts to finalize a class recursively |
| 552 | will fail. |
| 553 | |
| 554 | * A condition handler is established to keep track of whether any errors |
| 555 | are signalled during finalization. The CLASS is only marked as |
| 556 | successfully finalized if no (unhandled) errors are encountered." |
| 557 | (with-default-error-location (class) |
| 558 | (ecase (sod-class-state class) |
| 559 | ((nil) |
| 560 | |
| 561 | ;; If this fails, leave the class marked as a loss. |
| 562 | (setf (slot-value class 'state) :broken) |
| 563 | |
| 564 | ;; Invoke the finalization method proper. If it signals any |
| 565 | ;; continuable errors, take note of them so that we can report failure |
| 566 | ;; properly. |
| 567 | ;; |
| 568 | ;; Catch: we get called recursively to clean up superclasses and |
| 569 | ;; metaclasses, but there should only be one such handler, so don't |
| 570 | ;; add another. (In turn, this means that other methods mustn't |
| 571 | ;; actually trap their significant errors.) |
| 572 | (let ((have-handler-p (boundp '*finalization-errors*)) |
| 573 | (*finalization-errors* nil) |
| 574 | (*finalization-error-token* nil)) |
| 575 | (catch '%finalization-failed |
| 576 | (if have-handler-p (call-next-method) |
| 577 | (handler-bind ((error (lambda (cond) |
| 578 | (declare (ignore cond)) |
| 579 | (pushnew *finalization-error-token* |
| 580 | *finalization-errors* |
| 581 | :test #'equal) |
| 582 | :decline))) |
| 583 | (call-next-method))) |
| 584 | (when *finalization-errors* (finalization-failed)) |
| 585 | (setf (slot-value class 'state) :finalized) |
| 586 | t))) |
| 587 | |
| 588 | ;; If the class is broken, we're not going to be able to fix it now. |
| 589 | (:broken |
| 590 | nil) |
| 591 | |
| 592 | ;; If we already finalized it, there's no point doing it again. |
| 593 | (:finalized |
| 594 | t)))) |
| 595 | |
| 596 | (defmethod finalize-sod-class ((class sod-class)) |
| 597 | |
| 598 | ;; CLONE-AND-HACK WARNING: Note that `bootstrap-classes' has a (very brief) |
| 599 | ;; clone of the CPL and chain establishment code. If the interface changes |
| 600 | ;; then `bootstrap-classes' will need to be changed too. |
| 601 | |
| 602 | ;; Finalize all of the superclasses. There's some special pleading here to |
| 603 | ;; make bootstrapping work: we don't try to finalize the metaclass if we're |
| 604 | ;; a root class (no direct superclasses -- because in that case the |
| 605 | ;; metaclass will have to be a subclass of us!), or if it's equal to us. |
| 606 | ;; This is enough to tie the knot at the top of the class graph. If we |
| 607 | ;; can't manage this then we're doomed. |
| 608 | (flet ((try-finalizing (what other-class) |
| 609 | (unless (finalize-sod-class other-class) |
| 610 | (cerror* "Class `~A' has broken ~A `~A'" class what other-class) |
| 611 | (info-with-location other-class |
| 612 | "Class `~A' defined here" other-class) |
| 613 | (finalization-failed)))) |
| 614 | (let ((supers (sod-class-direct-superclasses class)) |
| 615 | (meta (sod-class-metaclass class))) |
| 616 | (dolist (super supers) |
| 617 | (try-finalizing "direct superclass" super)) |
| 618 | (unless (or (null supers) (eq class meta)) |
| 619 | (try-finalizing "metaclass" meta)))) |
| 620 | |
| 621 | ;; Stash the class's type. |
| 622 | (setf (slot-value class '%type) |
| 623 | (make-class-type (sod-class-name class))) |
| 624 | |
| 625 | ;; Clobber the lists of items if they've not been set. |
| 626 | (dolist (slot '(slots instance-initializers class-initializers |
| 627 | messages methods)) |
| 628 | (unless (slot-boundp class slot) |
| 629 | (setf (slot-value class slot) nil))) |
| 630 | |
| 631 | ;; If the CPL hasn't been done yet, compute it. If we can't manage this |
| 632 | ;; then there's no hope at all. |
| 633 | (unless (slot-boundp class 'class-precedence-list) |
| 634 | (restart-case |
| 635 | (setf (slot-value class 'class-precedence-list) (compute-cpl class)) |
| 636 | (continue () :report "Continue" |
| 637 | (finalization-failed)))) |
| 638 | |
| 639 | ;; Check that the class is fairly sane. |
| 640 | (check-sod-class class) |
| 641 | |
| 642 | ;; Determine the class's layout. |
| 643 | (setf (values (slot-value class 'chain-head) |
| 644 | (slot-value class 'chain) |
| 645 | (slot-value class 'chains)) |
| 646 | (compute-chains class))) |
| 647 | |
| 648 | ;;;----- That's all, folks -------------------------------------------------- |