| 1 | ;;; -*-lisp-*- |
| 2 | ;;; |
| 3 | ;;; Class finalization |
| 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 | ;;; Class finalization. |
| 30 | |
| 31 | ;; Protocol. |
| 32 | |
| 33 | (defgeneric compute-chains (class) |
| 34 | (:documentation |
| 35 | "Compute the layout chains for CLASS. |
| 36 | |
| 37 | Returns the following three values. |
| 38 | |
| 39 | * the head of the class's primary chain; |
| 40 | |
| 41 | * the class's primary chain as a list, most- to least-specific; and |
| 42 | |
| 43 | * the complete collection of chains, as a list of lists, each most- to |
| 44 | least-specific, with the primary chain first. |
| 45 | |
| 46 | These values will be stored in the CHAIN-HEAD, CHAIN and CHAINS slots. |
| 47 | |
| 48 | If the chains are ill-formed (i.e., not distinct) then an error is |
| 49 | signalled.")) |
| 50 | |
| 51 | (defgeneric check-sod-class (class) |
| 52 | (:documentation |
| 53 | "Check the CLASS for validity. |
| 54 | |
| 55 | This is done as part of class finalization. The checks performed are as |
| 56 | follows. |
| 57 | |
| 58 | * The class name and nickname, and the names of messages, obey the |
| 59 | rules (see VALID-NAME-P). |
| 60 | |
| 61 | * The messages and slots have distinct names. |
| 62 | |
| 63 | * The classes in the class-precedence-list have distinct nicknames. |
| 64 | |
| 65 | * The chain-link is actually a proper (though not necessarily direct) |
| 66 | superclass. |
| 67 | |
| 68 | * The chosen metaclass is actually a subclass of all of the |
| 69 | superclasses' metaclasses. |
| 70 | |
| 71 | Returns true if all is well; false (and signals errors) if anything was |
| 72 | wrong.")) |
| 73 | |
| 74 | (defgeneric finalize-sod-class (class) |
| 75 | (:documentation |
| 76 | "Computes all of the gory details about a class. |
| 77 | |
| 78 | Once one has stopped inserting methods and slots and so on into a class, |
| 79 | one needs to finalize it to determine the layout structure and the class |
| 80 | precedence list and so on. More precisely that gets done is this: |
| 81 | |
| 82 | * Related classes (i.e., direct superclasses and the metaclass) are |
| 83 | finalized if they haven't been already. |
| 84 | |
| 85 | * If you've been naughty and failed to store a list of slots or |
| 86 | whatever, then an empty list is inserted. |
| 87 | |
| 88 | * The class precedence list is computed and stored. |
| 89 | |
| 90 | * The class is checked for compiance with the well-formedness rules. |
| 91 | |
| 92 | * The layout chains are computed. |
| 93 | |
| 94 | Other stuff will need to happen later, but it's not been done yet. In |
| 95 | particular: |
| 96 | |
| 97 | * Actually computing the layout of the instance and the virtual tables. |
| 98 | |
| 99 | * Combining the applicable methods into effective methods. |
| 100 | |
| 101 | FIXME this needs doing.")) |
| 102 | |
| 103 | ;; Implementation. |
| 104 | |
| 105 | (defun sod-subclass-p (class-a class-b) |
| 106 | "Return whether CLASS-A is a descendent of CLASS-B." |
| 107 | (member class-b (sod-class-precedence-list class-a))) |
| 108 | |
| 109 | (defun valid-name-p (name) |
| 110 | "Checks whether NAME is a valid name. |
| 111 | |
| 112 | The rules are: |
| 113 | |
| 114 | * the name must be a string |
| 115 | * which is nonempty |
| 116 | * whose first character is alphabetic |
| 117 | * all of whose characters are alphanumeric or underscores |
| 118 | * and which doesn't contain two consecutive underscores." |
| 119 | |
| 120 | (and (stringp name) |
| 121 | (plusp (length name)) |
| 122 | (alpha-char-p (char name 0)) |
| 123 | (every (lambda (ch) (or (alphanumericp ch) (char= ch #\_))) name) |
| 124 | (not (search "__" name)))) |
| 125 | |
| 126 | (defmethod compute-chains ((class sod-class)) |
| 127 | (with-default-error-location (class) |
| 128 | (with-slots (chain-link class-precedence-list) class |
| 129 | (let* ((head (if chain-link |
| 130 | (sod-class-chain-head chain-link) |
| 131 | class)) |
| 132 | (chain (cons class (and chain-link |
| 133 | (sod-class-chain chain-link)))) |
| 134 | (table (make-hash-table))) |
| 135 | |
| 136 | ;; Check the chains. We work through each superclass, maintaining a |
| 137 | ;; hash table keyed by class. If we encounter a class C which links |
| 138 | ;; to L, then we store C as L's value; if L already has a value then |
| 139 | ;; we've found an error. By the end of all of this, the classes |
| 140 | ;; which don't have an entry are the chain tails. |
| 141 | (dolist (super class-precedence-list) |
| 142 | (let ((link (sod-class-chain-link super))) |
| 143 | (when link |
| 144 | (when (gethash link table) |
| 145 | (error "Conflicting chains in class ~A: ~ |
| 146 | (~A and ~A both link to ~A)" |
| 147 | class super (gethash link table) link)) |
| 148 | (setf (gethash link table) super)))) |
| 149 | |
| 150 | ;; Done. |
| 151 | (values head chain |
| 152 | (cons chain |
| 153 | (mapcar #'sod-class-chain |
| 154 | (remove-if (lambda (super) |
| 155 | (gethash super table)) |
| 156 | (cdr class-precedence-list))))))))) |
| 157 | |
| 158 | (defmethod check-sod-class ((class sod-class)) |
| 159 | (with-default-error-location (class) |
| 160 | |
| 161 | ;; Check the names of things are valid. |
| 162 | (with-slots (name nickname messages) class |
| 163 | (unless (valid-name-p name) |
| 164 | (error "Invalid class name `~A'" class)) |
| 165 | (unless (valid-name-p nickname) |
| 166 | (error "Invalid class nickname `~A' on class `~A'" nickname class)) |
| 167 | (dolist (message messages) |
| 168 | (unless (valid-name-p (sod-message-name message)) |
| 169 | (error "Invalid message name `~A' on class `~A'" |
| 170 | (sod-message-name message) class)))) |
| 171 | |
| 172 | ;; Check that the slots and messages have distinct names. |
| 173 | (with-slots (slots messages class-precedence-list) class |
| 174 | (flet ((check-list (list what namefunc) |
| 175 | (let ((table (make-hash-table :test #'equal))) |
| 176 | (dolist (item list) |
| 177 | (let ((name (funcall namefunc item))) |
| 178 | (if (gethash name table) |
| 179 | (error "Duplicate ~A name `~A' on class `~A'" |
| 180 | what name class) |
| 181 | (setf (gethash name table) item))))))) |
| 182 | (check-list slots "slot" #'sod-slot-name) |
| 183 | (check-list messages "message" #'sod-message-name) |
| 184 | (check-list class-precedence-list "nickname" #'sod-class-name))) |
| 185 | |
| 186 | ;; Check that the CHAIN-TO class is actually a proper superclass. (This |
| 187 | ;; eliminates hairy things like a class being its own link.) |
| 188 | (with-slots (class-precedence-list chain-link) class |
| 189 | (unless (or (not chain-link) |
| 190 | (member chain-link (cdr class-precedence-list))) |
| 191 | (error "In `~A~, chain-to class `~A' is not a proper superclass" |
| 192 | class chain-link))) |
| 193 | |
| 194 | ;; Check for circularity in the superclass graph. Since the superclasses |
| 195 | ;; should already be acyclic, it suffices to check that our class is not |
| 196 | ;; a superclass of any of its own direct superclasses. |
| 197 | (let ((circle (find-if (lambda (super) |
| 198 | (sod-subclass-p super class)) |
| 199 | (sod-class-direct-superclasses class)))) |
| 200 | (when circle |
| 201 | (error "Circularity: ~A is already a superclass of ~A" |
| 202 | class circle))) |
| 203 | |
| 204 | ;; Check that the class has a unique root superclass. |
| 205 | (find-root-superclass class) |
| 206 | |
| 207 | ;; Check that the metaclass is a subclass of each direct superclass's |
| 208 | ;; metaclass. |
| 209 | (with-slots (metaclass direct-superclasses) class |
| 210 | (dolist (super direct-superclasses) |
| 211 | (unless (sod-subclass-p metaclass (sod-class-metaclass super)) |
| 212 | (error "Incompatible metaclass for `~A': ~ |
| 213 | `~A' isn't a subclass of `~A' (of `~A')" |
| 214 | class metaclass (sod-class-metaclass super) super)))))) |
| 215 | |
| 216 | (defmethod finalize-sod-class ((class sod-class)) |
| 217 | |
| 218 | ;; CLONE-AND-HACK WARNING: Note that BOOTSTRAP-CLASSES has a (very brief) |
| 219 | ;; clone of the CPL and chain establishment code. If the interface changes |
| 220 | ;; then BOOTSTRAP-CLASSES will need to be changed too. |
| 221 | |
| 222 | (with-default-error-location (class) |
| 223 | (ecase (sod-class-state class) |
| 224 | ((nil) |
| 225 | |
| 226 | ;; If this fails, mark the class as a loss. |
| 227 | (setf (sod-class-state class) :broken) |
| 228 | |
| 229 | ;; Finalize all of the superclasses. There's some special pleading |
| 230 | ;; here to make bootstrapping work: we don't try to finalize the |
| 231 | ;; metaclass if we're a root class (no direct superclasses -- because |
| 232 | ;; in that case the metaclass will have to be a subclass of us!), or |
| 233 | ;; if it's equal to us. This is enough to tie the knot at the top of |
| 234 | ;; the class graph. |
| 235 | (with-slots (name direct-superclasses metaclass) class |
| 236 | (dolist (super direct-superclasses) |
| 237 | (finalize-sod-class super)) |
| 238 | (unless (or (null direct-superclasses) |
| 239 | (eq class metaclass)) |
| 240 | (finalize-sod-class metaclass))) |
| 241 | |
| 242 | ;; Stash the class's type. |
| 243 | (setf (sod-class-type class) |
| 244 | (make-class-type (sod-class-name class))) |
| 245 | |
| 246 | ;; Clobber the lists of items if they've not been set. |
| 247 | (dolist (slot '(slots instance-initializers class-initializers |
| 248 | messages methods)) |
| 249 | (unless (slot-boundp class slot) |
| 250 | (setf (slot-value class slot) nil))) |
| 251 | |
| 252 | ;; If the CPL hasn't been done yet, compute it. |
| 253 | (with-slots (class-precedence-list) class |
| 254 | (unless (slot-boundp class 'class-precedence-list) |
| 255 | (setf class-precedence-list (compute-cpl class)))) |
| 256 | |
| 257 | ;; If no metaclass has been established, then choose one. |
| 258 | (with-slots (metaclass) class |
| 259 | (unless (and (slot-boundp class 'metaclass) metaclass) |
| 260 | (setf metaclass (guess-metaclass class)))) |
| 261 | |
| 262 | ;; If no nickname has been set, choose a default. This might cause |
| 263 | ;; conflicts, but, well, the user should have chosen an explicit |
| 264 | ;; nickname. |
| 265 | (with-slots (name nickname) class |
| 266 | (unless (and (slot-boundp class 'nickname) nickname) |
| 267 | (setf nickname (string-downcase name)))) |
| 268 | |
| 269 | ;; Check that the class is fairly sane. |
| 270 | (check-sod-class class) |
| 271 | |
| 272 | ;; Determine the class's layout. |
| 273 | (with-slots (chain-head chain chains) class |
| 274 | (setf (values chain-head chain chains) (compute-chains class))) |
| 275 | |
| 276 | (with-slots (ilayout effective-methods vtables) class |
| 277 | (setf ilayout (compute-ilayout class)) |
| 278 | (setf effective-methods (compute-effective-methods class)) |
| 279 | (setf vtables (compute-vtables class))) |
| 280 | |
| 281 | ;; Done. |
| 282 | (setf (sod-class-state class) :finalized) |
| 283 | t) |
| 284 | |
| 285 | (:broken |
| 286 | nil) |
| 287 | |
| 288 | (:finalized |
| 289 | t)))) |
| 290 | |
| 291 | ;;;----- That's all, folks -------------------------------------------------- |