diff options
Diffstat (limited to 'lisp/emacs-lisp/cl-generic.el')
| -rw-r--r-- | lisp/emacs-lisp/cl-generic.el | 129 |
1 files changed, 92 insertions, 37 deletions
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 8e36dbe4a36..4a69df15bc8 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -189,6 +189,32 @@ SPECIALIZERS-FUNCTION takes as first argument a tag value TAG (setf (cl--generic name) (setq generic (cl--generic-make name)))) generic)) +(defvar cl--generic-edebug-name nil) + +(defun cl--generic-edebug-remember-name (name pf &rest specs) + ;; Remember the name in `cl-defgeneric' so we can use it when building + ;; the names of its `:methods'. + (let ((cl--generic-edebug-name (car name))) + (funcall pf specs))) + +(defun cl--generic-edebug-make-name (in:method _oldname &rest quals-and-args) + ;; The name to use in Edebug for a method: use the generic + ;; function's name plus all its qualifiers and finish with + ;; its specializers. + (pcase-let* + ((basename (if in:method cl--generic-edebug-name (pop quals-and-args))) + (args (car (last quals-and-args))) + (`(,spec-args . ,_) (cl--generic-split-args args)) + (specializers (mapcar (lambda (spec-arg) + (if (eq '&context (car-safe (car spec-arg))) + spec-arg (cdr spec-arg))) + spec-args))) + (format "%s %s" + (mapconcat (lambda (sexp) (format "%s" sexp)) + (cons basename (butlast quals-and-args)) + " ") + specializers))) + ;;;###autoload (defmacro cl-defgeneric (name args &rest options-and-methods) "Create a generic function NAME. @@ -206,24 +232,22 @@ DEFAULT-BODY, if present, is used as the body of a default method. \(fn NAME ARGS [DOC-STRING] [OPTIONS-AND-METHODS...] &rest DEFAULT-BODY)" (declare (indent 2) (doc-string 3) (debug - (&define [&or name ("setf" name :name setf)] listp - lambda-doc - [&rest [&or - ("declare" &rest sexp) - (":argument-precedence-order" &rest sexp) - (&define ":method" - ;; FIXME: The `:unique' - ;; construct works around - ;; Bug#42672. We'd rather want - ;; names like those generated by - ;; `cl-defmethod', but that - ;; requires larger changes to - ;; Edebug. - :unique "cl-generic-:method@" - [&rest cl-generic-method-qualifier] - cl-generic-method-args lambda-doc - def-body)]] - def-body))) + (&define + &interpose + [&name sexp] ;Allow (setf ...) additionally to symbols. + cl--generic-edebug-remember-name + listp lambda-doc + [&rest [&or + ("declare" &rest sexp) + (":argument-precedence-order" &rest sexp) + (&define ":method" + [&name + [[&rest cl-generic--method-qualifier-p] + listp] ;Formal args + cl--generic-edebug-make-name in:method] + lambda-doc + def-body)]] + def-body))) (let* ((doc (if (stringp (car-safe options-and-methods)) (pop options-and-methods))) (declarations nil) @@ -398,10 +422,23 @@ the specializer used will be the one returned by BODY." (let ((combined-doc (buffer-string))) (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc))))) +(defun cl-generic--method-qualifier-p (x) + (not (listp x))) + +(defun cl--defmethod-doc-pos () + "Return the index of the docstring for a `cl-defmethod'. +Presumes point is at the end of the `cl-defmethod' symbol." + (save-excursion + (let ((n 2)) + (while (and (ignore-errors (forward-sexp 1) t) + (not (eq (char-before) ?\)))) + (cl-incf n)) + n))) + ;;;###autoload (defmacro cl-defmethod (name args &rest body) "Define a new method for generic function NAME. -This it defines an implementation of NAME to use for invocations +This defines an implementation of NAME to use for invocations of specific types of arguments. ARGS is a list of dispatch arguments (see `cl-defun'), but where @@ -418,8 +455,12 @@ all methods of NAME have to use the same set of arguments for dispatch. Each dispatch argument and TYPE are specified in ARGS where the corresponding formal argument appears as (VAR TYPE) rather than just VAR. -The optional second argument QUALIFIER is a specifier that -modifies how the method is combined with other methods, including: +The optional EXTRA element, on the form `:extra STRING', allows +you to add more methods for the same specializers and qualifiers. +These are distinguished by STRING. + +The optional argument QUALIFIER is a specifier that modifies how +the method is combined with other methods, including: :before - Method will be called before the primary :after - Method will be called after the primary :around - Method will be called around everything else @@ -436,19 +477,18 @@ method to be applicable. The set of acceptable TYPEs (also called \"specializers\") is defined \(and can be extended) by the various methods of `cl-generic-generalizers'. -\(fn NAME [QUALIFIER] ARGS &rest [DOCSTRING] BODY)" - (declare (doc-string 3) (indent defun) +\(fn NAME [EXTRA] [QUALIFIER] ARGS &rest [DOCSTRING] BODY)" + (declare (doc-string cl--defmethod-doc-pos) (indent defun) (debug (&define ; this means we are defining something - [&or name ("setf" name :name setf)] - ;; ^^ This is the methods symbol - [ &rest cl-generic-method-qualifier ] - ;; Multiple qualifiers are allowed. - cl-generic-method-args ; arguments + [&name [sexp ;Allow (setf ...) additionally to symbols. + [&rest cl-generic--method-qualifier-p] ;qualifiers + listp] ; arguments + cl--generic-edebug-make-name nil] lambda-doc ; documentation string def-body))) ; part to be debugged (let ((qualifiers nil)) - (while (not (listp args)) + (while (cl-generic--method-qualifier-p args) (push args qualifiers) (setq args (pop body))) (when (eq 'setf (car-safe name)) @@ -461,7 +501,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (or (not (fboundp 'byte-compile-warning-enabled-p)) (byte-compile-warning-enabled-p 'obsolete name)) (let* ((obsolete (get name 'byte-obsolete-info))) - (macroexp--warn-and-return + (macroexp-warn-and-return (macroexp--obsolete-warning name obsolete "generic function") nil))) ;; You could argue that `defmethod' modifies rather than defines the @@ -528,17 +568,17 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (cons method mt) ;; Keep the ordering; important for methods with :extra qualifiers. (mapcar (lambda (x) (if (eq x (car me)) method x)) mt))) - (let ((sym (cl--generic-name generic))) ; Actual name (for aliases). + (let ((sym (cl--generic-name generic)) ; Actual name (for aliases). + ;; FIXME: Try to avoid re-constructing a new function if the old one + ;; is still valid (e.g. still empty method cache)? + (gfun (cl--generic-make-function generic))) (unless (symbol-function sym) (defalias sym 'dummy)) ;Record definition into load-history. (cl-pushnew `(cl-defmethod . ,(cl--generic-load-hist-format (cl--generic-name generic) qualifiers 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 + (let (;; Prevent `defalias' from recording this as the definition site of ;; the generic function. current-load-list ;; BEWARE! Don't purify this function definition, since that leads @@ -1113,12 +1153,27 @@ These match if the argument is a cons cell whose car is `eql' to VAL." (cl-generic-define-generalizer cl--generic-eql-generalizer 100 (lambda (name &rest _) `(gethash ,name cl--generic-eql-used)) - (lambda (tag &rest _) (if (eq (car-safe tag) 'eql) (list tag)))) + (lambda (tag &rest _) (if (eq (car-safe tag) 'eql) (cdr tag)))) (cl-defmethod cl-generic-generalizers ((specializer (head eql))) "Support for (eql VAL) specializers. These match if the argument is `eql' to VAL." - (puthash (cadr specializer) specializer cl--generic-eql-used) + (let* ((form (cadr specializer)) + (val (if (or (not (symbolp form)) (macroexp-const-p form)) + (eval form t) + ;; FIXME: Compatibility with Emacs<28. For now emitting + ;; a warning would be annoying for third party packages + ;; which can't use the new form without breaking compatibility + ;; with older Emacsen, but in the future we should emit + ;; a warning. + ;; (message "Quoting obsolete `eql' form: %S" specializer) + form)) + (specializers (cdr (gethash val cl--generic-eql-used)))) + ;; The `specializers-function' needs to return all the (eql EXP) that + ;; were used for the same VALue (bug#49866). + ;; So we keep this info in `cl--generic-eql-used'. + (cl-pushnew specializer specializers :test #'equal) + (puthash val `(eql . ,specializers) cl--generic-eql-used)) (list cl--generic-eql-generalizer)) (cl--generic-prefill-dispatchers 0 (eql nil)) |