chiark - git - mdw - sod/blob - class-builder.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Equipment for building classes and friends
   4 ;;;
   5 ;;; (c) 2009 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Simple Object Definition system.
  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 ;;; Finding things by name
  30
  31 (defun find-superclass-by-nick (class nick)
  32   "Returns the superclass of CLASS with nickname NICK, or signals an error."
  33
  34   ;; Slightly tricky.  The class almost certainly hasn't been finalized, so
  35   ;; trundle through its superclasses and hope for the best.
  36   (if (string= nick (sod-class-nickname class))
  37       class
  38       (or (some (lambda (super)
  39                   (find nick (sod-class-precedence-list super)
  40                         :key #'sod-class-nickname
  41                         :test #'string=))
  42                 (sod-class-direct-superclasses class))
  43           (error "No superclass of `~A' with nickname `~A'" class nick))))
  44
  45 (flet ((find-item-by-name (what class list name key)
  46          (or (find name list :key key :test #'string=)
  47              (error "No ~A in class `~A' with name `~A'" what class name))))
  48
  49   (defun find-instance-slot-by-name (class super-nick slot-name)
  50     (let ((super (find-superclass-by-nick class super-nick)))
  51       (find-item-by-name "slot" super (sod-class-slots super)
  52                          slot-name #'sod-slot-name)))
  53
  54   (defun find-class-slot-by-name (class super-nick slot-name)
  55     (let* ((meta (sod-class-metaclass class))
  56            (super (find-superclass-by-nick meta super-nick)))
  57       (find-item-by-name "slot" super (sod-class-slots super)
  58                          slot-name #'sod-slot-name)))
  59
  60   (defun find-message-by-name (class super-nick message-name)
  61     (let ((super (find-superclass-by-nick class super-nick)))
  62       (find-item-by-name "message" super (sod-class-messages super)
  63                          message-name #'sod-message-name))))
  64
  65 ;;;--------------------------------------------------------------------------
  66 ;;; Class construction.
  67
  68 (defun make-sod-class (name superclasses pset &optional location)
  69   "Construct and return a new SOD class with the given NAME and SUPERCLASSES.
  70
  71    This is the main constructor function for classes.  The protocol works as
  72    follows.  The :LISP-CLASS property in PSET is checked: if it exists, it
  73    must be a symbol naming a (CLOS) class, which is used in place of
  74    SOD-CLASS.  All of the arguments are then passed to MAKE-INSTANCE; further
  75    behaviour is left to the standard CLOS instance construction protocol; for
  76    example, SOD-CLASS defines an :AFTER-method on SHARED-INITIALIZE.
  77
  78    Minimal sanity checking is done during class construction; most of it is
  79    left for FINALIZE-SOD-CLASS to do (via CHECK-SOD-CLASS).
  80
  81    Unused properties in PSET are diagnosed as errors."
  82
  83   (with-default-error-location (location)
  84     (let ((class (make-instance (get-property pset :lisp-class :symbol
  85                                               'sod-class)
  86                                 :name name
  87                                 :superclasses superclasses
  88                                 :location (file-location location)
  89                                 :pset pset)))
  90       (check-unused-properties pset)
  91       class)))
  92
  93 (defgeneric guess-metaclass (class)
  94   (:documentation
  95    "Determine a suitable metaclass for the CLASS.
  96
  97    The default behaviour is to choose the most specific metaclass of any of
  98    the direct superclasses of CLASS, or to signal an error if that failed."))
  99
 100 (defmethod guess-metaclass ((class sod-class))
 101   "Default metaclass-guessing function for classes.
 102
 103    Return the most specific metaclass of any of the CLASS's direct
 104    superclasses."
 105   (do ((supers (sod-class-direct-superclasses class) (cdr supers))
 106        (meta nil (let ((candidate (sod-class-metaclass (car supers))))
 107                    (cond ((null meta) candidate)
 108                          ((sod-subclass-p meta candidate) meta)
 109                          ((sod-subclass-p candidate meta) candidate)
 110                          (t (error "Unable to choose metaclass for `~A'"
 111                                    class))))))
 112       ((endp supers) meta)))
 113
 114 (defmethod shared-initialize :after ((class sod-class) slot-names &key pset)
 115   "Specific behaviour for SOD class initialization.
 116
 117    Properties inspected are as follows:
 118
 119      * :METACLASS names the metaclass to use.  If unspecified, NIL is stored,
 120        and (unless you intervene later) GUESS-METACLASS will be called by
 121        FINALIZE-SOD-CLASS to find a suitable default.
 122
 123      * :NICK provides a nickname for the class.  If unspecified, a default
 124        (the class's name, forced to lowercase) will be chosen in
 125        FINALIZE-SOD-CLASS.
 126
 127      * :LINK names the chained superclass.  If unspecified, this class will
 128        be left at the head of its chain."
 129
 130   ;; If no nickname, copy the class name.  It won't be pretty, though.
 131   (default-slot (class 'nickname)
 132     (get-property pset :nick :id (string-downcase (slot-value class 'name))))
 133
 134   ;; If no metaclass, guess one in a (Lisp) class-specific way.
 135   (default-slot (class 'metaclass)
 136     (multiple-value-bind (name floc) (get-property pset :metaclass :id)
 137       (if floc
 138           (find-sod-class name floc)
 139           (guess-metaclass class))))
 140
 141   ;; If no chain-link, then start a new chain here.
 142   (default-slot (class 'chain-link)
 143     (multiple-value-bind (name floc) (get-property pset :link :id)
 144       (if floc
 145           (find-sod-class name floc)
 146           nil))))
 147
 148 ;;;--------------------------------------------------------------------------
 149 ;;; Slot construction.
 150
 151 (defgeneric make-sod-slot (class name type pset &optional location)
 152   (:documentation
 153    "Construct, add, and attach a new slot with given NAME and TYPE, to CLASS.
 154
 155    This is the main constructor function for slots.  This is a generic
 156    function primarily so that the CLASS can intervene in the construction
 157    process.  The default method uses the :LISP-CLASS property (defaulting to
 158    SOD-SLOT) to choose a (CLOS) class to instantiate.  The slot is then
 159    constructed by MAKE-INSTANCE passing the arguments as initargs; further
 160    behaviour is left to the standard CLOS instance construction protocol; for
 161    example, SOD-SLOT defines an :AFTER-method on SHARED-INITIALIZE.
 162
 163    Unused properties on PSET are diagnosed as errors."))
 164
 165 (defmethod make-sod-slot
 166     ((class sod-class) name type pset &optional location)
 167   (with-default-error-location (location)
 168     (let ((slot (make-instance (get-property pset :lisp-class :symbol
 169                                              'sod-slot)
 170                                :class class
 171                                :name name
 172                                :type type
 173                                :location (file-location location)
 174                                :pset pset)))
 175       (with-slots (slots) class
 176         (setf slots (append slots (list slot))))
 177       (check-unused-properties pset))))
 178
 179 (defmethod shared-initialize :after ((slot sod-slot) slot-names &key pset)
 180   "This method exists so that it isn't an error to provide a :PSET initarg
 181    to (make-instance 'sod-slot ...).  It does nothing."
 182   (declare (ignore slot-names pset))
 183   nil)
 184
 185 ;;;--------------------------------------------------------------------------
 186 ;;; Slot initializer construction.
 187
 188 (defgeneric make-sod-instance-initializer
 189     (class nick name value-kind value-form pset &optional location)
 190   (:documentation
 191    "Construct and attach an instance slot initializer, to CLASS.
 192
 193    This is the main constructor function for instance initializers.  This is
 194    a generic function primarily so that the CLASS can intervene in the
 195    construction process.  The default method looks up the slot using
 196    FIND-INSTANCE-SLOT-BY-NAME, calls MAKE-SOD-INITIALIZER-USING-SLOT to
 197    actually make the initializer object, and adds it to the appropriate list
 198    in CLASS.
 199
 200    Unused properties on PSET are diagnosed as errors."))
 201
 202 (defgeneric make-sod-class-initializer
 203     (class nick name value-kind value-form pset &optional location)
 204   (:documentation
 205    "Construct and attach a class slot initializer, to CLASS.
 206
 207    This is the main constructor function for class initializers.  This is a
 208    generic function primarily so that the CLASS can intervene in the
 209    construction process.  The default method looks up the slot using
 210    FIND-CLASS-SLOT-BY-NAME, calls MAKE-SOD-INITIALIZER-USING-SLOT to actually
 211    make the initializer object, and adds it to the appropriate list in CLASS.
 212
 213    Unused properties on PSET are diagnosed as errors."))
 214
 215 (defgeneric make-sod-initializer-using-slot
 216     (class slot init-class value-kind value-form pset location)
 217   (:documentation
 218    "Common construction protocol for slot initializers.
 219
 220    This generic function does the common work for constructing instance and
 221    class initializers.  It can usefully be specialized according to both the
 222    class and slot types.  The default method uses the :LISP-CLASS property
 223    (defaulting to INIT-CLASS) to choose a (CLOS) class to instantiate.  The
 224    slot is then constructed by MAKE-INSTANCE passing the arguments as
 225    initargs; further behaviour is left to the standard CLOS instance
 226    construction protocol; for example, SOD-INITIALIZER defines
 227    an :AFTER-method on SHARED-INITIALIZE.
 228
 229    Diagnosing unused properties is left for the caller (usually
 230    MAKE-SOD-INSTANCE-INITIALIZER or MAKE-SOD-CLASS-INITIALIZER) to do.  The
 231    caller is also expected to have set WITH-DEFAULT-ERROR-LOCATION if
 232    appropriate.
 233
 234    You are not expected to call this generic function directly; it's more
 235    useful as a place to hang methods for custom initializer classes."))
 236
 237 (defmethod make-sod-instance-initializer
 238     ((class sod-class) nick name value-kind value-form pset
 239      &optional location)
 240   (with-default-error-location (location)
 241     (let* ((slot (find-instance-slot-by-name class nick name))
 242            (initializer (make-sod-initializer-using-slot
 243                          class slot 'sod-instance-initializer
 244                          value-kind value-form pset
 245                          (file-location location))))
 246       (with-slots (instance-initializers) class
 247         (setf instance-initializers (append instance-initializers
 248                                             (list initializer))))
 249       (check-unused-properties pset))))
 250
 251 (defmethod make-sod-class-initializer
 252     ((class sod-class) nick name value-kind value-form pset
 253      &optional location)
 254   (with-default-error-location (location)
 255     (let* ((slot (find-class-slot-by-name class nick name))
 256            (initializer (make-sod-initializer-using-slot
 257                         class slot 'sod-class-initializer
 258                         value-kind value-form pset
 259                         (file-location location))))
 260       (with-slots (class-initializers) class
 261         (setf class-initializers (append class-initializers
 262                                          (list initializer))))
 263       (check-unused-properties pset))))
 264
 265 (defmethod make-sod-initializer-using-slot
 266     ((class sod-class) (slot sod-slot)
 267      init-class value-kind value-form pset location)
 268   (make-instance (get-property pset :lisp-class :symbol init-class)
 269                  :class class
 270                  :slot slot
 271                  :value-kind value-kind
 272                  :value-form value-form
 273                  :location location
 274                  :pset pset))
 275
 276 (defmethod shared-initialize :after
 277     ((init sod-initializer) slot-names &key pset)
 278   "This method exists so that it isn't an error to provide a :PSET initarg
 279    to (make-instance 'sod-initializer ...).  It does nothing."
 280   (declare (ignore slot-names pset))
 281   nil)
 282
 283 ;;;--------------------------------------------------------------------------
 284 ;;; Message construction.
 285
 286 (defgeneric make-sod-message (class name type pset &optional location)
 287   (:documentation
 288    "Construct and attach a new message with given NAME and TYPE, to CLASS.
 289
 290    This is the main constructor function for messages.  This is a generic
 291    function primarily so that the CLASS can intervene in the construction
 292    process.  The default method uses the :LISP-CLASS property (defaulting to
 293    SOD-MESSAGE) to choose a (CLOS) class to instantiate.  The message is then
 294    constructed by MAKE-INSTANCE passing the arguments as initargs; further
 295    behaviour is left to the standard CLOS instance construction protocol; for
 296    example, SOD-MESSAGE defines an :AFTER-method on SHARED-INITIALIZE.
 297
 298    Unused properties on PSET are diagnosed as errors."))
 299
 300 (defgeneric check-message-type (message type)
 301   (:documentation
 302    "Check that TYPE is a suitable type for MESSAGE.  Signal errors if not.
 303
 304    This is separated out of SHARED-INITIALIZE, where it's called, so that it
 305    can be overridden conveniently by subclasses."))
 306
 307 (defmethod make-sod-message
 308     ((class sod-class) name type pset &optional location)
 309   (with-default-error-location (location)
 310     (let ((message (make-instance (get-property pset :lisp-class :symbol
 311                                                 'standard-message)
 312                                :class class
 313                                :name name
 314                                :type type
 315                                :location (file-location location)
 316                                :pset pset)))
 317       (with-slots (messages) class
 318         (setf messages (append messages (list message))))
 319       (check-unused-properties pset))))
 320
 321 (defmethod check-message-type ((message sod-message) (type c-function-type))
 322   nil)
 323 (defmethod check-message-type ((message sod-message) (type c-type))
 324   (error "Messages must have function type, not ~A" type))
 325
 326 (defmethod shared-initialize :after
 327     ((message sod-message) slot-names &key pset)
 328   (declare (ignore slot-names pset))
 329   (with-slots (type) message
 330     (check-message-type message type)))
 331
 332 ;;;--------------------------------------------------------------------------
 333 ;;; Method construction.
 334
 335 (defgeneric make-sod-method
 336     (class nick name type body pset &optional location)
 337   (:documentation
 338    "Construct and attach a new method to CLASS.
 339
 340    This is the main constructor function for methods.  This is a generic
 341    function primarily so that the CLASS can intervene in the message lookup
 342    process, though this is actually a fairly unlikely occurrence.
 343
 344    The default method looks up the message using FIND-MESSAGE-BY-NAME,
 345    invokes MAKE-SOD-METHOD-USING-MESSAGE to make the method object, and then
 346    adds the method to the class's list of methods.  This split allows the
 347    message class to intervene in the class selection process, for example.
 348
 349    Unused properties on PSET are diagnosed as errors."))
 350
 351 (defgeneric make-sod-method-using-message
 352     (message class type body pset location)
 353   (:documentation
 354    "Main construction subroutine for method construction.
 355
 356    This is a generic function so that it can be specialized according to both
 357    a class and -- more particularly -- a message.  The default method uses
 358    the :LISP-CLASS property (defaulting to calling SOD-MESSAGE-METHOD-CLASS)
 359    to choose a (CLOS) class to instantiate.  The method is then constructed
 360    by MAKE-INSTANCE passing the arguments as initargs; further behaviour is
 361    left to the standard CLOS instance construction protocol; for example,
 362    SOD-METHOD defines an :AFTER-method on SHARED-INITIALIZE.
 363
 364    Diagnosing unused properties is left for the caller (usually
 365    MAKE-SOD-METHOD) to do.  The caller is also expected to have set
 366    WITH-DEFAULT-ERROR-LOCATION if appropriate.
 367
 368    You are not expected to call this generic function directly; it's more
 369    useful as a place to hang methods for custom initializer classes."))
 370
 371 (defgeneric sod-message-method-class (message class pset)
 372   (:documentation
 373    "Return the preferred class for methods on MESSAGE.
 374
 375    The message can inspect the PSET to decide on a particular message.  A
 376    :LISP-CLASS property will usually override this decision: it's then the
 377    programmer's responsibility to ensure that the selected method class is
 378    appropriate."))
 379
 380 (defgeneric check-method-type (method message type)
 381   (:documentation
 382    "Check that TYPE is a suitable type for METHOD.  Signal errors if not.
 383
 384    This is separated out of SHARED-INITIALIZE, where it's called, so that it
 385    can be overridden conveniently by subclasses."))
 386
 387 (defmethod make-sod-method
 388     ((class sod-class) nick name type body pset &optional location)
 389   (with-default-error-location (location)
 390     (let* ((message (find-message-by-name class nick name))
 391            (method (make-sod-method-using-message message class
 392                                                   type body pset
 393                                                   (file-location location))))
 394       (with-slots (methods) class
 395         (setf methods (append methods (list method)))))
 396     (check-unused-properties pset)))
 397
 398 (defmethod make-sod-method-using-message
 399     ((message sod-message) (class sod-class) type body pset location)
 400   (make-instance (or (get-property pset :lisp-class :symbol)
 401                      (sod-message-method-class message class pset))
 402                  :message message
 403                  :class class
 404                  :type type
 405                  :body body
 406                  :location location
 407                  :pset pset))
 408
 409 (defmethod sod-message-method-class
 410     ((message sod-message) (class sod-class) pset)
 411   (declare (ignore pset))
 412   'sod-method)
 413
 414 (defmethod check-method-type
 415     ((method sod-method) (message sod-message) (type c-type))
 416   (error "Methods must have function type, not ~A" type))
 417
 418 (defun argument-lists-compatible-p (message-args method-args)
 419   "Compare argument lists for compatibility.
 420
 421    Return true if METHOD-ARGS is a suitable method argument list
 422    corresponding to the message argument list MESSAGE-ARGS.  This is the case
 423    if the lists are the same length, each message argument has a
 424    corresponding method argument with the same type, and if the message
 425    arguments end in an ellpisis, the method arguments must end with a
 426    `va_list' argument.  (We can't pass actual variable argument lists around,
 427    except as `va_list' objects, which are devilish inconvenient things and
 428    require much hacking.  See the method combination machinery for details.)"
 429
 430   (and (= (length message-args) (length method-args))
 431        (every (lambda (message-arg method-arg)
 432                 (if (eq message-arg :ellipsis)
 433                     (eq method-arg (c-type va-list))
 434                     (c-type-equal-p (argument-type message-arg)
 435                                     (argument-type method-arg))))
 436               message-args method-args)))
 437
 438 (defmethod check-method-type
 439     ((method sod-method) (message sod-message) (type c-function-type))
 440   (with-slots ((msgtype type)) message
 441     (unless (c-type-equal-p (c-type-subtype msgtype)
 442                             (c-type-subtype type))
 443       (error "Method return type ~A doesn't match message ~A"
 444               (c-type-subtype msgtype) (c-type-subtype type)))
 445     (unless (argument-lists-compatible-p (c-function-arguments msgtype)
 446                                          (c-function-arguments type))
 447       (error "Method arguments ~A don't match message ~A" type msgtype))))
 448
 449 (defmethod shared-initialize :after
 450     ((method sod-method) slot-names &key pset)
 451   (declare (ignore slot-names pset))
 452
 453   ;; Check that the arguments are named if we have a method body.
 454   (with-slots (body type) method
 455     (unless (or (not body)
 456                 (every #'argument-name (c-function-arguments type)))
 457       (error "Abstract declarators not permitted in method definitions")))
 458
 459   ;; Check the method type.
 460   (with-slots (message type) method
 461     (check-method-type method message type)))
 462
 463 ;;;--------------------------------------------------------------------------
 464 ;;; Builder macros.
 465
 466 (defmacro define-sod-class (name (&rest superclasses) &body body)
 467   (let ((plist nil)
 468         (classvar (gensym "CLASS")))
 469     (loop
 470       (when (or (null body)
 471                 (not (keywordp (car body))))
 472         (return))
 473       (push (pop body) plist)
 474       (push (pop body) plist))
 475     `(let ((,classvar (make-sod-class ,name
 476                                       (mapcar #'find-sod-class
 477                                               (list ,@superclasses))
 478                                       (make-property-set
 479                                        ,@(nreverse plist)))))
 480        (macrolet ((message (name type &rest plist)
 481                     `(make-sod-message ,',classvar ,name (c-type ,type)
 482                                        (make-property-set ,@plist)))
 483                   (method (nick name type body &rest plist)
 484                     `(make-sod-method ,',classvar ,nick ,name (c-type ,type)
 485                                       ,body (make-property-set ,@plist)))
 486                   (slot (name type &rest plist)
 487                     `(make-sod-slot ,',classvar ,name (c-type ,type)
 488                                     (make-property-set ,@plist)))
 489                   (instance-initializer
 490                       (nick name value-kind value-form &rest plist)
 491                     `(make-sod-instance-initializer ,',classvar ,nick ,name
 492                                                     ,value-kind ,value-form
 493                                                     (make-property-set
 494                                                      ,@plist)))
 495                   (class-initializer
 496                       (nick name value-kind value-form &rest plist)
 497                     `(make-sod-class-initializer ,',classvar ,nick ,name
 498                                                  ,value-kind ,value-form
 499                                                  (make-property-set
 500                                                   ,@plist))))
 501          ,@body
 502          (finalize-sod-class ,classvar)
 503          (add-to-module *module* ,classvar)))))
 504
 505 ;;;----- That's all, folks --------------------------------------------------