;;; -*-lisp-*-
;;;
;;; Method combination 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)

;;;--------------------------------------------------------------------------
;;; Message classes.

(export 'basic-message)
(defclass basic-message (sod-message)
  ((argument-tail :type list :reader sod-message-argument-tail)
   (no-varargs-tail :type list :reader sod-message-no-varargs-tail))
  (:documentation
   "Base class for built-in message classes.

   Provides the basic functionality for the built-in method combinations.
   This is a separate class so that `special effect' messages can avoid
   inheriting its default behaviour.

   The function type protocol is implemented on `basic-message' using slot
   reader methods.  The actual values are computed on demand in methods
   defined on `slot-unbound'."))

(defmethod slot-unbound (class
			 (message basic-message)
			 (slot-name (eql 'argument-tail)))
  (declare (ignore class))
  (let ((seq 0))
    (setf (slot-value message 'argument-tail)
	  (mapcar (lambda (arg)
		    (if (or (eq arg :ellipsis) (argument-name arg)) arg
			(make-argument (make-instance 'temporary-argument
						      :tag (prog1 seq
							     (incf seq)))
				       (argument-type arg))))
		  (c-function-arguments (sod-message-type message))))))

(defmethod slot-unbound (class
			 (message basic-message)
			 (slot-name (eql 'no-varargs-tail)))
  (declare (ignore class))
  (setf (slot-value message 'no-varargs-tail)
	(mapcar (lambda (arg)
		  (if (eq arg :ellipsis)
		      (make-argument *sod-ap* (c-type va-list))
		      arg))
		(sod-message-argument-tail message))))

(defmethod sod-message-method-class
    ((message basic-message) (class sod-class) pset)
  (let ((role (get-property pset :role :keyword nil)))
    (case role
      ((:before :after) 'daemon-direct-method)
      (:around 'delegating-direct-method)
      ((nil) (error "How odd: a primary method slipped through the net"))
      (t (error "Unknown method role ~A" role)))))

(export 'simple-message)
(defclass simple-message (basic-message)
  ()
  (:documentation
   "Base class for messages with `simple' method combinations.

   A simple method combination is one which has only one method role other
   than the `before', `after' and `around' methods provided by
   `basic-message'.  We call these `primary' methods, and the programmer
   designates them by not specifying an explicit role.

   If the programmer doesn't define any primary methods then the effective
   method is null -- i.e., the method entry pointer shows up as a null
   pointer."))

(defmethod sod-message-method-class
    ((message simple-message) (class sod-class) pset)
  (if (get-property pset :role :keyword nil)
      (call-next-method)
      (primary-method-class message)))

(defmethod primary-method-class ((message simple-message))
  'basic-direct-method)

;;;--------------------------------------------------------------------------
;;; Direct method classes.

(export 'basic-direct-method)
(defclass basic-direct-method (sod-method)
  ((role :initarg :role :type symbol :reader sod-method-role)
   (function-type :type c-function-type :reader sod-method-function-type))
  (:documentation
   "Base class for built-in direct method classes.

   Provides the basic functionality for the built-in direct-method classes.
   This is a separate class so that `special effect' methods can avoid
   inheriting its default behaviour and slots.

   A basic method can be assigned a `role', which may be set either as an
   initarg or using the `:role' property.  Roles are used for method
   categorization.

   The function type protocol is implemented on `basic-direct-method' using
   slot reader methods.  The actual values are computed on demand in methods
   defined on `slot-unbound'."))

(defmethod shared-initialize :after
    ((method basic-direct-method) slot-names &key pset)
  (declare (ignore slot-names))
  (default-slot (method 'role) (get-property pset :role :keyword nil)))

(defmethod slot-unbound
    (class (method basic-direct-method) (slot-name (eql 'function-type)))
  (declare (ignore class))
  (let ((type (sod-method-type method)))
    (setf (slot-value method 'function-type)
	  (c-type (fun (lisp (c-type-subtype type))
		       ("me" (* (class (sod-method-class method))))
		       . (c-function-arguments type))))))

(defmethod sod-method-function-name ((method basic-direct-method))
  (with-slots (class role message) method
    (format nil "~A__~@[~(~A~)_~]method_~A__~A" class role
	    (sod-class-nickname (sod-message-class message))
	    (sod-message-name message))))

(export 'daemon-direct-method)
(defclass daemon-direct-method (basic-direct-method)
  ()
  (:documentation
   "A daemon direct method is invoked for side effects and cannot override.

   This is the direct method class for `before' and `after' methods, which
   cannot choose to override the remaining methods and are not involved in
   the computation of the final result.

   In C terms, a daemon method must return `void', and is not passed a
   `next_method' pointer."))

(defmethod check-method-type ((method daemon-direct-method)
			      (message sod-message)
			      (type c-function-type))
  (with-slots ((msgtype type)) message
    (unless (c-type-equal-p (c-type-subtype type) (c-type void))
      (error "Method return type ~A must be `void'" (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))))

(export 'delegating-direct-method)
(defclass delegating-direct-method (basic-direct-method)
  ((next-method-type :type c-function-type
		     :reader sod-method-next-method-type))
  (:documentation
   "A delegating direct method can choose to override other methods.

   This is the direct method class for `around' and standard-method-
   combination primary methods, which are given the choice of computing the
   entire method's result or delegating to (usually) less-specific methods.

   In C terms, a delegating method is passed a `next_method' pointer so that
   it can delegate part of its behaviour.  (A delegating direct method for a
   varargs message is also given an additional `va_list' argument,
   conventionally named `sod__ap_master', which it is expected to pass on to
   its `next_method' function if necessary.)

   The function type protocol is implemented on `delegating-direct-method'
   using slot reader methods.  The actual values are computed on demand in
   methods defined on `slot-unbound'."))

(defmethod slot-unbound (class
			 (method delegating-direct-method)
			 (slot-name (eql 'next-method-type)))
  (declare (ignore class))
  (let* ((message (sod-method-message method))
	 (type (sod-message-type message)))
    (setf (slot-value method 'next-method-type)
	  (c-type (fun (lisp (c-type-subtype type))
		       ("me" (* (class (sod-method-class method))))
		       .
		       (c-function-arguments type))))))

(defmethod slot-unbound (class
			 (method delegating-direct-method)
			 (slot-name (eql 'function-type)))
  (declare (ignore class))
  (let* ((message (sod-method-message method))
	 (type (sod-method-type method))
	 (method-args (c-function-arguments type)))
    (setf (slot-value method 'function-type)
	  (c-type (fun (lisp (c-type-subtype type))
		       ("me" (* (class (sod-method-class method))))
		       ("next_method" (* (lisp (commentify-function-type
						(sod-method-next-method-type
						 method)))))
		       .
		       (if (varargs-message-p message)
			   (cons (make-argument *sod-master-ap*
						(c-type va-list))
				 method-args)
			   method-args))))))

;;;--------------------------------------------------------------------------
;;; Effective method classes.

(export 'basic-effective-method)
(defclass basic-effective-method (effective-method)
  ((around-methods :initarg :around-methods :initform nil
		   :type list :reader effective-method-around-methods)
   (before-methods :initarg :before-methods :initform nil
		   :type list :reader effective-method-before-methods)
   (after-methods :initarg :after-methods :initform nil
		  :type list :reader effective-method-after-methods)
   (basic-argument-names :type list
			 :reader effective-method-basic-argument-names)
   (functions :type list :reader effective-method-functions))
  (:documentation
   "Base class for built-in effective method classes.

   This class maintains lists of the applicable `before', `after' and
   `around' methods and provides behaviour for invoking these methods
   correctly.

   The argument names protocol is implemented on `basic-effective-method'
   using a slot reader method.  The actual values are computed on demand in
   methods defined on `slot-unbound'."))

(defmethod slot-unbound (class
			 (method basic-effective-method)
			 (slot-name (eql 'basic-argument-names)))
  (declare (ignore class))
  (let ((message (effective-method-message method)))
    (setf (slot-value method 'basic-argument-names)
	  (subst *sod-master-ap* *sod-ap*
		 (mapcar #'argument-name
			 (sod-message-no-varargs-tail message))))))

(defmethod effective-method-function-name ((method effective-method))
  (let* ((class (effective-method-class method))
	 (message (effective-method-message method))
	 (message-class (sod-message-class message)))
    (format nil "~A__emethod_~A__~A"
	    class
	    (sod-class-nickname message-class)
	    (sod-message-name message))))

(defmethod slot-unbound
    (class (method basic-effective-method) (slot-name (eql 'functions)))
  (declare (ignore class))
  (setf (slot-value method 'functions)
	(compute-method-entry-functions method)))

(export 'simple-effective-method)
(defclass simple-effective-method (basic-effective-method)
  ((primary-methods :initarg :primary-methods :initform nil
		    :type list :reader effective-method-primary-methods))
  (:documentation
   "Effective method counterpart to `simple-message'."))

(defmethod shared-initialize :after
    ((method simple-effective-method) slot-names &key direct-methods)
  (declare (ignore slot-names))
  (categorize (method direct-methods :bind ((role (sod-method-role method))))
      ((primary (null role))
       (before (eq role :before))
       (after (eq role :after))
       (around (eq role :around)))
    (with-slots (primary-methods before-methods after-methods around-methods)
	method
      (setf primary-methods primary
	    before-methods before
	    after-methods (reverse after)
	    around-methods around))))

;;;--------------------------------------------------------------------------
;;; Code generation.

(defmethod shared-initialize :after
    ((codegen method-codegen) slot-names &key)
  (declare (ignore slot-names))
  (with-slots (message target) codegen
    (setf target
	  (if (eq (c-type-subtype (sod-message-type message)) (c-type void))
	      :void
	      :return))))

;;;--------------------------------------------------------------------------
;;; Invoking direct methods.

(export 'basic-effective-method-body)
(defun basic-effective-method-body (codegen target method body)
  "Build the common method-invocation structure.

   Writes to CODEGEN some basic method-invocation instructions.  It invokes
   the `around' methods, from most- to least-specific.  If they all delegate,
   then the `before' methods are run, most-specific first; next, the
   instructions generated by BODY (invoked with a target argument); then, the
   `after' methods are run, least-specific first; and, finally, the value
   delivered by the BODY is returned to the `around' methods.  The result
   returned by the outermost `around' method -- or, if there are none,
   delivered by the BODY -- is finally delivered to the TARGET."

  (with-slots (message class before-methods after-methods around-methods)
      method
    (let* ((message-type (sod-message-type message))
	   (return-type (c-type-subtype message-type))
	   (basic-tail (effective-method-basic-argument-names method)))
      (flet ((method-kernel (target)
	       (dolist (before before-methods)
		 (invoke-method codegen :void basic-tail before))
	       (if (null after-methods)
		   (funcall body target)
		   (convert-stmts codegen target return-type
				  (lambda (target)
				    (funcall body target)
				    (dolist (after (reverse after-methods))
				      (invoke-method codegen :void
						     basic-tail after)))))))
	(invoke-delegation-chain codegen target basic-tail
				 around-methods #'method-kernel)))))

;;;--------------------------------------------------------------------------
;;; Method entry points.

(defparameter *method-entry-inline-threshold* 200
  "Threshold below which effective method bodies are inlined into entries.

   After the effective method body has been computed, we calculate its
   metric, multiply by the number of entries we need to generate, and compare
   it with this threshold.  If the metric is below the threshold then we
   fold the method body into the entry functions; otherwise we split the
   effective method out into its own function.")

(defmethod method-entry-function-name
    ((method effective-method) (chain-head sod-class))
  (let* ((class (effective-method-class method))
	 (message (effective-method-message method))
	 (message-class (sod-message-class message)))
    (if (or (not (slot-boundp method 'functions))
	    (slot-value method 'functions))
	(format nil "~A__mentry_~A__~A__chain_~A"
		class
		(sod-class-nickname message-class)
		(sod-message-name message)
		(sod-class-nickname chain-head))
	0)))

(defmethod method-entry-function-type ((entry method-entry))
  (let* ((method (method-entry-effective-method entry))
	 (message (effective-method-message method))
	 (type (sod-message-type message)))
    (c-type (fun (lisp (c-type-subtype type))
		 ("me" (* (class (method-entry-chain-tail entry))))
		 . (sod-message-argument-tail message)))))

(defmethod make-method-entry ((method basic-effective-method)
			      (chain-head sod-class) (chain-tail sod-class))
  (make-instance 'method-entry
		 :method method
		 :chain-head chain-head
		 :chain-tail chain-tail))

(defmethod compute-method-entry-functions ((method basic-effective-method))

  ;; OK, there's quite a lot of this, so hold tight.
  ;;
  ;; The first thing we need to do is find all of the related objects.  This
  ;; is a bit verbose but fairly straightforward.
  ;;
  ;; Next, we generate the effective method body -- using `compute-effective-
  ;; method-body' of all things.  This gives us the declarations and body for
  ;; an effective method function, but we don't have an actual function yet.
  ;;
  ;; Now we look at the chains which are actually going to need a method
  ;; entry: only those chains whose tail (most specific) class is a
  ;; superclass of the class which defined the message need an entry.  We
  ;; build a list of these tail classes.
  ;;
  ;; Having done this, we decide whether it's better to generate a standalone
  ;; effective-method function and call it from each of the method entries,
  ;; or to inline the effective method body into each of the entries.
  ;;
  ;; Most of the complexity here comes from (a) dealing with the two
  ;; different strategies for constructing method entry functions and (b)
  ;; (unsurprisingly) the mess involved with dealing with varargs messages.

  (let* ((message (effective-method-message method))
	 (class (effective-method-class method))
	 (message-class (sod-message-class message))
	 (return-type (c-type-subtype (sod-message-type message)))
	 (codegen (make-instance 'method-codegen
				 :message message
				 :class class
				 :method method))

	 ;; Effective method function details.
	 (emf-name (effective-method-function-name method))
	 (ilayout-type (c-type (* (struct (ilayout-struct-tag class)))))
	 (emf-arg-tail (mapcar (lambda (arg)
				 (if (eq (argument-name arg) *sod-ap*)
				     (make-argument *sod-master-ap*
						    (c-type va-list))
				     arg))
			       (sod-message-no-varargs-tail message)))
	 (emf-type (c-type (fun (lisp return-type)
				("sod__obj" (lisp ilayout-type))
				. (sod-message-no-varargs-tail message))))

	 ;; Method entry details.
	 (chain-tails (remove-if-not (lambda (super)
				       (sod-subclass-p super message-class))
				     (mapcar #'car
					     (sod-class-chains class))))
	 (n-entries (length chain-tails))
	 (entry-args (sod-message-argument-tail message))
	 (parm-n (do ((prev "me" (car args))
		      (args entry-args (cdr args)))
		     ((endp args) nil)
		   (when (eq (car args) :ellipsis)
		     (return prev))))
	 (entry-target (codegen-target codegen)))

    (flet ((setup-entry (tail)
	     (let ((head (sod-class-chain-head tail)))
	       (codegen-push codegen)
	       (ensure-var codegen "sod__obj" ilayout-type
			   (make-convert-to-ilayout-inst class
							 head "me"))))
	   (varargs-prologue ()
	     (ensure-var codegen *sod-master-ap* (c-type va-list))
	     (emit-inst codegen
			(make-va-start-inst *sod-master-ap* parm-n)))
	   (varargs-epilogue ()
	     (emit-inst codegen (make-va-end-inst *sod-master-ap*)))
	   (finish-entry (tail)
	     (let* ((head (sod-class-chain-head tail))
		    (name (method-entry-function-name method head))
		    (type (c-type (fun (lisp return-type)
				       ("me" (* (class tail)))
				       . entry-args))))
	       (codegen-pop-function codegen name type))))

      ;; Generate the method body.  We'll work out what to do with it later.
      (codegen-push codegen)
      (let* ((result (if (eq return-type c-type-void) nil
			 (temporary-var codegen return-type)))
	     (emf-target (or result :void)))
	(compute-effective-method-body method codegen emf-target)
	(multiple-value-bind (vars insts) (codegen-pop codegen)
	  (cond ((or (= n-entries 1)
		     (<= (* n-entries (reduce #'+ insts :key #'inst-metric))
			 *method-entry-inline-threshold*))

		 ;; The effective method body is simple -- or there's only
		 ;; one of them.  We'll inline the method body into the entry
		 ;; functions.
		 (dolist (tail chain-tails)
		   (setup-entry tail)
		   (dolist (var vars)
		     (if (typep var 'var-inst)
			 (ensure-var codegen (inst-name var)
				     (inst-type var) (inst-init var))
			 (emit-decl codegen var)))
		   (when parm-n (varargs-prologue))
		   (emit-insts codegen insts)
		   (when parm-n (varargs-epilogue))
		   (deliver-expr codegen entry-target result)
		   (finish-entry tail)))

		(t

		 ;; The effective method body is complicated and we'd need
		 ;; more than one copy.  We'll generate an effective method
		 ;; function and call it a lot.
		 (codegen-build-function codegen emf-name emf-type vars
		  (nconc insts (and result
				    (list (make-return-inst result)))))

		 (let ((call (make-call-inst emf-name
			      (cons "sod__obj" (mapcar #'argument-name
						       emf-arg-tail)))))
		   (dolist (tail chain-tails)
		     (setup-entry tail)
		     (cond (parm-n
			    (varargs-prologue)
			    (convert-stmts codegen entry-target return-type
					   (lambda (target)
					     (deliver-expr codegen
							   target call)
					     (varargs-epilogue))))
			   (t
			    (deliver-expr codegen entry-target call)))
		     (finish-entry tail)))))))

      (codegen-functions codegen))))

(defmethod compute-method-entry-functions
    ((method simple-effective-method))
  (if (effective-method-primary-methods method)
      (call-next-method)
      nil))

(defmethod compute-effective-method-body
    ((method simple-effective-method) codegen target)
  (basic-effective-method-body codegen target method
			       (lambda (target)
				 (simple-method-body method
						     codegen
						     target))))

;;;--------------------------------------------------------------------------
;;; Standard method combination.

(export 'standard-message)
(defclass standard-message (simple-message)
  ()
  (:documentation
   "Message class for standard method combinations.

   Standard method combination is a simple method combination where the
   primary methods are invoked as a delegation chain, from most- to
   least-specific."))

(export 'standard-effective-method)
(defclass standard-effective-method (simple-effective-method) ()
  (:documentation "Effective method counterpart to `standard-message'."))

(defmethod primary-method-class ((message standard-message))
  'delegating-direct-method)

(defmethod message-effective-method-class ((message standard-message))
  'standard-effective-method)

(defmethod simple-method-body
    ((method standard-effective-method) codegen target)
  (invoke-delegation-chain codegen
			   target
			   (effective-method-basic-argument-names method)
			   (effective-method-primary-methods method)
			   nil))

;;;--------------------------------------------------------------------------
;;; Aggregate method combinations.

(export 'aggregating-message)
(defclass aggregating-message (simple-message)
  ((combination :initarg :combination :type keyword
		:reader message-combination)
   (kernel-function :type function :reader message-kernel-function))
  (:documentation
   "Message class for aggregating method combinations.

   An aggregating method combination invokes the primary methods in order,
   most-specific first, collecting their return values, and combining them
   together in some way to produce a result for the effective method as a
   whole.

   Mostly, this is done by initializing an accumulator to some appropriate
   value, updating it with the result of each primary method in turn, and
   finally returning some appropriate output function of it.  The order is
   determined by the `:most-specific' property, which may have the value
   `:first' or `:last'.

   The `progn' method combination is implemented as a slightly weird special
   case of an aggregating method combination with a trivial state.  More
   typical combinations are `:sum', `:product', `:min', `:max', `:and', and
   `:or'.  Finally, there's a `custom' combination which uses user-supplied
   code fragments to stitch everything together."))

(export 'aggregating-message-properties)
(defgeneric aggregating-message-properties (message combination)
  (:documentation
   "Return a description of the properties needed by the method COMBINATION.

   The description should be a plist of alternating property name and type
   keywords.  The named properties will be looked up in the pset supplied at
   initialization time, and supplied to `compute-aggregating-message-kernel'
   as keyword arguments.  Defaults can be supplied in method BVLs.

   The default is not to capture any property values.

   The reason for this is as not to retain the pset beyond message object
   initialization.")
  (:method (message combination) nil))

(export 'compute-aggregating-message-kernel)
(defgeneric compute-aggregating-message-kernel
    (message combination codegen target methods arg-names &key)
  (:documentation
   "Determine how to aggregate the direct methods for an aggregating message.

   The return value is a function taking arguments (CODEGEN TARGET ARG-NAMES
   METHODS): it should emit, to CODEGEN, an appropriate effective-method
   kernel which invokes the listed direct METHODS, in the appropriate order,
   collects and aggregates their values, and delivers to TARGET the final
   result of the method kernel.

   The easy way to implement this method is to use the macro
   `define-aggregating-method-combination'."))

(defmethod shared-initialize :before
    ((message aggregating-message) slot-names &key pset)
  (declare (ignore slot-names))
  (with-slots (combination kernel-function) message
    (let ((most-specific (get-property pset :most-specific :keyword :first))
	  (comb (get-property pset :combination :keyword)))

      ;; Check that we've been given a method combination and make sure it
      ;; actually exists.
      (unless comb
	(error "The `combination' property is required."))
      (unless (some (lambda (method)
		      (let* ((specs (method-specializers method))
			     (message-spec (car specs))
			     (combination-spec (cadr specs)))
			(and (typep message-spec 'class)
			     (typep message message-spec)
			     (typep combination-spec 'eql-specializer)
			     (eq (eql-specializer-object combination-spec)
				 comb))))
		    (generic-function-methods
		     #'compute-aggregating-message-kernel))
	(error "Unknown method combination `~(~A~)'." comb))
      (setf combination comb)

      ;; Make sure the ordering is actually valid.
      (unless (member most-specific '(:first :last))
	(error "The `most_specific' property must be `first' or `last'."))

      ;; Set up the function which will compute the kernel.
      (let ((magic (cons nil nil))
	    (keys nil))

	;; Collect the property values wanted by the method combination.
	(do ((want (aggregating-message-properties message comb)
		   (cddr want)))
	    ((endp want))
	  (let* ((name (car want))
		 (type (cadr want))
		 (prop (get-property pset name type magic)))
	    (unless (eq prop magic)
	      (setf keys (list* name prop keys)))))

	;; Set the kernel function for later.
	(setf kernel-function
	      (lambda (codegen target arg-names methods)
		(apply #'compute-aggregating-message-kernel
		       message comb
		       codegen target
		       (ecase most-specific
			 (:first methods)
			 (:last (setf methods (reverse methods))))
		       arg-names
		       keys)))))))

(export 'check-aggregating-message-type)
(defgeneric check-aggregating-message-type (message combination type)
  (:documentation
   "Check that TYPE is an acceptable function TYPE for the COMBINATION.

   For example, `progn' messages must return `void', while `and' and `or'
   messages must return `int'.")
  (:method (message combination type)
    t))

(defmethod check-message-type ((message aggregating-message) type)
  (with-slots (combination) message
    (check-aggregating-message-type message combination type)))

(flet ((check (comb want type)
	 (unless (eq (c-type-subtype type) want)
	   (error "Messages with `~A' combination must return `~A'."
		  (string-downcase comb) want))))
  (defmethod check-aggregating-message-type
      ((message aggregating-message)
       (combination (eql :progn))
       (type c-function-type))
    (check combination c-type-void type)
    (call-next-method))
  (defmethod check-aggregating-message-type
      ((message aggregating-message)
       (combination (eql :and))
       (type c-function-type))
    (check combination c-type-int type)
    (call-next-method))
  (defmethod check-aggregating-message-type
      ((message aggregating-message)
       (combination (eql :or))
       (type c-function-type))
    (check combination c-type-int type)
    (call-next-method)))

(export 'define-aggregating-method-combination)
(defmacro define-aggregating-method-combination
    (comb
     (vars
      &key (codegen (gensym "CODEGEN-"))
	   (methods (gensym "METHODS-")))
     &key properties
	  ((:around around-func) '#'funcall)
	  ((:first-method first-method-func) nil firstp)
	  ((:methods methods-func) '#'funcall))
  "Utility macro for definining aggregating method combinations.

   The VARS are a list of variable names to be bound to temporary variable
   objects of the method's return type.  Additional keyword arguments define
   variables names to be bound to other possibly interesting values:

     * CODEGEN is the `codegen' object passed at effective-method computation
       time; and

     * METHODS is the list of primary methods, in the order in which they
       should be invoked.  Note that this list must be non-empty, since
       otherwise the method on `compute-effective-method-body' specialized to
       `simple-effective-method' will suppress the method entirely.

   The PROPERTIES, if specified, are a list of properties to be collected
   during message-object initialization; items in the list have the form

	   (([KEYWORD] NAME) TYPE [DEFAULT] [SUPPLIEDP])

   similar to a `&key' BVL entry, except for the additional TYPE entry.  In
   particular, a symbolic NAME may be written in place of a singleton list.
   The KEYWORD names the property as it should be looked up in the pset,
   while the NAME names a variable to which the property value or default is
   bound.

   All of these variables, and the VARS, are available in the functions
   described below.

   The AROUND, FIRST-METHOD, and METHODS are function designators (probably
   `lambda' forms) providing pieces of the aggregating behaviour.

   The AROUND function is called first, with a single argument BODY, though
   the variables above are also in scope.  It is expected to emit code to
   CODEGEN which invokes the METHODS in the appropriate order, and arranges
   to store the aggregated return value in the first of the VARS.

   It may call BODY as a function in order to assist with this; let ARGS be
   the list of arguments supplied to it.  The default behaviour is to call
   BODY with no arguments.  The BODY function first calls FIRST-METHOD,
   passing it as arguments a function INVOKE and the ARGS which were passed
   to BODY, and then calls METHODS once for each remaining method, again
   passing an INVOKE function and the ARGS.  If FIRST-METHOD is not
   specified, then the METHODS function is used for all of the methods.  If
   METHODS is not specified, then the behaviour is simply to call INVOKE
   immediately.  (See the definition of the `:progn' method combination.)

   Calling (funcall INVOKE [TARGET]) emits instructions to CODEGEN to call
   the appropriate direct method and deliver its return value to TARGET,
   which defaults to `:void'."

  (with-gensyms (type msg combvar target arg-names args
		 meth targ func call-methfunc
		 aroundfunc fmethfunc methfunc)
    `(progn

       ;; If properties are listed, arrange for them to be collected.
       ,@(and properties
	      `((defmethod aggregating-message-properties
		    ((,msg aggregating-message) (,combvar (eql ',comb)))
		  ',(mapcan (lambda (prop)
			      (list (let* ((name (car prop))
					   (names (if (listp name) name
						      (list name))))
				      (if (cddr names) (car names)
					  (intern (car names) :keyword)))
				    (cadr prop)))
			    properties))))

       ;; Define the main kernel-compuation method.
       (defmethod compute-aggregating-message-kernel
	   ((,msg aggregating-message) (,combvar (eql ',comb))
	    ,codegen ,target ,methods ,arg-names
	    &key ,@(mapcar (lambda (prop) (cons (car prop) (cddr prop)))
			   properties))
	 (declare (ignore ,combvar))

	 ;; Declare the necessary variables and give names to the functions
	 ;; supplied by the caller.
	 (let* (,@(and vars
		       `((,type (c-type-subtype (sod-message-type ,msg)))))
		,@(mapcar (lambda (var)
			    (list var `(temporary-var ,codegen ,type)))
			  vars)
		(,aroundfunc ,around-func)
		(,methfunc ,methods-func)
		(,fmethfunc ,(if firstp first-method-func methfunc)))

	   ;; Arrange to release the temporaries when we're finished with
	   ;; them.
	   (unwind-protect
		(progn

		  ;; Wrap the AROUND function around most of the work.
		  (funcall ,aroundfunc
			   (lambda (&rest ,args)
			     (flet ((,call-methfunc (,func ,meth)
				      ;; Call FUNC, passing it an INVOKE
				      ;; function which will generate a call
				      ;; to METH.
				      (apply ,func
					     (lambda
						 (&optional (,targ :void))
					       (invoke-method ,codegen
							      ,targ
							      ,arg-names
							      ,meth))
					     ,args)))

			       ;; The first method might need special
			       ;; handling.
			       (,call-methfunc ,fmethfunc (car ,methods))

			       ;; Call the remaining methods in the right
			       ;; order.
			       (dolist (,meth (cdr ,methods))
				 (,call-methfunc ,methfunc ,meth)))))

		  ;; Outside the AROUND function now, deliver the final
		  ;; result to the right place.
		  (deliver-expr ,codegen ,target ,(car vars)))

	     ;; Finally, release the temporary variables.
	     ,@(mapcar (lambda (var) `(setf (var-in-use-p ,var) nil))
		       vars))))

       ',comb)))

(define-aggregating-method-combination :progn (nil))

(define-aggregating-method-combination :sum ((acc val) :codegen codegen)
  :first-method (lambda (invoke)
		  (funcall invoke val)
		  (emit-inst codegen (make-set-inst acc val)))
  :methods (lambda (invoke)
	     (funcall invoke val)
	     (emit-inst codegen (make-update-inst acc #\+ val))))

(define-aggregating-method-combination :product ((acc val) :codegen codegen)
  :first-method (lambda (invoke)
		  (funcall invoke val)
		  (emit-inst codegen (make-set-inst acc val)))
  :methods (lambda (invoke)
	     (funcall invoke val)
	     (emit-inst codegen (make-update-inst acc #\* val))))

(define-aggregating-method-combination :min ((acc val) :codegen codegen)
  :first-method (lambda (invoke)
		  (funcall invoke val)
		  (emit-inst codegen (make-set-inst acc val)))
  :methods (lambda (invoke)
	     (funcall invoke val)
	     (emit-inst codegen (make-if-inst (format nil "~A > ~A" acc val)
					      (make-set-inst acc val) nil))))

(define-aggregating-method-combination :max ((acc val) :codegen codegen)
  :first-method (lambda (invoke)
		  (funcall invoke val)
		  (emit-inst codegen (make-set-inst acc val)))
  :methods (lambda (invoke)
	     (funcall invoke val)
	     (emit-inst codegen (make-if-inst (format nil "~A < ~A" acc val)
					      (make-set-inst acc val) nil))))

(define-aggregating-method-combination :and ((ret val) :codegen codegen)
  :around (lambda (body)
	    (codegen-push codegen)
	    (deliver-expr codegen ret 0)
	    (funcall body)
	    (deliver-expr codegen ret 1)
	    (emit-inst codegen
		       (make-do-while-inst (codegen-pop-block codegen) 0)))
  :methods (lambda (invoke)
	     (funcall invoke val)
	     (emit-inst codegen (make-if-inst (format nil "!~A" val)
					      (make-break-inst) nil))))

(define-aggregating-method-combination :or ((ret val) :codegen codegen)
  :around (lambda (body)
	    (codegen-push codegen)
	    (deliver-expr codegen ret 1)
	    (funcall body)
	    (deliver-expr codegen ret 0)
	    (emit-inst codegen
		       (make-do-while-inst (codegen-pop-block codegen) 0)))
  :methods (lambda (invoke)
	     (funcall invoke val)
	     (emit-inst codegen (make-if-inst val (make-break-inst) nil))))

(defmethod aggregating-message-properties
    ((message aggregating-message) (combination (eql :custom)))
  '(:retvar :id
    :valvar :id
    :decls :fragment
    :before :fragment
    :first :fragment
    :each :fragment
    :after :fragment))

(defmethod compute-aggregating-message-kernel
    ((message aggregating-message) (combination (eql :custom))
     codegen target methods arg-names
     &key (retvar "sod_ret") (valvar "sod_val")
	  decls before each (first each) after)
  (let* ((type (c-type-subtype (sod-message-type message)))
	 (not-void-p (not (eq type c-type-void))))
    (when not-void-p
      (ensure-var codegen retvar type)
      (ensure-var codegen valvar type))
    (when decls
      (emit-decl codegen decls))
    (labels ((maybe-emit (fragment)
	       (when fragment (emit-inst codegen fragment)))
	     (invoke (method fragment)
	       (invoke-method codegen (if not-void-p valvar :void)
			      arg-names method)
	       (maybe-emit fragment)))
      (maybe-emit before)
      (invoke (car methods) first)
      (dolist (method (cdr methods)) (invoke method each))
      (maybe-emit after)
      (deliver-expr codegen target retvar))))

(export 'standard-effective-method)
(defclass aggregating-effective-method (simple-effective-method) ()
  (:documentation "Effective method counterpart to `aggregating-message'."))

(defmethod message-effective-method-class ((message aggregating-message))
  'aggregating-effective-method)

(defmethod simple-method-body
    ((method aggregating-effective-method) codegen target)
  (let ((argument-names (effective-method-basic-argument-names method))
	(primary-methods (effective-method-primary-methods method)))
    (funcall (message-kernel-function (effective-method-message method))
	     codegen target argument-names primary-methods)))

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