It lives!

[sod] / combination.lisp

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

;;;--------------------------------------------------------------------------
;;; Common behaviour.

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

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

(defgeneric primary-method-class (message)
  (:documentation
   "Return the name of the primary direct method class for MESSAGE."))

(defgeneric simple-method-body (method codegen target)
  (:documentation
   "Generate the body of a simple effective method.

   The function is invoked on an effective METHOD, with a CODEGEN to which it
   should emit code delivering the method's value to TARGET."))

(defmethod sod-message-method-class
    ((message standard-message) (class sod-class) pset)
  (if (get-property pset :role :keyword nil)
      (call-next-method)
      (primary-method-class 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))))

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

(defmethod compute-effective-method-body
    ((method simple-effective-method) codegen target)
  (with-slots (message basic-argument-names primary-methods) method
    (basic-effective-method-body codegen target method
				 (lambda (target)
				   (simple-method-body method
						       codegen
						       target)))))

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

(defclass standard-message (simple-message)
  ()
  (:documentation
   "Message class for standard method combination.

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

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

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