OClosure: Add support for defmethod dispatch

* lisp/emacs-lisp/oclosure.el (oclosure--class): Add slot `allparents`.
(oclosure--class-make): Add corresponding arg `allparents`.
(oclosure, oclosure--build-class): Pass the new arg to the constructor.
(oclosure--define): Make the predicate function understand subtyping.

* lisp/emacs-lisp/cl-preloaded.el (cl--class-allparents): Move from
`cl-generic.el`.

* lisp/emacs-lisp/cl-generic.el (cl--generic-class-parents): Move to
`cl-preloaded.el` and rename to `cl--class-allparents`.
Adjust all callers.
(cl--generic-oclosure-tag, cl-generic--oclosure-specializers): New functions.
(cl-generic-generalizers) <oclosure-struct>: New generalizer.

* test/lisp/emacs-lisp/oclosure-tests.el (oclosure-test-gen):
New generic function.
(oclosure-test): Add test for dispatch on oclosure types.

diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 5cbdb9523ac54f10fd9c6945ead8b303b62c1180..32a5fe5e54b1590816ede4027afd98ae8b0845b4 100644 (file)
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -1126,7 +1126,7 @@ MET-NAME is as returned by `cl--generic-load-hist-format'."
                  (let ((sclass (cl--find-class specializer))
                        (tclass (cl--find-class type)))
                    (when (and sclass tclass)
-                     (member specializer (cl--generic-class-parents tclass))))))
+                     (member specializer (cl--class-allparents tclass))))))
            (setq applies t)))
     applies))
 
@@ -1255,22 +1255,11 @@ These match if the argument is `eql' to VAL."
   ;; Use exactly the same code as for `typeof'.
   `(if ,name (type-of ,name) 'null))
 
-(defun cl--generic-class-parents (class)
-  (let ((parents ())
-        (classes (list class)))
-    ;; BFS precedence.  FIXME: Use a topological sort.
-    (while (let ((class (pop classes)))
-             (cl-pushnew (cl--class-name class) parents)
-             (setq classes
-                   (append classes
-                           (cl--class-parents class)))))
-    (nreverse parents)))
-
 (defun cl--generic-struct-specializers (tag &rest _)
   (and (symbolp tag)
        (let ((class (get tag 'cl--class)))
          (when (cl-typep class 'cl-structure-class)
-           (cl--generic-class-parents class)))))
+           (cl--class-allparents class)))))
 
 (cl-generic-define-generalizer cl--generic-struct-generalizer
   50 #'cl--generic-struct-tag
@@ -1353,6 +1342,42 @@ Used internally for the (major-mode MODE) context specializers."
                     (progn (cl-assert (null modes)) mode)
                   `(derived-mode ,mode . ,modes))))
 
+;;; Dispatch on OClosure type
+
+;; It would make sense to put this into `oclosure.el' except that when
+;; `oclosure.el' is loaded `cl-defmethod' is not available yet.
+
+(defun cl--generic-oclosure-tag (name &rest _)
+  `(oclosure-type ,name))
+
+(defun cl-generic--oclosure-specializers (tag &rest _)
+  (and (symbolp tag)
+       (let ((class (cl--find-class tag)))
+         (when (cl-typep class 'oclosure--class)
+           (oclosure--class-allparents class)))))
+
+(cl-generic-define-generalizer cl-generic--oclosure-generalizer
+  ;; Give slightly higher priority than the struct specializer, so that
+  ;; for a generic function with methods dispatching structs and on OClosures,
+  ;; we first try `oclosure-type' before `type-of' since `type-of' will return
+  ;; non-nil for an OClosure as well.
+  51 #'cl--generic-oclosure-tag
+  #'cl-generic--oclosure-specializers)
+
+(cl-defmethod cl-generic-generalizers :extra "oclosure-struct" (type)
+  "Support for dispatch on types defined by `oclosure-define'."
+  (or
+   (when (symbolp type)
+     ;; Use the "cl--struct-class*" (inlinable) functions/macros rather than
+     ;; the "cl-struct-*" variants which aren't inlined, so that dispatch can
+     ;; take place without requiring cl-lib.
+     (let ((class (cl--find-class type)))
+       (and (cl-typep class 'oclosure--class)
+            (list cl-generic--oclosure-generalizer))))
+   (cl-call-next-method)))
+
+(cl--generic-prefill-dispatchers 0 oclosure)
+
 ;;; Support for unloading.
 
 (cl-defmethod loadhist-unload-element ((x (head cl-defmethod)))

diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 6aa45526d845cd33259910a5086b226c23f307b6..93713f506d2c6cf914cfa3db9cf59b1647493356 100644 (file)
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -305,6 +305,17 @@ supertypes from the most specific to least specific.")
 (cl-assert (cl--class-p (cl--find-class 'cl-structure-class)))
 (cl-assert (cl--class-p (cl--find-class 'cl-structure-object)))
 
+(defun cl--class-allparents (class)
+  (let ((parents ())
+        (classes (list class)))
+    ;; BFS precedence.  FIXME: Use a topological sort.
+    (while (let ((class (pop classes)))
+             (cl-pushnew (cl--class-name class) parents)
+             (setq classes
+                   (append classes
+                           (cl--class-parents class)))))
+    (nreverse parents)))
+
 ;; Make sure functions defined with cl-defsubst can be inlined even in
 ;; packages which do not require CL.  We don't put an autoload cookie
 ;; directly on that function, since those cookies only go to cl-loaddefs.

diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el
index db108bd7beee5ea066325326ffa5a78925f4661a..c37a5352a3a2e520bfb747a42b6cc75b6fae6d42 100644 (file)
--- a/lisp/emacs-lisp/oclosure.el
+++ b/lisp/emacs-lisp/oclosure.el
@@ -131,16 +131,17 @@
 (cl-defstruct (oclosure--class
                (:constructor nil)
                (:constructor oclosure--class-make
-                ( name docstring slots parents
+                ( name docstring slots parents allparents
                   &aux (index-table (oclosure--index-table slots))))
                (:include cl--class)
                (:copier nil))
-  "Metaclass for OClosure classes.")
+  "Metaclass for OClosure classes."
+  (allparents nil :read-only t :type (list-of symbol)))
 
 (setf (cl--find-class 'oclosure)
       (oclosure--class-make 'oclosure
                             "The root parent of all OClosure classes"
-                            nil nil))
+                            nil nil '(oclosure)))
 (defun oclosure--p (oclosure)
   (not (not (oclosure-type oclosure))))
 
@@ -283,7 +284,9 @@ list of slot properties.  The currently known properties are the following:
     (oclosure--class-make name docstring slotdescs
                           (if (cdr parent-names)
                               (oclosure--class-parents parent-class)
-                            (list parent-class)))))
+                            (list parent-class))
+                          (cons name (oclosure--class-allparents
+                                      parent-class)))))
 
 (defmacro oclosure--define-functions (name copiers)
   (let* ((class (cl--find-class name))
@@ -324,7 +327,10 @@ list of slot properties.  The currently known properties are the following:
                               &rest props)
   (let* ((class (oclosure--build-class name docstring parent-names slots))
          (pred (lambda (oclosure)
-                 (eq name (oclosure-type oclosure))))
+                 (let ((type (oclosure-type oclosure)))
+                   (when type
+                     (memq name (oclosure--class-allparents
+                                 (cl--find-class type)))))))
          (predname (or (plist-get props :predicate)
                        (intern (format "%s--internal-p" name)))))
     (setf (cl--find-class name) class)

diff --git a/test/lisp/emacs-lisp/oclosure-tests.el b/test/lisp/emacs-lisp/oclosure-tests.el
index e7e76fa4bda33f750913f8abcdb9890c4d54fc11..c72a9dbd7ad63dfebfa3cd44a3d8ada1c692a340 100644 (file)
--- a/test/lisp/emacs-lisp/oclosure-tests.el
+++ b/test/lisp/emacs-lisp/oclosure-tests.el
@@ -29,6 +29,16 @@
   "Simple OClosure."
   fst snd name)
 
+(cl-defmethod oclosure-test-gen ((_x compiled-function)) "#<bytecode>")
+
+(cl-defmethod oclosure-test-gen ((_x cons)) "#<cons>")
+
+(cl-defmethod oclosure-test-gen ((_x oclosure))
+  (format "#<oclosure:%s>" (cl-call-next-method)))
+
+(cl-defmethod oclosure-test-gen ((_x oclosure-test))
+  (format "#<oclosure-test:%s>" (cl-call-next-method)))
+
 (ert-deftest oclosure-test ()
   (let* ((i 42)
          (ocl1 (oclosure-lambda (oclosure-test (fst 1) (snd 2) (name "hi"))
@@ -51,6 +61,9 @@
     (should (equal (funcall (oclosure-test-copy1 ocl1 9)) '(9 2 44)))
     (should (cl-typep ocl1 'oclosure-test))
     (should (cl-typep ocl1 'oclosure))
+    (should (member (oclosure-test-gen ocl1)
+                    '("#<oclosure-test:#<oclosure:#<cons>>>"
+                      "#<oclosure-test:#<oclosure:#<bytecode>>>")))
     ))
 
 (ert-deftest oclosure-test-limits ()