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 &optional 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
 103                                           slot pset 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 &optional 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
 131                                             pset 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 &optional 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 &optional 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 &optional location)
 178   (let ((slot (find-instance-slot-by-name class nick slot-name)))
 179     (make-sod-slot-initarg-using-slot class name slot pset location)))
 180
 181 (defmethod make-sod-slot-initarg-using-slot
 182     ((class sod-class) name (slot sod-slot) pset &optional location)
 183   (with-slots (initargs) class
 184     (with-slots ((type %type)) slot
 185       (push (make-instance (get-property pset :initarg-class :symbol
 186                                          'sod-slot-initarg)
 187                            :location (file-location location)
 188                            :class class :name name :type type :slot slot)
 189             initargs))))
 190
 191 (defmethod sod-initarg-default ((initarg sod-initarg)) nil)
 192
 193 (defmethod sod-initarg-argument ((initarg sod-initarg))
 194   (make-argument (sod-initarg-name initarg)
 195                  (sod-initarg-type initarg)
 196                  (sod-initarg-default initarg)))
 197
 198 ;;;--------------------------------------------------------------------------
 199 ;;; Initialization and teardown fragments.
 200
 201 (defmethod make-sod-class-initfrag
 202     ((class sod-class) frag pset &optional location)
 203   (declare (ignore pset location))
 204   (with-slots (initfrags) class
 205     (setf initfrags (append initfrags (list frag)))))
 206
 207 (defmethod make-sod-class-tearfrag
 208     ((class sod-class) frag pset &optional location)
 209   (declare (ignore pset location))
 210   (with-slots (tearfrags) class
 211     (setf tearfrags (append tearfrags (list frag)))))
 212
 213 ;;;--------------------------------------------------------------------------
 214 ;;; Messages.
 215
 216 (defmethod make-sod-message
 217     ((class sod-class) name type pset &optional location)
 218   (with-default-error-location (location)
 219     (let* ((msg-class (or (get-property pset :message-class :symbol)
 220                           (and (get-property pset :combination :keyword)
 221                                'aggregating-message)
 222                           'standard-message))
 223            (message (make-instance msg-class
 224                                    :class class
 225                                    :name name
 226                                    :type type
 227                                    :location (file-location location)
 228                                    :pset pset)))
 229       (with-slots (messages) class
 230         (setf messages (append messages (list message))))
 231       message)))
 232
 233 (defmethod shared-initialize :after
 234     ((message sod-message) slot-names &key pset)
 235   (declare (ignore slot-names pset))
 236   (with-slots ((type %type)) message
 237     (check-message-type message type)))
 238
 239 (defmethod check-message-type ((message sod-message) (type c-function-type))
 240   nil)
 241
 242 (defmethod check-message-type ((message sod-message) (type c-type))
 243   (error "Messages must have function type, not ~A" type))
 244
 245 ;;;--------------------------------------------------------------------------
 246 ;;; Methods.
 247
 248 (defmethod make-sod-method
 249     ((class sod-class) nick name type body pset &optional location)
 250   (with-default-error-location (location)
 251     (let* ((message (find-message-by-name class nick name))
 252            (method (make-sod-method-using-message message class
 253                                                   type body pset
 254                                                   (file-location location))))
 255       (with-slots (methods) class
 256         (setf methods (append methods (list method))))
 257       method)))
 258
 259 (defmethod make-sod-method-using-message
 260     ((message sod-message) (class sod-class) type body pset location)
 261   (make-instance (or (get-property pset :method-class :symbol)
 262                      (sod-message-method-class message class pset))
 263                  :message message
 264                  :class class
 265                  :type type
 266                  :body body
 267                  :location (file-location location)
 268                  :pset pset))
 269
 270 (defmethod sod-message-method-class
 271     ((message sod-message) (class sod-class) pset)
 272   (declare (ignore pset))
 273   'sod-method)
 274
 275 (defmethod shared-initialize :after
 276     ((method sod-method) slot-names &key pset)
 277   (declare (ignore slot-names pset))
 278
 279   ;; Check that the arguments are named if we have a method body.
 280   (with-slots (body (type %type)) method
 281     (unless (or (not body)
 282                 (every (lambda (arg)
 283                          (or (eq arg :ellipsis)
 284                              (argument-name arg)
 285                              (c-type-equal-p (argument-type arg)
 286                                              c-type-void)))
 287                        (c-function-arguments type)))
 288       (error "Abstract declarators not permitted in method definitions")))
 289
 290   ;; Check the method type.
 291   (with-slots (message (type %type)) method
 292     (check-method-type method message type)))
 293
 294 (defmethod check-method-type
 295     ((method sod-method) (message sod-message) (type c-type))
 296   (error "Methods must have function type, not ~A" type))
 297
 298 (export 'check-method-return-type)
 299 (defun check-method-return-type (method-type wanted-type)
 300   "Signal an error unless METHOD-TYPE does not return the WANTED-TYPE."
 301   (let ((method-returns (c-type-subtype method-type)))
 302     (unless (c-type-equal-p method-returns wanted-type)
 303       (error "Method return type ~A should be ~A"
 304              method-returns wanted-type))))
 305
 306 (export 'check-method-return-type-against-message)
 307 (defun check-method-return-type-against-message (method-type message-type)
 308   "Signal an error unless METHOD-TYPE and MESSAGE-TYPE return the same type."
 309   (let ((message-returns (c-type-subtype message-type))
 310         (method-returns (c-type-subtype method-type)))
 311     (unless (c-type-equal-p message-returns method-returns)
 312       (error "Method return type ~A doesn't match message ~A"
 313              method-returns message-returns))))
 314
 315 (export 'check-method-argument-lists)
 316 (defun check-method-argument-lists (method-type message-type)
 317   "Signal an error unless METHOD-TYPE and MESSAGE-TYPE have matching argument
 318    lists.
 319
 320   This checks that (a) the two types have matching lists of mandatory
 321   arguments, and (b) that either both or neither types accept keyword
 322   arguments."
 323   (let ((message-keywords-p (typep message-type 'c-keyword-function-type))
 324         (method-keywords-p (typep method-type 'c-keyword-function-type)))
 325     (cond (message-keywords-p
 326            (unless method-keywords-p
 327              (error "Method must declare a keyword argument list")))
 328           (method-keywords-p
 329            (error "Method must not declare a keyword argument list"))))
 330   (unless (argument-lists-compatible-p (c-function-arguments message-type)
 331                                        (c-function-arguments method-type))
 332     (error "Method arguments ~A don't match message ~A"
 333            method-type message-type)))
 334
 335 (defmethod check-method-type
 336     ((method sod-method) (message sod-message) (type c-function-type))
 337   (with-slots ((msgtype %type)) message
 338     (check-method-return-type-against-message type msgtype)
 339     (check-method-argument-lists type msgtype)))
 340
 341 ;;;----- That's all, folks --------------------------------------------------