[sod] / src / class-make-impl.lisp

;;; -*-lisp-*-
;;;
;;; Class construction protocol implementation
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensible Object Design, an object system for C.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; SOD is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with SOD; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(cl:in-package #:sod)

;;;--------------------------------------------------------------------------
;;; Classes.

(defmethod guess-metaclass ((class sod-class))
  "Default metaclass-guessing function for classes.

   Return the most specific metaclass of any of the CLASS's direct
   superclasses."

  (select-minimal-class-property (sod-class-direct-superclasses class)
                                 #'sod-class-metaclass
                                 #'sod-subclass-p class "metaclass"))

(defmethod shared-initialize :after ((class sod-class) slot-names &key pset)
  "Specific behaviour for SOD class initialization.

   Properties inspected are as follows:

     * `:metaclass' names the metaclass to use.  If unspecified, this will be
       left unbound, and (unless you intervene later) `guess-metaclass' will
       be called by `finalize-sod-class' to find a suitable default.

     * `:nick' provides a nickname for the class.  If unspecified, a default
       (the class's name, forced to lowercase) will be chosen in
       `finalize-sod-class'.

     * `:link' names the chained superclass.  If unspecified, this class will
       be left at the head of its chain.

   Usually, the class's metaclass is determined here, either direcly from the
   `:metaclass' property or by calling `guess-metaclass'.  Guessing is
   inhibited if the `:%bootstrapping' property is non-nil."

  ;; If no nickname, copy the class name.  It won't be pretty, though.
  (default-slot-from-property (class 'nickname slot-names)
      (pset :nick :id)
    (string-downcase (slot-value class 'name)))

  ;; Set the metaclass if the appropriate property has been provided or we're
  ;; not bootstreapping; otherwise leave it unbound for now, and trust the
  ;; caller to sort out the mess.
  (multiple-value-bind (meta floc) (get-property pset :metaclass :id)
    (cond (floc
           (setf (slot-value class 'metaclass)
                 (with-default-error-location (floc)
                   (find-sod-class meta))))
          ((not (get-property pset :%bootstrapping :boolean))
           (default-slot (class 'metaclass slot-names)
             (guess-metaclass class)))))

  ;; If no chain-link, then start a new chain here.
  (default-slot-from-property (class 'chain-link slot-names)
      (pset :link :id link (find-sod-class link))
    nil))

;;;--------------------------------------------------------------------------
;;; Slots.

(defmethod make-sod-slot
    ((class sod-class) name type pset &key location)
  (with-default-error-location (location)
    (when (typep type 'c-function-type)
      (error "Slot declarations cannot have function type"))
    (let ((slot (make-instance (get-property pset :slot-class :symbol
                                             'sod-slot)
                               :class class
                               :name name
                               :type type
                               :location (file-location location)
                               :pset pset))
          (initarg-name (get-property pset :initarg :id)))
      (with-slots (slots) class
        (setf slots (append slots (list slot))))
      (when initarg-name
        (make-sod-slot-initarg-using-slot class initarg-name slot pset
                                          :location location))
      slot)))

(defmethod shared-initialize :after ((slot sod-slot) slot-names &key pset)
  "This method does nothing.

   It only exists so that it isn't an error to provide a `:pset' initarg
   to (make-instance 'sod-slot ...)."

  (declare (ignore slot-names pset)))

;;;--------------------------------------------------------------------------
;;; Slot initializers.

(defmethod make-sod-instance-initializer
    ((class sod-class) nick name value pset &key location inhibit-initargs)
  (with-default-error-location (location)
    (let* ((slot (find-instance-slot-by-name class nick name))
           (initarg-name (get-property pset :initarg :id))
           (initializer (and value
                             (make-sod-initializer-using-slot
                              class slot 'sod-instance-initializer
                              value pset (file-location location)))))
      (with-slots (instance-initializers) class
        (unless (or initarg-name initializer)
          (error "Slot initializer declaration with no effect"))
        (when (and initarg-name (not inhibit-initargs))
          (make-sod-slot-initarg-using-slot class initarg-name slot pset
                                            :location location))
        (when initializer
          (setf instance-initializers
                (append instance-initializers (list initializer)))))
      initializer)))

(defmethod make-sod-class-initializer
    ((class sod-class) nick name value pset &key location)
  (with-default-error-location (location)
    (let* ((slot (find-class-slot-by-name class nick name))
           (initializer (make-sod-initializer-using-slot
                         class slot 'sod-class-initializer
                         value pset (file-location location))))
      (with-slots (class-initializers) class
        (setf class-initializers
              (append class-initializers (list initializer))))
      initializer)))

(defmethod make-sod-initializer-using-slot
    ((class sod-class) (slot sod-slot) init-class value pset location)
  (make-instance (get-property pset :initializer-class :symbol init-class)
                 :class class
                 :slot slot
                 :value value
                 :location (file-location location)
                 :pset pset))

(defmethod shared-initialize :after
    ((init sod-initializer) slot-names &key pset)
  "This method does nothing.

   It only exists so that it isn't an error to provide a `:pset' initarg
   to (make-instance 'sod-initializer ...)."
  (declare (ignore slot-names pset))
  nil)

(defmethod make-sod-user-initarg
    ((class sod-class) name type pset &key default location)
  (with-slots (initargs) class
    (push (make-instance (get-property pset :initarg-class :symbol
                                       'sod-user-initarg)
                         :location (file-location location)
                         :class class :name name :type type :default default)
          initargs)))

(defmethod make-sod-slot-initarg
    ((class sod-class) name nick slot-name pset &key location)
  (let ((slot (find-instance-slot-by-name class nick slot-name)))
    (make-sod-slot-initarg-using-slot class name slot pset
                                      :location location)))

(defmethod make-sod-slot-initarg-using-slot
    ((class sod-class) name (slot sod-slot) pset &key location)
  (with-slots (initargs) class
    (with-slots ((type %type)) slot
      (setf initargs
            (append initargs
                    (cons (make-instance (get-property pset :initarg-class
                                                       :symbol
                                                       'sod-slot-initarg)
                                         :location (file-location location)
                                         :class class :name name
                                         :type type :slot slot)
                          nil))))))

(defmethod sod-initarg-default ((initarg sod-initarg)) nil)

(defmethod sod-initarg-argument ((initarg sod-initarg))
  (make-argument (sod-initarg-name initarg)
                 (sod-initarg-type initarg)
                 (sod-initarg-default initarg)))

;;;--------------------------------------------------------------------------
;;; Initialization and teardown fragments.

(defmethod make-sod-class-initfrag
    ((class sod-class) frag pset &key location)
  (declare (ignore pset location))
  (with-slots (initfrags) class
    (setf initfrags (append initfrags (list frag)))))

(defmethod make-sod-class-tearfrag
    ((class sod-class) frag pset &key location)
  (declare (ignore pset location))
  (with-slots (tearfrags) class
    (setf tearfrags (append tearfrags (list frag)))))

;;;--------------------------------------------------------------------------
;;; Messages.

(defmethod make-sod-message
    ((class sod-class) name type pset &key location)
  (with-default-error-location (location)
    (let* ((msg-class (or (get-property pset :message-class :symbol)
                          (and (get-property pset :combination :keyword)
                               'aggregating-message)
                          'standard-message))
           (message (make-instance msg-class
                                   :class class
                                   :name name
                                   :type type
                                   :location (file-location location)
                                   :pset pset)))
      (with-slots (messages) class
        (setf messages (append messages (list message))))
      message)))

(defmethod shared-initialize :after
    ((message sod-message) slot-names &key pset)
  (declare (ignore slot-names pset))
  (with-slots ((type %type)) message
    (check-message-type message type)))

(defmethod check-message-type ((message sod-message) (type c-function-type))
  nil)

(defmethod check-message-type ((message sod-message) (type c-type))
  (error "Messages must have function type, not ~A" type))

;;;--------------------------------------------------------------------------
;;; Methods.

(defmethod make-sod-method
    ((class sod-class) nick name type body pset &key location)
  (with-default-error-location (location)
    (let* ((message (find-message-by-name class nick name))
           (method (make-sod-method-using-message message class
                                                  type body pset
                                                  (file-location location))))
      (with-slots (methods) class
        (setf methods (append methods (list method))))
      method)))

(defmethod make-sod-method-using-message
    ((message sod-message) (class sod-class) type body pset location)
  (make-instance (or (get-property pset :method-class :symbol)
                     (sod-message-method-class message class pset))
                 :message message
                 :class class
                 :type type
                 :body body
                 :location (file-location location)
                 :pset pset))

(defmethod sod-message-method-class
    ((message sod-message) (class sod-class) pset)
  (declare (ignore pset))
  'sod-method)

(defmethod shared-initialize :after
    ((method sod-method) slot-names &key pset)
  (declare (ignore slot-names pset))

  ;; Check that the arguments are named if we have a method body.
  (with-slots (body (type %type)) method
    (unless (or (not body)
                (every (lambda (arg)
                         (or (eq arg :ellipsis)
                             (argument-name arg)
                             (c-type-equal-p (argument-type arg)
                                             c-type-void)))
                       (c-function-arguments type)))
      (error "Abstract declarators not permitted in method definitions")))

  ;; Check the method type.
  (with-slots (message (type %type)) method
    (check-method-type method message type)))

(defmethod check-method-type
    ((method sod-method) (message sod-message) (type c-type))
  (error "Methods must have function type, not ~A" type))

(export 'check-method-return-type)
(defun check-method-return-type (method-type wanted-type)
  "Signal an error unless METHOD-TYPE does not return the WANTED-TYPE."
  (let ((method-returns (c-type-subtype method-type)))
    (unless (c-type-equal-p method-returns wanted-type)
      (error "Method return type ~A should be ~A"
             method-returns wanted-type))))

(export 'check-method-return-type-against-message)
(defun check-method-return-type-against-message (method-type message-type)
  "Signal an error unless METHOD-TYPE and MESSAGE-TYPE return the same type."
  (let ((message-returns (c-type-subtype message-type))
        (method-returns (c-type-subtype method-type)))
    (unless (c-type-equal-p message-returns method-returns)
      (error "Method return type ~A doesn't match message ~A"
             method-returns message-returns))))

(export 'check-method-argument-lists)
(defun check-method-argument-lists (method-type message-type)
  "Signal an error unless METHOD-TYPE and MESSAGE-TYPE have matching argument
   lists.

   This checks (a) that the two types have matching lists of mandatory
   arguments, and (b) that either both or neither types accept keyword
   arguments."
  (let ((message-keywords-p (typep message-type 'c-keyword-function-type))
        (method-keywords-p (typep method-type 'c-keyword-function-type)))
    (cond (message-keywords-p
           (unless method-keywords-p
             (error "Method must declare a keyword argument list")))
          (method-keywords-p
           (error "Method must not declare a keyword argument list"))))
  (unless (argument-lists-compatible-p (c-function-arguments message-type)
                                       (c-function-arguments method-type))
    (error "Method arguments ~A don't match message ~A"
           method-type message-type)))

(defmethod check-method-type
    ((method sod-method) (message sod-message) (type c-function-type))
  (with-slots ((msgtype %type)) message
    (check-method-return-type-against-message type msgtype)
    (check-method-argument-lists type msgtype)))

;;;----- That's all, folks --------------------------------------------------