;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: CLOS -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:

;;;;
;;;;  Copyright (c) 1992, Giuseppe Attardi.
;;;;  Copyright (c) 2001, Juan Jose Garcia Ripoll.
;;;;
;;;;    See file 'LICENSE' for the copyright details.

(in-package "CLOS")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; COMPILING EFFECTIVE METHODS
;;;
;;; The following functions take care of transforming the forms
;;; produced by the method combinations into effective methods. In ECL
;;; effective methods are nothing but directly callable functions.
;;; Ideally, this compilation should just produce new compiled
;;; functions. However, we do not want to cons a lot of functions, and
;;; therefore we use closures.
;;;
;;; Formerly we used to keep a list of precompiled effective methods
;;; and made a structural comparison between the current method and
;;; the precompiled ones, so as to save memory. This only causes
;;; improvements in declarative combinations. For standard combinations
;;; it should be enough with a couple of different closures and hence
;;; the structural comparison is a loss of time.
;;;
;;; This is the core routine. It produces effective methods (i.e.
;;; functions) out of the forms generated by the method combinators.
;;; We consider the following cases:
;;;  1) Ordinary methods. The function of the method is extracted.
;;;  2) Functions. They map to themselves. This only happens
;;;     when these functions have been generated by previous calls
;;;     to EFFECTIVE-METHOD-FUNCTION.
;;;  3) (CALL-METHOD method rest-methods) A closure is
;;;     generated that invokes the current method while informing
;;;     it about the remaining methods.
;;;  4) (MAKE-METHOD form) A function is created that takes the
;;;     list of arguments of the generic function and evaluates
;;;     the forms in a null environment. This is the only form
;;;     that may lead to consing of new bytecodes objects. Nested
;;;     CALL-METHOD are handled via the global macro CALL-METHOD.
;;;  5) Ordinary forms are turned into lambda forms, much like
;;;     what happens with the content of MAKE-METHOD.
;;;
(defun effective-method-function (form &optional top-level &aux first)
  (cond ((functionp form)
         form)
        ((method-p form)
         (method-function form))
        ((atom form)
         (error "Malformed effective method form:~%~A" form))
        ((eq (setf first (first form)) 'MAKE-METHOD)
         (coerce `(lambda (.combined-method-args. *next-methods*)
                    (declare (special .combined-method-args. *next-methods*))
                    ,(second form))
                 'function))
        ((eq first 'CALL-METHOD)
         (combine-method-functions
          (effective-method-function (second form))
          (mapcar #'effective-method-function (third form))))
        (top-level
         (coerce `(lambda (.combined-method-args. no-next-methods)
                    (declare (ignorable no-next-methods))
                    ,form)
                 'function))
        (t
         (error "Malformed effective method form:~%~A" form))))

;;;
;;; This function is a combinator of effective methods. It creates a
;;; closure that invokes the first method while passing the information
;;; of the remaining methods. The resulting closure (or effective method)
;;; is the equivalent of (CALL-METHOD method rest-methods)
;;;
(defun combine-method-functions (method rest-methods)
  (declare (si::c-local))
  #'(lambda (.combined-method-args. no-next-methods)
      (declare (ignorable no-next-methods))
      (funcall method .combined-method-args. rest-methods)))

(defmacro call-method (method &optional rest-methods)
  `(funcall ,(effective-method-function method)
            .combined-method-args.
            ',(and rest-methods (mapcar #'effective-method-function rest-methods))))

(defun call-next-method (&rest args)
  (declare (special .combined-method-args. *next-methods*))
  (unless *next-methods*
    (error "No next method."))
  (funcall (car *next-methods*) (or args .combined-method-args.) (rest *next-methods*)))

(defun next-method-p ()
  (declare (special *next-methods*))
  *next-methods*)

(define-compiler-macro call-next-method (&rest args)
  `(if *next-methods*
       (funcall (car *next-methods*)
                ,(if args `(list ,@args) '.combined-method-args.)
                (rest *next-methods*))
       (error "No next method.")))

(define-compiler-macro next-method-p ()
  'clos::*next-methods*)

(defun error-qualifier (m qualifier)
  (declare (si::c-local))
  (error "Standard method combination allows only one qualifier ~
          per method, either :BEFORE, :AFTER, or :AROUND; while ~
          a method with ~S was found."
         m qualifier))

(defun standard-main-effective-method (before primary after)
  (declare (si::c-local))
  #'(lambda (.combined-method-args. no-next-method)
      (declare (ignorable no-next-method))
      (dolist (i before)
        (funcall i .combined-method-args. nil))
      (if after
          (multiple-value-prog1
           (funcall (first primary) .combined-method-args. (rest primary))
           (dolist (i after)
             (funcall i .combined-method-args. nil)))
        (funcall (first primary) .combined-method-args. (rest primary)))))

(defun standard-compute-effective-method (gf methods)
  (with-early-accessors (+standard-method-slots+)
    (let* ((before ())
           (primary ())
           (after ())
           (around ()))
      (dolist (m methods)
        (let* ((qualifiers (method-qualifiers m))
               (f (method-function m)))
          (cond ((null qualifiers) (push f primary))
                ((rest qualifiers) (error-qualifier m qualifiers))
                ((eq (setq qualifiers (first qualifiers)) :BEFORE)
                 (push f before))
                ((eq qualifiers :AFTER) (push f after))
                ((eq qualifiers :AROUND) (push f around))
                (t (error-qualifier m qualifiers)))))
      ;; When there are no primary methods, an error is to be signaled,
      ;; and we need not care about :AROUND, :AFTER or :BEFORE methods.
      (when (null primary)
        (return-from standard-compute-effective-method
          #'(lambda (&rest args)
              (apply 'no-primary-method gf args))))
      ;; PRIMARY, BEFORE and AROUND are reversed because they have to
      ;; be on most-specific-first order (ANSI 7.6.6.2), while AFTER
      ;; may remain as it is because it is least-specific-order.
      (setf primary (nreverse primary)
            before (nreverse before))
      (if around
          (let ((main (if (or before after)
                          (list
                           (standard-main-effective-method before primary after))
                          primary)))
            (setf around (nreverse around))
            (combine-method-functions (first around)
                                      (nconc (rest around) main)))
          (if (or before after)
              (standard-main-effective-method before primary after)
              (combine-method-functions (first primary) (rest primary)))) )))

;;; ----------------------------------------------------------------------
;;; COMPUTE-EFFECTIVE-METHOD
;;;

(eval-when (:compile-toplevel)
  (let* ((class (find-class 'method-combination)))
    (define-compiler-macro method-combination-compiler (o)
      `(si::instance-ref
        ,o ,(slot-definition-location (gethash 'compiler (slot-table class)))))
    (define-compiler-macro method-combination-options (o)
      `(si::instance-ref
        ,o ,(slot-definition-location (gethash 'options (slot-table class)))))))

(defun std-compute-effective-method (gf method-combination applicable-methods)
  (declare (type method-combination method-combination)
           (type generic-function gf)
           (optimize speed (safety 0)))
  (with-early-accessors (+method-combination-slots+)
    (let* ((compiler (method-combination-compiler method-combination))
           (options (method-combination-options method-combination)))
      (if options
          (apply compiler gf applicable-methods options)
          (funcall compiler gf applicable-methods)))))

(defun compute-effective-method-function (gf method-combination applicable-methods)
  ;; Cannot be inlined because it will be a method
  (declare (notinline compute-effective-method))
  (let ((form (compute-effective-method gf method-combination applicable-methods)))
    (let ((aux form) f)
      (if (and (listp aux)
               (eq (pop aux) 'funcall)
               (functionp (setf f (pop aux)))
               (eq (pop aux) '.combined-method-args.)
               (eq (pop aux) '*next-methods*))
          f
          (effective-method-function form t)))))

(defun compute-effective-method (gf method-combination applicable-methods)
  `(funcall ,(std-compute-effective-method gf method-combination applicable-methods)
            .combined-method-args. *next-methods*))
