summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/emacs-lisp')
-rw-r--r--lisp/emacs-lisp/cl-generic.el13
-rw-r--r--lisp/emacs-lisp/cl-macs.el6
-rw-r--r--lisp/emacs-lisp/edebug.el27
-rw-r--r--lisp/emacs-lisp/generator.el9
-rw-r--r--lisp/emacs-lisp/pcase.el2
-rw-r--r--lisp/emacs-lisp/rmc.el199
-rw-r--r--lisp/emacs-lisp/subr-x.el170
-rw-r--r--lisp/emacs-lisp/tabulated-list.el11
8 files changed, 240 insertions, 197 deletions
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index b2f76abd88e..62befd4742a 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -204,7 +204,16 @@ OPTIONS-AND-METHODS currently understands:
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))
+ (declare (indent 2) (doc-string 3)
+ (debug
+ (&define name cl-lambda-list 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)))
(let* ((doc (if (stringp (car-safe options-and-methods))
(pop options-and-methods)))
(declarations nil)
@@ -422,7 +431,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
; Like in CLOS spec, we support
; any non-list values.
cl-generic-method-args ; arguments
- [ &optional stringp ] ; documentation string
+ lambda-doc ; documentation string
def-body))) ; part to be debugged
(let ((qualifiers nil))
(while (not (listp args))
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 32ba0ac3091..40eda1e0d65 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -190,7 +190,7 @@ The name is made by appending a number to PREFIX, default \"T\"."
(&rest ("cl-declare" &rest sexp)))
(def-edebug-spec cl-declarations-or-string
- (&or stringp cl-declarations))
+ (&or lambda-doc cl-declarations))
(def-edebug-spec cl-lambda-list
(([&rest arg]
@@ -447,8 +447,8 @@ more details.
(def-edebug-spec cl-lambda-expr
(&define ("lambda" cl-lambda-list
- ;;cl-declarations-or-string
- ;;[&optional ("interactive" interactive)]
+ cl-declarations-or-string
+ [&optional ("interactive" interactive)]
def-body)))
;; Redefine function-form to also match cl-function
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index dbc56e272fd..d00b14e803e 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -1986,15 +1986,14 @@ expressions; a `progn' form will be returned enclosing these forms."
(def-edebug-spec defvar (symbolp &optional form stringp))
(def-edebug-spec defun
- (&define name lambda-list
- [&optional stringp]
+ (&define name lambda-list lambda-doc
[&optional ("declare" &rest sexp)]
[&optional ("interactive" interactive)]
def-body))
(def-edebug-spec defmacro
;; FIXME: Improve `declare' so we can Edebug gv-expander and
;; gv-setter declarations.
- (&define name lambda-list [&optional stringp]
+ (&define name lambda-list lambda-doc
[&optional ("declare" &rest sexp)] def-body))
(def-edebug-spec arglist lambda-list) ;; deprecated - use lambda-list.
@@ -2005,6 +2004,10 @@ expressions; a `progn' form will be returned enclosing these forms."
&optional ["&rest" arg]
)))
+(def-edebug-spec lambda-doc
+ (&optional [&or stringp
+ (&define ":documentation" def-form)]))
+
(def-edebug-spec interactive
(&optional &or stringp def-form))
@@ -3204,15 +3207,6 @@ generated symbols for methods. If a function or method to
instrument cannot be found, signal an error."
(let ((func-marker (get func 'edebug)))
(cond
- ((and (markerp func-marker) (marker-buffer func-marker))
- ;; It is uninstrumented, so instrument it.
- (with-current-buffer (marker-buffer func-marker)
- (goto-char func-marker)
- (edebug-eval-top-level-form)
- (list func)))
- ((consp func-marker)
- (message "%s is already instrumented." func)
- (list func))
((cl-generic-p func)
(let ((method-defs (cl--generic-method-files func))
symbols)
@@ -3227,6 +3221,15 @@ instrument cannot be found, signal an error."
(edebug-eval-top-level-form)
(push (edebug-form-data-symbol) symbols))))
symbols))
+ ((and (markerp func-marker) (marker-buffer func-marker))
+ ;; It is uninstrumented, so instrument it.
+ (with-current-buffer (marker-buffer func-marker)
+ (goto-char func-marker)
+ (edebug-eval-top-level-form)
+ (list func)))
+ ((consp func-marker)
+ (message "%s is already instrumented." func)
+ (list func))
(t
(let ((loc (find-function-noselect func t)))
(unless (cdr loc)
diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el
index f3597cc387d..410e4edcc92 100644
--- a/lisp/emacs-lisp/generator.el
+++ b/lisp/emacs-lisp/generator.el
@@ -142,8 +142,7 @@ the CPS state machinery.
`(let ((,dynamic-var ,static-var))
(unwind-protect ; Update the static shadow after evaluation is done
,form
- (setf ,static-var ,dynamic-var))
- ,form)))
+ (setf ,static-var ,dynamic-var)))))
(defmacro cps--with-dynamic-binding (dynamic-var static-var &rest body)
"Evaluate BODY such that generated atomic evaluations run with
@@ -681,7 +680,8 @@ sub-iterator function returns via `iter-end-of-sequence'."
When called as a function, NAME returns an iterator value that
encapsulates the state of a computation that produces a sequence
of values. Callers can retrieve each value using `iter-next'."
- (declare (indent defun))
+ (declare (indent defun)
+ (debug (&define name lambda-list lambda-doc def-body)))
(cl-assert lexical-binding)
(let* ((parsed-body (macroexp-parse-body body))
(declarations (car parsed-body))
@@ -693,7 +693,8 @@ of values. Callers can retrieve each value using `iter-next'."
(defmacro iter-lambda (arglist &rest body)
"Return a lambda generator.
`iter-lambda' is to `iter-defun' as `lambda' is to `defun'."
- (declare (indent defun))
+ (declare (indent defun)
+ (debug (&define lambda-list lambda-doc def-body)))
(cl-assert lexical-binding)
`(lambda ,arglist
,(cps-generate-evaluator body)))
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index c703cae4458..36af88423c8 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -226,7 +226,7 @@ I.e. accepts the usual &optional and &rest keywords, but every
formal argument can be any pattern accepted by `pcase' (a mere
variable name being but a special case of it)."
(declare (doc-string 2) (indent defun)
- (debug ((&rest pcase-PAT) body)))
+ (debug (&define (&rest pcase-PAT) lambda-doc def-body)))
(let* ((bindings ())
(parsed-body (macroexp-parse-body body))
(args (mapcar (lambda (pat)
diff --git a/lisp/emacs-lisp/rmc.el b/lisp/emacs-lisp/rmc.el
new file mode 100644
index 00000000000..417301cde06
--- /dev/null
+++ b/lisp/emacs-lisp/rmc.el
@@ -0,0 +1,199 @@
+;;; rmc.el --- read from a multiple choice question -*- lexical-binding: t -*-
+
+;; Copyright (C) 2017 Free Software Foundation, Inc.
+
+;; Maintainer: emacs-devel@gnu.org
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+;;;###autoload
+(defun read-multiple-choice (prompt choices)
+ "Ask user a multiple choice question.
+PROMPT should be a string that will be displayed as the prompt.
+
+CHOICES is an alist where the first element in each entry is a
+character to be entered, the second element is a short name for
+the entry to be displayed while prompting (if there's room, it
+might be shortened), and the third, optional entry is a longer
+explanation that will be displayed in a help buffer if the user
+requests more help.
+
+This function translates user input into responses by consulting
+the bindings in `query-replace-map'; see the documentation of
+that variable for more information. In this case, the useful
+bindings are `recenter', `scroll-up', and `scroll-down'. If the
+user enters `recenter', `scroll-up', or `scroll-down' responses,
+perform the requested window recentering or scrolling and ask
+again.
+
+When `use-dialog-box' is t (the default), this function can pop
+up a dialog window to collect the user input. That functionality
+requires `display-popup-menus-p' to return t. Otherwise, a text
+dialog will be used.
+
+The return value is the matching entry from the CHOICES list.
+
+Usage example:
+
+\(read-multiple-choice \"Continue connecting?\"
+ \\='((?a \"always\")
+ (?s \"session only\")
+ (?n \"no\")))"
+ (let* ((altered-names nil)
+ (full-prompt
+ (format
+ "%s (%s): "
+ prompt
+ (mapconcat
+ (lambda (elem)
+ (let* ((name (cadr elem))
+ (pos (seq-position name (car elem)))
+ (altered-name
+ (cond
+ ;; Not in the name string.
+ ((not pos)
+ (format "[%c] %s" (car elem) name))
+ ;; The prompt character is in the name, so highlight
+ ;; it on graphical terminals...
+ ((display-supports-face-attributes-p
+ '(:underline t) (window-frame))
+ (setq name (copy-sequence name))
+ (put-text-property pos (1+ pos)
+ 'face 'read-multiple-choice-face
+ name)
+ name)
+ ;; And put it in [bracket] on non-graphical terminals.
+ (t
+ (concat
+ (substring name 0 pos)
+ "["
+ (upcase (substring name pos (1+ pos)))
+ "]"
+ (substring name (1+ pos)))))))
+ (push (cons (car elem) altered-name)
+ altered-names)
+ altered-name))
+ (append choices '((?? "?")))
+ ", ")))
+ tchar buf wrong-char answer)
+ (save-window-excursion
+ (save-excursion
+ (while (not tchar)
+ (message "%s%s"
+ (if wrong-char
+ "Invalid choice. "
+ "")
+ full-prompt)
+ (setq tchar
+ (if (and (display-popup-menus-p)
+ last-input-event ; not during startup
+ (listp last-nonmenu-event)
+ use-dialog-box)
+ (x-popup-dialog
+ t
+ (cons prompt
+ (mapcar
+ (lambda (elem)
+ (cons (capitalize (cadr elem))
+ (car elem)))
+ choices)))
+ (condition-case nil
+ (let ((cursor-in-echo-area t))
+ (read-char))
+ (error nil))))
+ (setq answer (lookup-key query-replace-map (vector tchar) t))
+ (setq tchar
+ (cond
+ ((eq answer 'recenter)
+ (recenter) t)
+ ((eq answer 'scroll-up)
+ (ignore-errors (scroll-up-command)) t)
+ ((eq answer 'scroll-down)
+ (ignore-errors (scroll-down-command)) t)
+ ((eq answer 'scroll-other-window)
+ (ignore-errors (scroll-other-window)) t)
+ ((eq answer 'scroll-other-window-down)
+ (ignore-errors (scroll-other-window-down)) t)
+ (t tchar)))
+ (when (eq tchar t)
+ (setq wrong-char nil
+ tchar nil))
+ ;; The user has entered an invalid choice, so display the
+ ;; help messages.
+ (when (and (not (eq tchar nil))
+ (not (assq tchar choices)))
+ (setq wrong-char (not (memq tchar '(?? ?\C-h)))
+ tchar nil)
+ (when wrong-char
+ (ding))
+ (with-help-window (setq buf (get-buffer-create
+ "*Multiple Choice Help*"))
+ (with-current-buffer buf
+ (erase-buffer)
+ (pop-to-buffer buf)
+ (insert prompt "\n\n")
+ (let* ((columns (/ (window-width) 25))
+ (fill-column 21)
+ (times 0)
+ (start (point)))
+ (dolist (elem choices)
+ (goto-char start)
+ (unless (zerop times)
+ (if (zerop (mod times columns))
+ ;; Go to the next "line".
+ (goto-char (setq start (point-max)))
+ ;; Add padding.
+ (while (not (eobp))
+ (end-of-line)
+ (insert (make-string (max (- (* (mod times columns)
+ (+ fill-column 4))
+ (current-column))
+ 0)
+ ?\s))
+ (forward-line 1))))
+ (setq times (1+ times))
+ (let ((text
+ (with-temp-buffer
+ (insert (format
+ "%c: %s\n"
+ (car elem)
+ (cdr (assq (car elem) altered-names))))
+ (fill-region (point-min) (point-max))
+ (when (nth 2 elem)
+ (let ((start (point)))
+ (insert (nth 2 elem))
+ (unless (bolp)
+ (insert "\n"))
+ (fill-region start (point-max))))
+ (buffer-string))))
+ (goto-char start)
+ (dolist (line (split-string text "\n"))
+ (end-of-line)
+ (if (bolp)
+ (insert line "\n")
+ (insert line))
+ (forward-line 1)))))))))))
+ (when (buffer-live-p buf)
+ (kill-buffer buf))
+ (assq tchar choices)))
+
+(provide 'rmc)
+
+;;; rmc.el ends here
diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el
index 5189cc4a6e8..8ed29d8659d 100644
--- a/lisp/emacs-lisp/subr-x.el
+++ b/lisp/emacs-lisp/subr-x.el
@@ -245,176 +245,6 @@ TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"."
(substring string 0 (- (length string) (length suffix)))
string))
-(defun read-multiple-choice (prompt choices)
- "Ask user a multiple choice question.
-PROMPT should be a string that will be displayed as the prompt.
-
-CHOICES is an alist where the first element in each entry is a
-character to be entered, the second element is a short name for
-the entry to be displayed while prompting (if there's room, it
-might be shortened), and the third, optional entry is a longer
-explanation that will be displayed in a help buffer if the user
-requests more help.
-
-This function translates user input into responses by consulting
-the bindings in `query-replace-map'; see the documentation of
-that variable for more information. In this case, the useful
-bindings are `recenter', `scroll-up', and `scroll-down'. If the
-user enters `recenter', `scroll-up', or `scroll-down' responses,
-perform the requested window recentering or scrolling and ask
-again.
-
-When `use-dialog-box' is t (the default), this function can pop
-up a dialog window to collect the user input. That functionality
-requires `display-popup-menus-p' to return t. Otherwise, a text
-dialog will be used.
-
-The return value is the matching entry from the CHOICES list.
-
-Usage example:
-
-\(read-multiple-choice \"Continue connecting?\"
- \\='((?a \"always\")
- (?s \"session only\")
- (?n \"no\")))"
- (let* ((altered-names nil)
- (full-prompt
- (format
- "%s (%s): "
- prompt
- (mapconcat
- (lambda (elem)
- (let* ((name (cadr elem))
- (pos (seq-position name (car elem)))
- (altered-name
- (cond
- ;; Not in the name string.
- ((not pos)
- (format "[%c] %s" (car elem) name))
- ;; The prompt character is in the name, so highlight
- ;; it on graphical terminals...
- ((display-supports-face-attributes-p
- '(:underline t) (window-frame))
- (setq name (copy-sequence name))
- (put-text-property pos (1+ pos)
- 'face 'read-multiple-choice-face
- name)
- name)
- ;; And put it in [bracket] on non-graphical terminals.
- (t
- (concat
- (substring name 0 pos)
- "["
- (upcase (substring name pos (1+ pos)))
- "]"
- (substring name (1+ pos)))))))
- (push (cons (car elem) altered-name)
- altered-names)
- altered-name))
- (append choices '((?? "?")))
- ", ")))
- tchar buf wrong-char answer)
- (save-window-excursion
- (save-excursion
- (while (not tchar)
- (message "%s%s"
- (if wrong-char
- "Invalid choice. "
- "")
- full-prompt)
- (setq tchar
- (if (and (display-popup-menus-p)
- last-input-event ; not during startup
- (listp last-nonmenu-event)
- use-dialog-box)
- (x-popup-dialog
- t
- (cons prompt
- (mapcar
- (lambda (elem)
- (cons (capitalize (cadr elem))
- (car elem)))
- choices)))
- (condition-case nil
- (let ((cursor-in-echo-area t))
- (read-char))
- (error nil))))
- (setq answer (lookup-key query-replace-map (vector tchar) t))
- (setq tchar
- (cond
- ((eq answer 'recenter)
- (recenter) t)
- ((eq answer 'scroll-up)
- (ignore-errors (scroll-up-command)) t)
- ((eq answer 'scroll-down)
- (ignore-errors (scroll-down-command)) t)
- ((eq answer 'scroll-other-window)
- (ignore-errors (scroll-other-window)) t)
- ((eq answer 'scroll-other-window-down)
- (ignore-errors (scroll-other-window-down)) t)
- (t tchar)))
- (when (eq tchar t)
- (setq wrong-char nil
- tchar nil))
- ;; The user has entered an invalid choice, so display the
- ;; help messages.
- (when (and (not (eq tchar nil))
- (not (assq tchar choices)))
- (setq wrong-char (not (memq tchar '(?? ?\C-h)))
- tchar nil)
- (when wrong-char
- (ding))
- (with-help-window (setq buf (get-buffer-create
- "*Multiple Choice Help*"))
- (with-current-buffer buf
- (erase-buffer)
- (pop-to-buffer buf)
- (insert prompt "\n\n")
- (let* ((columns (/ (window-width) 25))
- (fill-column 21)
- (times 0)
- (start (point)))
- (dolist (elem choices)
- (goto-char start)
- (unless (zerop times)
- (if (zerop (mod times columns))
- ;; Go to the next "line".
- (goto-char (setq start (point-max)))
- ;; Add padding.
- (while (not (eobp))
- (end-of-line)
- (insert (make-string (max (- (* (mod times columns)
- (+ fill-column 4))
- (current-column))
- 0)
- ?\s))
- (forward-line 1))))
- (setq times (1+ times))
- (let ((text
- (with-temp-buffer
- (insert (format
- "%c: %s\n"
- (car elem)
- (cdr (assq (car elem) altered-names))))
- (fill-region (point-min) (point-max))
- (when (nth 2 elem)
- (let ((start (point)))
- (insert (nth 2 elem))
- (unless (bolp)
- (insert "\n"))
- (fill-region start (point-max))))
- (buffer-string))))
- (goto-char start)
- (dolist (line (split-string text "\n"))
- (end-of-line)
- (if (bolp)
- (insert line "\n")
- (insert line))
- (forward-line 1)))))))))))
- (when (buffer-live-p buf)
- (kill-buffer buf))
- (assq tchar choices)))
-
(provide 'subr-x)
;;; subr-x.el ends here
diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el
index e940588db7b..d1d7c0a8042 100644
--- a/lisp/emacs-lisp/tabulated-list.el
+++ b/lisp/emacs-lisp/tabulated-list.el
@@ -329,6 +329,8 @@ Check the current row, the previous one and the next row."
(string-width (if (stringp nt) nt (car nt)))))
tabulated-list--near-rows)))
+(defvar tabulated-list-entry-lnum-width nil)
+
(defun tabulated-list-print (&optional remember-pos update)
"Populate the current Tabulated List mode buffer.
This sorts the `tabulated-list-entries' list if sorting is
@@ -371,6 +373,7 @@ changing `tabulated-list-sort-key'."
(unless tabulated-list-use-header-line
(tabulated-list-print-fake-header)))
;; Finally, print the resulting list.
+ (setq tabulated-list-entry-lnum-width (tabulated-list-line-number-width))
(while entries
(let* ((elt (car entries))
(tabulated-list--near-rows
@@ -383,7 +386,7 @@ changing `tabulated-list-sort-key'."
(equal entry-id id)
(setq entry-id nil
saved-pt (point)))
- ;; If the buffer this empty, simply print each elt.
+ ;; If the buffer is empty, simply print each elt.
(if (or (not update) (eobp))
(apply tabulated-list-printer elt)
(while (let ((local-id (tabulated-list-get-id)))
@@ -424,12 +427,10 @@ of column descriptors."
(let ((beg (point))
(x (max tabulated-list-padding 0))
(ncols (length tabulated-list-format))
- (lnum-width (tabulated-list-line-number-width))
(inhibit-read-only t))
- (if display-line-numbers
- (setq x (+ x lnum-width)))
+ (setq x (+ x tabulated-list-entry-lnum-width))
(if (> tabulated-list-padding 0)
- (insert (make-string (- x lnum-width) ?\s)))
+ (insert (make-string (- x tabulated-list-entry-lnum-width) ?\s)))
(let ((tabulated-list--near-rows ; Bind it if not bound yet (Bug#25506).
(or (bound-and-true-p tabulated-list--near-rows)
(list (or (tabulated-list-get-entry (point-at-bol 0))
generated by cgit v1.2.3 (git 2.39.1) at 2025-06-15 19:02:52 +0000