[sod] / class-builder.lisp

;;; -*-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."))

(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 (class 'nickname)
    (get-property pset :nick :id (string-downcase (slot-value class 'name))))

  ;; If no metaclass, guess one in a (Lisp) class-specific way.
  (default-slot (class 'metaclass)
    (multiple-value-bind (name floc) (get-property pset :metaclass :id)
      (if floc
	  (find-sod-class name floc)
	  (guess-metaclass class))))

  ;; If no chain-link, then start a new chain here.
  (default-slot (class 'chain-link)
    (multiple-value-bind (name floc) (get-property pset :link :id)
      (if floc
	  (find-sod-class name floc)
	  nil))))

;;;--------------------------------------------------------------------------
;;; 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."))

(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))))
      (check-unused-properties pset))))

(defmethod shared-initialize :after ((slot sod-slot) slot-names &key pset)
  "This method exists so that it isn't an error to provide a :PSET initarg
   to (make-instance 'sod-slot ...).  It does nothing."
  (declare (ignore slot-names pset))
  nil)

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

(defgeneric make-sod-instance-initializer
    (class nick name value-kind value-form pset &optional location)
  (:documentation
   "Construct and attach an instance slot initializer, to CLASS.

   This is the main constructor function for instance initializers.  This is
   a generic function primarily so that the CLASS can intervene in the
   construction process.  The default method looks up the slot using
   FIND-INSTANCE-SLOT-BY-NAME, calls MAKE-SOD-INITIALIZER-USING-SLOT to
   actually make the initializer object, and adds it to the appropriate list
   in CLASS.

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

(defgeneric make-sod-class-initializer
    (class nick name value-kind value-form pset &optional location)
  (:documentation
   "Construct and attach a class slot initializer, to CLASS.

   This is the main constructor function for class initializers.  This is a
   generic function primarily so that the CLASS can intervene in the
   construction process.  The default method looks up the slot using
   FIND-CLASS-SLOT-BY-NAME, calls MAKE-SOD-INITIALIZER-USING-SLOT to actually
   make the initializer object, and adds it to the appropriate list in CLASS.

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

(defgeneric make-sod-initializer-using-slot
    (class slot init-class value-kind value-form pset location)
  (:documentation
   "Common construction protocol for slot initializers.

   This generic function does the common work for constructing instance and
   class initializers.  It can usefully be specialized according to both the
   class and slot types.  The default method uses the :LISP-CLASS property
   (defaulting to INIT-CLASS) 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-INITIALIZER defines
   an :AFTER-method on SHARED-INITIALIZE.

   Diagnosing unused properties is left for the caller (usually
   MAKE-SOD-INSTANCE-INITIALIZER or MAKE-SOD-CLASS-INITIALIZER) to do.  The
   caller is also expected to have set WITH-DEFAULT-ERROR-LOCATION if
   appropriate.

   You are not expected to call this generic function directly; it's more
   useful as a place to hang methods for custom initializer classes."))

(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))))
      (check-unused-properties pset))))

(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))))
      (check-unused-properties pset))))

(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 exists so that it isn't an error to provide a :PSET initarg
   to (make-instance 'sod-initializer ...).  It does nothing."
  (declare (ignore slot-names pset))
  nil)

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

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

   This is the main constructor function for messages.  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-MESSAGE) to choose a (CLOS) class to instantiate.  The message 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-MESSAGE defines an :AFTER-method on SHARED-INITIALIZE.

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

(defgeneric check-message-type (message type)
  (:documentation
   "Check that TYPE is a suitable type for MESSAGE.  Signal errors if not.

   This is separated out of SHARED-INITIALIZE, where it's called, so that it
   can be overridden conveniently by subclasses."))

(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))))
      (check-unused-properties pset))))

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

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

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

(defgeneric make-sod-method
    (class nick name type body pset &optional location)
  (:documentation
   "Construct and attach a new method to CLASS.

   This is the main constructor function for methods.  This is a generic
   function primarily so that the CLASS can intervene in the message lookup
   process, though this is actually a fairly unlikely occurrence.

   The default method looks up the message using FIND-MESSAGE-BY-NAME,
   invokes MAKE-SOD-METHOD-USING-MESSAGE to make the method object, and then
   adds the method to the class's list of methods.  This split allows the
   message class to intervene in the class selection process, for example.

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

(defgeneric make-sod-method-using-message
    (message class type body pset location)
  (:documentation
   "Main construction subroutine for method construction.

   This is a generic function so that it can be specialized according to both
   a class and -- more particularly -- a message.  The default method uses
   the :LISP-CLASS property (defaulting to calling SOD-MESSAGE-METHOD-CLASS)
   to choose a (CLOS) class to instantiate.  The method 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-METHOD defines an :AFTER-method on SHARED-INITIALIZE.

   Diagnosing unused properties is left for the caller (usually
   MAKE-SOD-METHOD) to do.  The caller is also expected to have set
   WITH-DEFAULT-ERROR-LOCATION if appropriate.

   You are not expected to call this generic function directly; it's more
   useful as a place to hang methods for custom initializer classes."))

(defgeneric sod-message-method-class (message class pset)
  (:documentation
   "Return the preferred class for methods on MESSAGE.

   The message can inspect the PSET to decide on a particular message.  A
   :LISP-CLASS property will usually override this decision: it's then the
   programmer's responsibility to ensure that the selected method class is
   appropriate."))

(defgeneric check-method-type (method message type)
  (:documentation
   "Check that TYPE is a suitable type for METHOD.  Signal errors if not.

   This is separated out of SHARED-INITIALIZE, where it's called, so that it
   can be overridden conveniently by subclasses."))

(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)))))
    (check-unused-properties pset)))

(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 check-method-type
    ((method sod-method) (message sod-message) (type c-type))
  (error "Methods must have function type, not ~A" type))

(defun argument-lists-compatible-p (message-args method-args)
  "Compare argument lists for compatibility.

   Return true if METHOD-ARGS is a suitable method argument list
   corresponding to the message argument list MESSAGE-ARGS.  This is the case
   if the lists are the same length, each message argument has a
   corresponding method argument with the same type, and if the message
   arguments end in an ellpisis, the method arguments must end with a
   `va_list' argument.  (We can't pass actual variable argument lists around,
   except as `va_list' objects, which are devilish inconvenient things and
   require much hacking.  See the method combination machinery for details.)"

  (and (= (length message-args) (length method-args))
       (every (lambda (message-arg method-arg)
		(if (eq message-arg :ellipsis)
		    (eq method-arg (c-type va-list))
		    (c-type-equal-p (argument-type message-arg)
				    (argument-type method-arg))))
	      message-args method-args)))

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

(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 #'argument-name (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)))

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

(defmacro define-sod-class (name (&rest superclasses) &body body)
  (let ((plist nil)
	(classvar (gensym "CLASS")))
    (loop
      (when (or (null body)
		(not (keywordp (car body))))
	(return))
      (push (pop body) plist)
      (push (pop body) plist))
    `(let ((,classvar (make-sod-class ,name
				      (mapcar #'find-sod-class
					      (list ,@superclasses))
				      (make-property-set
				       ,@(nreverse plist)))))
       (macrolet ((message (name type &rest plist)
		    `(make-sod-message ,',classvar ,name (c-type ,type)
				       (make-property-set ,@plist)))
		  (method (nick name type body &rest plist)
		    `(make-sod-method ,',classvar ,nick ,name (c-type ,type)
				      ,body (make-property-set ,@plist)))
		  (slot (name type &rest plist)
		    `(make-sod-slot ,',classvar ,name (c-type ,type)
				    (make-property-set ,@plist)))
		  (instance-initializer
		      (nick name value-kind value-form &rest plist)
		    `(make-sod-instance-initializer ,',classvar ,nick ,name
						    ,value-kind ,value-form
						    (make-property-set
						     ,@plist)))
		  (class-initializer
		      (nick name value-kind value-form &rest plist)
		    `(make-sod-class-initializer ,',classvar ,nick ,name
						 ,value-kind ,value-form
						 (make-property-set
						  ,@plist))))
	 ,@body
	 (finalize-sod-class ,classvar)
	 (add-to-module *module* ,classvar)))))

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