src/: Factor out common machinery in `check-method-type' methods.

[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 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, nil is
       stored, 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."

  ;; 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;
  ;; otherwise leave it unbound for now, and we'll sort out the mess during
  ;; finalization.
  (default-slot-from-property (class 'metaclass slot-names)
      (pset :metaclass :id meta (find-sod-class meta)))

  ;; 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 &optional location)
  (with-default-error-location (location)
    (let ((slot (make-instance (get-property pset :slot-class :symbol
					     'sod-slot)
			       :class class
			       :name name
			       :type type
			       :location (file-location location)
			       :pset pset)))
      (with-slots (slots) class
	(setf slots (append slots (list slot))))
      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-kind value-form pset
     &optional location)
  (with-default-error-location (location)
    (let* ((slot (find-instance-slot-by-name class nick name))
	   (initializer (make-sod-initializer-using-slot
			 class slot 'sod-instance-initializer
			 value-kind value-form pset
			 (file-location location))))
      (with-slots (instance-initializers) class
	(setf instance-initializers
	      (append instance-initializers (list initializer))))
      initializer)))

(defmethod make-sod-class-initializer
    ((class sod-class) nick name value-kind value-form pset
     &optional 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-kind value-form 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-kind value-form pset location)
  (make-instance (get-property pset :initializer-class :symbol init-class)
		 :class class
		 :slot slot
		 :value-kind value-kind
		 :value-form value-form
		 :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)

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

(defmethod make-sod-message
    ((class sod-class) name type pset &optional 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 &optional 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 that the two types have matching lists of arguments."
  (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 --------------------------------------------------