mdw@git.distorted.org.uk Git - sod/blob - src/class-make-impl.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Class construction protocol implementation
   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 (defmethod guess-metaclass ((class sod-class))
  32   "Default metaclass-guessing function for classes.
  33
  34    Return the most specific metaclass of any of the CLASS's direct
  35    superclasses."
  36
  37   (select-minimal-class-property (sod-class-direct-superclasses class)
  38                                  #'sod-class-metaclass
  39                                  #'sod-subclass-p class "metaclass"))
  40
  41 (defmethod shared-initialize :after ((class sod-class) slot-names &key pset)
  42   "Specific behaviour for SOD class initialization.
  43
  44    Properties inspected are as follows:
  45
  46      * `:metaclass' names the metaclass to use.  If unspecified, this will be
  47        left unbound, and (unless you intervene later) `guess-metaclass' will
  48        be called by `finalize-sod-class' to find a suitable default.
  49
  50      * `:nick' provides a nickname for the class.  If unspecified, a default
  51        (the class's name, forced to lowercase) will be chosen in
  52        `finalize-sod-class'.
  53
  54      * `:link' names the chained superclass.  If unspecified, this class will
  55        be left at the head of its chain.
  56
  57    Usually, the class's metaclass is determined here, either direcly from the
  58    `:metaclass' property or by calling `guess-metaclass'.  Guessing is
  59    inhibited if the `:%bootstrapping' property is non-nil."
  60
  61   ;; If no nickname, copy the class name.  It won't be pretty, though.
  62   (default-slot-from-property (class 'nickname slot-names)
  63       (pset :nick :id)
  64     (string-downcase (slot-value class 'name)))
  65
  66   ;; Set the metaclass if the appropriate property has been provided or we're
  67   ;; not bootstreapping; otherwise leave it unbound for now, and trust the
  68   ;; caller to sort out the mess.
  69   (multiple-value-bind (meta floc) (get-property pset :metaclass :id)
  70     (cond (floc
  71            (setf (slot-value class 'metaclass)
  72                  (with-default-error-location (floc)
  73                    (find-sod-class meta))))
  74           ((not (get-property pset :%bootstrapping :boolean))
  75            (default-slot (class 'metaclass slot-names)
  76              (guess-metaclass class)))))
  77
  78   ;; If no chain-link, then start a new chain here.
  79   (default-slot-from-property (class 'chain-link slot-names)
  80       (pset :link :id link (find-sod-class link))
  81     nil))
  82
  83 ;;;--------------------------------------------------------------------------
  84 ;;; Slots.
  85
  86 (defmethod make-sod-slot
  87     ((class sod-class) name type pset &key location)
  88   (with-default-error-location (location)
  89     (when (typep type 'c-function-type)
  90       (error "Slot declarations cannot have function type"))
  91     (let ((slot (make-instance (get-property pset :slot-class :symbol
  92                                              'sod-slot)
  93                                :class class
  94                                :name name
  95                                :type type
  96                                :location (file-location location)
  97                                :pset pset))
  98           (initarg-name (get-property pset :initarg :id)))
  99       (with-slots (slots) class
 100         (setf slots (append slots (list slot))))
 101       (when initarg-name
 102         (make-sod-slot-initarg-using-slot class initarg-name slot pset
 103                                           :location location))
 104       slot)))
 105
 106 (defmethod shared-initialize :after ((slot sod-slot) slot-names &key pset)
 107   "This method does nothing.
 108
 109    It only exists so that it isn't an error to provide a `:pset' initarg
 110    to (make-instance 'sod-slot ...)."
 111
 112   (declare (ignore slot-names pset)))
 113
 114 ;;;--------------------------------------------------------------------------
 115 ;;; Slot initializers.
 116
 117 (defmethod make-sod-instance-initializer
 118     ((class sod-class) nick name value pset
 119      &key location inhibit-initargs (add-to-class t))
 120   (with-default-error-location (location)
 121     (let* ((slot (find-instance-slot-by-name class nick name))
 122            (initarg-name (get-property pset :initarg :id))
 123            (initializer (and value
 124                              (make-sod-initializer-using-slot
 125                               class slot 'sod-instance-initializer
 126                               value pset (file-location location)))))
 127       (with-slots (instance-initializers) class
 128         (unless (or initarg-name initializer)
 129           (error "Slot initializer declaration with no effect"))
 130         (when (and initarg-name (not inhibit-initargs))
 131           (make-sod-slot-initarg-using-slot class initarg-name slot pset
 132                                             :location location))
 133         (when (and initializer add-to-class)
 134           (setf instance-initializers
 135                 (append instance-initializers (list initializer)))))
 136       initializer)))
 137
 138 (defmethod make-sod-class-initializer
 139     ((class sod-class) nick name value pset &key location (add-to-class t))
 140   (with-default-error-location (location)
 141     (let* ((slot (find-class-slot-by-name class nick name))
 142            (initializer (make-sod-initializer-using-slot
 143                          class slot 'sod-class-initializer
 144                          value pset (file-location location))))
 145       (when add-to-class
 146         (with-slots (class-initializers) class
 147           (setf class-initializers
 148                 (append class-initializers (list initializer)))))
 149       initializer)))
 150
 151 (defmethod make-sod-initializer-using-slot
 152     ((class sod-class) (slot sod-slot) init-class value pset location)
 153   (make-instance (get-property pset :initializer-class :symbol init-class)
 154                  :class class
 155                  :slot slot
 156                  :value value
 157                  :location (file-location location)
 158                  :pset pset))
 159
 160 (defmethod shared-initialize :after
 161     ((init sod-initializer) slot-names &key pset)
 162   "This method does nothing.
 163
 164    It only exists so that it isn't an error to provide a `:pset' initarg
 165    to (make-instance 'sod-initializer ...)."
 166   (declare (ignore slot-names pset))
 167   nil)
 168
 169 (defmethod make-sod-user-initarg
 170     ((class sod-class) name type pset &key default location)
 171   (with-slots (initargs) class
 172     (push (make-instance (get-property pset :initarg-class :symbol
 173                                        'sod-user-initarg)
 174                          :location (file-location location)
 175                          :class class :name name :type type :default default)
 176           initargs)))
 177
 178 (defmethod make-sod-slot-initarg
 179     ((class sod-class) name nick slot-name pset &key location)
 180   (let ((slot (find-instance-slot-by-name class nick slot-name)))
 181     (make-sod-slot-initarg-using-slot class name slot pset
 182                                       :location location)))
 183
 184 (defmethod make-sod-slot-initarg-using-slot
 185     ((class sod-class) name (slot sod-slot) pset &key location)
 186   (with-slots (initargs) class
 187     (with-slots ((type %type)) slot
 188       (setf initargs
 189             (append initargs
 190                     (cons (make-instance (get-property pset :initarg-class
 191                                                        :symbol
 192                                                        'sod-slot-initarg)
 193                                          :location (file-location location)
 194                                          :class class :name name
 195                                          :type type :slot slot)
 196                           nil))))))
 197
 198 (defmethod sod-initarg-default ((initarg sod-initarg)) nil)
 199
 200 (defmethod sod-initarg-argument ((initarg sod-initarg))
 201   (make-argument (sod-initarg-name initarg)
 202                  (sod-initarg-type initarg)
 203                  (sod-initarg-default initarg)))
 204
 205 ;;;--------------------------------------------------------------------------
 206 ;;; Initialization and teardown fragments.
 207
 208 (defmethod make-sod-class-initfrag
 209     ((class sod-class) frag pset &key location)
 210   (declare (ignore pset location))
 211   (with-slots (initfrags) class
 212     (setf initfrags (append initfrags (list frag)))))
 213
 214 (defmethod make-sod-class-tearfrag
 215     ((class sod-class) frag pset &key location)
 216   (declare (ignore pset location))
 217   (with-slots (tearfrags) class
 218     (setf tearfrags (append tearfrags (list frag)))))
 219
 220 ;;;--------------------------------------------------------------------------
 221 ;;; Messages.
 222
 223 (defmethod make-sod-message
 224     ((class sod-class) name type pset &key location)
 225   (with-default-error-location (location)
 226     (let* ((msg-class (or (get-property pset :message-class :symbol)
 227                           (and (get-property pset :combination :keyword)
 228                                'aggregating-message)
 229                           'standard-message))
 230            (message (make-instance msg-class
 231                                    :class class
 232                                    :name name
 233                                    :type type
 234                                    :location (file-location location)
 235                                    :pset pset)))
 236       (with-slots (messages) class
 237         (setf messages (append messages (list message))))
 238       message)))
 239
 240 (defmethod shared-initialize :after
 241     ((message sod-message) slot-names &key pset)
 242   (with-slots ((type %type)) message
 243     (check-message-type message type))
 244   (default-slot-from-property (message 'readonlyp slot-names)
 245       (pset :readonly :boolean)
 246     nil))
 247
 248 (defmethod check-message-type ((message sod-message) (type c-function-type))
 249   nil)
 250
 251 (defmethod check-message-type ((message sod-message) (type c-type))
 252   (error "Messages must have function type, not ~A" type))
 253
 254 ;;;--------------------------------------------------------------------------
 255 ;;; Methods.
 256
 257 (defmethod make-sod-method
 258     ((class sod-class) nick name type body pset &key location)
 259   (with-default-error-location (location)
 260     (let* ((message (find-message-by-name class nick name))
 261            (method (make-sod-method-using-message message class
 262                                                   type body pset
 263                                                   (file-location location))))
 264       (with-slots (methods) class
 265         (setf methods (append methods (list method))))
 266       method)))
 267
 268 (defmethod make-sod-method-using-message
 269     ((message sod-message) (class sod-class) type body pset location)
 270   (make-instance (or (get-property pset :method-class :symbol)
 271                      (sod-message-method-class message class pset))
 272                  :message message
 273                  :class class
 274                  :type type
 275                  :body body
 276                  :location (file-location location)
 277                  :pset pset))
 278
 279 (defmethod sod-message-method-class
 280     ((message sod-message) (class sod-class) pset)
 281   (declare (ignore pset))
 282   'sod-method)
 283
 284 (defmethod shared-initialize :after
 285     ((method sod-method) slot-names &key pset)
 286   (declare (ignore slot-names pset))
 287
 288   ;; Check that the arguments are named if we have a method body.
 289   (with-slots (body (type %type)) method
 290     (unless (or (not body)
 291                 (every (lambda (arg)
 292                          (or (eq arg :ellipsis)
 293                              (argument-name arg)
 294                              (c-type-equal-p (argument-type arg)
 295                                              c-type-void)))
 296                        (c-function-arguments type)))
 297       (error "Abstract declarators not permitted in method definitions")))
 298
 299   ;; Check the method type.
 300   (with-slots (message (type %type)) method
 301     (check-method-type method message type)))
 302
 303 (defmethod check-method-type
 304     ((method sod-method) (message sod-message) (type c-type))
 305   (error "Methods must have function type, not ~A" type))
 306
 307 (export 'check-method-return-type)
 308 (defun check-method-return-type (method-type wanted-type)
 309   "Signal an error unless METHOD-TYPE does not return the WANTED-TYPE."
 310   (let ((method-returns (c-type-subtype method-type)))
 311     (unless (c-type-equal-p method-returns wanted-type)
 312       (error "Method return type ~A should be ~A"
 313              method-returns wanted-type))))
 314
 315 (export 'check-method-return-type-against-message)
 316 (defun check-method-return-type-against-message (method-type message-type)
 317   "Signal an error unless METHOD-TYPE and MESSAGE-TYPE return the same type."
 318   (let ((message-returns (c-type-subtype message-type))
 319         (method-returns (c-type-subtype method-type)))
 320     (unless (c-type-equal-p message-returns method-returns)
 321       (error "Method return type ~A doesn't match message ~A"
 322              method-returns message-returns))))
 323
 324 (export 'check-method-argument-lists)
 325 (defun check-method-argument-lists (method-type message-type)
 326   "Signal an error unless METHOD-TYPE and MESSAGE-TYPE have matching argument
 327    lists.
 328
 329    This checks (a) that the two types have matching lists of mandatory
 330    arguments, and (b) that either both or neither types accept keyword
 331    arguments."
 332   (let ((message-keywords-p (typep message-type 'c-keyword-function-type))
 333         (method-keywords-p (typep method-type 'c-keyword-function-type)))
 334     (cond (message-keywords-p
 335            (unless method-keywords-p
 336              (error "Method must declare a keyword argument list")))
 337           (method-keywords-p
 338            (error "Method must not declare a keyword argument list"))))
 339   (unless (argument-lists-compatible-p (c-function-arguments message-type)
 340                                        (c-function-arguments method-type))
 341     (error "Method arguments ~A don't match message ~A"
 342            method-type message-type)))
 343
 344 (defmethod check-method-type
 345     ((method sod-method) (message sod-message) (type c-function-type))
 346   (with-slots ((msgtype %type)) message
 347     (check-method-return-type-against-message type msgtype)
 348     (check-method-argument-lists type msgtype)))
 349
 350 ;;;----- That's all, folks --------------------------------------------------