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