;;;; -*- 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.
;;;;
;;;;    This program is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU Library General Public
;;;;    License as published by the Free Software Foundation; either
;;;;    version 2 of the License, or (at your option) any later version.
;;;;
;;;;    See file '../Copyright' for full details.

(in-package "CLOS")

(defparameter *clos-booted* nil)

;;; ----------------------------------------------------------------------
;;;
;;; FIND-CLASS  naming classes.
;;;
;;;
;;; (FIND-CLASS <name>) returns the class named <name>.  setf can be used
;;; with find-class to set the class named <name>.  These are "extrinsic"
;;; names.  Neither find-class nor setf of find-class do anything with the
;;; name slot of the class, they only lookup and change the association from
;;; name to class.
;;; 
;;; This is only used during boot. The real one is in built-in.
(eval-when (:compile-toplevel)
  (defun setf-find-class (new-value class &optional errorp env)
    (warn "Ignoring class definition for ~S" class)))

(defun setf-find-class (new-value name &optional errorp env)
  (declare (ignore errorp env))
  (let ((old-class (find-class name nil)))
    (cond
      ((and old-class
            (or (typep old-class 'built-in-class)
                (member name '(class built-in-class) :test #'eq)))
       (unless (eq new-value old-class)
         (error "The class associated to the CL specifier ~S cannot be changed."
                name)))
      ((classp new-value)
       (setf (gethash name si:*class-name-hash-table*) new-value))
      ((null new-value) (remhash name si:*class-name-hash-table*))
      (t (error "~A is not a class." new-value))))
  new-value)

(defsetf find-class (&rest x) (v) `(setf-find-class ,v ,@x))

(defun classp (obj)
  (and (si:instancep obj)
       (let ((topmost (find-class 'CLASS nil)))
         ;; All instances can be classes until the class CLASS has
         ;; been installed. Otherwise, we check the parents.
         ;(print (list (class-id (class-of obj))topmost (and topmost (class-precedence-list topmost))))
         (or (null topmost)
             (si::subclassp (si::instance-class obj) topmost)))
       t))

;;; ----------------------------------------------------------------------
;;; Methods

(defun install-method (name qualifiers specializers lambda-list fun &rest options)
  (declare (notinline ensure-generic-function))
  ;;(record-definition 'method `(method ,name ,@qualifiers ,specializers))
  (let* ((gf (ensure-generic-function name))
         (fun (wrapped-method-function fun))
         (specializers (mapcar #'(lambda (x)
                                   (cond ((consp x) (intern-eql-specializer (second x)))
                                         ((typep x 'specializer) x)
                                         ((find-class x nil))
                                         (t
                                          (error "In method definition for ~A, found an invalid specializer ~A" name specializers))))
                               specializers))
         (method (make-method (generic-function-method-class gf)
                              qualifiers specializers lambda-list
                              fun options)))
    (add-method gf method)
    method))

(defun wrapped-method-function (method-function)
  #'(lambda (.combined-method-args. *next-methods*)
      (declare (special .combined-method-args. *next-methods*))
      (apply method-function .combined-method-args.)))

;;; ----------------------------------------------------------------------
;;;                                                         early versions

;;; early version used during bootstrap
(defun ensure-generic-function (name &key (lambda-list (si::unbound) l-l-p))
  (if (and (fboundp name) (si::instancep (fdefinition name)))
      (fdefinition name)
      ;; create a fake standard-generic-function object:
      (with-early-make-instance +standard-generic-function-slots+
        (gfun (find-class 'standard-generic-function)
              :name name
              :spec-list nil
              :method-combination (find-method-combination nil 'standard nil)
              :lambda-list lambda-list
              :argument-precedence-order
              (and l-l-p (rest (si::process-lambda-list lambda-list t)))
              :method-class (find-class 'standard-method)
              :docstring nil
              :methods nil
              :a-p-o-function nil
              :declarations nil
              :dependents nil)
        ;; create a new gfun
        (set-funcallable-instance-function gfun 'standard-generic-function)
        (setf (fdefinition name) gfun)
        gfun)))

(defun (setf generic-function-name) (new-name gf)
  (if *clos-booted*
      (reinitialize-instance gf :name new-name)
      (setf (slot-value gf 'name) new-name)))

(defun default-dispatch (generic-function)
  (cond ((null *clos-booted*)
         'standard-generic-function)
        ((eq (class-id (class-of generic-function))
             'standard-generic-function)
         'standard-generic-function)
        (t)))

(defun compute-discriminating-function (generic-function)
  (values #'(lambda (&rest args)
              (multiple-value-bind (method-list ok)
                  (compute-applicable-methods-using-classes
                   generic-function
                   (mapcar #'class-of args))
                (unless ok
                  (setf method-list
                        (compute-applicable-methods generic-function args))
                  (unless method-list
                    (apply #'no-applicable-method generic-function args)))
                (funcall (compute-effective-method-function
                          generic-function
                          (generic-function-method-combination generic-function)
                          method-list)
                         args
                         nil)))
          t))

(defun set-generic-function-dispatch (gfun)
  ;;
  ;; We have to decide which discriminating function to install:
  ;;    1* One supplied by the user
  ;;    2* One coded in C that follows the MOP
  ;;    3* One in C specialized for slot accessors
  ;;    4* One in C that does not use generic versions of compute-applicable-...
  ;; Respectively
  ;;    1* The user supplies a discriminating function, or the number of arguments
  ;;       is so large that they cannot be handled by the C dispatchers with
  ;;       with memoization.
  ;;    2* The generic function is not a s-g-f but takes less than 64 arguments
  ;;    3* The generic function is a standard-generic-function and all its slots
  ;;       are standard-{reader,writer}-slots
  ;;    4* The generic function is a standard-generic-function with less
  ;;       than 64 arguments
  ;;
  ;; This chain of reasoning uses the fact that the user cannot override methods
  ;; such as COMPUTE-APPLICABLE-METHODS, or COMPUTE-EFFECTIVE-METHOD, or
  ;; COMPUTE-DISCRIMINATING-FUNCTION acting on STANDARD-GENERIC-FUNCTION.
  ;;
  (declare (notinline compute-discriminating-function))
  (multiple-value-bind (default-function optimizable)
      ;;
      ;; If the class is not a standard-generic-function, we must honor whatever function
      ;; the user provides. However, we still recognize the case without user-computed
      ;; function, where we can replace the output of COMPUTE-DISCRIMINATING-FUNCTION with
      ;; a similar implementation in C
      (compute-discriminating-function gfun)
    (let ((methods (slot-value gfun 'methods)))
      (set-funcallable-instance-function
       gfun
       (cond
         ;; Case 1*
         ((or (not optimizable)
              (> (length (slot-value gfun 'spec-list))
                 si::c-arguments-limit))
          default-function)
         ;; Case 2*
         ((and (not (eq (slot-value (class-of gfun) 'name)
                        'standard-generic-function))
               *clos-booted*)
          t)
         ((null methods)
          'standard-generic-function)
         ;; Cases 3*
         ((loop with class = (find-class 'standard-optimized-reader-method nil)
             for m in methods
             always (eq class (class-of m)))
          'standard-optimized-reader-method)
         ((loop with class = (find-class 'standard-optimized-writer-method nil)
             for m in methods
             always (eq class (class-of m)))
          'standard-optimized-writer-method)
         ;; Case 4*
         (t
          'standard-generic-function))))))

;;; ----------------------------------------------------------------------
;;; COMPUTE-APPLICABLE-METHODS
;;;
;;; This part is a source of problems because we have to access slots of
;;; various objects, which could potentially lead to infinite recursion as
;;; those accessors require also some dispatch. The solution is to avoid
;;; calling then generic function that implement the accessors.
;;; This is possible because:
;;;   1. The user can only extend compute-applicable-methods if it
;;;      defines a method with a subclass of standard-generic-function
;;;   2. The user cannot extend slot-value and friends on standard-classes
;;;      due to the restriction "Any method defined by a portable program
;;;      on a specified generic function must have at least one specializer
;;;      that is neither a specified class nor an eql specializer whose
;;;      associated value is an instance of a specified class."
;;;   3. Subclasses of specified classes preserve the slot order in ECL.
;;;
(defun std-compute-applicable-methods (gf args)
  (sort-applicable-methods gf
                           (applicable-method-list gf args)
                           (mapcar #'class-of args)))

(setf (fdefinition 'compute-applicable-methods) #'std-compute-applicable-methods)

(defun applicable-method-list (gf args)
  (declare (optimize (speed 3))
           (si::c-local))
  (with-early-accessors (+standard-method-slots+
                         +standard-generic-function-slots+
                         +eql-specializer-slots+
                         +standard-class-slots+)
    (flet ((applicable-method-p (method args)
             (loop for spec in (method-specializers method)
                for arg in args
                always (if (eql-specializer-flag spec)
                           (eql arg (eql-specializer-object spec))
                           (si::of-class-p arg spec)))))
      (loop for method in (generic-function-methods gf)
         when (applicable-method-p method args)
         collect method))))

(defun std-compute-applicable-methods-using-classes (gf classes)
  (declare (optimize (speed 3)))
  (with-early-accessors (+standard-method-slots+ +eql-specializer-slots+ +standard-generic-function-slots+)
    (flet ((applicable-method-p (method classes)
             (loop for spec in (method-specializers method)
                for class in classes
                always (cond ((eql-specializer-flag spec)
                              ;; EQL specializer invalidate computation
                              ;; we return NIL
                              (when (si::of-class-p (eql-specializer-object spec) class)
                                (return-from std-compute-applicable-methods-using-classes
                                  (values nil nil)))
                              nil)
                             ((si::subclassp class spec))))))
      (values (sort-applicable-methods
               gf
               (loop for method in (generic-function-methods gf)
                  when (applicable-method-p method classes)
                  collect method)
               classes)
              t))))

(defun sort-applicable-methods (gf applicable-list args-specializers)
  (declare (optimize (safety 0) (speed 3)))
  (with-early-accessors (+standard-method-slots+ +standard-generic-function-slots+)
    (let ((f (generic-function-a-p-o-function gf)))
      ;; reorder args to match the precedence order
      (when f
        (setf args-specializers
              (funcall f (subseq args-specializers 0
                                 (length (generic-function-argument-precedence-order gf))))))
      ;; then order the list
      (do* ((scan applicable-list)
            (most-specific (first scan) (first scan))
            (ordered-list))
           ((null (cdr scan))
            (when most-specific
              ;; at least one method
              (nreverse
               (push most-specific ordered-list))))
        (dolist (meth (cdr scan))
          (when (eq (compare-methods most-specific
                                     meth args-specializers f) 2)
            (setq most-specific meth)))
        (setq scan (delete most-specific scan))
        (push most-specific ordered-list)))))

(defun compare-methods (method-1 method-2 args-specializers f)
  (declare (si::c-local))
  (with-early-accessors (+standard-method-slots+)
    (let* ((specializers-list-1 (method-specializers method-1))
           (specializers-list-2 (method-specializers method-2)))
      (compare-specializers-lists (if f (funcall f specializers-list-1) specializers-list-1)
                                  (if f (funcall f specializers-list-2) specializers-list-2)
                                  args-specializers))))

(defun compare-specializers-lists (spec-list-1 spec-list-2 args-specializers)
  (declare (si::c-local))
  (when (or spec-list-1 spec-list-2)
    (ecase (compare-specializers (first spec-list-1)
                                 (first spec-list-2)
                                 (first args-specializers))
      (1 '1)
      (2 '2)
      (= 
       (compare-specializers-lists (cdr spec-list-1)
                                   (cdr spec-list-2)
                                   (cdr args-specializers)))
      ((nil)
       (error "The type specifiers ~S and ~S can not be disambiguated~
                  with respect to the argument specializer: ~S"
              (or (car spec-list-1) t)
              (or (car spec-list-2) t)
              (car args-specializers)))))
  )

(defun fast-subtypep (spec1 spec2)
  (declare (si::c-local))
  ;; Specialized version of subtypep which uses the fact that spec1
  ;; and spec2 are either classes or of the form (EQL x)
  (with-early-accessors (+eql-specializer-slots+ +standard-class-slots+)
    (if (eql-specializer-flag spec1)
        (if (eql-specializer-flag spec2)
            (eql (eql-specializer-object spec1)
                 (eql-specializer-object spec2))
            (si::of-class-p (eql-specializer-object spec1) spec2))
        (if (eql-specializer-flag spec2)
            ;; There is only one class with a single element, which
            ;; is NULL = (MEMBER NIL).
            (and (null (eql-specializer-object spec2))
                 (eq (class-name spec1) 'null))
            (si::subclassp spec1 spec2)))))

(defun compare-specializers (spec-1 spec-2 arg-class)
  (declare (si::c-local))
  (with-early-accessors (+standard-class-slots+ +standard-class-slots+)
    (let* ((cpl (class-precedence-list arg-class)))
      (cond ((eq spec-1 spec-2) '=)
            ((fast-subtypep spec-1 spec-2) '1)
            ((fast-subtypep spec-2 spec-1) '2)
            ((eql-specializer-flag spec-1) '1) ; is this engough?
            ((eql-specializer-flag spec-2) '2) ; Beppe
            ((member spec-1 (member spec-2 cpl)) '2)
            ((member spec-2 (member spec-1 cpl)) '1)
            ;; This will force an error in the caller
            (t nil)))))

(defun compute-g-f-spec-list (gf)
  (with-early-accessors (+standard-generic-function-slots+
                         +eql-specializer-slots+
                         +standard-method-slots+)
    (flet ((nupdate-spec-how-list (spec-how-list specializers gf)
             ;; update the spec-how of the gfun 
             ;; computing the or of the previous value and the new one
             (setf spec-how-list (or spec-how-list
                                     (copy-list specializers)))
             (do* ((l specializers (cdr l))
                   (l2 spec-how-list (cdr l2))
                   (spec-how)
                   (spec-how-old))
                  ((null l))
               (setq spec-how (first l) spec-how-old (first l2))
               (setf (first l2)
                     (if (eql-specializer-flag spec-how)
                         (list* (eql-specializer-object spec-how)
                                (and (consp spec-how-old) spec-how-old))
                         (if (consp spec-how-old)
                             spec-how-old
                             spec-how))))
             spec-how-list))
      (let* ((spec-how-list nil)
             (function nil)
             (a-p-o (generic-function-argument-precedence-order gf)))
        (dolist (method (generic-function-methods gf))
          (setf spec-how-list
                (nupdate-spec-how-list spec-how-list (method-specializers method) gf)))
        (setf (generic-function-spec-list gf)
              (loop for type in spec-how-list
                 for i from 0
                 when type collect (cons type i)))
        (let* ((g-f-l-l (generic-function-lambda-list gf)))
          (when (consp g-f-l-l)
            (let ((required-arguments (rest (si::process-lambda-list g-f-l-l t))))
              (unless (equal a-p-o required-arguments)
                (setf function
                      (coerce `(lambda (%list)
                                 (destructuring-bind ,required-arguments %list
                                   (list ,@a-p-o)))
                              'function))))))
        (setf (generic-function-a-p-o-function gf) function)
        (si:clear-gfun-hash gf)))))

(defun print-object (object stream)
  (print-unreadable-object (object stream)))
