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