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