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