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

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensble 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."
  (do ((supers (sod-class-direct-superclasses class) (cdr supers))
       (meta nil (let ((candidate (sod-class-metaclass (car supers))))
		   (cond ((null meta) candidate)
			 ((sod-subclass-p meta candidate) meta)
			 ((sod-subclass-p candidate meta) candidate)
			 (t (error "Unable to choose metaclass for `~A'"
				   class))))))
      ((endp supers) meta)))

(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)))

  ;; If no metaclass, guess one in a (Lisp) class-specific way.
  (default-slot-from-property (class 'metaclass slot-names)
      (pset :metaclass :id meta (find-sod-class meta))
    (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 &optional location)
  (with-default-error-location (location)
    (let ((slot (make-instance (get-property pset :lisp-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)))))))

(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)))))))

(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)))))))

(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 :lisp-class :symbol init-class)
		 :class class
		 :slot slot
		 :value-kind value-kind
		 :value-form value-form
		 :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 ((message (make-instance (get-property pset :lisp-class :symbol
						'standard-message)
				  :class class
				  :name name
				  :type type
				  :location (file-location location)
				  :pset pset)))
      (with-slots (messages) class
	(setf messages (append messages (list message)))))))

(defmethod shared-initialize :after
    ((message sod-message) slot-names &key pset)
  (declare (ignore slot-names pset))
  (with-slots (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)))))))

(defmethod make-sod-method-using-message
    ((message sod-message) (class sod-class) type body pset location)
  (make-instance (or (get-property pset :lisp-class :symbol)
		     (sod-message-method-class message class pset))
		 :message message
		 :class class
		 :type type
		 :body body
		 :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) method
    (unless (or (not body)
		(every (lambda (arg)
			 (or (argument-name arg)
			     (eq (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) 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))

(defmethod check-method-type
    ((method sod-method) (message sod-message) (type c-function-type))
  (with-slots ((msgtype type)) message
    (unless (c-type-equal-p (c-type-subtype msgtype)
			    (c-type-subtype type))
      (error "Method return type ~A doesn't match message ~A"
	      (c-type-subtype msgtype) (c-type-subtype type)))
    (unless (argument-lists-compatible-p (c-function-arguments msgtype)
					 (c-function-arguments type))
      (error "Method arguments ~A don't match message ~A" type msgtype))))

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