[sod] / src / method-impl.lisp

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

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

(export 'basic-message)
(defclass basic-message (sod-message)
  ((argument-tail :type list :reader sod-message-argument-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."))

(define-on-demand-slot basic-message argument-tail (message)
  (let ((seq 0))
    (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 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 sod-method-role))
(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."))

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

(defun direct-method-suppliedp-struct-tag (direct-method)
  (with-slots ((class %class) role message) direct-method
    (format nil "~A__~@[~(~A~)_~]suppliedp_~A__~A"
	    class role
	    (sod-class-nickname (sod-message-class message))
	    (sod-message-name message))))

(defun effective-method-keyword-struct-tag (effective-method)
  (with-slots ((class %class) message) effective-method
    (format nil "~A__keywords_~A__~A"
	    class
	    (sod-class-nickname (sod-message-class message))
	    (sod-message-name message))))

(defun fix-up-keyword-method-args (method args)
  "Adjust the ARGS to include METHOD's `suppliedp' and keyword arguments.

   Return the adjusted list.  The `suppliedp' argument, if any, is prepended
   to the list; the keyword arguments are added to the end.

   (The input ARGS list is not actually modified.)"
  (let* ((type (sod-method-type method))
	 (keys (c-function-keywords type))
	 (tag (direct-method-suppliedp-struct-tag method)))
    (append (and keys
		 (list (make-argument "suppliedp" (c-type (struct tag)))))
	    args
	    (mapcar (lambda (key)
		      (make-argument (argument-name key)
				     (argument-type key)))
		    keys))))

(define-on-demand-slot basic-direct-method function-type (method)
  (let* ((message (sod-method-message method))
	 (type (sod-method-type method))
	 (method-args (c-function-arguments type)))
    (when (keyword-message-p message)
      (setf method-args (fix-up-keyword-method-args method method-args)))
    (c-type (fun (lisp (c-type-subtype type))
		 ("me" (* (class (sod-method-class method))))
		 . method-args))))

(defmethod sod-method-description ((method basic-direct-method))
  (with-slots (role) method
    (if role (string-downcase role)
	"primary")))

(defmethod sod-method-function-name ((method basic-direct-method))
  (with-slots ((class %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
    (check-method-return-type type c-type-void)
    (check-method-argument-lists 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.."))

(define-on-demand-slot delegating-direct-method next-method-type (method)
  (let* ((message (sod-method-message method))
	 (return-type (c-type-subtype (sod-message-type message)))
	 (msgargs (sod-message-argument-tail message))
	 (arguments (cond ((varargs-message-p message)
			   (cons (make-argument *sod-master-ap*
						c-type-va-list)
				 (butlast msgargs)))
			  ((keyword-message-p message)
			   (cons (make-argument *sod-keywords*
						(c-type (* (void :const))))
				 msgargs))
			  (t
			   msgargs))))
    (c-type (fun (lisp return-type)
		 ("me" (* (class (sod-method-class method))))
		 . arguments))))

(define-on-demand-slot delegating-direct-method function-type (method)
  (let* ((message (sod-method-message method))
	 (type (sod-method-type method))
	 (method-args (c-function-arguments type))
	 (next-method-arg (make-argument
			   "next_method"
			   (make-pointer-type
			    (commentify-function-type
			     (sod-method-next-method-type method))))))
    (cond ((varargs-message-p message)
	   (push (make-argument *sod-master-ap* c-type-va-list)
		 method-args)
	   (push next-method-arg method-args))
	  ((keyword-message-p message)
	   (push (make-argument *sod-keywords* (c-type (* (void :const))))
		 method-args)
	   (push next-method-arg method-args)
	   (setf method-args
		 (fix-up-keyword-method-args method method-args)))
	  (t
	   (push next-method-arg method-args)))
    (c-type (fun (lisp (c-type-subtype type))
		 ("me" (* (class (sod-method-class method))))
		 . method-args))))

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

(defmethod sod-message-keyword-argument-lists
    ((message sod-message) (class sod-class) direct-methods state)
  (and (keyword-message-p message)
       (cons (cons (lambda (arg)
		     (let ((class (sod-message-class message)))
		       (info-with-location
			message "Type `~A' declared in message ~
				 definition in `~A' (here)"
			(argument-type arg) class)
		       (report-inheritance-path state class)))
		   (c-function-keywords (sod-message-type message)))
	     (mapcar (lambda (method)
		       (cons (lambda (arg)
			       (let ((class (sod-method-class method)))
				 (info-with-location
				  method "Type `~A' declared in ~A direct ~
					  method of `~A' (defined here)"
				  (argument-type arg)
				  (sod-method-description method) class)
				 (report-inheritance-path state class)))
			     (c-function-keywords (sod-method-type method))))
		     direct-methods))))


(defmethod shared-initialize :after
    ((method effective-method) slot-names &key direct-methods)
  (declare (ignore slot-names))

  ;; Set the keyword argument list.  Blame the class as a whole for mismatch
  ;; errors, because they're fundamentally a non-local problem about the
  ;; class construction.
  (with-slots ((class %class) message keywords) method
    (setf keywords
	  (compute-effective-method-keyword-arguments message
						      class
						      direct-methods))))

(export '(basic-effective-method
	  effective-method-around-methods effective-method-before-methods
	  effective-method-after-methods))
(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."))

(define-on-demand-slot basic-effective-method basic-argument-names (method)
  (let* ((message (effective-method-message method))
	 (raw-tail (sod-message-argument-tail message)))
    (mapcar #'argument-name (reify-variable-argument-tail raw-tail))))

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

(define-on-demand-slot basic-effective-method functions (method)
  (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 %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) role)
  (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__~A__chain_~A"
		class role
		(sod-class-nickname message-class)
		(sod-message-name message)
		(sod-class-nickname chain-head))
	*null-pointer*)))

(defmethod method-entry-slot-name ((entry method-entry))
  (let* ((method (method-entry-effective-method entry))
	 (message (effective-method-message method))
	 (name (sod-message-name message))
	 (role (method-entry-role entry)))
    (method-entry-slot-name-by-role entry role name)))

(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))
	 (keywordsp (keyword-message-p message))
	 (raw-tail (append (sod-message-argument-tail message)
			   (and keywordsp (list :ellipsis))))
	 (tail (ecase (method-entry-role entry)
		 ((nil) raw-tail)
		 (:valist (reify-variable-argument-tail raw-tail)))))
    (c-type (fun (lisp (c-type-subtype type))
		 ("me" (* (class (method-entry-chain-tail entry))))
		 . tail))))

(defgeneric effective-method-keyword-parser-function-name (method)
  (:documentation
   "Return the name of the keyword-parsing function for an effective METHOD.

   See `make-keyword-parser-function' for details of what this function
   actually does."))

(defmethod effective-method-keyword-parser-function-name
    ((method basic-effective-method))
  (with-slots ((class %class) message) method
    (format nil "~A__kwparse_~A__~A"
	    class
	    (sod-class-nickname (sod-message-class message))
	    (sod-message-name message))))

(defun make-keyword-parser-function (codegen method tag set keywords)
  "Construct and return a keyword-argument parsing function.

   The function is contributed to the CODEGEN, with the name constructed from
   the effective METHOD.  It will populate an argument structure with the
   given TAG.  In case of error, it will mention the name SET in its report.
   The KEYWORDS are a list of `argument' objects naming the keywords to be
   accepted.

   The generated function has the signature

	void NAME(struct TAG *kw, va_list *ap, struct kwval *v, size_t n)

    It assumes that AP includes the first keyword name.  (This makes it
    different from the keyword-parsing functions generated by the
    `KWSET_PARSEFN' macro, but this interface is slightly more convenient and
    we don't need to cope with functions which accept no required
    arguments.)"

  ;; Let's start, then.
  (codegen-push codegen)

  ;; Set up the local variables we'll need.
  (macrolet ((var (name type)
	       `(ensure-var codegen ,name (c-type ,type))))
    (var "k" const-string)
    (var "aap" (* va-list))
    (var "t" (* (struct "kwtab" :const)))
    (var "vv" (* (struct "kwval" :const)))
    (var "nn" size-t))

  (flet ((call (target func &rest args)
	   ;; Call FUNC with ARGS; return result in TARGET.

	   (apply #'deliver-call codegen target func args))

	 (convert (target type)
	   ;; Fetch the object of TYPE pointed to by `v->val', and store it
	   ;; in TARGET.

	   (deliver-expr codegen target
			 (format nil "*(~A)v->val"
				 (make-pointer-type (qualify-c-type
						     type (list :const))))))

	 (namecheck (var name conseq alt)
	   ;; Return an instruction: if VAR matches the string NAME then do
	   ;; CONSEQ; otherwise do ALT.

	   (make-if-inst (make-call-inst "!strcmp"
					 var (prin1-to-string name))
			 conseq alt)))

    ;; Prepare the main parsing loops.  We're going to construct them both at
    ;; the same time.  They're not quite similar enough for it to be
    ;; worthwhile abstracting this further, but carving up the keywords is
    ;; too tedious to write out more than once.
    (let ((va-act (make-expr-inst (make-call-inst "kw_unknown" set "k")))
	  (tab-act (make-expr-inst (make-call-inst "kw_unknown"
						   set "v->kw")))
	  (name (effective-method-keyword-parser-function-name method)))

      ;; Work through the keywords.  We're going to be building up the
      ;; conditional dispatch from the end, so reverse the (nicely sorted)
      ;; list before processing it.
      (dolist (key (reverse keywords))
	(let* ((key-name (argument-name key))
	       (key-type (argument-type key)))

	  ;; Handle the varargs case.
	  (codegen-push codegen)
	  (deliver-expr codegen (format nil "kw->~A__suppliedp" key-name) 1)
	  (call (format nil "kw->~A" key-name) "va_arg" "*ap" key-type)
	  (setf va-act (namecheck "k" key-name
				  (codegen-pop-block codegen) va-act))

	  ;; Handle the table case.
	  (codegen-push codegen)
	  (deliver-expr codegen (format nil "kw->~A__suppliedp" key-name) 1)
	  (convert (format nil "kw->~A" key-name) key-type)
	  (setf tab-act (namecheck "v->kw" key-name
				   (codegen-pop-block codegen) tab-act))))

      ;; Deal with the special `kw.' keywords read via varargs.
      (codegen-push codegen)
      (call "vv" "va_arg" "*ap" (c-type (* (struct "kwval" :const))))
      (call "nn" "va_arg" "*ap" c-type-size-t)
      (call :void name "kw" *null-pointer* "vv" "nn")
      (setf va-act (namecheck "k" "kw.tab"
			      (codegen-pop-block codegen) va-act))

      (codegen-push codegen)
      (call "aap" "va_arg" "*ap" (c-type (* va-list)))
      (call :void name "kw" "aap" *null-pointer* 0)
      (setf va-act (namecheck "k" "kw.va_list"
			      (codegen-pop-block codegen) va-act))

      ;; Finish up the varargs loop.
      (emit-banner codegen "Parse keywords from the variable-length tail.")
      (codegen-push codegen)
      (call "k" "va_arg" "*ap" c-type-const-string)
      (emit-inst codegen (make-if-inst "!k" (make-break-inst)))
      (emit-inst codegen va-act)
      (let ((loop (make-for-inst nil nil nil (codegen-pop-block codegen))))
	(emit-inst codegen
		   (make-if-inst "ap" (make-block-inst nil (list loop)))))

      ;; Deal with the special `kw.' keywords read from a table.
      (codegen-push codegen)
      (deliver-expr codegen "t"
		    (format nil "(~A)v->val"
			    (c-type (* (struct "kwtab" :const)))))
      (call :void name "kw" *null-pointer* "t->v" "t->n")
      (setf tab-act (namecheck "v->kw" "kw.tab"
			       (codegen-pop-block codegen) tab-act))

      (emit-banner codegen "Parse keywords from the argument table.")
      (codegen-push codegen)
      (convert "aap" (c-type (* va-list)))
      (call :void name "kw" "aap" *null-pointer* 0)
      (setf tab-act (namecheck "v->kw" "kw.va_list"
			       (codegen-pop-block codegen) tab-act))

      ;; Finish off the table loop.
      (codegen-push codegen)
      (emit-inst codegen tab-act)
      (emit-inst codegen (make-expr-inst "v++"))
      (emit-inst codegen (make-expr-inst "n--"))
      (emit-inst codegen (make-while-inst "n" (codegen-pop-block codegen)))

      ;; Wrap the whole lot up with a nice bow.
      (let ((message (effective-method-message method)))
	(codegen-pop-function codegen name
			      (c-type (fun void
					   ("kw" (* (struct tag)))
					   ("ap" (* va-list))
					   ("v" (* (struct "kwval" :const)))
					   ("n" size-t)))
			      "Keyword parsing for `~A.~A' on class `~A'."
			      (sod-class-nickname
			       (sod-message-class message))
			      (sod-message-name message)
			      (effective-method-class method))))))

(defmethod make-method-entries ((method basic-effective-method)
				(chain-head sod-class)
				(chain-tail sod-class))
  (let ((entries nil)
	(message (effective-method-message method)))
    (flet ((make (role)
	     (push (make-instance 'method-entry
				  :method method :role role
				  :chain-head chain-head
				  :chain-tail chain-tail)
		   entries)))
      (when (or (varargs-message-p message)
		(keyword-message-p message))
	(make :valist))
      (make nil)
      entries)))

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

	 ;; 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))
	 (raw-entry-args (append (sod-message-argument-tail message)
				 (and (keyword-message-p message)
				      (list :ellipsis))))
	 (entry-args (reify-variable-argument-tail raw-entry-args))
	 (parm-n (let ((tail (last (cons (make-argument "me" c-type-void)
					 raw-entry-args) 2)))
		   (and tail (eq (cadr tail) :ellipsis)
			(argument-name (car tail)))))
	 (entry-target (codegen-target codegen))

	 ;; Effective method function details.
	 (emf-name (effective-method-function-name method))
	 (ilayout-type (c-type (* (struct (ilayout-struct-tag class)))))
	 (emf-type (c-type (fun (lisp return-type)
				("sod__obj" (lisp ilayout-type))
				. entry-args))))

    (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"))
	       (deliver-call codegen :void "SOD__IGNORE" "sod__obj")))
	   (finish-entry (tail)
	     (let* ((head (sod-class-chain-head tail))
		    (role (if parm-n :valist nil))
		    (name (method-entry-function-name method head role))
		    (type (c-type (fun (lisp return-type)
				       ("me" (* (class tail)))
				       . entry-args))))
	       (codegen-pop-function codegen name type
		"~@(~@[~A ~]entry~) function ~:_~
		 for method `~A.~A' ~:_~
		 via chain headed by `~A' ~:_~
		 defined on `~A'."
		(if parm-n "Indirect argument-tail" nil)
		(sod-class-nickname message-class)
		(sod-message-name message)
		head class)

	       ;; If this is a varargs or keyword method then we've made the
	       ;; `:valist' role.  Also make the `nil' role.
	       (when parm-n
		 (let ((call (apply #'make-call-inst name "me"
				    (mapcar #'argument-name entry-args)))
		       (main (method-entry-function-name method head nil))
		       (main-type (c-type (fun (lisp return-type)
					       ("me" (* (class tail)))
					       . raw-entry-args))))
		   (codegen-push codegen)
		   (ensure-var codegen *sod-ap* c-type-va-list)
		   (convert-stmts codegen entry-target return-type
				  (lambda (target)
				    (deliver-call codegen :void "va_start"
						  *sod-ap* parm-n)
				    (deliver-expr codegen target call)
				    (deliver-call codegen :void "va_end"
						  *sod-ap*)))
		   (codegen-pop-function codegen main main-type
		    "Variable-length argument list ~:_~
		     entry function ~:_~
		     for method `~A.~A' ~:_~
		     via chain headed by `~A' ~:_~
		     defined on `~A'."
		(sod-class-nickname message-class)
		(sod-message-name message)
		head class))))))

      ;; 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)))
		   (emit-insts codegen insts)
		   (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))))
		  "Effective method function ~:_for `~A.~A' ~:_~
		   defined on `~A'."
		  (sod-class-nickname message-class)
		  (sod-message-name message)
		  (effective-method-class method))

		 (let ((call (apply #'make-call-inst emf-name "sod__obj"
				    (mapcar #'argument-name entry-args))))
		   (dolist (tail chain-tails)
		     (setup-entry tail)
		     (deliver-expr codegen entry-target call)
		     (finish-entry tail)))))))

      (codegen-functions codegen))))

(defmethod compute-effective-method-body :around
    ((method basic-effective-method) codegen target)
  (let* ((message (effective-method-message method))
	 (keywordsp (keyword-message-p message))
	 (keywords (effective-method-keywords method))
	 (ap-addr (format nil "&~A" *sod-tmp-ap*))
	 (set (format nil "\"~A:~A.~A\""
		      (sod-class-name (effective-method-class method))
		      (sod-class-nickname (sod-message-class message))
		      (sod-message-name message))))
    (labels ((call (target func &rest args)
	       (apply #'deliver-call codegen target func args))
	     (parse-keywords (body)
	       (ensure-var codegen *sod-tmp-ap* c-type-va-list)
	       (call :void "va_copy" *sod-tmp-ap* *sod-ap*)
	       (funcall body)
	       (call :void "va_end" *sod-tmp-ap*)))
      (cond ((not keywordsp)
	     (call-next-method))
	    ((null keywords)
	     (let ((*keyword-struct-disposition* :null))
	       (parse-keywords (lambda ()
				 (with-temporary-var
				     (codegen kw c-type-const-string)
				   (call kw "va_arg"
					 *sod-tmp-ap* c-type-const-string)
				   (call :void "kw_parseempty" set
					 kw ap-addr *null-pointer* 0))))
	       (call-next-method)))
	    (t
	     (let* ((name
		     (effective-method-keyword-parser-function-name method))
		    (tag (effective-method-keyword-struct-tag method))
		    (kw-addr (format nil "&~A" *sod-keywords*))
		    (*keyword-struct-disposition* :local))
	       (ensure-var codegen *sod-keywords* (c-type (struct tag)))
	       (make-keyword-parser-function codegen method tag set keywords)
	       (emit-insts codegen
			   (mapcar (lambda (keyword)
				     (make-set-inst
				      (format nil "~A.~A__suppliedp"
					      *sod-keywords*
					      (argument-name keyword))
				      0))
				   keywords))
	       (parse-keywords (lambda ()
				 (call :void name kw-addr ap-addr
				       *null-pointer* 0)))
	       (call-next-method)))))))

(defmethod effective-method-live-p ((method simple-effective-method))
  (effective-method-primary-methods method))

(defmethod compute-method-entry-functions :around ((method effective-method))
  (if (effective-method-live-p 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 sod-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))

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