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
 140    (defaulting to `sod-message') to choose a (CLOS) class to instantiate.
 141    The message is then constructed by `make-instance' passing the arguments
 142    as initargs; further behaviour is left to the standard CLOS instance
 143    construction protocol; for example, `sod-message' defines an
 144    `:after'-method on `shared-initialize'."))
 145
 146 (export 'make-sod-method)
 147 (defgeneric make-sod-method
 148     (class nick name type body pset &optional location)
 149   (:documentation
 150    "Construct and attach a new method to CLASS.
 151
 152    This is the main constructor function for methods.  This is a generic
 153    function primarily so that the CLASS can intervene in the message lookup
 154    process, though this is actually a fairly unlikely occurrence.
 155
 156    The default method looks up the message using `find-message-by-name',
 157    invokes `make-sod-method-using-message' to make the method object, and
 158    then adds the method to the class's list of methods.  This split allows
 159    the message class to intervene in the class selection process, for
 160    example."))
 161
 162 (export 'make-sod-method-using-message)
 163 (defgeneric make-sod-method-using-message
 164     (message class type body pset location)
 165   (:documentation
 166    "Main construction subroutine for method construction.
 167
 168    This is a generic function so that it can be specialized according to both
 169    a class and -- more particularly -- a message.  The default method uses
 170    the `:method-class' property (defaulting to the result of calling
 171    `sod-message-method-class') to choose a (CLOS) class to instantiate.  The
 172    method is then constructed by `make-instance' passing the arguments as
 173    initargs; further behaviour is left to the standard CLOS instance
 174    construction protocol; for example, `sod-method' defines an
 175    `:after'-method on `shared-initialize'.
 176
 177    Diagnosing unused properties is left for the caller (usually
 178    `make-sod-method') to do.  The caller is also expected to have set
 179    `with-default-error-location' if appropriate.
 180
 181    You are not expected to call this generic function directly; it's more
 182    useful as a place to hang methods for custom method classes."))
 183
 184 (export 'sod-message-method-class)
 185 (defgeneric sod-message-method-class (message class pset)
 186   (:documentation
 187    "Return the preferred class for methods on MESSAGE.
 188
 189    The message can inspect the PSET to decide on a particular message.  A
 190    `:method-class' property will usually override this decision: it's then
 191    the programmer's responsibility to ensure that the selected method class
 192    is appropriate."))
 193
 194 (export 'check-message-type)
 195 (defgeneric check-message-type (message type)
 196   (:documentation
 197    "Check that TYPE is a suitable type for MESSAGE.  Signal errors if not.
 198
 199    This is separated out of `shared-initialize', where it's called, so that
 200    it can be overridden conveniently by subclasses."))
 201
 202 (export 'check-method-type)
 203 (defgeneric check-method-type (method message type)
 204   (:documentation
 205    "Check that TYPE is a suitable type for METHOD.  Signal errors if not.
 206
 207    This is separated out of `shared-initialize', where it's called, so that
 208    it can be overridden conveniently by subclasses."))
 209
 210 ;;;--------------------------------------------------------------------------
 211 ;;; Builder macros.
 212
 213 (export 'define-sod-class)
 214 (defmacro define-sod-class (name (&rest superclasses) &body body)
 215   "Construct a new SOD class called NAME in the current module.
 216
 217    The new class has the named direct SUPERCLASSES, which should be a list of
 218    strings.
 219
 220    The BODY begins with a sequence of alternating keyword/value pairs
 221    defining properties for the new class.  The keywords are (obviously) not
 222    evaluated, but the value forms are.
 223
 224    The remainder of the BODY are a sequence of forms to be evaluated as an
 225    implicit `progn'.  Additional macros are available to the BODY, to make
 226    defining the class easier.
 227
 228    In the following, NAME is a string giving a C identifier; NICK is a string
 229    giving the nickname of a superclass; TYPE is a C type using S-expression
 230    notation.
 231
 232      * message NAME TYPE &rest PLIST
 233
 234      * method NICK NAME TYPE BODY &rest PLIST
 235
 236      * slot NAME TYPE &rest PLIST
 237
 238      * instance-initializer NICK NAME VALUE-KIND VALUE-FORM &rest PLIST
 239
 240      * class-initializer NICK NAME VALUE-KIND VALUE-FORM &rest PLIST"
 241
 242   (let ((plist nil)
 243         (classvar (gensym "CLASS-")))
 244     (loop
 245       (when (or (null body)
 246                 (not (keywordp (car body))))
 247         (return))
 248       (push (pop body) plist)
 249       (push (pop body) plist))
 250     `(let ((,classvar (make-sod-class ,name
 251                                       (mapcar #'find-sod-class
 252                                               (list ,@superclasses))
 253                                       (make-property-set
 254                                        ,@(nreverse plist)))))
 255        (macrolet ((message (name type &rest plist)
 256                     `(make-sod-message ,',classvar ,name (c-type ,type)
 257                                        (make-property-set ,@plist)))
 258                   (method (nick name type body &rest plist)
 259                     `(make-sod-method ,',classvar ,nick ,name (c-type ,type)
 260                                       ,body (make-property-set ,@plist)))
 261                   (slot (name type &rest plist)
 262                     `(make-sod-slot ,',classvar ,name (c-type ,type)
 263                                     (make-property-set ,@plist)))
 264                   (instance-initializer
 265                       (nick name value-kind value-form &rest plist)
 266                     `(make-sod-instance-initializer ,',classvar ,nick ,name
 267                                                     ,value-kind ,value-form
 268                                                     (make-property-set
 269                                                      ,@plist)))
 270                   (class-initializer
 271                       (nick name value-kind value-form &rest plist)
 272                     `(make-sod-class-initializer ,',classvar ,nick ,name
 273                                                  ,value-kind ,value-form
 274                                                  (make-property-set
 275                                                   ,@plist))))
 276          ,@body
 277          (finalize-sod-class ,classvar)
 278          (add-to-module *module* ,classvar)))))
 279
 280 ;;;----- That's all, folks --------------------------------------------------