;;; -*-lisp-*-
;;;
;;; Equipment for building classes and friends
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Simple Object Definition system.
;;;
;;; 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)

;;;--------------------------------------------------------------------------
;;; Finding things by name

(defun find-superclass-by-nick (class nick)
  "Returns the superclass of CLASS with nickname NICK, or signals an error."

  ;; Slightly tricky.  The class almost certainly hasn't been finalized, so
  ;; trundle through its superclasses and hope for the best.
  (if (string= nick (sod-class-nickname class))
      class
      (or (some (lambda (super)
		  (find nick (sod-class-precedence-list super)
			:key #'sod-class-nickname
			:test #'string=))
		(sod-class-direct-superclasses class))
	  (error "No superclass of `~A' with nickname `~A'" class nick))))

(flet ((find-item-by-name (what class list name key)
	 (or (find name list :key key :test #'string=)
	     (error "No ~A in class `~A' with name `~A'" what class name))))

  (defun find-instance-slot-by-name (class super-nick slot-name)
    (let ((super (find-superclass-by-nick class super-nick)))
      (find-item-by-name "slot" super (sod-class-slots super)
			 slot-name #'sod-slot-name)))

  (defun find-class-slot-by-name (class super-nick slot-name)
    (let* ((meta (sod-class-metaclass class))
	   (super (find-superclass-by-nick meta super-nick)))
      (find-item-by-name "slot" super (sod-class-slots super)
			 slot-name #'sod-slot-name)))

  (defun find-message-by-name (class super-nick message-name)
    (let ((super (find-superclass-by-nick class super-nick)))
      (find-item-by-name "message" super (sod-class-messages super)
			 message-name #'sod-message-name))))

;;;--------------------------------------------------------------------------
;;; Class construction.

(defun make-sod-class (name superclasses pset &optional location)
  "Construct and return a new SOD class with the given NAME and SUPERCLASSES.

   This is the main constructor function for classes.  The protocol works as
   follows.  The :LISP-CLASS property in PSET is checked: if it exists, it
   must be a symbol naming a (CLOS) class, which is used in place of
   SOD-CLASS.  All of the arguments are then passed to MAKE-INSTANCE; further
   behaviour is left to the standard CLOS instance construction protocol; for
   example, SOD-CLASS defines an :AFTER-method on SHARED-INITIALIZE.

   Minimal sanity checking is done during class construction; most of it is
   left for FINALIZE-SOD-CLASS to do (via CHECK-SOD-CLASS).

   Unused properties in PSET are diagnosed as errors."

  (with-default-error-location (location)
    (let ((class (make-instance (get-property pset :lisp-class :symbol
					      'sod-class)
				:name name
				:superclasses superclasses
				:location (file-location location)
				:pset pset)))
      (check-unused-properties pset)
      class)))

(defgeneric guess-metaclass (class)
  (:documentation
   "Determine a suitable metaclass for the CLASS.

   The default behaviour is to choose the most specific metaclass of any of
   the direct superclasses of CLASS, or to signal an error if that failed."))

;;;--------------------------------------------------------------------------
;;; Slot construction.

(defgeneric make-sod-slot (class name type pset &optional location)
  (:documentation
   "Construct, add, and attach a new slot with given NAME and TYPE, to CLASS.

   This is the main constructor function for slots.  This is a generic
   function primarily so that the CLASS can intervene in the construction
   process.  The default method uses the :LISP-CLASS property (defaulting to
   SOD-SLOT) to choose a (CLOS) class to instantiate.  The slot is then
   constructed by MAKE-INSTANCE passing the arguments as initargs; further
   behaviour is left to the standard CLOS instance construction protocol; for
   example, SOD-SLOT defines an :AFTER-method on SHARED-INITIALIZE.

   Unused properties on PSET are diagnosed as errors."))

;;;--------------------------------------------------------------------------
;;; Slot initializer construction.

;;;--------------------------------------------------------------------------
;;; Message construction.

;;;--------------------------------------------------------------------------
;;; Method construction.

;;;--------------------------------------------------------------------------
;;; Builder macros.

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