diff options
Diffstat (limited to 'lisp/emacs-lisp/cl-generic.el')
| -rw-r--r-- | lisp/emacs-lisp/cl-generic.el | 144 |
1 files changed, 97 insertions, 47 deletions
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 9dbcadec3ce..544704be387 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,15 +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" [&rest atom] - 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) @@ -295,15 +328,6 @@ the specializer used will be the one returned by BODY." (lambda ,args ,@body)))) (eval-and-compile ;Needed while compiling the cl-defmethod calls below! - (defun cl--generic-fgrep (vars sexp) ;Copied from pcase.el. - "Check which of the symbols VARS appear in SEXP." - (let ((res '())) - (while (consp sexp) - (dolist (var (cl--generic-fgrep vars (pop sexp))) - (unless (memq var res) (push var res)))) - (and (memq sexp vars) (not (memq sexp res)) (push sexp res)) - res)) - (defun cl--generic-split-args (args) "Return (SPEC-ARGS . PLAIN-ARGS)." (let ((plain-args ()) @@ -366,11 +390,11 @@ the specializer used will be the one returned by BODY." ;; is used. ;; FIXME: Also, optimize the case where call-next-method is ;; only called with explicit arguments. - (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody))) + (uses-cnm (macroexp--fgrep `((,cnm) (,nmp)) nbody))) (cons (not (not uses-cnm)) `#'(lambda (,@(if uses-cnm (list cnm)) ,@args) ,@(car parsed-body) - ,(if (not (memq nmp uses-cnm)) + ,(if (not (assq nmp uses-cnm)) nbody `(let ((,nmp (lambda () (cl--generic-isnot-nnm-p ,cnm)))) @@ -398,18 +422,45 @@ 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. -I.e. it defines the implementation of NAME to use for invocations where the -values of the dispatch arguments match the specified TYPEs. +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 +each variable element is either just a single variable name VAR, +or a list on the form (VAR TYPE). + +For instance: + + (cl-defmethod foo (bar (format-string string) &optional zot) + (format format-string bar)) + The dispatch arguments have to be among the mandatory arguments, and 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 @@ -426,20 +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 atom ] ; Multiple qualifiers are allowed. - ; Like in CLOS spec, we support - ; any non-list values. - 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)) @@ -452,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 @@ -519,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 @@ -599,11 +648,11 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (lambda (,@fixedargs &rest args) (let ,bindings (apply (cl--generic-with-memoization - (gethash ,tag-exp method-cache) - (cl--generic-cache-miss - generic ',dispatch-arg dispatches-left methods - ,(if (cdr typescodes) - `(append ,@typescodes) (car typescodes)))) + (gethash ,tag-exp method-cache) + (cl--generic-cache-miss + generic ',dispatch-arg dispatches-left methods + ,(if (cdr typescodes) + `(append ,@typescodes) (car typescodes)))) ,@fixedargs args))))))))) (defun cl--generic-make-function (generic) @@ -793,8 +842,8 @@ It should return a function that expects the same arguments as the methods, and 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.") +The function can use `cl-generic-call-method' to create functions that call +those methods.") (unless (ignore-errors (cl-generic-generalizers t)) ;; Temporary definition to let the next defmethod succeed. @@ -1092,7 +1141,8 @@ These match if the argument is a cons cell whose car is `eql' to VAL." (if (not (eq (car-safe specializer) 'head)) (cl-call-next-method) (cl--generic-with-memoization - (gethash (cadr specializer) cl--generic-head-used) specializer) + (gethash (cadr specializer) cl--generic-head-used) + specializer) (list cl--generic-head-generalizer))) (cl--generic-prefill-dispatchers 0 (head eql)) |