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