(in-package :closer-common-lisp-user)

#|
Here is an implementation of the an object-oriented extension suggested by
Goldberg, Findler and Flatt and discussed, for example, here:
http://lambda-the-ultimate.org/node/3731

This code relies on Closer to MOP which can be found at
http://common-lisp.net/project/closer/

The code has been successfully tested in Allegro Common Lisp, clisp,
Clozure Common Lisp, LispWorks and Steel Bank Common Lisp.

Thanks to Gareth McCaughan for improvements.
|#

(eval-when (:compile-toplevel :load-toplevel :execute)
  
  (defclass beta-generic-function (standard-generic-function) ()
    (:metaclass funcallable-standard-class))

  (defclass beta-method (standard-method)
    ((betap :reader betap
            :initarg :betap
            :initform nil))
    #+clozure (:default-initargs :closer-patch t))

  (defmethod initialize-instance :around
    ((method beta-method) &rest initargs &key qualifiers)
    (declare (dynamic-extent initargs))
    (if (equal qualifiers '(:beta))
      (apply #'call-next-method method
             :qualifiers ()
             :betap t
             initargs)
      (call-next-method)))

  (defun collect-runs (methods)
    (let ((complete-runs nil)
          (current-run nil))
      (flet ((complete-run ()
               (when current-run
                 (push (nreverse current-run) complete-runs)
                 (setf current-run nil))))
        (loop for method in methods do
              (when (betap method) (complete-run))
              (push method current-run))
        (complete-run))
      complete-runs))

  (define-method-combination beta ()
    ((around (:around))
     (before (:before))
     (primary () :required t)
     (after (:after)))
    (flet ((call-methods (methods)
             (mapcar (lambda (method) `(call-method ,method))
                     methods)))
      (let ((form (if (or before after (rest primary))
                    (let ((runs (collect-runs primary)))
                      `(multiple-value-prog1
                           (progn ,@(call-methods before)
                             (call-method ,(first (first runs))
                                          ,(rest (first runs))
                                          :inner-runs ,(rest runs)))
                         ,@(call-methods (reverse after))))
                    `(call-method ,(first primary)))))
        (if around
          `(call-method ,(first around)
                        (,@(rest around)
                         (make-method ,form)))
          form))))

  (defmethod make-method-lambda
             ((gf beta-generic-function) method-prototype
              lambda-expression environment)
    (declare (ignore method-prototype environment))
    (let ((method-args (gensym))
          (next-methods (gensym))
          (generic-function (gensym))
          (method (gensym))
          (inner-runs (gensym)))
      `(lambda (,method-args &optional ,next-methods
                             &key ((:generic-function ,generic-function))
                             ((:method ,method))
                             ((:inner-runs ,inner-runs)))
         (declare (ignorable ,next-methods ,generic-function ,method ,inner-runs))
         (flet ((call-next-method (&rest args)
                  (declare (dynamic-extent args))
                  (if (null ,next-methods)
                    (apply #'no-next-method ,generic-function ,method args)
                    (funcall (method-function (car ,next-methods))
                             (if args args ,method-args)
                             (cdr ,next-methods)
                             :generic-function ,generic-function
                             :method (car ,next-methods)
                             :inner-runs ,inner-runs)))
                (next-method-p () (not (null ,next-methods)))
                (call-inner-method (&rest args)
                  (declare (dynamic-extent args))
                  (if (null ,inner-runs)
                    (apply #'no-next-method ,generic-function ,method args)
                    (funcall (method-function (caar ,inner-runs))
                             (if args args ,method-args)
                             (cdar ,inner-runs)
                             :generic-function ,generic-function
                             :method (caar ,inner-runs)
                             :inner-runs (cdr ,inner-runs))))
                (inner-method-p () (not (null ,inner-runs))))
           (apply ,lambda-expression ,method-args)))))

  (defmacro define-beta-function (name (&rest args) &rest options)
    `(defgeneric ,name ,args
       ,@(unless (member :generic-function-class options :key #'car)
           '((:generic-function-class beta-generic-function)))
       ,@(unless (member :method-class options :key #'car)
           '((:method-class beta-method)))
       ,@(unless (member :method-combination options :key #'car)
           '((:method-combination beta)))
       ,@options)))


(defclass top () ())

(defclass middle (top) ())

(defclass bottom (middle) ())

(define-beta-function test (object))

(defmethod test ((object top))
  (print 'top))

(defmethod test :beta ((object middle))
  (print 'middle)
  (call-inner-method)
  (call-next-method)
  (values))
     
(defmethod test ((object bottom))
  (print 'bottom))

(defun run-test ()
  (test (make-instance 'bottom)))