chiark - git - mdw - sod/blob - src/class-make-proto.lisp

   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 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 ;;; 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 --------------------------------------------------