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 &key location)
 119   (with-default-error-location (location)
 120     (let* ((slot (find-instance-slot-by-name class nick name))
 121            (initarg-name (get-property pset :initarg :id))
 122            (initializer (and value
 123                              (make-sod-initializer-using-slot
 124                               class slot 'sod-instance-initializer
 125                               value pset (file-location location)))))
 126       (with-slots (instance-initializers) class
 127         (unless (or initarg-name initializer)
 128           (error "Slot initializer declaration with no effect"))
 129         (when initarg-name
 130           (make-sod-slot-initarg-using-slot class initarg-name slot pset
 131                                             :location location))
 132         (when initializer
 133           (setf instance-initializers
 134                 (append instance-initializers (list initializer)))))
 135       initializer)))
 136
 137 (defmethod make-sod-class-initializer
 138     ((class sod-class) nick name value pset &key location)
 139   (with-default-error-location (location)
 140     (let* ((slot (find-class-slot-by-name class nick name))
 141            (initializer (make-sod-initializer-using-slot
 142                          class slot 'sod-class-initializer
 143                          value pset (file-location location))))
 144       (with-slots (class-initializers) class
 145         (setf class-initializers
 146               (append class-initializers (list initializer))))
 147       initializer)))
 148
 149 (defmethod make-sod-initializer-using-slot
 150     ((class sod-class) (slot sod-slot) init-class value pset location)
 151   (make-instance (get-property pset :initializer-class :symbol init-class)
 152                  :class class
 153                  :slot slot
 154                  :value value
 155                  :location (file-location location)
 156                  :pset pset))
 157
 158 (defmethod shared-initialize :after
 159     ((init sod-initializer) slot-names &key pset)
 160   "This method does nothing.
 161
 162    It only exists so that it isn't an error to provide a `:pset' initarg
 163    to (make-instance 'sod-initializer ...)."
 164   (declare (ignore slot-names pset))
 165   nil)
 166
 167 (defmethod make-sod-user-initarg
 168     ((class sod-class) name type pset &key default location)
 169   (with-slots (initargs) class
 170     (push (make-instance (get-property pset :initarg-class :symbol
 171                                        'sod-user-initarg)
 172                          :location (file-location location)
 173                          :class class :name name :type type :default default)
 174           initargs)))
 175
 176 (defmethod make-sod-slot-initarg
 177     ((class sod-class) name nick slot-name pset &key location)
 178   (let ((slot (find-instance-slot-by-name class nick slot-name)))
 179     (make-sod-slot-initarg-using-slot class name slot pset
 180                                       :location location)))
 181
 182 (defmethod make-sod-slot-initarg-using-slot
 183     ((class sod-class) name (slot sod-slot) pset &key location)
 184   (with-slots (initargs) class
 185     (with-slots ((type %type)) slot
 186       (push (make-instance (get-property pset :initarg-class :symbol
 187                                          'sod-slot-initarg)
 188                            :location (file-location location)
 189                            :class class :name name :type type :slot slot)
 190             initargs))))
 191
 192 (defmethod sod-initarg-default ((initarg sod-initarg)) nil)
 193
 194 (defmethod sod-initarg-argument ((initarg sod-initarg))
 195   (make-argument (sod-initarg-name initarg)
 196                  (sod-initarg-type initarg)
 197                  (sod-initarg-default initarg)))
 198
 199 ;;;--------------------------------------------------------------------------
 200 ;;; Initialization and teardown fragments.
 201
 202 (defmethod make-sod-class-initfrag
 203     ((class sod-class) frag pset &key location)
 204   (declare (ignore pset location))
 205   (with-slots (initfrags) class
 206     (setf initfrags (append initfrags (list frag)))))
 207
 208 (defmethod make-sod-class-tearfrag
 209     ((class sod-class) frag pset &key location)
 210   (declare (ignore pset location))
 211   (with-slots (tearfrags) class
 212     (setf tearfrags (append tearfrags (list frag)))))
 213
 214 ;;;--------------------------------------------------------------------------
 215 ;;; Messages.
 216
 217 (defmethod make-sod-message
 218     ((class sod-class) name type pset &key location)
 219   (with-default-error-location (location)
 220     (let* ((msg-class (or (get-property pset :message-class :symbol)
 221                           (and (get-property pset :combination :keyword)
 222                                'aggregating-message)
 223                           'standard-message))
 224            (message (make-instance msg-class
 225                                    :class class
 226                                    :name name
 227                                    :type type
 228                                    :location (file-location location)
 229                                    :pset pset)))
 230       (with-slots (messages) class
 231         (setf messages (append messages (list message))))
 232       message)))
 233
 234 (defmethod shared-initialize :after
 235     ((message sod-message) slot-names &key pset)
 236   (declare (ignore slot-names pset))
 237   (with-slots ((type %type)) message
 238     (check-message-type message type)))
 239
 240 (defmethod check-message-type ((message sod-message) (type c-function-type))
 241   nil)
 242
 243 (defmethod check-message-type ((message sod-message) (type c-type))
 244   (error "Messages must have function type, not ~A" type))
 245
 246 ;;;--------------------------------------------------------------------------
 247 ;;; Methods.
 248
 249 (defmethod make-sod-method
 250     ((class sod-class) nick name type body pset &key location)
 251   (with-default-error-location (location)
 252     (let* ((message (find-message-by-name class nick name))
 253            (method (make-sod-method-using-message message class
 254                                                   type body pset
 255                                                   (file-location location))))
 256       (with-slots (methods) class
 257         (setf methods (append methods (list method))))
 258       method)))
 259
 260 (defmethod make-sod-method-using-message
 261     ((message sod-message) (class sod-class) type body pset location)
 262   (make-instance (or (get-property pset :method-class :symbol)
 263                      (sod-message-method-class message class pset))
 264                  :message message
 265                  :class class
 266                  :type type
 267                  :body body
 268                  :location (file-location location)
 269                  :pset pset))
 270
 271 (defmethod sod-message-method-class
 272     ((message sod-message) (class sod-class) pset)
 273   (declare (ignore pset))
 274   'sod-method)
 275
 276 (defmethod shared-initialize :after
 277     ((method sod-method) slot-names &key pset)
 278   (declare (ignore slot-names pset))
 279
 280   ;; Check that the arguments are named if we have a method body.
 281   (with-slots (body (type %type)) method
 282     (unless (or (not body)
 283                 (every (lambda (arg)
 284                          (or (eq arg :ellipsis)
 285                              (argument-name arg)
 286                              (c-type-equal-p (argument-type arg)
 287                                              c-type-void)))
 288                        (c-function-arguments type)))
 289       (error "Abstract declarators not permitted in method definitions")))
 290
 291   ;; Check the method type.
 292   (with-slots (message (type %type)) method
 293     (check-method-type method message type)))
 294
 295 (defmethod check-method-type
 296     ((method sod-method) (message sod-message) (type c-type))
 297   (error "Methods must have function type, not ~A" type))
 298
 299 (export 'check-method-return-type)
 300 (defun check-method-return-type (method-type wanted-type)
 301   "Signal an error unless METHOD-TYPE does not return the WANTED-TYPE."
 302   (let ((method-returns (c-type-subtype method-type)))
 303     (unless (c-type-equal-p method-returns wanted-type)
 304       (error "Method return type ~A should be ~A"
 305              method-returns wanted-type))))
 306
 307 (export 'check-method-return-type-against-message)
 308 (defun check-method-return-type-against-message (method-type message-type)
 309   "Signal an error unless METHOD-TYPE and MESSAGE-TYPE return the same type."
 310   (let ((message-returns (c-type-subtype message-type))
 311         (method-returns (c-type-subtype method-type)))
 312     (unless (c-type-equal-p message-returns method-returns)
 313       (error "Method return type ~A doesn't match message ~A"
 314              method-returns message-returns))))
 315
 316 (export 'check-method-argument-lists)
 317 (defun check-method-argument-lists (method-type message-type)
 318   "Signal an error unless METHOD-TYPE and MESSAGE-TYPE have matching argument
 319    lists.
 320
 321    This checks (a) that the two types have matching lists of mandatory
 322    arguments, and (b) that either both or neither types accept keyword
 323    arguments."
 324   (let ((message-keywords-p (typep message-type 'c-keyword-function-type))
 325         (method-keywords-p (typep method-type 'c-keyword-function-type)))
 326     (cond (message-keywords-p
 327            (unless method-keywords-p
 328              (error "Method must declare a keyword argument list")))
 329           (method-keywords-p
 330            (error "Method must not declare a keyword argument list"))))
 331   (unless (argument-lists-compatible-p (c-function-arguments message-type)
 332                                        (c-function-arguments method-type))
 333     (error "Method arguments ~A don't match message ~A"
 334            method-type message-type)))
 335
 336 (defmethod check-method-type
 337     ((method sod-method) (message sod-message) (type c-function-type))
 338   (with-slots ((msgtype %type)) message
 339     (check-method-return-type-against-message type msgtype)
 340     (check-method-argument-lists type msgtype)))
 341
 342 ;;;----- That's all, folks --------------------------------------------------