| 1 | ;;; -*-lisp-*- |
| 2 | ;;; |
| 3 | ;;; Class construction protocol |
| 4 | ;;; |
| 5 | ;;; (c) 2009 Straylight/Edgeware |
| 6 | ;;; |
| 7 | |
| 8 | ;;;----- Licensing notice --------------------------------------------------- |
| 9 | ;;; |
| 10 | ;;; This file is part of the Sensble 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 | ;;; Classes. |
| 30 | |
| 31 | (export 'make-sod-class) |
| 32 | (defun make-sod-class (name superclasses pset &optional location) |
| 33 | "Construct and return a new SOD class with the given NAME and SUPERCLASSES. |
| 34 | |
| 35 | This is the main constructor function for classes. The protocol works as |
| 36 | follows. The `:lisp-metaclass' property in PSET is checked: if it exists, |
| 37 | it must be a symbol naming a (CLOS) class, which is used in place of |
| 38 | `sod-class'. All of the arguments are then passed to `make-instance'; |
| 39 | further behaviour is left to the standard CLOS instance construction |
| 40 | protocol; for example, `sod-class' defines an `:after'-method on |
| 41 | `shared-initialize'. |
| 42 | |
| 43 | Minimal sanity checking is done during class construction; most of it is |
| 44 | left for `finalize-sod-class' to do (via `check-sod-class')." |
| 45 | |
| 46 | (with-default-error-location (location) |
| 47 | (let* ((pset (property-set pset)) |
| 48 | (best-class (or (get-property pset :lisp-metaclass :symbol nil) |
| 49 | (if superclasses |
| 50 | (maximum (mapcar #'class-of superclasses) |
| 51 | #'subtypep |
| 52 | (format nil "Lisp metaclass for ~A" |
| 53 | name)) |
| 54 | 'sod-class))) |
| 55 | (class (make-instance best-class |
| 56 | :name name |
| 57 | :superclasses superclasses |
| 58 | :location (file-location location) |
| 59 | :pset pset))) |
| 60 | class))) |
| 61 | |
| 62 | (export 'guess-metaclass) |
| 63 | (defgeneric guess-metaclass (class) |
| 64 | (:documentation |
| 65 | "Determine a suitable metaclass for the CLASS. |
| 66 | |
| 67 | The default behaviour is to choose the most specific metaclass of any of |
| 68 | the direct superclasses of CLASS, or to signal an error if that failed.")) |
| 69 | |
| 70 | ;;;-------------------------------------------------------------------------- |
| 71 | ;;; Slots and slot initializers. |
| 72 | |
| 73 | (export 'make-sod-slot) |
| 74 | (defgeneric make-sod-slot (class name type pset &optional location) |
| 75 | (:documentation |
| 76 | "Construct, add, and attach a new slot with given NAME and TYPE, to CLASS. |
| 77 | |
| 78 | This is the main constructor function for slots. This is a generic |
| 79 | function primarily so that the CLASS can intervene in the construction |
| 80 | process. The default method uses the `:slot-class' property (defaulting |
| 81 | to `sod-slot') to choose a (CLOS) class to instantiate. The slot is then |
| 82 | constructed by `make-instance' passing the arguments as initargs; further |
| 83 | behaviour is left to the standard CLOS instance construction protocol; for |
| 84 | example, `sod-slot' defines an `:after'-method on `shared-initialize'.")) |
| 85 | |
| 86 | (export 'make-sod-instance-initializer) |
| 87 | (defgeneric make-sod-instance-initializer |
| 88 | (class nick name value-kind value-form pset &optional location) |
| 89 | (:documentation |
| 90 | "Construct and attach an instance slot initializer, to CLASS. |
| 91 | |
| 92 | This is the main constructor function for instance initializers. This is |
| 93 | a generic function primarily so that the CLASS can intervene in the |
| 94 | construction process. The default method looks up the slot using |
| 95 | `find-instance-slot-by-name', calls `make-sod-initializer-using-slot' to |
| 96 | actually make the initializer object, and adds it to the appropriate list |
| 97 | in CLASS.")) |
| 98 | |
| 99 | (export 'make-sod-class-initializer) |
| 100 | (defgeneric make-sod-class-initializer |
| 101 | (class nick name value-kind value-form pset &optional location) |
| 102 | (:documentation |
| 103 | "Construct and attach a class slot initializer, to CLASS. |
| 104 | |
| 105 | This is the main constructor function for class initializers. This is a |
| 106 | generic function primarily so that the CLASS can intervene in the |
| 107 | construction process. The default method looks up the slot using |
| 108 | `find-class-slot-by-name', calls `make-sod-initializer-using-slot' to |
| 109 | actually make the initializer object, and adds it to the appropriate list |
| 110 | in CLASS.")) |
| 111 | |
| 112 | (export 'make-sod-initializer-using-slot) |
| 113 | (defgeneric make-sod-initializer-using-slot |
| 114 | (class slot init-class value-kind value-form pset location) |
| 115 | (:documentation |
| 116 | "Common construction protocol for slot initializers. |
| 117 | |
| 118 | This generic function does the common work for constructing instance and |
| 119 | class initializers. It can usefully be specialized according to both the |
| 120 | class and slot types. The default method uses the `:initializer-class' |
| 121 | property (defaulting to INIT-CLASS) to choose a (CLOS) class to |
| 122 | instantiate. The slot is then constructed by `make-instance' passing the |
| 123 | arguments as initargs; further behaviour is left to the standard CLOS |
| 124 | instance construction protocol; for example, `sod-initializer' defines an |
| 125 | `:after'-method on `shared-initialize'. |
| 126 | |
| 127 | Diagnosing unused properties is left for the caller (usually |
| 128 | `make-sod-instance-initializer' or `make-sod-class-initializer') to do. |
| 129 | The caller is also expected to have set `with-default-error-location' if |
| 130 | appropriate. |
| 131 | |
| 132 | You are not expected to call this generic function directly; it's more |
| 133 | useful as a place to hang methods for custom initializer classes.")) |
| 134 | |
| 135 | ;;;-------------------------------------------------------------------------- |
| 136 | ;;; Messages and methods. |
| 137 | |
| 138 | (export 'make-sod-message) |
| 139 | (defgeneric make-sod-message (class name type pset &optional location) |
| 140 | (:documentation |
| 141 | "Construct and attach a new message with given NAME and TYPE, to CLASS. |
| 142 | |
| 143 | This is the main constructor function for messages. This is a generic |
| 144 | function primarily so that the CLASS can intervene in the construction |
| 145 | process. The default method uses the `:message-class' property to choose |
| 146 | a (CLOS) class to instantiate; if no such property is provided but a |
| 147 | `combination' property is present, then `aggregating-message' is chosen; |
| 148 | otherwise `standard-message' is used. The message is then constructed by |
| 149 | `make-instance' passing the arguments as initargs; further behaviour is |
| 150 | left to the standard CLOS instance construction protocol; for example, |
| 151 | `sod-message' defines an `:after'-method on `shared-initialize'.")) |
| 152 | |
| 153 | (export 'make-sod-method) |
| 154 | (defgeneric make-sod-method |
| 155 | (class nick name type body pset &optional location) |
| 156 | (:documentation |
| 157 | "Construct and attach a new method to CLASS. |
| 158 | |
| 159 | This is the main constructor function for methods. This is a generic |
| 160 | function primarily so that the CLASS can intervene in the message lookup |
| 161 | process, though this is actually a fairly unlikely occurrence. |
| 162 | |
| 163 | The default method looks up the message using `find-message-by-name', |
| 164 | invokes `make-sod-method-using-message' to make the method object, and |
| 165 | then adds the method to the class's list of methods. This split allows |
| 166 | the message class to intervene in the class selection process, for |
| 167 | example.")) |
| 168 | |
| 169 | (export 'make-sod-method-using-message) |
| 170 | (defgeneric make-sod-method-using-message |
| 171 | (message class type body pset location) |
| 172 | (:documentation |
| 173 | "Main construction subroutine for method construction. |
| 174 | |
| 175 | This is a generic function so that it can be specialized according to both |
| 176 | a class and -- more particularly -- a message. The default method uses |
| 177 | the `:method-class' property (defaulting to the result of calling |
| 178 | `sod-message-method-class') to choose a (CLOS) class to instantiate. The |
| 179 | method is then constructed by `make-instance' passing the arguments as |
| 180 | initargs; further behaviour is left to the standard CLOS instance |
| 181 | construction protocol; for example, `sod-method' defines an |
| 182 | `:after'-method on `shared-initialize'. |
| 183 | |
| 184 | Diagnosing unused properties is left for the caller (usually |
| 185 | `make-sod-method') to do. The caller is also expected to have set |
| 186 | `with-default-error-location' if appropriate. |
| 187 | |
| 188 | You are not expected to call this generic function directly; it's more |
| 189 | useful as a place to hang methods for custom method classes.")) |
| 190 | |
| 191 | (export 'sod-message-method-class) |
| 192 | (defgeneric sod-message-method-class (message class pset) |
| 193 | (:documentation |
| 194 | "Return the preferred class for methods on MESSAGE. |
| 195 | |
| 196 | The message can inspect the PSET to decide on a particular message. A |
| 197 | `:method-class' property will usually override this decision: it's then |
| 198 | the programmer's responsibility to ensure that the selected method class |
| 199 | is appropriate.")) |
| 200 | |
| 201 | (export 'check-message-type) |
| 202 | (defgeneric check-message-type (message type) |
| 203 | (:documentation |
| 204 | "Check that TYPE is a suitable type for MESSAGE. Signal errors if not. |
| 205 | |
| 206 | This is separated out of `shared-initialize', where it's called, so that |
| 207 | it can be overridden conveniently by subclasses.")) |
| 208 | |
| 209 | (export 'check-method-type) |
| 210 | (defgeneric check-method-type (method message type) |
| 211 | (:documentation |
| 212 | "Check that TYPE is a suitable type for METHOD. Signal errors if not. |
| 213 | |
| 214 | This is separated out of `shared-initialize', where it's called, so that |
| 215 | it can be overridden conveniently by subclasses.")) |
| 216 | |
| 217 | ;;;-------------------------------------------------------------------------- |
| 218 | ;;; Builder macros. |
| 219 | |
| 220 | (export 'define-sod-class) |
| 221 | (defmacro define-sod-class (name (&rest superclasses) &body body) |
| 222 | "Construct a new SOD class called NAME in the current module. |
| 223 | |
| 224 | The new class has the named direct SUPERCLASSES, which should be a list of |
| 225 | strings. |
| 226 | |
| 227 | The BODY begins with a sequence of alternating keyword/value pairs |
| 228 | defining properties for the new class. The keywords are (obviously) not |
| 229 | evaluated, but the value forms are. |
| 230 | |
| 231 | The remainder of the BODY are a sequence of forms to be evaluated as an |
| 232 | implicit `progn'. Additional macros are available to the BODY, to make |
| 233 | defining the class easier. |
| 234 | |
| 235 | In the following, NAME is a string giving a C identifier; NICK is a string |
| 236 | giving the nickname of a superclass; TYPE is a C type using S-expression |
| 237 | notation. |
| 238 | |
| 239 | * message NAME TYPE &rest PLIST |
| 240 | |
| 241 | * method NICK NAME TYPE BODY &rest PLIST |
| 242 | |
| 243 | * slot NAME TYPE &rest PLIST |
| 244 | |
| 245 | * instance-initializer NICK NAME VALUE-KIND VALUE-FORM &rest PLIST |
| 246 | |
| 247 | * class-initializer NICK NAME VALUE-KIND VALUE-FORM &rest PLIST" |
| 248 | |
| 249 | (let ((plist nil) |
| 250 | (classvar (gensym "CLASS-"))) |
| 251 | (loop |
| 252 | (when (or (null body) |
| 253 | (not (keywordp (car body)))) |
| 254 | (return)) |
| 255 | (push (pop body) plist) |
| 256 | (push (pop body) plist)) |
| 257 | `(let ((,classvar (make-sod-class ,name |
| 258 | (mapcar #'find-sod-class |
| 259 | (list ,@superclasses)) |
| 260 | (make-property-set |
| 261 | ,@(nreverse plist))))) |
| 262 | (macrolet ((message (name type &rest plist) |
| 263 | `(make-sod-message ,',classvar ,name (c-type ,type) |
| 264 | (make-property-set ,@plist))) |
| 265 | (method (nick name type body &rest plist) |
| 266 | `(make-sod-method ,',classvar ,nick ,name (c-type ,type) |
| 267 | ,body (make-property-set ,@plist))) |
| 268 | (slot (name type &rest plist) |
| 269 | `(make-sod-slot ,',classvar ,name (c-type ,type) |
| 270 | (make-property-set ,@plist))) |
| 271 | (instance-initializer |
| 272 | (nick name value-kind value-form &rest plist) |
| 273 | `(make-sod-instance-initializer ,',classvar ,nick ,name |
| 274 | ,value-kind ,value-form |
| 275 | (make-property-set |
| 276 | ,@plist))) |
| 277 | (class-initializer |
| 278 | (nick name value-kind value-form &rest plist) |
| 279 | `(make-sod-class-initializer ,',classvar ,nick ,name |
| 280 | ,value-kind ,value-form |
| 281 | (make-property-set |
| 282 | ,@plist)))) |
| 283 | ,@body |
| 284 | (finalize-sod-class ,classvar) |
| 285 | (add-to-module *module* ,classvar))))) |
| 286 | |
| 287 | ;;;----- That's all, folks -------------------------------------------------- |