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 the two types have matching lists of arguments."
 247   (unless (argument-lists-compatible-p (c-function-arguments message-type)
 248                                        (c-function-arguments method-type))
 249     (error "Method arguments ~A don't match message ~A"
 250            method-type message-type)))
 251
 252 (defmethod check-method-type
 253     ((method sod-method) (message sod-message) (type c-function-type))
 254   (with-slots ((msgtype %type)) message
 255     (check-method-return-type-against-message type msgtype)
 256     (check-method-argument-lists type msgtype)))
 257
 258 ;;;----- That's all, folks --------------------------------------------------