* lisp/emacs-lisp/cl-generic.el (cl--generic-method): New struct.

[gnu-emacs] / lisp / emacs-lisp / eieio-opt.el

diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el
index 6f1d01c211f11b7ae9439704700e9dae20908e59..8d40edf56248c348e635e4845ff698ce2483aabf 100644 (file)
--- a/lisp/emacs-lisp/eieio-opt.el
+++ b/lisp/emacs-lisp/eieio-opt.el
@@ -1,6 +1,6 @@
 ;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar)
 
 ;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar)
 

-;; Copyright (C) 1996, 1998-2003, 2005, 2008-2014 Free Software
+;; Copyright (C) 1996, 1998-2003, 2005, 2008-2015 Free Software

 ;; Foundation, Inc.
 
 ;; Author: Eric M. Ludlam <zappo@gnu.org>
 ;; Foundation, Inc.
 
 ;; Author: Eric M. Ludlam <zappo@gnu.org>


@@ -60,7 +60,7 @@ Argument PREFIX is the character prefix to use.
 Argument CH-PREFIX is another character prefix to display."
   (eieio--check-type class-p this-root)
   (let ((myname (symbol-name this-root))
 Argument CH-PREFIX is another character prefix to display."
   (eieio--check-type class-p this-root)
   (let ((myname (symbol-name this-root))

-       (chl (eieio--class-children (class-v this-root)))
+       (chl (eieio--class-children (eieio--class-v this-root)))

        (fprefix (concat ch-prefix "  +--"))
        (mprefix (concat ch-prefix "  |  "))
        (lprefix (concat ch-prefix "     ")))
        (fprefix (concat ch-prefix "  +--"))
        (mprefix (concat ch-prefix "  |  "))
        (lprefix (concat ch-prefix "     ")))


@@ -81,7 +81,7 @@ If CLASS is actually an object, then also display current values of that object.
   ;; Header line
   (prin1 class)
   (insert " is a"
   ;; Header line
   (prin1 class)
   (insert " is a"

-         (if (class-option class :abstract)
+         (if (eieio--class-option (eieio--class-v class) :abstract)

              "n abstract"
            "")
          " class")
              "n abstract"
            "")
          " class")


@@ -122,34 +122,23 @@ If CLASS is actually an object, then also display current values of that object.
   ;; Describe all the slots in this class.
   (eieio-help-class-slots class)
   ;; Describe all the methods specific to this class.
   ;; Describe all the slots in this class.
   (eieio-help-class-slots class)
   ;; Describe all the methods specific to this class.

-  (let ((methods (eieio-all-generic-functions class))
-       (type [":STATIC" ":BEFORE" ":PRIMARY" ":AFTER"])
-       counter doc)
-    (when methods
+  (let ((generics (eieio-all-generic-functions class)))
+    (when generics

       (insert (propertize "Specialized Methods:\n\n" 'face 'bold))
       (insert (propertize "Specialized Methods:\n\n" 'face 'bold))

-      (while methods
-       (setq doc (eieio-method-documentation (car methods) class))
-       (insert "`")
-       (help-insert-xref-button (symbol-name (car methods))
-                                'help-function (car methods))
-       (insert "'")
-       (if (not doc)
-           (insert "  Undocumented")
-         (setq counter 0)
-         (dolist (cur doc)
-           (when cur
-             (insert " " (aref type counter) " "
-                     (prin1-to-string (car cur) (current-buffer))
-                     "\n"
-                     (or (cdr cur) "")))
-           (setq counter (1+ counter))))
-       (insert "\n\n")
-       (setq methods (cdr methods))))))
+      (dolist (generic generics)
+        (insert "`")
+        (help-insert-xref-button (symbol-name generic) 'help-function generic)
+        (insert "'")
+       (pcase-dolist (`(,qualifiers ,args ,doc)
+                       (eieio-method-documentation generic class))
+          (insert (format " %s%S\n" qualifiers args)
+                  (or doc "")))
+       (insert "\n\n")))))

 
 (defun eieio-help-class-slots (class)
   "Print help description for the slots in CLASS.
 Outputs to the current buffer."
 
 (defun eieio-help-class-slots (class)
   "Print help description for the slots in CLASS.
 Outputs to the current buffer."

-  (let* ((cv (class-v class))
+  (let* ((cv (eieio--class-v class))

         (docs   (eieio--class-public-doc cv))
         (names  (eieio--class-public-a cv))
         (deflt  (eieio--class-public-d cv))
         (docs   (eieio--class-public-doc cv))
         (names  (eieio--class-public-a cv))
         (deflt  (eieio--class-public-d cv))


@@ -218,11 +207,10 @@ Outputs to the current buffer."
 (defun eieio-build-class-list (class)
   "Return a list of all classes that inherit from CLASS."
   (if (class-p class)
 (defun eieio-build-class-list (class)
   "Return a list of all classes that inherit from CLASS."
   (if (class-p class)

-      (apply #'append
-            (mapcar
-             (lambda (c)
-               (append (list c) (eieio-build-class-list c)))
-             (eieio-class-children-fast class)))
+      (cl-mapcan
+       (lambda (c)
+         (append (list c) (eieio-build-class-list c)))
+       (eieio--class-children (eieio--class-v class)))

     (list class)))
 
 (defun eieio-build-class-alist (&optional class instantiable-only buildlist)
     (list class)))
 
 (defun eieio-build-class-alist (&optional class instantiable-only buildlist)


@@ -231,15 +219,16 @@ Optional argument CLASS is the class to start with.
 If INSTANTIABLE-ONLY is non nil, only allow names of classes which
 are not abstract, otherwise allow all classes.
 Optional argument BUILDLIST is more list to attach and is used internally."
 If INSTANTIABLE-ONLY is non nil, only allow names of classes which
 are not abstract, otherwise allow all classes.
 Optional argument BUILDLIST is more list to attach and is used internally."

-  (let* ((cc (or class eieio-default-superclass))
-        (sublst (eieio--class-children (class-v cc))))
+  (let* ((cc (or class 'eieio-default-superclass))
+        (sublst (eieio--class-children (eieio--class-v cc))))

     (unless (assoc (symbol-name cc) buildlist)
       (when (or (not instantiable-only) (not (class-abstract-p cc)))
     (unless (assoc (symbol-name cc) buildlist)
       (when (or (not instantiable-only) (not (class-abstract-p cc)))

+        ;; FIXME: Completion tables don't need alists, and ede/generic.el needs
+        ;; the symbols rather than their names.

        (setq buildlist (cons (cons (symbol-name cc) 1) buildlist))))
        (setq buildlist (cons (cons (symbol-name cc) 1) buildlist))))

-    (while sublst
+    (dolist (elem sublst)

       (setq buildlist (eieio-build-class-alist
       (setq buildlist (eieio-build-class-alist

-                      (car sublst) instantiable-only buildlist))
-      (setq sublst (cdr sublst)))
+                      elem instantiable-only buildlist)))

     buildlist))
 
 (defvar eieio-read-class nil
     buildlist))
 
 (defvar eieio-read-class nil


@@ -311,133 +300,50 @@ are not abstract."
          (eieio-help-class ctr))
        ))))
 
          (eieio-help-class ctr))
        ))))
 

-
-;;;###autoload
-(defun eieio-help-generic (generic)
-  "Describe GENERIC if it is a generic function."
-  (when (and (symbolp generic) (generic-p generic))
-    (save-excursion
-      (goto-char (point-min))
-      (when (re-search-forward " in `.+'.$" nil t)
-       (replace-match ".")))
-    (save-excursion
-      (insert "\n\nThis is a generic function"
-             (cond
-              ((and (generic-primary-only-p generic)
-                    (generic-primary-only-one-p generic))
-               " with only one primary method")
-              ((generic-primary-only-p generic)
-               " with only primary methods")
-              (t ""))
-             ".\n\n")
-      (insert (propertize "Implementations:\n\n" 'face 'bold))
-      (let ((i 4)
-           (prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] ))
-       ;; Loop over fanciful generics
-       (while (< i 7)
-         (let ((gm (aref (get generic 'eieio-method-tree) i)))
-           (when gm
-             (insert "Generic "
-                     (aref prefix (- i 3))
-                     "\n"
-                     (or (nth 2 gm) "Undocumented")
-                     "\n\n")))
-         (setq i (1+ i)))
-       (setq i 0)
-       ;; Loop over defined class-specific methods
-       (while (< i 4)
-         (let* ((gm (reverse (aref (get generic 'eieio-method-tree) i)))
-                cname location)
-           (while gm
-             (setq cname (caar gm))
-             (insert "`")
-             (help-insert-xref-button (symbol-name cname)
-                                      'help-variable cname)
-             (insert "' " (aref prefix i) " ")
-             ;; argument list
-             (let* ((func (cdr (car gm)))
-                    (arglst (help-function-arglist func)))
-               (prin1 arglst (current-buffer)))
-             (insert "\n"
-                     (or (documentation (cdr (car gm)))
-                         "Undocumented"))
-             ;; Print file location if available
-             (when (and (setq location (get generic 'method-locations))
-                        (setq location (assoc cname location)))
-               (setq location (cadr location))
-               (insert "\n\nDefined in `")
-               (help-insert-xref-button
-                (file-name-nondirectory location)
-                'eieio-method-def cname generic location)
-               (insert "'\n"))
-             (setq gm (cdr gm))
-             (insert "\n")))
-         (setq i (1+ i)))))))
+(defun eieio--specializers-apply-to-class-p (specializers class)
+  "Return non-nil if a method with SPECIALIZERS applies to CLASS."
+  (let ((applies nil))
+    (dolist (specializer specializers)
+      (if (eq 'subclass (car-safe specializer))
+          (setq specializer (nth 1 specializer)))
+      ;; Don't include the methods that are "too generic", such as those
+      ;; applying to `eieio-default-superclass'.
+      (and (not (memq specializer '(t eieio-default-superclass)))
+           (class-p specializer)
+           (child-of-class-p class specializer)
+           (setq applies t)))
+    applies))

 
 (defun eieio-all-generic-functions (&optional class)
   "Return a list of all generic functions.
 Optional CLASS argument returns only those functions that contain
 methods for CLASS."
 
 (defun eieio-all-generic-functions (&optional class)
   "Return a list of all generic functions.
 Optional CLASS argument returns only those functions that contain
 methods for CLASS."

-  (let ((l nil) tree (cn (if class (symbol-name class) nil)))
+  (let ((l nil))

     (mapatoms
      (lambda (symbol)
     (mapatoms
      (lambda (symbol)

-       (setq tree (get symbol 'eieio-method-obarray))
-       (if tree
-          (progn
-            ;; A symbol might be interned for that class in one of
-            ;; these three slots in the method-obarray.
-            (if (or (not class)
-                    (fboundp (intern-soft cn (aref tree 0)))
-                    (fboundp (intern-soft cn (aref tree 1)))
-                    (fboundp (intern-soft cn (aref tree 2))))
-                (setq l (cons symbol l)))))))
+       (let ((generic (and (fboundp symbol) (cl--generic symbol))))
+         (and generic
+             (catch 'found
+               (if (null class) (throw 'found t))
+               (dolist (method (cl--generic-method-table generic))
+                 (if (eieio--specializers-apply-to-class-p
+                      (cl--generic-method-specializers method) class)
+                     (throw 'found t))))
+             (push symbol l)))))

     l))
 
 (defun eieio-method-documentation (generic class)
     l))
 
 (defun eieio-method-documentation (generic class)

-  "Return a list of the specific documentation of GENERIC for CLASS.
-If there is not an explicit method for CLASS in GENERIC, or if that
-function has no documentation, then return nil."
-  (let ((tree (get generic 'eieio-method-obarray))
-       (cn (symbol-name class))
-       before primary after)
-    (if (not tree)
-       nil
-      ;; A symbol might be interned for that class in one of
-      ;; these three slots in the method-obarray.
-      (setq before (intern-soft cn (aref tree 0))
-           primary (intern-soft cn (aref tree 1))
-           after (intern-soft cn (aref tree 2)))
-      (if (not (or (fboundp before)
-                  (fboundp primary)
-                  (fboundp after)))
-         nil
-       (list (if (fboundp before)
-                 (cons (help-function-arglist before)
-                       (documentation before))
-               nil)
-             (if (fboundp primary)
-                 (cons (help-function-arglist primary)
-                       (documentation primary))
-               nil)
-             (if (fboundp after)
-                 (cons (help-function-arglist after)
-                       (documentation after))
-               nil))))))
-
-(defvar eieio-read-generic nil
-  "History of the `eieio-read-generic' prompt.")
-
-(defun eieio-read-generic-p (fn)
-  "Function used in function `eieio-read-generic'.
-This is because `generic-p' is a macro.
-Argument FN is the function to test."
-  (generic-p fn))
-
-(defun eieio-read-generic (prompt &optional historyvar)
-  "Read a generic function from the minibuffer with PROMPT.
-Optional argument HISTORYVAR is the variable to use as history."
-  (intern (completing-read prompt obarray 'eieio-read-generic-p
-                          t nil (or historyvar 'eieio-read-generic))))
+  "Return info for all methods of GENERIC applicable to CLASS.
+The value returned is a list of elements of the form
+\(QUALIFIERS ARGS DOC)."
+  (let ((generic (cl--generic generic))
+        (docs ()))
+    (when generic
+      (dolist (method (cl--generic-method-table generic))
+        (when (eieio--specializers-apply-to-class-p
+               (cl--generic-method-specializers method) class)
+          (push (cl--generic-method-info method) docs))))
+    docs))

 
 ;;; METHOD STATS
 ;;
 
 ;;; METHOD STATS
 ;;


@@ -627,21 +533,21 @@ Optional argument HISTORYVAR is the variable to use as history."
   ()
   "Menu part in easymenu format used in speedbar while in `eieio' mode.")
 
   ()
   "Menu part in easymenu format used in speedbar while in `eieio' mode.")
 

-(defun eieio-class-speedbar (dir-or-object depth)
+(defun eieio-class-speedbar (_dir-or-object _depth)

   "Create buttons in speedbar that represents the current project.
 DIR-OR-OBJECT is the object to expand, or nil, and DEPTH is the
 current expansion depth."
   (when (eq (point-min) (point-max))
     ;; This function is only called once, to start the whole deal.
     ;; Create and expand the default object.
   "Create buttons in speedbar that represents the current project.
 DIR-OR-OBJECT is the object to expand, or nil, and DEPTH is the
 current expansion depth."
   (when (eq (point-min) (point-max))
     ;; This function is only called once, to start the whole deal.
     ;; Create and expand the default object.

-    (eieio-class-button eieio-default-superclass 0)
+    (eieio-class-button 'eieio-default-superclass 0)

     (forward-line -1)
     (speedbar-expand-line)))
 
 (defun eieio-class-button (class depth)
   "Draw a speedbar button at the current point for CLASS at DEPTH."
   (eieio--check-type class-p class)
     (forward-line -1)
     (speedbar-expand-line)))
 
 (defun eieio-class-button (class depth)
   "Draw a speedbar button at the current point for CLASS at DEPTH."
   (eieio--check-type class-p class)

-  (let ((subclasses (eieio--class-children (class-v class))))
+  (let ((subclasses (eieio--class-children (eieio--class-v class))))

     (if subclasses
        (speedbar-make-tag-line 'angle ?+
                                'eieio-sb-expand
     (if subclasses
        (speedbar-make-tag-line 'angle ?+
                                'eieio-sb-expand


@@ -666,7 +572,7 @@ Argument INDENT is the depth of indentation."
         (speedbar-with-writable
           (save-excursion
             (end-of-line) (forward-char 1)
         (speedbar-with-writable
           (save-excursion
             (end-of-line) (forward-char 1)

-            (let ((subclasses (eieio--class-children (class-v class))))
+            (let ((subclasses (eieio--class-children (eieio--class-v class))))

               (while subclasses
                 (eieio-class-button (car subclasses) (1+ indent))
                 (setq subclasses (cdr subclasses)))))))
               (while subclasses
                 (eieio-class-button (car subclasses) (1+ indent))
                 (setq subclasses (cdr subclasses)))))))


@@ -676,7 +582,7 @@ Argument INDENT is the depth of indentation."
        (t (error "Ooops...  not sure what to do")))
   (speedbar-center-buffer-smartly))
 
        (t (error "Ooops...  not sure what to do")))
   (speedbar-center-buffer-smartly))
 

-(defun eieio-describe-class-sb (text token indent)
+(defun eieio-describe-class-sb (_text token _indent)

   "Describe the class TEXT in TOKEN.
 INDENT is the current indentation level."
   (dframe-with-attached-buffer
   "Describe the class TEXT in TOKEN.
 INDENT is the current indentation level."
   (dframe-with-attached-buffer