From ff067408e460c02e69c5b7fd06a03c9b12a5744b Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 1 Apr 2022 08:54:55 -0400 Subject: [PATCH] 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) : New generalizer. * test/lisp/emacs-lisp/oclosure-tests.el (oclosure-test-gen): New generic function. (oclosure-test): Add test for dispatch on oclosure types. --- lisp/emacs-lisp/cl-generic.el | 51 +++++++++++++++++++------- lisp/emacs-lisp/cl-preloaded.el | 11 ++++++ lisp/emacs-lisp/oclosure.el | 16 +++++--- test/lisp/emacs-lisp/oclosure-tests.el | 13 +++++++ 4 files changed, 73 insertions(+), 18 deletions(-) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 5cbdb9523ac..32a5fe5e54b 100644 --- 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 6aa45526d84..93713f506d2 100644 --- 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 db108bd7bee..c37a5352a3a 100644 --- 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 e7e76fa4bda..c72a9dbd7ad 100644 --- 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)) "#") + +(cl-defmethod oclosure-test-gen ((_x cons)) "#") + +(cl-defmethod oclosure-test-gen ((_x oclosure)) + (format "#" (cl-call-next-method))) + +(cl-defmethod oclosure-test-gen ((_x oclosure-test)) + (format "#" (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) + '("#>>" + "#>>"))) )) (ert-deftest oclosure-test-limits () -- 2.39.2