diff options
| author | Stefan Monnier <monnier@iro.umontreal.ca> | 2022-04-01 08:54:55 -0400 |
|---|---|---|
| committer | Stefan Monnier <monnier@iro.umontreal.ca> | 2022-04-01 08:54:55 -0400 |
| commit | ff067408e460c02e69c5b7fd06a03c9b12a5744b (patch) | |
| tree | 8df8cebc6c4d77ed6899ba05b88e3816c45fff12 /lisp/emacs-lisp/oclosure.el | |
| parent | 611179d000cd5cf8e8955e3b3c205692a3e91225 (diff) | |
| download | emacs-ff067408e460c02e69c5b7fd06a03c9b12a5744b.tar.gz emacs-ff067408e460c02e69c5b7fd06a03c9b12a5744b.tar.bz2 emacs-ff067408e460c02e69c5b7fd06a03c9b12a5744b.zip | |
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.
Diffstat (limited to 'lisp/emacs-lisp/oclosure.el')
| -rw-r--r-- | lisp/emacs-lisp/oclosure.el | 16 |
1 files changed, 11 insertions, 5 deletions
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) |