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