summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/emacs-lisp')
-rw-r--r--lisp/emacs-lisp/cl-extra.el39
-rw-r--r--lisp/emacs-lisp/cl-print.el11
-rw-r--r--lisp/emacs-lisp/debug.el188
-rw-r--r--lisp/emacs-lisp/eieio-core.el10
-rw-r--r--lisp/emacs-lisp/ert.el87
-rw-r--r--lisp/emacs-lisp/lisp-mnt.el7
6 files changed, 148 insertions, 194 deletions
diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index 3852ceb6c31..99df209d1a2 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -437,22 +437,38 @@ as an integer unless JUNK-ALLOWED is non-nil."
;; Random numbers.
+(defun cl--random-time ()
+ (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0))
+ (while (>= (cl-decf i) 0) (setq v (+ (* v 3) (aref time i))))
+ v))
+
+;;;###autoload (autoload 'cl-random-state-p "cl-extra")
+(cl-defstruct (cl--random-state
+ (:copier nil)
+ (:predicate cl-random-state-p)
+ (:constructor nil)
+ (:constructor cl--make-random-state (vec)))
+ (i -1) (j 30) vec)
+
+(defvar cl--random-state (cl--make-random-state (cl--random-time)))
+
;;;###autoload
(defun cl-random (lim &optional state)
"Return a random nonnegative number less than LIM, an integer or float.
Optional second arg STATE is a random-state object."
(or state (setq state cl--random-state))
;; Inspired by "ran3" from Numerical Recipes. Additive congruential method.
- (let ((vec (aref state 3)))
+ (let ((vec (cl--random-state-vec state)))
(if (integerp vec)
(let ((i 0) (j (- 1357335 (abs (% vec 1357333)))) (k 1))
- (aset state 3 (setq vec (make-vector 55 nil)))
+ (setf (cl--random-state-vec state)
+ (setq vec (make-vector 55 nil)))
(aset vec 0 j)
(while (> (setq i (% (+ i 21) 55)) 0)
(aset vec i (setq j (prog1 k (setq k (- j k))))))
(while (< (setq i (1+ i)) 200) (cl-random 2 state))))
- (let* ((i (aset state 1 (% (1+ (aref state 1)) 55)))
- (j (aset state 2 (% (1+ (aref state 2)) 55)))
+ (let* ((i (cl-callf (lambda (x) (% (1+ x) 55)) (cl--random-state-i state)))
+ (j (cl-callf (lambda (x) (% (1+ x) 55)) (cl--random-state-j state)))
(n (logand 8388607 (aset vec i (- (aref vec i) (aref vec j))))))
(if (integerp lim)
(if (<= lim 512) (% n lim)
@@ -466,17 +482,10 @@ Optional second arg STATE is a random-state object."
(defun cl-make-random-state (&optional state)
"Return a copy of random-state STATE, or of the internal state if omitted.
If STATE is t, return a new state object seeded from the time of day."
- (cond ((null state) (cl-make-random-state cl--random-state))
- ((vectorp state) (copy-tree state t))
- ((integerp state) (vector 'cl--random-state-tag -1 30 state))
- (t (cl-make-random-state (cl--random-time)))))
-
-;;;###autoload
-(defun cl-random-state-p (object)
- "Return t if OBJECT is a random-state object."
- (and (vectorp object) (= (length object) 4)
- (eq (aref object 0) 'cl--random-state-tag)))
-
+ (unless state (setq state cl--random-state))
+ (if (cl-random-state-p state)
+ (copy-tree state t)
+ (cl--make-random-state (if (integerp state) state (cl--random-time)))))
;; Implementation limits.
diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el
index 89a71d1b6c5..e9ca0412848 100644
--- a/lisp/emacs-lisp/cl-print.el
+++ b/lisp/emacs-lisp/cl-print.el
@@ -90,7 +90,7 @@ call other entry points instead, such as `cl-prin1'."
- `disassemble' to print the disassembly of the code.
- nil to skip printing any details about the code.")
-(defvar cl-print-compiled-button nil
+(defvar cl-print-compiled-button t
"Control how to print byte-compiled functions into buffers.
When the stream is a buffer, make the bytecode part of the output
into a button whose action shows the function's disassembly.")
@@ -105,10 +105,11 @@ into a button whose action shows the function's disassembly.")
(if args
(prin1 args stream)
(princ "()" stream)))
- (let ((doc (documentation object 'raw)))
- (when doc
- (princ " " stream)
- (prin1 doc stream)))
+ (pcase (help-split-fundoc (documentation object 'raw) object)
+ ;; Drop args which `help-function-arglist' already printed.
+ (`(,_usage . ,(and doc (guard (stringp doc))))
+ (princ " " stream)
+ (prin1 doc stream)))
(let ((inter (interactive-form object)))
(when inter
(princ " " stream)
diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el
index 83456fc31a2..2b8782590c4 100644
--- a/lisp/emacs-lisp/debug.el
+++ b/lisp/emacs-lisp/debug.el
@@ -49,6 +49,12 @@ the middle is discarded, and just the beginning and end are displayed."
:group 'debugger
:version "21.1")
+(defcustom debugger-print-function #'cl-prin1
+ "Function used to print values in the debugger backtraces."
+ :type 'function
+ :options '(cl-prin1 prin1)
+ :version "26.1")
+
(defcustom debugger-bury-or-kill 'bury
"What to do with the debugger buffer when exiting `debug'.
The value affects the behavior of operations on any window
@@ -264,6 +270,40 @@ first will be printed into the backtrace buffer."
(setq debug-on-next-call debugger-step-after-exit)
debugger-value)))
+
+(defun debugger-insert-backtrace (frames do-xrefs)
+ "Format and insert the backtrace FRAMES at point.
+Make functions into cross-reference buttons if DO-XREFS is non-nil."
+ (let ((standard-output (current-buffer))
+ (eval-buffers eval-buffer-list))
+ (require 'help-mode) ; Define `help-function-def' button type.
+ (pcase-dolist (`(,evald ,fun ,args ,flags) frames)
+ (insert (if (plist-get flags :debug-on-exit)
+ "* " " "))
+ (let ((fun-file (and do-xrefs (symbol-file fun 'defun)))
+ (fun-pt (point)))
+ (cond
+ ((and evald (not debugger-stack-frame-as-list))
+ (funcall debugger-print-function fun)
+ (if args (funcall debugger-print-function args) (princ "()")))
+ (t
+ (funcall debugger-print-function (cons fun args))
+ (cl-incf fun-pt)))
+ (when fun-file
+ (make-text-button fun-pt (+ fun-pt (length (symbol-name fun)))
+ :type 'help-function-def
+ 'help-args (list fun fun-file))))
+ ;; After any frame that uses eval-buffer, insert a line that
+ ;; states the buffer position it's reading at.
+ (when (and eval-buffers (memq fun '(eval-buffer eval-region)))
+ (insert (format " ; Reading at buffer position %d"
+ ;; This will get the wrong result if there are
+ ;; two nested eval-region calls for the same
+ ;; buffer. That's not a very useful case.
+ (with-current-buffer (pop eval-buffers)
+ (point)))))
+ (insert "\n"))))
+
(defun debugger-setup-buffer (args)
"Initialize the `*Backtrace*' buffer for entry to the debugger.
That buffer should be current already."
@@ -271,27 +311,20 @@ That buffer should be current already."
(erase-buffer)
(set-buffer-multibyte t) ;Why was it nil ? -stef
(setq buffer-undo-list t)
- (let ((standard-output (current-buffer))
- (print-escape-newlines t)
- (print-level 8)
- (print-length 50))
- ;; FIXME the debugger could pass a custom callback to mapbacktrace
- ;; instead of manipulating printed results.
- (mapbacktrace #'backtrace--print-frame 'debug))
- (goto-char (point-min))
- (delete-region (point)
- (progn
- (forward-line (if (eq (car args) 'debug)
- ;; Remove debug--implement-debug-on-entry
- ;; and the advice's `apply' frame.
- 3
- 1))
- (point)))
(insert "Debugger entered")
- ;; lambda is for debug-on-call when a function call is next.
- ;; debug is for debug-on-entry function called.
- (let ((pos (point)))
+ (let ((frames (nthcdr
+ ;; Remove debug--implement-debug-on-entry and the
+ ;; advice's `apply' frame.
+ (if (eq (car args) 'debug) 3 1)
+ (backtrace-frames 'debug)))
+ (print-escape-newlines t)
+ (print-escape-control-characters t)
+ (print-level 8)
+ (print-length 50)
+ (pos (point)))
(pcase (car args)
+ ;; lambda is for debug-on-call when a function call is next.
+ ;; debug is for debug-on-entry function called.
((or `lambda `debug)
(insert "--entering a function:\n")
(setq pos (1- (point))))
@@ -300,11 +333,9 @@ That buffer should be current already."
(insert "--returning value: ")
(setq pos (point))
(setq debugger-value (nth 1 args))
- (prin1 debugger-value (current-buffer))
- (insert ?\n)
- (delete-char 1)
- (insert ? )
- (beginning-of-line))
+ (funcall debugger-print-function debugger-value (current-buffer))
+ (setf (cl-getf (nth 3 (car frames)) :debug-on-exit) nil)
+ (insert ?\n))
;; Watchpoint triggered.
((and `watchpoint (let `(,symbol ,newval . ,details) (cdr args)))
(insert
@@ -327,7 +358,7 @@ That buffer should be current already."
(`error
(insert "--Lisp error: ")
(setq pos (point))
- (prin1 (nth 1 args) (current-buffer))
+ (funcall debugger-print-function (nth 1 args) (current-buffer))
(insert ?\n))
;; debug-on-call, when the next thing is an eval.
(`t
@@ -337,98 +368,15 @@ That buffer should be current already."
(_
(insert ": ")
(setq pos (point))
- (prin1 (if (eq (car args) 'nil)
- (cdr args) args)
- (current-buffer))
+ (funcall debugger-print-function
+ (if (eq (car args) 'nil)
+ (cdr args) args)
+ (current-buffer))
(insert ?\n)))
+ (debugger-insert-backtrace frames t)
;; Place point on "stack frame 0" (bug#15101).
- (goto-char pos))
- ;; After any frame that uses eval-buffer,
- ;; insert a line that states the buffer position it's reading at.
- (save-excursion
- (let ((tem eval-buffer-list))
- (while (and tem
- (re-search-forward "^ eval-\\(buffer\\|region\\)(" nil t))
- (end-of-line)
- (insert (format " ; Reading at buffer position %d"
- ;; This will get the wrong result
- ;; if there are two nested eval-region calls
- ;; for the same buffer. That's not a very useful case.
- (with-current-buffer (car tem)
- (point))))
- (pop tem))))
- (debugger-make-xrefs))
-
-(defun debugger-make-xrefs (&optional buffer)
- "Attach cross-references to function names in the `*Backtrace*' buffer."
- (interactive "b")
- (with-current-buffer (or buffer (current-buffer))
- (save-excursion
- (setq buffer (current-buffer))
- (let ((inhibit-read-only t)
- (old-end (point-min)) (new-end (point-min)))
- ;; If we saved an old backtrace, find the common part
- ;; between the new and the old.
- ;; Compare line by line, starting from the end,
- ;; because that's the part that is likely to be unchanged.
- (if debugger-previous-backtrace
- (let (old-start new-start (all-match t))
- (goto-char (point-max))
- (with-temp-buffer
- (insert debugger-previous-backtrace)
- (while (and all-match (not (bobp)))
- (setq old-end (point))
- (forward-line -1)
- (setq old-start (point))
- (with-current-buffer buffer
- (setq new-end (point))
- (forward-line -1)
- (setq new-start (point)))
- (if (not (zerop
- (let ((case-fold-search nil))
- (compare-buffer-substrings
- (current-buffer) old-start old-end
- buffer new-start new-end))))
- (setq all-match nil))))
- ;; Now new-end is the position of the start of the
- ;; unchanged part in the current buffer, and old-end is
- ;; the position of that same text in the saved old
- ;; backtrace. But we must subtract (point-min) since strings are
- ;; indexed in origin 0.
-
- ;; Replace the unchanged part of the backtrace
- ;; with the text from debugger-previous-backtrace,
- ;; since that already has the proper xrefs.
- ;; With this optimization, we only need to scan
- ;; the changed part of the backtrace.
- (delete-region new-end (point-max))
- (goto-char (point-max))
- (insert (substring debugger-previous-backtrace
- (- old-end (point-min))))
- ;; Make the unchanged part of the backtrace inaccessible
- ;; so it won't be scanned.
- (narrow-to-region (point-min) new-end)))
-
- ;; Scan the new part of the backtrace, inserting xrefs.
- (goto-char (point-min))
- (while (progn
- (goto-char (+ (point) 2))
- (skip-syntax-forward "^w_")
- (not (eobp)))
- (let* ((beg (point))
- (end (progn (skip-syntax-forward "w_") (point)))
- (sym (intern-soft (buffer-substring-no-properties
- beg end)))
- (file (and sym (symbol-file sym 'defun))))
- (when file
- (goto-char beg)
- ;; help-xref-button needs to operate on something matched
- ;; by a regexp, so set that up for it.
- (re-search-forward "\\(\\sw\\|\\s_\\)+")
- (help-xref-button 0 'help-function-def sym file)))
- (forward-line 1))
- (widen))
- (setq debugger-previous-backtrace (buffer-string)))))
+ (goto-char pos)))
+
(defun debugger-step-through ()
"Proceed, stepping through subexpressions of this expression.
@@ -866,9 +814,13 @@ To specify a nil argument interactively, exit with an empty minibuffer."
'type 'help-function
'help-args (list fun))
(terpri))
- (terpri)
- (princ "Note: if you have redefined a function, then it may no longer\n")
- (princ "be set to debug on entry, even if it is in the list."))))))
+ ;; Now that debug--function-list uses advice-member-p, its
+ ;; output should be reliable (except for bugs and the exceptional
+ ;; case where some other advice ends up overriding ours).
+ ;;(terpri)
+ ;;(princ "Note: if you have redefined a function, then it may no longer\n")
+ ;;(princ "be set to debug on entry, even if it is in the list.")
+ )))))
(defun debug--implement-debug-watch (symbol newval op where)
"Conditionally call the debugger.
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index dfe1c06bfaf..9d618e1dc81 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -84,7 +84,7 @@ Currently under control of this var:
(progn
;; Arrange for field access not to bother checking if the access is indeed
;; made to an eieio--class object.
- (cl-declaim (optimize (safety 0)))
+ (eval-when-compile (cl-declaim (optimize (safety 0))))
(cl-defstruct (eieio--class
(:constructor nil)
@@ -103,8 +103,12 @@ Currently under control of this var:
options ;; storage location of tagged class option
; Stored outright without modifications or stripping
)
- ;; Set it back to the default value.
- (cl-declaim (optimize (safety 1))))
+ ;; Set it back to the default value. NOTE: Using the default
+ ;; `safety' value does NOT give the default
+ ;; `byte-compile-delete-errors' value. Therefore limit this (and
+ ;; the above `cl-declaim') to compile time so that we don't affect
+ ;; code which only loads this library.
+ (eval-when-compile (cl-declaim (optimize (safety 1)))))
(eval-and-compile
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index 2c49a634e35..eb2b2e3e11b 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -670,48 +670,12 @@ and is displayed in front of the value of MESSAGE-FORM."
(cl-defstruct (ert-test-aborted-with-non-local-exit
(:include ert-test-result)))
-
-(defun ert--record-backtrace ()
- "Record the current backtrace (as a list) and return it."
- ;; Since the backtrace is stored in the result object, result
- ;; objects must only be printed with appropriate limits
- ;; (`print-level' and `print-length') in place. For interactive
- ;; use, the cost of ensuring this possibly outweighs the advantage
- ;; of storing the backtrace for
- ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we
- ;; already have `ert-results-rerun-test-debugging-errors-at-point'.
- ;; For batch use, however, printing the backtrace may be useful.
- (cl-loop
- ;; 6 is the number of frames our own debugger adds (when
- ;; compiled; more when interpreted). FIXME: Need to describe a
- ;; procedure for determining this constant.
- for i from 6
- for frame = (backtrace-frame i)
- while frame
- collect frame))
-
-(defun ert--print-backtrace (backtrace)
+(defun ert--print-backtrace (backtrace do-xrefs)
"Format the backtrace BACKTRACE to the current buffer."
- ;; This is essentially a reimplementation of Fbacktrace
- ;; (src/eval.c), but for a saved backtrace, not the current one.
(let ((print-escape-newlines t)
(print-level 8)
(print-length 50))
- (dolist (frame backtrace)
- (pcase-exhaustive frame
- (`(nil ,special-operator . ,arg-forms)
- ;; Special operator.
- (insert
- (format " %S\n" (cons special-operator arg-forms))))
- (`(t ,fn . ,args)
- ;; Function call.
- (insert (format " %S(" fn))
- (cl-loop for firstp = t then nil
- for arg in args do
- (unless firstp
- (insert " "))
- (insert (format "%S" arg)))
- (insert ")\n"))))))
+ (debugger-insert-backtrace backtrace do-xrefs)))
;; A container for the state of the execution of a single test and
;; environment data needed during its execution.
@@ -750,7 +714,19 @@ run. ARGS are the arguments to `debugger'."
((quit) 'quit)
((ert-test-skipped) 'skipped)
(otherwise 'failed)))
- (backtrace (ert--record-backtrace))
+ ;; We store the backtrace in the result object for
+ ;; `ert-results-pop-to-backtrace-for-test-at-point'.
+ ;; This means we have to limit `print-level' and
+ ;; `print-length' when printing result objects. That
+ ;; might not be worth while when we can also use
+ ;; `ert-results-rerun-test-debugging-errors-at-point',
+ ;; (i.e., when running interactively) but having the
+ ;; backtrace ready for printing is important for batch
+ ;; use.
+ ;;
+ ;; Grab the frames starting from `signal', frames below
+ ;; that are all from the debugger.
+ (backtrace (backtrace-frames 'signal))
(infos (reverse ert--infos)))
(setf (ert--test-execution-info-result info)
(cl-ecase type
@@ -1409,8 +1385,9 @@ Returns the stats object."
(ert-test-result-with-condition
(message "Test %S backtrace:" (ert-test-name test))
(with-temp-buffer
- (ert--print-backtrace (ert-test-result-with-condition-backtrace
- result))
+ (ert--print-backtrace
+ (ert-test-result-with-condition-backtrace result)
+ nil)
(goto-char (point-min))
(while (not (eobp))
(let ((start (point))
@@ -1491,7 +1468,7 @@ this exits Emacs, with status as per `ert-run-tests-batch-and-exit'."
(with-temp-buffer
(while (setq logfile (pop command-line-args-left))
(erase-buffer)
- (insert-file-contents logfile)
+ (when (file-readable-p logfile) (insert-file-contents logfile))
(if (not (re-search-forward "^Running \\([0-9]+\\) tests" nil t))
(push logfile notests)
(setq ntests (+ ntests (string-to-number (match-string 1))))
@@ -1828,12 +1805,23 @@ EWOC and STATS are arguments for `ert--results-update-stats-display'."
BEGIN and END specify a region in the current buffer."
(save-excursion
- (save-restriction
- (narrow-to-region begin end)
- ;; Inhibit optimization in `debugger-make-xrefs' that would
- ;; sometimes insert unrelated backtrace info into our buffer.
- (let ((debugger-previous-backtrace nil))
- (debugger-make-xrefs)))))
+ (goto-char begin)
+ (while (progn
+ (goto-char (+ (point) 2))
+ (skip-syntax-forward "^w_")
+ (< (point) end))
+ (let* ((beg (point))
+ (end (progn (skip-syntax-forward "w_") (point)))
+ (sym (intern-soft (buffer-substring-no-properties
+ beg end)))
+ (file (and sym (symbol-file sym 'defun))))
+ (when file
+ (goto-char beg)
+ ;; help-xref-button needs to operate on something matched
+ ;; by a regexp, so set that up for it.
+ (re-search-forward "\\(\\sw\\|\\s_\\)+")
+ (help-xref-button 0 'help-function-def sym file)))
+ (forward-line 1))))
(defun ert--string-first-line (s)
"Return the first line of S, or S if it contains no newlines.
@@ -2420,8 +2408,7 @@ To be used in the ERT results buffer."
;; Use unibyte because `debugger-setup-buffer' also does so.
(set-buffer-multibyte nil)
(setq truncate-lines t)
- (ert--print-backtrace backtrace)
- (debugger-make-xrefs)
+ (ert--print-backtrace backtrace t)
(goto-char (point-min))
(insert (substitute-command-keys "Backtrace for test `"))
(ert-insert-test-name-button (ert-test-name test))
diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el
index fc3caf3359a..a1c5b6977f8 100644
--- a/lisp/emacs-lisp/lisp-mnt.el
+++ b/lisp/emacs-lisp/lisp-mnt.el
@@ -326,12 +326,13 @@ Return argument is of the form (\"HOLDER\" \"YEAR1\" ... \"YEARN\")"
(start (point))
(end (line-end-position)))
;; Cope with multi-line copyright `lines'. Assume the second
- ;; line is indented (with the same commenting style).
+ ;; line is indented at least as much as the original, with the
+ ;; same commenting style.
(save-excursion
(beginning-of-line 2)
- (let ((str (concat (match-string-no-properties 1) "[ \t]+")))
+ (let ((str (match-string-no-properties 1)))
(beginning-of-line)
- (while (looking-at str)
+ (while (and (looking-at str) (not (looking-at lm-copyright-prefix)))
(setq end (line-end-position))
(beginning-of-line 2))))
;; Make a single line and parse that.
generated by cgit v1.2.3 (git 2.39.1) at 2025-06-22 21:13:24 +0000