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