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 Sensble 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 guess-metaclass ((class sod-class))
  32   "Default metaclass-guessing function for classes.
  33
  34    Return the most specific metaclass of any of the CLASS's direct
  35    superclasses."
  36   (do ((supers (sod-class-direct-superclasses class) (cdr supers))
  37        (meta nil (let ((candidate (sod-class-metaclass (car supers))))
  38                    (cond ((null meta) candidate)
  39                          ((sod-subclass-p meta candidate) meta)
  40                          ((sod-subclass-p candidate meta) candidate)
  41                          (t (error "Unable to choose metaclass for `~A'"
  42                                    class))))))
  43       ((endp supers) meta)))
  44
  45 (defmethod shared-initialize :after ((class sod-class) slot-names &key pset)
  46   "Specific behaviour for SOD class initialization.
  47
  48    Properties inspected are as follows:
  49
  50      * `:metaclass' names the metaclass to use.  If unspecified, nil is
  51        stored, and (unless you intervene later) `guess-metaclass' will be
  52        called by `finalize-sod-class' to find a suitable default.
  53
  54      * `:nick' provides a nickname for the class.  If unspecified, a default
  55        (the class's name, forced to lowercase) will be chosen in
  56        `finalize-sod-class'.
  57
  58      * `:link' names the chained superclass.  If unspecified, this class will
  59        be left at the head of its chain."
  60
  61   ;; If no nickname, copy the class name.  It won't be pretty, though.
  62   (default-slot-from-property (class 'nickname slot-names)
  63       (pset :nick :id)
  64     (string-downcase (slot-value class 'name)))
  65
  66   ;; If no metaclass, guess one in a (Lisp) class-specific way.
  67   (default-slot-from-property (class 'metaclass slot-names)
  68       (pset :metaclass :id meta (find-sod-class meta))
  69     (guess-metaclass class))
  70
  71   ;; If no chain-link, then start a new chain here.
  72   (default-slot-from-property (class 'chain-link slot-names)
  73       (pset :link :id link (find-sod-class link))
  74     nil))
  75
  76 ;;;--------------------------------------------------------------------------
  77 ;;; Slots.
  78
  79 (defmethod make-sod-slot
  80     ((class sod-class) name type pset &optional location)
  81   (with-default-error-location (location)
  82     (let ((slot (make-instance (get-property pset :slot-class :symbol
  83                                              'sod-slot)
  84                                :class class
  85                                :name name
  86                                :type type
  87                                :location (file-location location)
  88                                :pset pset)))
  89       (with-slots (slots) class
  90         (setf slots (append slots (list slot)))))))
  91
  92 (defmethod shared-initialize :after ((slot sod-slot) slot-names &key pset)
  93   "This method does nothing.
  94
  95    It only exists so that it isn't an error to provide a `:pset' initarg
  96    to (make-instance 'sod-slot ...)."
  97
  98   (declare (ignore slot-names pset)))
  99
 100 ;;;--------------------------------------------------------------------------
 101 ;;; Slot initializers.
 102
 103 (defmethod make-sod-instance-initializer
 104     ((class sod-class) nick name value-kind value-form pset
 105      &optional location)
 106   (with-default-error-location (location)
 107     (let* ((slot (find-instance-slot-by-name class nick name))
 108            (initializer (make-sod-initializer-using-slot
 109                          class slot 'sod-instance-initializer
 110                          value-kind value-form pset
 111                          (file-location location))))
 112       (with-slots (instance-initializers) class
 113         (setf instance-initializers
 114               (append instance-initializers (list initializer)))))))
 115
 116 (defmethod make-sod-class-initializer
 117     ((class sod-class) nick name value-kind value-form pset
 118      &optional location)
 119   (with-default-error-location (location)
 120     (let* ((slot (find-class-slot-by-name class nick name))
 121            (initializer (make-sod-initializer-using-slot
 122                          class slot 'sod-class-initializer
 123                          value-kind value-form pset
 124                          (file-location location))))
 125       (with-slots (class-initializers) class
 126         (setf class-initializers
 127               (append class-initializers (list initializer)))))))
 128
 129 (defmethod make-sod-initializer-using-slot
 130     ((class sod-class) (slot sod-slot)
 131      init-class value-kind value-form pset location)
 132   (make-instance (get-property pset :initializer-class :symbol init-class)
 133                  :class class
 134                  :slot slot
 135                  :value-kind value-kind
 136                  :value-form value-form
 137                  :location location
 138                  :pset pset))
 139
 140 (defmethod shared-initialize :after
 141     ((init sod-initializer) slot-names &key pset)
 142   "This method does nothing.
 143
 144    It only exists so that it isn't an error to provide a `:pset' initarg
 145    to (make-instance 'sod-initializer ...)."
 146   (declare (ignore slot-names pset))
 147   nil)
 148
 149 ;;;--------------------------------------------------------------------------
 150 ;;; Messages.
 151
 152 (defmethod make-sod-message
 153     ((class sod-class) name type pset &optional location)
 154   (with-default-error-location (location)
 155     (let* ((msg-class (or (get-property pset :message-class :symbol)
 156                           (and (get-property pset :combination :keyword)
 157                                'aggregating-message)
 158                           'standard-message))
 159            (message (make-instance msg-class
 160                                    :class class
 161                                    :name name
 162                                    :type type
 163                                    :location (file-location location)
 164                                    :pset pset)))
 165       (with-slots (messages) class
 166         (setf messages (append messages (list message)))))))
 167
 168 (defmethod shared-initialize :after
 169     ((message sod-message) slot-names &key pset)
 170   (declare (ignore slot-names pset))
 171   (with-slots (type) message
 172     (check-message-type message type)))
 173
 174 (defmethod check-message-type ((message sod-message) (type c-function-type))
 175   nil)
 176
 177 (defmethod check-message-type ((message sod-message) (type c-type))
 178   (error "Messages must have function type, not ~A" type))
 179
 180 ;;;--------------------------------------------------------------------------
 181 ;;; Methods.
 182
 183 (defmethod make-sod-method
 184     ((class sod-class) nick name type body pset &optional location)
 185   (with-default-error-location (location)
 186     (let* ((message (find-message-by-name class nick name))
 187            (method (make-sod-method-using-message message class
 188                                                   type body pset
 189                                                   (file-location location))))
 190       (with-slots (methods) class
 191         (setf methods (append methods (list method)))))))
 192
 193 (defmethod make-sod-method-using-message
 194     ((message sod-message) (class sod-class) type body pset location)
 195   (make-instance (or (get-property pset :method-class :symbol)
 196                      (sod-message-method-class message class pset))
 197                  :message message
 198                  :class class
 199                  :type type
 200                  :body body
 201                  :location location
 202                  :pset pset))
 203
 204 (defmethod sod-message-method-class
 205     ((message sod-message) (class sod-class) pset)
 206   (declare (ignore pset))
 207   'sod-method)
 208
 209 (defmethod shared-initialize :after
 210     ((method sod-method) slot-names &key pset)
 211   (declare (ignore slot-names pset))
 212
 213   ;; Check that the arguments are named if we have a method body.
 214   (with-slots (body type) method
 215     (unless (or (not body)
 216                 (every (lambda (arg)
 217                          (or (argument-name arg)
 218                              (eq (argument-type arg) (c-type void))))
 219                        (c-function-arguments type)))
 220       (error "Abstract declarators not permitted in method definitions")))
 221
 222   ;; Check the method type.
 223   (with-slots (message type) method
 224     (check-method-type method message type)))
 225
 226 (defmethod check-method-type
 227     ((method sod-method) (message sod-message) (type c-type))
 228   (error "Methods must have function type, not ~A" type))
 229
 230 (defmethod check-method-type
 231     ((method sod-method) (message sod-message) (type c-function-type))
 232   (with-slots ((msgtype type)) message
 233     (unless (c-type-equal-p (c-type-subtype msgtype)
 234                             (c-type-subtype type))
 235       (error "Method return type ~A doesn't match message ~A"
 236               (c-type-subtype msgtype) (c-type-subtype type)))
 237     (unless (argument-lists-compatible-p (c-function-arguments msgtype)
 238                                          (c-function-arguments type))
 239       (error "Method arguments ~A don't match message ~A" type msgtype))))
 240
 241 ;;;----- That's all, folks --------------------------------------------------