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