diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/cl-generic.el | 36 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-macs.el | 9 | ||||
| -rw-r--r-- | lisp/emacs-lisp/edebug.el | 92 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-compat.el | 2 | ||||
| -rw-r--r-- | lisp/emacs-lisp/ert.el | 4 | ||||
| -rw-r--r-- | lisp/emacs-lisp/gv.el | 3 |
6 files changed, 89 insertions, 57 deletions
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 8e36dbe4a36..229608395eb 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -206,22 +206,29 @@ 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 + (&define [&name sexp] ;Allow (setf ...) additionally to symbols. + listp lambda-doc [&rest [&or ("declare" &rest sexp) (":argument-precedence-order" &rest sexp) (&define ":method" - ;; FIXME: The `:unique' + ;; FIXME: The `gensym' ;; 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 + [&name "cl-generic-:method@" []] + [&name [] gensym] ;Make it unique! + [&name + [[&rest cl-generic--method-qualifier-p] + ;; FIXME: We don't actually want the + ;; argument's names to be considered + ;; part of the name of the defined + ;; function. + listp]] ;Formal args + lambda-doc def-body)]] def-body))) (let* ((doc (if (stringp (car-safe options-and-methods)) @@ -398,6 +405,9 @@ 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))) + ;;;###autoload (defmacro cl-defmethod (name args &rest body) "Define a new method for generic function NAME. @@ -440,15 +450,17 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (declare (doc-string 3) (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. + ;; Multiple qualifiers are allowed. + [&rest cl-generic--method-qualifier-p] + ;; FIXME: We don't actually want the argument's names + ;; to be considered part of the name of the + ;; defined function. + listp]] ; arguments 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)) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 5967e0d084f..e2faf6df534 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -358,7 +358,7 @@ more details. \(fn NAME ARGLIST [DOCSTRING] BODY...)" (declare (debug ;; Same as defun but use cl-lambda-list. - (&define [&or name ("setf" :name setf name)] + (&define [&name sexp] ;Allow (setf ...) additionally to symbols. cl-lambda-list cl-declarations-or-string [&optional ("interactive" interactive)] @@ -376,7 +376,7 @@ and BODY is implicitly surrounded by (cl-block NAME ...). \(fn NAME ARGLIST [DOCSTRING] BODY...)" (declare (debug ;; Same as iter-defun but use cl-lambda-list. - (&define [&or name ("setf" :name setf name)] + (&define [&name sexp] ;Allow (setf ...) additionally to symbols. cl-lambda-list cl-declarations-or-string [&optional ("interactive" interactive)] @@ -2016,8 +2016,9 @@ info node `(cl) Function Bindings' for details. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" (declare (indent 1) - (debug ((&rest [&or (&define name :unique "cl-flet@" form) - (&define name :unique "cl-flet@" + (debug ((&rest [&or (symbolp form) + (&define [&name symbolp "@cl-flet@"] + [&name [] gensym] ;Make it unique! cl-lambda-list cl-declarations-or-string [&optional ("interactive" interactive)] diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index cbf2d171a96..867161e0280 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1748,16 +1748,12 @@ contains a circular object." (dolist (pair '((form . edebug-match-form) (sexp . edebug-match-sexp) (body . edebug-match-body) - (name . edebug-match-name) (arg . edebug-match-arg) (def-body . edebug-match-def-body) (def-form . edebug-match-def-form) ;; Less frequently used: ;; (function . edebug-match-function) (lambda-expr . edebug-match-lambda-expr) - (cl-generic-method-qualifier - . edebug-match-cl-generic-method-qualifier) - (cl-generic-method-args . edebug-match-cl-generic-method-args) (cl-macrolet-expr . edebug-match-cl-macrolet-expr) (cl-macrolet-name . edebug-match-cl-macrolet-name) (cl-macrolet-body . edebug-match-cl-macrolet-body) @@ -2056,19 +2052,61 @@ and then matches the rest against the output of (FUN ARGS... HEAD)." ))) -(defun edebug-match-name (cursor) - ;; Set the edebug-def-name bound in edebug-defining-form. - (let ((name (edebug-top-element-required cursor "Expected name"))) - ;; Maybe strings and numbers could be used. - (if (not (symbolp name)) - (edebug-no-match cursor "Symbol expected for name of definition")) - (setq edebug-def-name - (if edebug-def-name - ;; Construct a new name by appending to previous name. - (intern (format "%s@%s" edebug-def-name name)) - name)) - (edebug-move-cursor cursor) - (list name))) +(cl-defmethod edebug--handle-&-spec-op ((_ (eql &name)) cursor specs) + "Compute the name for `&name SPEC FUN` spec operator. + +The full syntax of that operator is: + &name [PRESTRING] SPEC [POSTSTRING] FUN ARGS... + +Extracts the head of the data by matching it against SPEC, +and then get the new name to use by calling + (FUN ARGS... OLDNAME [PRESTRING] HEAD [POSTSTRING]) +FUN should return either a string or a symbol. +FUN can be missing in which case it defaults to concatenating +the new name to the end of the old with an \"@\" char between the two. +PRESTRING and POSTSTRING are optional strings that get prepended +or appended to the actual name." + (pcase-let* + ((`(,spec ,fun . ,args) specs) + (prestrings (when (stringp spec) + (prog1 (list spec) (setq spec fun fun (pop args))))) + (poststrings (when (stringp fun) + (prog1 (list fun) (setq fun (pop args))))) + (exps (edebug-cursor-expressions cursor)) + (instrumented (edebug-match-one-spec cursor spec)) + (consumed (- (length exps) + (length (edebug-cursor-expressions cursor)))) + (newname (apply (or fun #'edebug--concat-name) + `(,@args ,edebug-def-name + ,@prestrings + ,@(seq-subseq exps 0 consumed) + ,@poststrings)))) + (cl-assert (eq (edebug-cursor-expressions cursor) (nthcdr consumed exps))) + (setq edebug-def-name (if (stringp newname) (intern newname) newname)) + instrumented)) + +(defun edebug--concat-name (oldname &rest newnames) + (let ((newname (if (null (cdr newnames)) + (car newnames) + ;; Put spaces between each name, but not for the + ;; leading and trailing strings, if any. + (let (beg mid end) + (dolist (name newnames) + (if (stringp name) + (push name (if mid end beg)) + (when end (setq mid (nconc end mid) end nil)) + (push name mid))) + (apply #'concat `(,@(nreverse beg) + ,(mapconcat (lambda (x) (format "%s" x)) + (nreverse mid) " ") + ,@(nreverse end))))))) + (if (null oldname) + (if (or (stringp newname) (symbolp newname)) + newname + (format "%s" newname)) + (format "%s@%s" edebug-def-name newname)))) + +(def-edebug-elem-spec 'name '(&name symbolp)) (cl-defgeneric edebug--handle-:-spec-op (op cursor spec) "Handle :foo spec operators. @@ -2094,26 +2132,6 @@ SPEC is the symbol name prefix for `gensym'." suffix))) nil) -(defun edebug-match-cl-generic-method-qualifier (cursor) - "Match a QUALIFIER for `cl-defmethod' at CURSOR." - (let ((args (edebug-top-element-required cursor "Expected qualifier"))) - ;; Like in CLOS spec, we support any non-list values. - (unless (atom args) (edebug-no-match cursor "Atom expected")) - ;; Append the arguments to `edebug-def-name' (Bug#42671). - (setq edebug-def-name (intern (format "%s %s" edebug-def-name args))) - (edebug-move-cursor cursor) - (list args))) - -(defun edebug-match-cl-generic-method-args (cursor) - (let ((args (edebug-top-element-required cursor "Expected arguments"))) - (if (not (consp args)) - (edebug-no-match cursor "List expected")) - ;; Append the arguments to edebug-def-name. - (setq edebug-def-name - (intern (format "%s %s" edebug-def-name args))) - (edebug-move-cursor cursor) - (list args))) - (defvar edebug--cl-macrolet-defs nil "List of symbols found within the bindings of enclosing `cl-macrolet' forms.") (defvar edebug--current-cl-macrolet-defs nil diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el index db97d4ca4e8..6d84839c341 100644 --- a/lisp/emacs-lisp/eieio-compat.el +++ b/lisp/emacs-lisp/eieio-compat.el @@ -105,7 +105,7 @@ Summary: (declare (doc-string 3) (obsolete cl-defmethod "25.1") (debug (&define ; this means we are defining something - [&or name ("setf" name :name setf)] + [&name sexp] ;Allow (setf ...) additionally to symbols. ;; ^^ This is the methods symbol [ &optional symbolp ] ; this is key :before etc cl-generic-method-args ; arguments diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index fdbf95319ff..e08fa7ac7b3 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -196,8 +196,8 @@ it has to be wrapped in `(eval (quote ...))'. \(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ [:tags \\='(TAG...)] BODY...)" - (declare (debug (&define :name test - name sexp [&optional stringp] + (declare (debug (&define [&name "test@" symbolp] + sexp [&optional stringp] [&rest keywordp sexp] def-body)) (doc-string 3) (indent 2)) diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index edacdf7f0c8..3200b1c3494 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -229,7 +229,8 @@ The first arg in ARGLIST (the one that receives VAL) receives an expression which can do arbitrary things, whereas the other arguments are all guaranteed to be pure and copyable. Example use: (gv-define-setter aref (v a i) \\=`(aset ,a ,i ,v))" - (declare (indent 2) (debug (&define name :name gv-setter sexp def-body))) + (declare (indent 2) + (debug (&define [&name symbolp "@gv-setter"] sexp def-body))) `(gv-define-expander ,name (lambda (do &rest args) (declare-function |