[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] master 21c5478: Replace *-function vars with generic funct
|
From: |
Stefan Monnier |
|
Subject: |
[Emacs-diffs] master 21c5478: Replace *-function vars with generic functions in cl-generic. |
|
Date: |
Thu, 05 Mar 2015 01:05:17 +0000 |
branch: master
commit 21c547863d5950a9d623d62ab743e92c0e1fd95f
Author: Stefan Monnier <address@hidden>
Commit: Stefan Monnier <address@hidden>
Replace *-function vars with generic functions in cl-generic.
* lisp/emacs-lisp/cl-generic.el (cl--generic-generalizer): New struct.
(cl-generic-tagcode-function, cl-generic-tag-types-function): Remove.
(cl--generic-t-generalizer): New const.
(cl--generic-make-method): Rename from `cl--generic-method-make'.
(cl--generic-make): Change calling convention.
(cl--generic): Add `options' field.
(cl-generic-function-options): New function.
(cl-defgeneric): Rewrite handling of options. Add support for :method
options and allow the use of a default body.
(cl-generic-define): Save options in the corresponding new field.
(cl-defmethod): Fix ordering of qualifiers.
(cl-generic-define-method): Use cl-generic-generalizers.
(cl--generic-get-dispatcher): Change calling convention, and change
calling convention of the returned function as well so as to take the
list of methods separately from the generic function object, so that it
can receive the original generic function object.
(cl--generic-make-next-function): New function, extracted from
cl--generic-make-function.
(cl--generic-make-function): Use it.
(cl-generic-method-combination-function): Remove.
(cl--generic-cyclic-definition): New error.
(cl-generic-call-method): Take a generic function object rather than
its name.
(cl-method-qualifiers): New alias.
(cl--generic-build-combined-method): Use cl-generic-combine-methods,
don't segregate by qualifiers here any more.
(cl--generic-standard-method-combination): Segregate by qualifiers
here instead. Add support for the `:extra' qualifier.
(cl--generic-cache-miss): Move earlier, adjust to new calling convention.
(cl-generic-generalizers, cl-generic-combine-methods):
New generic functions.
(cl-no-next-method, cl-no-applicable-method, cl-no-primary-method):
Use the new "default method in defgeneric" functionality, change
calling convention to receive a generic function object.
(cl--generic-head-used): New var.
(cl--generic-head-generalizer, cl--generic-eql-generalizer)
(cl--generic-struct-generalizer, cl--generic-typeof-generalizer):
New consts.
* lisp/emacs-lisp/eieio-core.el (eieio--generic-generalizer)
(eieio--generic-subclass-generalizer): New consts.
(cl-generic-generalizers): New methods.
* lisp/emacs-lisp/eieio-compat.el (eieio--generic-static-symbol-generalizer)
(eieio--generic-static-object-generalizer): New consts.
(cl-generic-generalizers) <(head eieio--static)>: New method.
* lisp/emacs-lisp/byte-opt.el (byte-optimize-form-code-walker):
Unfold closures like lambdas.
---
lisp/ChangeLog | 74 ++++-
lisp/emacs-lisp/byte-opt.el | 2 +-
lisp/emacs-lisp/cl-generic.el | 625 ++++++++++++++++++++++++---------------
lisp/emacs-lisp/eieio-compat.el | 56 ++--
lisp/emacs-lisp/eieio-core.el | 54 ++--
5 files changed, 504 insertions(+), 307 deletions(-)
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index cdd4bf8..d4bc0af 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,53 @@
+2015-03-05 Stefan Monnier <address@hidden>
+
+ Replace *-function vars with generic functions in cl-generic.
+ * emacs-lisp/cl-generic.el (cl--generic-generalizer): New struct.
+ (cl-generic-tagcode-function, cl-generic-tag-types-function): Remove.
+ (cl--generic-t-generalizer): New const.
+ (cl--generic-make-method): Rename from `cl--generic-method-make'.
+ (cl--generic-make): Change calling convention.
+ (cl--generic): Add `options' field.
+ (cl-generic-function-options): New function.
+ (cl-defgeneric): Rewrite handling of options. Add support for :method
+ options and allow the use of a default body.
+ (cl-generic-define): Save options in the corresponding new field.
+ (cl-defmethod): Fix ordering of qualifiers.
+ (cl-generic-define-method): Use cl-generic-generalizers.
+ (cl--generic-get-dispatcher): Change calling convention, and change
+ calling convention of the returned function as well so as to take the
+ list of methods separately from the generic function object, so that it
+ can receive the original generic function object.
+ (cl--generic-make-next-function): New function, extracted from
+ cl--generic-make-function.
+ (cl--generic-make-function): Use it.
+ (cl-generic-method-combination-function): Remove.
+ (cl--generic-cyclic-definition): New error.
+ (cl-generic-call-method): Take a generic function object rather than
+ its name.
+ (cl-method-qualifiers): New alias.
+ (cl--generic-build-combined-method): Use cl-generic-combine-methods,
+ don't segregate by qualifiers here any more.
+ (cl--generic-standard-method-combination): Segregate by qualifiers
+ here instead. Add support for the `:extra' qualifier.
+ (cl--generic-cache-miss): Move earlier, adjust to new calling
convention.
+ (cl-generic-generalizers, cl-generic-combine-methods):
+ New generic functions.
+ (cl-no-next-method, cl-no-applicable-method, cl-no-primary-method):
+ Use the new "default method in defgeneric" functionality, change
+ calling convention to receive a generic function object.
+ (cl--generic-head-used): New var.
+ (cl--generic-head-generalizer, cl--generic-eql-generalizer)
+ (cl--generic-struct-generalizer, cl--generic-typeof-generalizer):
+ New consts.
+ * emacs-lisp/eieio-core.el (eieio--generic-generalizer)
+ (eieio--generic-subclass-generalizer): New consts.
+ (cl-generic-generalizers): New methods.
+ * emacs-lisp/eieio-compat.el (eieio--generic-static-symbol-generalizer)
+ (eieio--generic-static-object-generalizer): New consts.
+ (cl-generic-generalizers) <(head eieio--static)>: New method.
+ * emacs-lisp/byte-opt.el (byte-optimize-form-code-walker):
+ Unfold closures like lambdas.
+
2015-03-04 Filipp Gunbin <address@hidden>
* autorevert.el (auto-revert-notify-add-watch):
@@ -142,8 +192,8 @@
2015-03-03 Eli Zaretskii <address@hidden>
* frame.el (frame-notice-user-settings): Refresh the value of
- frame parameters after calling tty-handle-reverse-video. Call
- face-set-after-frame-default with the actual parameters, to avoid
+ frame parameters after calling tty-handle-reverse-video.
+ Call face-set-after-frame-default with the actual parameters, to avoid
resetting colors back to unspecified.
(set-background-color, set-foreground-color): Pass the foreground
and background colors to face-set-after-frame-default. (Bug#19802)
@@ -176,8 +226,8 @@
2015-03-03 Eli Zaretskii <address@hidden>
- * textmodes/artist.el (artist-ellipse-compute-fill-info): Use
- mapcar, not mapc, to create the other half of fill-info.
+ * textmodes/artist.el (artist-ellipse-compute-fill-info):
+ Use mapcar, not mapc, to create the other half of fill-info.
(Bug#19763)
2015-03-03 Nicolas Petton <address@hidden>
@@ -323,8 +373,8 @@
Handle "#" operator properly inside macro. Fix coding bug.
- * progmodes/cc-mode.el (c-neutralize-syntax-in-and-mark-CPP): On
- finding a "#" which looks like the start of a macro, check it
+ * progmodes/cc-mode.el (c-neutralize-syntax-in-and-mark-CPP):
+ On finding a "#" which looks like the start of a macro, check it
isn't already inside a macro.
* progmodes/cc-engine.el (c-state-safe-place): Don't record a new
@@ -364,15 +414,15 @@
2015-02-25 Oleh Krehel <address@hidden>
- * emacs-lisp/check-declare.el (check-declare-warn): Use
- compilation-style warnings.
+ * emacs-lisp/check-declare.el (check-declare-warn):
+ Use compilation-style warnings.
(check-declare-files): Make sure that
`check-declare-warning-buffer' is in `compilation-mode'.
2015-02-25 Oleh Krehel <address@hidden>
- * emacs-lisp/check-declare.el (check-declare-ext-errors): New
- defcustom.
+ * emacs-lisp/check-declare.el (check-declare-ext-errors):
+ New defcustom.
(check-declare): New defgroup.
(check-declare-verify): When `check-declare-ext-errors' is
non-nil, warn about an unfound function, instead of saying
@@ -380,8 +430,8 @@
2015-02-25 Tassilo Horn <address@hidden>
- * textmodes/reftex-vars.el (reftex-include-file-commands): Call
- reftex-set-dirty on changes.
+ * textmodes/reftex-vars.el (reftex-include-file-commands):
+ Call reftex-set-dirty on changes.
2015-02-25 Stefan Monnier <address@hidden>
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 149c472..e149f80 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -390,7 +390,7 @@
(and (nth 1 form)
(not for-effect)
form))
- ((eq 'lambda (car-safe fn))
+ ((memq (car-safe fn) '(lambda closure))
(let ((newform (byte-compile-unfold-lambda form)))
(if (eq newform form)
;; Some error occurred, avoid infinite recursion
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 99924ba..a8483ea 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -31,37 +31,51 @@
;; from a significant problem: the method-combination code returns a sexp
;; that needs to be `eval'uated or compiled. IOW it requires run-time
;; code generation. Given how rarely method-combinations are used,
-;; I just provided a cl-generic-method-combination-function, which
-;; people can use if they are really desperate for such functionality.
+;; I just provided a cl-generic-combine-methods generic function, to which
+;; people can add methods if they are really desperate for such
functionality.
;; - In defgeneric we don't support the options:
-;; declare, :method-combination, :generic-function-class, :method-class,
-;; :method.
+;; declare, :method-combination, :generic-function-class, :method-class.
;; Added elements:
;; - We support aliases to generic functions.
-;; - The kind of thing on which to dispatch can be extended.
-;; There is support in this file for dispatch on:
+;; - cl-generic-generalizers. This generic function lets you extend the kind
+;; of thing on which to dispatch. There is support in this file for
+;; dispatch on:
;; - (eql <val>)
+;; - (head <val>) which checks that the arg is a cons with <val> as its head.
;; - plain old types
;; - type of CL structs
;; eieio-core adds dispatch on:
;; - class of eieio objects
;; - actual class argument, using the syntax (subclass <class>).
-;; - cl-generic-method-combination-function (i.s.o define-method-combination).
+;; - cl-generic-combine-methods (i.s.o define-method-combination and
+;; compute-effective-method).
;; - cl-generic-call-method (which replaces make-method and call-method).
+;; - The standard method combination supports ":extra STRING" qualifiers
+;; which simply allows adding more methods for the same
+;; specializers&qualifiers.
;; Efficiency considerations: overall, I've made an effort to make this fairly
;; efficient for the expected case (e.g. no constant redefinition of methods).
;; - Generic functions which do not dispatch on any argument are implemented
;; optimally (just as efficient as plain old functions).
;; - Generic functions which only dispatch on one argument are fairly efficient
-;; (not a lot of room for improvement, I think).
+;; (not a lot of room for improvement without changes to the byte-compiler,
+;; I think).
;; - Multiple dispatch is implemented rather naively. There's an extra `apply'
;; function call for every dispatch; we don't optimize each dispatch
;; based on the set of candidate methods remaining; we don't optimize the
-;; order in which we performs the dispatches either; If/when this
-;; becomes a problem, we can try and optimize it.
+;; order in which we performs the dispatches either;
+;; If/when this becomes a problem, we can try and optimize it.
;; - call-next-method could be made more efficient, but isn't too terrible.
+;; TODO:
+;;
+;; - A generic "filter" generalizer (e.g. could be used to cleanly adds methods
+;; to cl-generic-combine-methods with a specializer that says it applies only
+;; when some particular qualifier is used).
+;; - A way to dispatch on the context (e.g. the major-mode, some global
+;; variable, you name it).
+
;;; Code:
;; Note: For generic functions that dispatch on several arguments (i.e. those
@@ -70,40 +84,24 @@
;; often suboptimal since after one dispatch, the remaining dispatches can
;; usually be simplified, or even completely skipped.
-;; TODO/FIXME:
-;; - WIBNI we could use something like
-;; (add-function :before (cl-method-function (cl-find-method ...)) ...)
-
(eval-when-compile (require 'cl-lib))
(eval-when-compile (require 'pcase))
-(defvar cl-generic-tagcode-function
- (lambda (type _name)
- (if (eq type t) '(0 . 'cl--generic-type)
- (error "Unknown specializer %S" type)))
- "Function to get the Elisp code to extract the tag on which we dispatch.
-Takes a \"parameter-specializer-name\" and a variable name, and returns
-a pair (PRIORITY . CODE) where CODE is an Elisp expression that should be
-used to extract the \"tag\" (from the object held in the named variable)
-that should uniquely determine if we have a match
-\(i.e. the \"tag\" is the value that will be used to dispatch to the proper
-method(s)).
-Such \"tagcodes\" will be or'd together.
-PRIORITY is an integer from 0 to 100 which is used to sort the tagcodes
-in the `or'. The higher the priority, the more specific the tag should be.
-More specifically, if PRIORITY is N and we have two objects X and Y
-whose tag (according to TAGCODE) is `eql', then it should be the case
-that for all other (PRIORITY . TAGCODE) where PRIORITY ≤ N, then
-\(eval TAGCODE) for X is `eql' to (eval TAGCODE) for Y.")
-
-(defvar cl-generic-tag-types-function
- (lambda (tag) (if (eq tag 'cl--generic-type) '(t)))
- "Function to get the list of types that a given \"tag\" matches.
-They should be sorted from most specific to least specific.")
+(cl-defstruct (cl--generic-generalizer
+ (:constructor nil)
+ (:constructor cl-generic-make-generalizer
+ (priority tagcode-function specializers-function)))
+ (priority nil :type integer)
+ tagcode-function
+ specializers-function)
+
+(defconst cl--generic-t-generalizer
+ (cl-generic-make-generalizer
+ 0 (lambda (_name) nil) (lambda (_tag) '(t))))
(cl-defstruct (cl--generic-method
(:constructor nil)
- (:constructor cl--generic-method-make
+ (:constructor cl--generic-make-method
(specializers qualifiers uses-cnm function))
(:predicate nil))
(specializers nil :read-only t :type list)
@@ -115,8 +113,7 @@ They should be sorted from most specific to least
specific.")
(cl-defstruct (cl--generic
(:constructor nil)
- (:constructor cl--generic-make
- (name &optional dispatches method-table))
+ (:constructor cl--generic-make (name))
(:predicate nil))
(name nil :type symbol :read-only t) ;Pointer back to the symbol.
;; `dispatches' holds a list of (ARGNUM . TAGCODES) where ARGNUM is the index
@@ -125,8 +122,13 @@ They should be sorted from most specific to least
specific.")
;; on which to dispatch and PRIORITY is the priority of each expression to
;; decide in which order to sort them.
;; The most important dispatch is last in the list (and the least is first).
- (dispatches nil :type (list-of (cons natnum (list-of tagcode))))
- (method-table nil :type (list-of cl--generic-method)))
+ (dispatches nil :type (list-of (cons natnum (list-of generalizers))))
+ (method-table nil :type (list-of cl--generic-method))
+ (options nil :type list))
+
+(defun cl-generic-function-options (generic)
+ "Return the options of the generic function GENERIC."
+ (cl--generic-options generic))
(defmacro cl--generic (name)
`(get ,name 'cl--generic))
@@ -170,20 +172,34 @@ is appropriate to use. Specific methods are defined with
`cl-defmethod'.
With this implementation the ARGS are currently ignored.
OPTIONS-AND-METHODS currently understands:
- (:documentation DOCSTRING)
-- (declare DECLARATIONS)"
+- (declare DECLARATIONS)
+- (:argument-precedence-order &rest ARGS)
+- (:method [QUALIFIERS...] ARGS &rest BODY)
+BODY, if present, is used as the body of a default method.
+
+\(fn NAME ARGS [DOC-STRING] [OPTIONS-AND-METHODS...] &rest BODY)"
(declare (indent 2) (doc-string 3))
- (let* ((docprop (assq :documentation options-and-methods))
- (doc (cond ((stringp (car-safe options-and-methods))
- (pop options-and-methods))
- (docprop
- (prog1
- (cadr docprop)
- (setq options-and-methods
- (delq docprop options-and-methods))))))
- (declarations (assq 'declare options-and-methods)))
- (when declarations
- (setq options-and-methods
- (delq declarations options-and-methods)))
+ (let* ((doc (if (stringp (car-safe options-and-methods))
+ (pop options-and-methods)))
+ (declarations nil)
+ (methods ())
+ (options ())
+ next-head)
+ (while (progn (setq next-head (car-safe (car options-and-methods)))
+ (or (keywordp next-head)
+ (eq next-head 'declare)))
+ (pcase next-head
+ (`:documentation
+ (when doc (error "Multiple doc strings for %S" name))
+ (setq doc (cadr (pop options-and-methods))))
+ (`declare
+ (when declarations (error "Multiple `declare' for %S" name))
+ (setq declarations (pop options-and-methods)))
+ (`:method (push (cdr (pop options-and-methods)) methods))
+ (_ (push (pop options-and-methods) options))))
+ (when options-and-methods
+ ;; Anything remaining is assumed to be a default method body.
+ (push `(,args ,@options-and-methods) methods))
`(progn
,(when (eq 'setf (car-safe name))
(pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite
@@ -200,8 +216,10 @@ OPTIONS-AND-METHODS currently understands:
nil))))
(cdr declarations))
(defalias ',name
- (cl-generic-define ',name ',args ',options-and-methods)
- ,(help-add-fundoc-usage doc args)))))
+ (cl-generic-define ',name ',args ',(nreverse options))
+ ,(help-add-fundoc-usage doc args))
+ ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method))
+ (nreverse methods)))))
(defun cl--generic-mandatory-args (args)
(let ((res ()))
@@ -210,10 +228,10 @@ OPTIONS-AND-METHODS currently understands:
(nreverse res)))
;;;###autoload
-(defun cl-generic-define (name args options-and-methods)
+(defun cl-generic-define (name args options)
(let ((generic (cl-generic-ensure-function name))
(mandatory (cl--generic-mandatory-args args))
- (apo (assq :argument-precedence-order options-and-methods)))
+ (apo (assq :argument-precedence-order options)))
(setf (cl--generic-dispatches generic) nil)
(when apo
(dolist (arg (cdr apo))
@@ -222,6 +240,7 @@ OPTIONS-AND-METHODS currently understands:
(push (list (- (length mandatory) (length pos)))
(cl--generic-dispatches generic)))))
(setf (cl--generic-method-table generic) nil)
+ (setf (cl--generic-options generic) options)
(cl--generic-make-function generic)))
(defmacro cl-generic-current-method-specializers ()
@@ -341,7 +360,7 @@ which case this method will be invoked when the argument is
`eql' to VAL.
;; But in practice, it's common to use `cl-defmethod'
;; without a previous `cl-defgeneric'.
(declare-function ,name "")
- (cl-generic-define-method ',name ',qualifiers ',args
+ (cl-generic-define-method ',name ',(nreverse qualifiers) ',args
,uses-cnm ,fun)))))
(defun cl--generic-member-method (specializers qualifiers methods)
@@ -359,28 +378,33 @@ which case this method will be invoked when the argument
is `eql' to VAL.
(mandatory (cl--generic-mandatory-args args))
(specializers
(mapcar (lambda (arg) (if (consp arg) (cadr arg) t)) mandatory))
- (method (cl--generic-method-make
+ (method (cl--generic-make-method
specializers qualifiers uses-cnm function))
(mt (cl--generic-method-table generic))
(me (cl--generic-member-method specializers qualifiers mt))
(dispatches (cl--generic-dispatches generic))
(i 0))
(dolist (specializer specializers)
- (let* ((tagcode (funcall cl-generic-tagcode-function specializer 'arg))
+ (let* ((generalizers (cl-generic-generalizers specializer))
(x (assq i dispatches)))
(unless x
- (setq x (list i (funcall cl-generic-tagcode-function t 'arg)))
+ (setq x (cons i (cl-generic-generalizers t)))
(setf (cl--generic-dispatches generic)
(setq dispatches (cons x dispatches))))
- (unless (member tagcode (cdr x))
- (setf (cdr x)
- (nreverse (sort (cons tagcode (cdr x))
- #'car-less-than-car))))
+ (dolist (generalizer generalizers)
+ (unless (member generalizer (cdr x))
+ (setf (cdr x)
+ (sort (cons generalizer (cdr x))
+ (lambda (x y)
+ (> (cl--generic-generalizer-priority x)
+ (cl--generic-generalizer-priority y)))))))
(setq i (1+ i))))
(if me (setcar me method)
(setf (cl--generic-method-table generic) (cons method mt)))
(cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers))
current-load-list :test #'equal)
+ ;; FIXME: Try to avoid re-constructing a new function if the old one
+ ;; is still valid (e.g. still empty method cache)?
(let ((gfun (cl--generic-make-function generic))
;; Prevent `defalias' from recording this as the definition site of
;; the generic function.
@@ -399,62 +423,73 @@ which case this method will be invoked when the argument
is `eql' to VAL.
(defvar cl--generic-dispatchers (make-hash-table :test #'equal))
-(defun cl--generic-get-dispatcher (tagcodes dispatch-arg)
+(defun cl--generic-get-dispatcher (dispatch)
(cl--generic-with-memoization
- (gethash (cons dispatch-arg tagcodes) cl--generic-dispatchers)
- (let ((lexical-binding t)
- (tag-exp `(or ,@(mapcar #'cdr
- ;; Minor optimization: since this tag-exp is
- ;; only used to lookup the method-cache, it
- ;; doesn't matter if the default value is some
- ;; constant or nil.
- (if (macroexp-const-p (car (last tagcodes)))
- (butlast tagcodes)
- tagcodes))))
- (extraargs ()))
+ (gethash dispatch cl--generic-dispatchers)
+ (let* ((dispatch-arg (car dispatch))
+ (generalizers (cdr dispatch))
+ (lexical-binding t)
+ (tagcodes
+ (mapcar (lambda (generalizer)
+ (funcall (cl--generic-generalizer-tagcode-function
+ generalizer)
+ 'arg))
+ generalizers))
+ (typescodes
+ (mapcar (lambda (generalizer)
+ `(funcall
',(cl--generic-generalizer-specializers-function
+ generalizer)
+ ,(funcall
(cl--generic-generalizer-tagcode-function
+ generalizer)
+ 'arg)))
+ generalizers))
+ (tag-exp
+ ;; Minor optimization: since this tag-exp is
+ ;; only used to lookup the method-cache, it
+ ;; doesn't matter if the default value is some
+ ;; constant or nil.
+ `(or ,@(if (macroexp-const-p (car (last tagcodes)))
+ (butlast tagcodes)
+ tagcodes)))
+ (extraargs ()))
(dotimes (_ dispatch-arg)
(push (make-symbol "arg") extraargs))
+ ;; FIXME: For generic functions with a single method (or with 2 methods,
+ ;; one of which always matches), using a tagcode + hash-table is
+ ;; overkill: better just use a `cl-typep' test.
(byte-compile
- `(lambda (generic dispatches-left)
+ `(lambda (generic dispatches-left methods)
(let ((method-cache (make-hash-table :test #'eql)))
(lambda (,@extraargs arg &rest args)
(apply (cl--generic-with-memoization
(gethash ,tag-exp method-cache)
(cl--generic-cache-miss
- generic ',dispatch-arg dispatches-left
- (list ,@(mapcar #'cdr tagcodes))))
+ generic ',dispatch-arg dispatches-left methods
+ ,(if (cdr typescodes)
+ `(append ,@typescodes) (car typescodes))))
,@extraargs arg args))))))))
(defun cl--generic-make-function (generic)
- (let* ((dispatches (cl--generic-dispatches generic))
- (dispatch
+ (cl--generic-make-next-function generic
+ (cl--generic-dispatches generic)
+ (cl--generic-method-table generic)))
+
+(defun cl--generic-make-next-function (generic dispatches methods)
+ (let* ((dispatch
(progn
(while (and dispatches
- (member (cdar dispatches)
- '(nil ((0 . 'cl--generic-type)))))
+ (let ((x (nth 1 (car dispatches))))
+ ;; No need to dispatch for `t' specializers.
+ (or (null x) (equal x cl--generic-t-generalizer))))
(setq dispatches (cdr dispatches)))
(pop dispatches))))
- (if (null dispatch)
- (cl--generic-build-combined-method
- (cl--generic-name generic)
- (cl--generic-method-table generic))
- (let ((dispatcher (cl--generic-get-dispatcher
- (cdr dispatch) (car dispatch))))
- (funcall dispatcher generic dispatches)))))
-
-(defvar cl-generic-method-combination-function
- #'cl--generic-standard-method-combination
- "Function to build the effective method.
-Called with 2 arguments: NAME and METHOD-ALIST.
-It should return an effective method, i.e. a function that expects the same
-arguments as the methods, and calls those methods in some appropriate order.
-NAME is the name (a symbol) of the corresponding generic function.
-METHOD-ALIST is a list of elements (QUALIFIERS . METHODS) where
-QUALIFIERS is a list of qualifiers, and METHODS is a list of the selected
-methods for that qualifier list.
-The METHODS lists are sorted from most generic first to most specific last.
-The function can use `cl-generic-call-method' to create functions that call
those
-methods.")
+ (if (not (and dispatch
+ ;; If there's no method left, there's no point checking
+ ;; further arguments.
+ methods))
+ (cl--generic-build-combined-method generic methods)
+ (let ((dispatcher (cl--generic-get-dispatcher dispatch)))
+ (funcall dispatcher generic dispatches methods)))))
(defvar cl--generic-combined-method-memoization
(make-hash-table :test #'equal :weakness 'value)
@@ -463,27 +498,37 @@ This is particularly useful when many different tags
select the same set
of methods, since this table then allows us to share a single combined-method
for all those different tags in the method-cache.")
-(defun cl--generic-build-combined-method (generic-name methods)
- (cl--generic-with-memoization
- (gethash (cons generic-name methods)
- cl--generic-combined-method-memoization)
- (let ((mets-by-qual ()))
- (dolist (method methods)
- (let* ((qualifiers (cl--generic-method-qualifiers method))
- (x (assoc qualifiers mets-by-qual)))
- ;; FIXME: sadly, alist-get only uses `assq' and we need `assoc'.
- ;;(push (cdr qm) (alist-get qualifiers mets-by-qual)))
- (if x
- (push method (cdr x))
- (push (list qualifiers method) mets-by-qual))))
- (funcall cl-generic-method-combination-function
- generic-name mets-by-qual))))
+(define-error 'cl--generic-cyclic-definition "Cyclic definition: %S")
+
+(defun cl--generic-build-combined-method (generic methods)
+ (if (null methods)
+ ;; Special case needed to fix a circularity during bootstrap.
+ (cl--generic-standard-method-combination generic methods)
+ (let ((f
+ (cl--generic-with-memoization
+ ;; FIXME: Since the fields of `generic' are modified, this
+ ;; hash-table won't work right, because the hashes will change!
+ ;; It's not terribly serious, but reduces the effectiveness of
+ ;; the table.
+ (gethash (cons generic methods)
+ cl--generic-combined-method-memoization)
+ (puthash (cons generic methods) :cl--generic--under-construction
+ cl--generic-combined-method-memoization)
+ (condition-case nil
+ (cl-generic-combine-methods generic methods)
+ ;; Special case needed to fix a circularity during bootstrap.
+ (cl--generic-cyclic-definition
+ (cl--generic-standard-method-combination generic methods))))))
+ (if (eq f :cl--generic--under-construction)
+ (signal 'cl--generic-cyclic-definition
+ (list (cl--generic-name generic)))
+ f))))
(defun cl--generic-no-next-method-function (generic method)
(lambda (&rest args)
(apply #'cl-no-next-method generic method args)))
-(defun cl-generic-call-method (generic-name method &optional fun)
+(defun cl-generic-call-method (generic method &optional fun)
"Return a function that calls METHOD.
FUN is the function that should be called when METHOD calls
`call-next-method'."
@@ -491,7 +536,7 @@ FUN is the function that should be called when METHOD calls
(cl--generic-method-function method)
(let ((met-fun (cl--generic-method-function method))
(next (or fun (cl--generic-no-next-method-function
- generic-name method))))
+ generic method))))
(lambda (&rest args)
(apply met-fun
;; FIXME: This sucks: passing just `next' would
@@ -503,42 +548,122 @@ FUN is the function that should be called when METHOD
calls
(apply next (or cnm-args args)))
args)))))
-(defun cl--generic-standard-method-combination (generic-name mets-by-qual)
- (dolist (x mets-by-qual)
- (unless (member (car x) '(() (:after) (:before) (:around)))
- (error "Unsupported qualifiers in function %S: %S" generic-name (car
x))))
- (cond
- ((null mets-by-qual)
- (lambda (&rest args)
- (apply #'cl-no-applicable-method generic-name args)))
- ((null (alist-get nil mets-by-qual))
- (lambda (&rest args)
- (apply #'cl-no-primary-method generic-name args)))
- (t
- (let* ((fun nil)
- (ab-call (lambda (m) (cl-generic-call-method generic-name m)))
- (before
- (mapcar ab-call (reverse (cdr (assoc '(:before) mets-by-qual)))))
- (after (mapcar ab-call (cdr (assoc '(:after) mets-by-qual)))))
- (dolist (method (cdr (assoc nil mets-by-qual)))
- (setq fun (cl-generic-call-method generic-name method fun)))
- (when (or after before)
- (let ((next fun))
- (setq fun (lambda (&rest args)
- (dolist (bf before)
- (apply bf args))
- (prog1
- (apply next args)
- (dolist (af after)
- (apply af args)))))))
- (dolist (method (cdr (assoc '(:around) mets-by-qual)))
- (setq fun (cl-generic-call-method generic-name method fun)))
- fun))))
+;; Standard CLOS name.
+(defalias 'cl-method-qualifiers #'cl--generic-method-qualifiers)
+
+(defun cl--generic-standard-method-combination (generic methods)
+ (let ((mets-by-qual ()))
+ (dolist (method methods)
+ (let ((qualifiers (cl-method-qualifiers method)))
+ (if (eq (car qualifiers) :extra) (setq qualifiers (cddr qualifiers)))
+ (unless (member qualifiers '(() (:after) (:before) (:around)))
+ (error "Unsupported qualifiers in function %S: %S"
+ (cl--generic-name generic) qualifiers))
+ (push method (alist-get (car qualifiers) mets-by-qual))))
+ (cond
+ ((null mets-by-qual)
+ (lambda (&rest args)
+ (apply #'cl-no-applicable-method generic args)))
+ ((null (alist-get nil mets-by-qual))
+ (lambda (&rest args)
+ (apply #'cl-no-primary-method generic args)))
+ (t
+ (let* ((fun nil)
+ (ab-call (lambda (m) (cl-generic-call-method generic m)))
+ (before
+ (mapcar ab-call (reverse (cdr (assoc :before mets-by-qual)))))
+ (after (mapcar ab-call (cdr (assoc :after mets-by-qual)))))
+ (dolist (method (cdr (assoc nil mets-by-qual)))
+ (setq fun (cl-generic-call-method generic method fun)))
+ (when (or after before)
+ (let ((next fun))
+ (setq fun (lambda (&rest args)
+ (dolist (bf before)
+ (apply bf args))
+ (prog1
+ (apply next args)
+ (dolist (af after)
+ (apply af args)))))))
+ (dolist (method (cdr (assoc :around mets-by-qual)))
+ (setq fun (cl-generic-call-method generic method fun)))
+ fun)))))
+
+(defun cl--generic-cache-miss (generic
+ dispatch-arg dispatches-left methods-left types)
+ (let ((methods '()))
+ (dolist (method methods-left)
+ (let* ((specializer (or (nth dispatch-arg
+ (cl--generic-method-specializers method))
+ t))
+ (m (member specializer types)))
+ (when m
+ (push (cons (length m) method) methods))))
+ ;; Sort the methods, most specific first.
+ ;; It would be tempting to sort them once and for all in the method-table
+ ;; rather than here, but the order might depend on the actual argument
+ ;; (e.g. for multiple inheritance with defclass).
+ (setq methods (nreverse (mapcar #'cdr (sort methods #'car-less-than-car))))
+ (cl--generic-make-next-function generic dispatches-left methods)))
+
+(cl-defgeneric cl-generic-generalizers (specializer)
+ "Return a list of generalizers for a given SPECIALIZER.
+To each kind of `specializer', corresponds a `generalizer' which describes
+how to extract a \"tag\" from an object which will then let us check if this
+object matches the specializer. A typical example of a \"tag\" would be the
+type of an object. It's called a `generalizer' because it
+takes a specific object and returns a more general approximation,
+denoting a set of objects to which it belongs.
+A generalizer gives us the chunk of code which the
+dispatch function needs to use to extract the \"tag\" of an object, as well
+as a function which turns this tag into an ordered list of
+`specializers' that this object matches.
+The code which extracts the tag should be as fast as possible.
+The tags should be chosen according to the following rules:
+- The tags should not be too specific: similar objects which match the
+ same list of specializers should ideally use the same (`eql') tag.
+ This insures that the cached computation of the applicable
+ methods for one object can be reused for other objects.
+- Corollary: objects which don't match any of the relevant specializers
+ should ideally all use the same tag (typically nil).
+ This insures that this cache does not grow unnecessarily large.
+- Two different generalizers G1 and G2 should not use the same tag
+ unless they use it for the same set of objects. IOW, if G1.tag(X1) =
+ G2.tag(X2) then G1.tag(X1) = G2.tag(X1) = G1.tag(X2) = G2.tag(X2).
+- If G1.priority > G2.priority and G1.tag(X1) = G1.tag(X2) and this tag is
+ non-nil, then you have to make sure that the G2.tag(X1) = G2.tag(X2).
+ This is because the method-cache is only indexed with the first non-nil
+ tag (by order of decreasing priority).")
+
+
+(cl-defgeneric cl-generic-combine-methods (generic methods)
+ "Build the effective method made of METHODS.
+It should return a function that expects the same arguments as the methods, and
+ calls those methods in some appropriate order.
+GENERIC is the generic function (mostly used for its name).
+METHODS is the list of the selected methods.
+The METHODS list is sorted from most specific first to most generic last.
+The function can use `cl-generic-call-method' to create functions that call
those
+methods.")
+
+;; Temporary definition to let the next defmethod succeed.
+(fset 'cl-generic-generalizers
+ (lambda (_specializer) (list cl--generic-t-generalizer)))
+(fset 'cl-generic-combine-methods
+ #'cl--generic-standard-method-combination)
+
+(cl-defmethod cl-generic-generalizers (specializer)
+ "Support for the catch-all `t' specializer."
+ (if (eq specializer t) (list cl--generic-t-generalizer)
+ (error "Unknown specializer %S" specializer)))
+
+(cl-defmethod cl-generic-combine-methods (generic methods)
+ "Standard support for :after, :before, :around, and `:extra NAME'
qualifiers."
+ (cl--generic-standard-method-combination generic methods))
(defconst cl--generic-nnm-sample (cl--generic-no-next-method-function t t))
(defconst cl--generic-cnm-sample
(funcall (cl--generic-build-combined-method
- nil (list (cl--generic-method-make () () t #'identity)))))
+ nil (list (cl--generic-make-method () () t #'identity)))))
(defun cl--generic-isnot-nnm-p (cnm)
"Return non-nil if CNM is the function that calls `cl-no-next-method'."
@@ -566,24 +691,6 @@ FUN is the function that should be called when METHOD calls
(setq cnm-env (cdr cnm-env)))))
(error "Haven't found no-next-method-sample in cnm-sample")))
-(defun cl--generic-cache-miss (generic dispatch-arg dispatches-left tags)
- (let ((types (apply #'append (mapcar cl-generic-tag-types-function tags)))
- (methods '()))
- (dolist (method (cl--generic-method-table generic))
- (let* ((specializer (or (nth dispatch-arg
- (cl--generic-method-specializers method))
- t))
- (m (member specializer types)))
- (when m
- (push (cons (length m) method) methods))))
- ;; Sort the methods, most specific first.
- ;; It would be tempting to sort them once and for all in the method-table
- ;; rather than here, but the order might depend on the actual argument
- ;; (e.g. for multiple inheritance with defclass).
- (setq methods (nreverse (mapcar #'cdr (sort methods #'car-less-than-car))))
- (cl--generic-make-function (cl--generic-make (cl--generic-name generic)
- dispatches-left methods))))
-
;;; Define some pre-defined generic functions, used internally.
(define-error 'cl-no-method "No method for %S")
@@ -593,19 +700,16 @@ FUN is the function that should be called when METHOD
calls
'cl-no-method)
(cl-defgeneric cl-no-next-method (generic method &rest args)
- "Function called when `cl-call-next-method' finds no next method.")
-(cl-defmethod cl-no-next-method (generic method &rest args)
- (signal 'cl-no-next-method `(,generic ,method ,@args)))
+ "Function called when `cl-call-next-method' finds no next method."
+ (signal 'cl-no-next-method `(,(cl--generic-name generic) ,method ,@args)))
(cl-defgeneric cl-no-applicable-method (generic &rest args)
- "Function called when a method call finds no applicable method.")
-(cl-defmethod cl-no-applicable-method (generic &rest args)
- (signal 'cl-no-applicable-method `(,generic ,@args)))
+ "Function called when a method call finds no applicable method."
+ (signal 'cl-no-applicable-method `(,(cl--generic-name generic) ,@args)))
(cl-defgeneric cl-no-primary-method (generic &rest args)
- "Function called when a method call finds no primary method.")
-(cl-defmethod cl-no-primary-method (generic &rest args)
- (signal 'cl-no-primary-method `(,generic ,@args)))
+ "Function called when a method call finds no primary method."
+ (signal 'cl-no-primary-method `(,(cl--generic-name generic) ,@args)))
(defun cl-call-next-method (&rest _args)
"Function to call the next applicable method.
@@ -700,27 +804,57 @@ Can only be used from within the lexical body of a
primary or around method."
(insert "'.\n")))
(insert "\n" (or (nth 2 info) "Undocumented") "\n\n")))))))
+;;; Support for (head <val>) specializers.
+
+;; For both the `eql' and the `head' specializers, the dispatch
+;; is unsatisfactory. Basically, in the "common&fast case", we end up doing
+;;
+;; (let ((tag (gethash value <tagcode-hashtable>)))
+;; (funcall (gethash tag <method-cache>)))
+;;
+;; whereas we'd like to just do
+;;
+;; (funcall (gethash value <method-cache>)))
+;;
+;; but the problem is that the method-cache is normally "open ended", so
+;; a nil means "not computed yet" and if we bump into it, we dutifully fill the
+;; corresponding entry, whereas we'd want to just fallback on some default
+;; effective method (so as not to fill the cache with lots of redundant
+;; entries).
+
+(defvar cl--generic-head-used (make-hash-table :test #'eql))
+
+(defconst cl--generic-head-generalizer
+ (cl-generic-make-generalizer
+ 80 (lambda (name) `(gethash (car-safe ,name) cl--generic-head-used))
+ (lambda (tag) (if (eq (car-safe tag) 'head) (list tag)))))
+
+(cl-defmethod cl-generic-generalizers :extra "head" (specializer)
+ "Support for the `(head VAL)' specializers."
+ ;; We have to implement `head' here using the :extra qualifier,
+ ;; since we can't use the `head' specializer to implement itself.
+ (if (not (eq (car-safe specializer) 'head))
+ (cl-call-next-method)
+ (cl--generic-with-memoization
+ (gethash (cadr specializer) cl--generic-head-used) specializer)
+ (list cl--generic-head-generalizer)))
+
;;; Support for (eql <val>) specializers.
(defvar cl--generic-eql-used (make-hash-table :test #'eql))
-(add-function :before-until cl-generic-tagcode-function
- #'cl--generic-eql-tagcode)
-(defun cl--generic-eql-tagcode (type name)
- (when (eq (car-safe type) 'eql)
- (puthash (cadr type) type cl--generic-eql-used)
- `(100 . (gethash ,name cl--generic-eql-used))))
+(defconst cl--generic-eql-generalizer
+ (cl-generic-make-generalizer
+ 100 (lambda (name) `(gethash ,name cl--generic-eql-used))
+ (lambda (tag) (if (eq (car-safe tag) 'eql) (list tag)))))
-(add-function :before-until cl-generic-tag-types-function
- #'cl--generic-eql-tag-types)
-(defun cl--generic-eql-tag-types (tag)
- (if (eq (car-safe tag) 'eql) (list tag)))
+(cl-defmethod cl-generic-generalizers ((specializer (head eql)))
+ "Support for the `(eql VAL)' specializers."
+ (puthash (cadr specializer) specializer cl--generic-eql-used)
+ (list cl--generic-eql-generalizer))
;;; Support for cl-defstructs specializers.
-(add-function :before-until cl-generic-tagcode-function
- #'cl--generic-struct-tagcode)
-
(defun cl--generic-struct-tag (name)
`(and (vectorp ,name)
(> (length ,name) 0)
@@ -728,41 +862,46 @@ Can only be used from within the lexical body of a
primary or around method."
(if (eq (symbol-function tag) :quick-object-witness-check)
tag))))
-(defun cl--generic-struct-tagcode (type name)
- (and (symbolp type)
- (get type 'cl-struct-type)
- (or (null (car (get type 'cl-struct-type)))
- (error "Can't dispatch on cl-struct %S: type is %S"
- type (car (get type 'cl-struct-type))))
- (or (equal '(cl-tag-slot) (car (get type 'cl-struct-slots)))
- (error "Can't dispatch on cl-struct %S: no tag in slot 0"
- type))
- ;; It's tempting to use (and (vectorp ,name) (aref ,name 0))
- ;; but that would suffer from some problems:
- ;; - the vector may have size 0.
- ;; - when called on an actual vector (rather than an object), we'd
- ;; end up returning an arbitrary value, possibly colliding with
- ;; other tagcode's values.
- ;; - it can also result in returning all kinds of irrelevant
- ;; values which would end up filling up the method-cache with
- ;; lots of irrelevant/redundant entries.
- ;; FIXME: We could speed this up by introducing a dedicated
- ;; vector type at the C level, so we could do something like
- ;; (and (vector-objectp ,name) (aref ,name 0))
- `(50 . ,(cl--generic-struct-tag name))))
-
-(add-function :before-until cl-generic-tag-types-function
- #'cl--generic-struct-tag-types)
-(defun cl--generic-struct-tag-types (tag)
- ;; FIXME: cl-defstruct doesn't make it easy for us.
+(defun cl--generic-struct-specializers (tag)
(and (symbolp tag)
;; A method call shouldn't itself mess with the match-data.
(string-match-p "\\`cl-struct-\\(.*\\)" (symbol-name tag))
(let ((types (list (intern (substring (symbol-name tag) 10)))))
- (while (get (car types) 'cl-struct-include)
- (push (get (car types) 'cl-struct-include) types))
- (push 'cl-structure-object types) ;The "parent type" of all
cl-structs.
- (nreverse types))))
+ (while (get (car types) 'cl-struct-include)
+ (push (get (car types) 'cl-struct-include) types))
+ (push 'cl-structure-object types) ;The "parent type" of all cl-structs.
+ (nreverse types))))
+
+(defconst cl--generic-struct-generalizer
+ (cl-generic-make-generalizer
+ 50 #'cl--generic-struct-tag
+ #'cl--generic-struct-specializers))
+
+(cl-defmethod cl-generic-generalizers :extra "cl-struct" (type)
+ "Support for dispatch on cl-struct types."
+ (or
+ (and (symbolp type)
+ (get type 'cl-struct-type)
+ (or (null (car (get type 'cl-struct-type)))
+ (error "Can't dispatch on cl-struct %S: type is %S"
+ type (car (get type 'cl-struct-type))))
+ (or (equal '(cl-tag-slot) (car (get type 'cl-struct-slots)))
+ (error "Can't dispatch on cl-struct %S: no tag in slot 0"
+ type))
+ ;; It's tempting to use (and (vectorp ,name) (aref ,name 0))
+ ;; but that would suffer from some problems:
+ ;; - the vector may have size 0.
+ ;; - when called on an actual vector (rather than an object), we'd
+ ;; end up returning an arbitrary value, possibly colliding with
+ ;; other tagcode's values.
+ ;; - it can also result in returning all kinds of irrelevant
+ ;; values which would end up filling up the method-cache with
+ ;; lots of irrelevant/redundant entries.
+ ;; FIXME: We could speed this up by introducing a dedicated
+ ;; vector type at the C level, so we could do something like
+ ;; (and (vector-objectp ,name) (aref ,name 0))
+ (list cl--generic-struct-generalizer))
+ (cl-call-next-method)))
;;; Dispatch on "system types".
@@ -784,23 +923,23 @@ Can only be used from within the lexical body of a
primary or around method."
(sequence)
(number)))
-(add-function :before-until cl-generic-tagcode-function
- #'cl--generic-typeof-tagcode)
-(defun cl--generic-typeof-tagcode (type name)
+(defconst cl--generic-typeof-generalizer
+ (cl-generic-make-generalizer
+ ;; FIXME: We could also change `type-of' to return `null' for nil.
+ 10 (lambda (name) `(if ,name (type-of ,name) 'null))
+ (lambda (tag) (and (symbolp tag) (assq tag cl--generic-typeof-types)))))
+
+(cl-defmethod cl-generic-generalizers :extra "typeof" (type)
+ "Support for dispatch on builtin types."
;; FIXME: Add support for other types accepted by `cl-typep' such
;; as `character', `atom', `face', `function', ...
- (and (assq type cl--generic-typeof-types)
- (progn
- (if (memq type '(vector array sequence))
- (message "`%S' also matches CL structs and EIEIO classes" type))
- ;; FIXME: We could also change `type-of' to return `null' for nil.
- `(10 . (if ,name (type-of ,name) 'null)))))
-
-(add-function :before-until cl-generic-tag-types-function
- #'cl--generic-typeof-types)
-(defun cl--generic-typeof-types (tag)
- (and (symbolp tag)
- (assq tag cl--generic-typeof-types)))
+ (or
+ (and (assq type cl--generic-typeof-types)
+ (progn
+ (if (memq type '(vector array sequence))
+ (message "`%S' also matches CL structs and EIEIO classes" type))
+ (list cl--generic-typeof-generalizer)))
+ (cl-call-next-method)))
;;; Just for kicks: dispatch on major-mode
;;
@@ -814,7 +953,7 @@ Can only be used from within the lexical body of a primary
or around method."
;; (defvar cl--generic-major-modes (make-hash-table :test #'eq))
;;
-;; (add-function :before-until cl-generic-tagcode-function
+;; (add-function :before-until cl-generic-generalizer-function
;; #'cl--generic-major-mode-tagcode)
;; (defun cl--generic-major-mode-tagcode (type name)
;; (if (eq 'major-mode (car-safe type))
diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el
index 7468c04..ee8e731 100644
--- a/lisp/emacs-lisp/eieio-compat.el
+++ b/lisp/emacs-lisp/eieio-compat.el
@@ -124,30 +124,38 @@ Summary:
(defgeneric ,method ,args)
(eieio--defmethod ',method ',key ',class #',code))))
-(add-function :before-until cl-generic-tagcode-function
- #'eieio--generic-static-tagcode)
-(defun eieio--generic-static-tagcode (type name)
- (and (eq 'eieio--static (car-safe type))
- `(40 . (cond
- ((symbolp ,name) (eieio--class-v ,name))
- ((vectorp ,name) (aref ,name 0))))))
-
-(add-function :around cl-generic-tag-types-function
- #'eieio--generic-static-tag-types)
-(defun eieio--generic-static-tag-types (orig-fun tag)
- (cond
- ((or (eieio--class-p tag)
- (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag))))
- (let ((superclasses (funcall orig-fun tag))
- (types ()))
- ;; Interleave: (subclass <foo>) (eieio--static <foo>) <subclass <bar>) ..
- (dolist (superclass superclasses)
- (push superclass types)
- (push `(eieio--static
- ,(if (consp superclass) (cadr superclass) superclass))
- types))
- (nreverse types)))
- (t (funcall orig-fun tag))))
+(defconst eieio--generic-static-symbol-generalizer
+ (cl-generic-make-generalizer
+ ;; Give it a slightly higher priority than `subclass' so that the
+ ;; interleaved list comes before subclass's non-interleaved list.
+ 61 (lambda (name) `(and (symbolp ,name) (eieio--class-v ,name)))
+ (lambda (tag)
+ (when (eieio--class-p tag)
+ (let ((superclasses (eieio--generic-subclass-specializers tag))
+ (specializers ()))
+ (dolist (superclass superclasses)
+ (push superclass specializers)
+ (push `(eieio--static ,(cadr superclass)) specializers))
+ (nreverse specializers))))))
+(defconst eieio--generic-static-object-generalizer
+ (cl-generic-make-generalizer
+ ;; Give it a slightly higher priority than `class' so that the
+ ;; interleaved list comes before the class's non-interleaved list.
+ 51 #'cl--generic-struct-tag
+ (lambda (tag)
+ (and (symbolp tag) (boundp tag) (setq tag (symbol-value tag))
+ (eieio--class-p tag)
+ (let ((superclasses (eieio--class-precedence-list tag))
+ (specializers ()))
+ (dolist (superclass superclasses)
+ (setq superclass (eieio--class-symbol superclass))
+ (push superclass specializers)
+ (push `(eieio--static ,superclass) specializers))
+ (nreverse specializers))))))
+
+(cl-defmethod cl-generic-generalizers ((_specializer (head eieio--static)))
+ (list eieio--generic-static-symbol-generalizer
+ eieio--generic-static-object-generalizer))
;;;###autoload
(defun eieio--defgeneric-init-form (method doc-string)
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index 408922a..1e226c1 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -1203,25 +1203,26 @@ method invocation orders of the involved classes."
;;;; General support to dispatch based on the type of the argument.
-(add-function :before-until cl-generic-tagcode-function
- #'eieio--generic-tagcode)
-(defun eieio--generic-tagcode (type name)
+(defconst eieio--generic-generalizer
+ (cl-generic-make-generalizer
+ ;; Use the exact same tagcode as for cl-struct, so that methods
+ ;; that dispatch on both kinds of objects get to share this
+ ;; part of the dispatch code.
+ 50 #'cl--generic-struct-tag
+ (lambda (tag)
+ (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag))
+ (mapcar #'eieio--class-symbol
+ (eieio--class-precedence-list (symbol-value tag)))))))
+
+(cl-defmethod cl-generic-generalizers :extra "class" (specializer)
;; CLHS says:
;; A class must be defined before it can be used as a parameter
;; specializer in a defmethod form.
;; So we can ignore types that are not known to denote classes.
- (and (eieio--class-p (eieio--class-object type))
- ;; Use the exact same code as for cl-struct, so that methods
- ;; that dispatch on both kinds of objects get to share this
- ;; part of the dispatch code.
- `(50 . ,(cl--generic-struct-tag name))))
-
-(add-function :before-until cl-generic-tag-types-function
- #'eieio--generic-tag-types)
-(defun eieio--generic-tag-types (tag)
- (and (symbolp tag) (boundp tag) (eieio--class-p (symbol-value tag))
- (mapcar #'eieio--class-symbol
- (eieio--class-precedence-list (symbol-value tag)))))
+ (or
+ (and (eieio--class-p (eieio--class-object specializer))
+ (list eieio--generic-generalizer))
+ (cl-call-next-method)))
;;;; Dispatch for arguments which are classes.
@@ -1231,23 +1232,22 @@ method invocation orders of the involved classes."
;; would not make much sense (e.g. to which argument should it apply?).
;; Instead, we add a new "subclass" specializer.
-(add-function :before-until cl-generic-tagcode-function
- #'eieio--generic-subclass-tagcode)
-(defun eieio--generic-subclass-tagcode (type name)
- (when (eq 'subclass (car-safe type))
- `(60 . (and (symbolp ,name) (eieio--class-v ,name)))))
-
-(add-function :before-until cl-generic-tag-types-function
- #'eieio--generic-subclass-tag-types)
-(defun eieio--generic-subclass-tag-types (tag)
+(defun eieio--generic-subclass-specializers (tag)
(when (eieio--class-p tag)
(mapcar (lambda (class)
- `(subclass
- ,(if (symbolp class) class (eieio--class-symbol class))))
+ `(subclass ,(eieio--class-symbol class)))
(eieio--class-precedence-list tag))))
+(defconst eieio--generic-subclass-generalizer
+ (cl-generic-make-generalizer
+ 60 (lambda (name) `(and (symbolp ,name) (eieio--class-v ,name)))
+ #'eieio--generic-subclass-specializers))
+
+(cl-defmethod cl-generic-generalizers ((_specializer (head subclass)))
+ (list eieio--generic-subclass-generalizer))
+
-;;;### (autoloads nil "eieio-compat" "eieio-compat.el"
"5b04c9a8fff2bd3f3d3ac54aba0f65b7")
+;;;### (autoloads nil "eieio-compat" "eieio-compat.el"
"25a66814a400e7dea16bf0f3bfe245ed")
;;; Generated autoloads from eieio-compat.el
(autoload 'eieio--defalias "eieio-compat" "\
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] master 21c5478: Replace *-function vars with generic functions in cl-generic.,
Stefan Monnier <=