diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/ert-x.el | 57 | ||||
| -rw-r--r-- | lisp/emacs-lisp/ert.el | 5 | ||||
| -rw-r--r-- | lisp/emacs-lisp/smie.el | 4 | ||||
| -rw-r--r-- | lisp/emacs-lisp/subr-x.el | 2 | ||||
| -rw-r--r-- | lisp/emacs-lisp/syntax.el | 107 | ||||
| -rw-r--r-- | lisp/emacs-lisp/timer-list.el | 6 |
6 files changed, 125 insertions, 56 deletions
diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index 6d9a7d9211a..71d46c11077 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -286,27 +286,60 @@ BUFFER defaults to current buffer. Does not modify BUFFER." (defmacro ert-with-message-capture (var &rest body) - "Execute BODY while collecting anything written with `message' in VAR. + "Execute BODY while collecting messages in VAR. -Capture all messages produced by `message' when it is called from -Lisp, and concatenate them separated by newlines into one string. +Capture messages issued by Lisp code and concatenate them +separated by newlines into one string. This includes messages +written by `message' as well as objects printed by `print', +`prin1' and `princ' to the echo area. Messages issued from C +code using the above mentioned functions will not be captured. This is useful for separating the issuance of messages by the code under test from the behavior of the *Messages* buffer." (declare (debug (symbolp body)) (indent 1)) - (let ((g-advice (gensym))) + (let ((g-message-advice (gensym)) + (g-print-advice (gensym)) + (g-collector (gensym))) `(let* ((,var "") - (,g-advice (lambda (func &rest args) - (if (or (null args) (equal (car args) "")) - (apply func args) - (let ((msg (apply #'format-message args))) - (setq ,var (concat ,var msg "\n")) - (funcall func "%s" msg)))))) - (advice-add 'message :around ,g-advice) + (,g-collector (lambda (msg) (setq ,var (concat ,var msg)))) + (,g-message-advice (ert--make-message-advice ,g-collector)) + (,g-print-advice (ert--make-print-advice ,g-collector))) + (advice-add 'message :around ,g-message-advice) + (advice-add 'prin1 :around ,g-print-advice) + (advice-add 'princ :around ,g-print-advice) + (advice-add 'print :around ,g-print-advice) (unwind-protect (progn ,@body) - (advice-remove 'message ,g-advice))))) + (advice-remove 'print ,g-print-advice) + (advice-remove 'princ ,g-print-advice) + (advice-remove 'prin1 ,g-print-advice) + (advice-remove 'message ,g-message-advice))))) + +(defun ert--make-message-advice (collector) + "Create around advice for `message' for `ert-collect-messages'. +COLLECTOR will be called with the message before it is passed +to the real `message'." + (lambda (func &rest args) + (if (or (null args) (equal (car args) "")) + (apply func args) + (let ((msg (apply #'format-message args))) + (funcall collector (concat msg "\n")) + (funcall func "%s" msg))))) + +(defun ert--make-print-advice (collector) + "Create around advice for print functions for `ert-collect-messages'. +The created advice function will just call the original function +unless the output is going to the echo area (when PRINTCHARFUN is +t or PRINTCHARFUN is nil and `standard-output' is t). If the +output is destined for the echo area, the advice function will +convert it to a string and pass it to COLLECTOR first." + (lambda (func object &optional printcharfun) + (if (not (eq t (or printcharfun standard-output))) + (funcall func object printcharfun) + (funcall collector (with-output-to-string + (funcall func object))) + (funcall func object printcharfun)))) (provide 'ert-x) diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index d4276221ba5..83acbacb883 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -742,9 +742,8 @@ run. ARGS are the arguments to `debugger'." ;; 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)) + ;; Grab the frames above the debugger. + (backtrace (cdr (backtrace-frames debugger))) (infos (reverse ert--infos))) (setf (ert--test-execution-info-result info) (cl-ecase type diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index 87c4782e217..da1e12b1408 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -1956,7 +1956,7 @@ E.g. provided via a file-local call to `smie-config-local'.") (defvar smie-config--modefuns nil) (defun smie-config--setter (var value) - (setq-default var value) + (set-default var value) (let ((old-modefuns smie-config--modefuns)) (setq smie-config--modefuns nil) (pcase-dolist (`(,mode . ,rules) value) @@ -1982,7 +1982,7 @@ value with which to replace it." ;; FIXME improve value-type. :type '(choice (const nil) (alist :key-type symbol)) - :initialize 'custom-initialize-default + :initialize 'custom-initialize-set :set #'smie-config--setter) (defun smie-config-local (rules) diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 077ad22c75d..edba6550fa2 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -128,7 +128,7 @@ binding value is nil. If all are non-nil, the value of THEN is returned, or the last form in ELSE is returned. Each element of VARLIST is a list (SYMBOL VALUEFORM) which binds -SYMBOL to the value of VALUEFORM). An element can additionally +SYMBOL to the value of VALUEFORM. An element can additionally be of the form (VALUEFORM), which is evaluated and checked for nil; i.e. SYMBOL can be omitted if only the test result is of interest." diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el index f6137837858..9eb6bde7454 100644 --- a/lisp/emacs-lisp/syntax.el +++ b/lisp/emacs-lisp/syntax.el @@ -381,10 +381,26 @@ This function should move the cursor back to some syntactically safe point (where the PPSS is equivalent to nil).") (make-obsolete-variable 'syntax-begin-function nil "25.1") -(defvar-local syntax-ppss-cache nil - "List of (POS . PPSS) pairs, in decreasing POS order.") -(defvar-local syntax-ppss-last nil - "Cache of (LAST-POS . LAST-PPSS).") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Several caches. +;; +;; Because `syntax-ppss' is equivalent to (parse-partial-sexp +;; (POINT-MIN) x), we need either to empty the cache when we narrow +;; the buffer, which is suboptimal, or we need to use several caches. +;; We use two of them, one for widened buffer, and one for narrowing. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar-local syntax-ppss-wide nil + "Cons of two elements (LAST . CACHE). +Where LAST is a pair (LAST-POS . LAST-PPS) caching the last invocation +and CACHE is a list of (POS . PPSS) pairs, in decreasing POS order. +These are valid when the buffer has no restriction.") + +(defvar-local syntax-ppss-narrow nil + "Same as `syntax-ppss-wide' but for a narrowed buffer.") + +(defvar-local syntax-ppss-narrow-start nil + "Start position of the narrowing for `syntax-ppss-narrow'.") (defalias 'syntax-ppss-after-change-function 'syntax-ppss-flush-cache) (defun syntax-ppss-flush-cache (beg &rest ignored) @@ -392,24 +408,29 @@ point (where the PPSS is equivalent to nil).") ;; Set syntax-propertize to refontify anything past beg. (setq syntax-propertize--done (min beg syntax-propertize--done)) ;; Flush invalid cache entries. - (while (and syntax-ppss-cache (> (caar syntax-ppss-cache) beg)) - (setq syntax-ppss-cache (cdr syntax-ppss-cache))) - ;; Throw away `last' value if made invalid. - (when (< beg (or (car syntax-ppss-last) 0)) - ;; If syntax-begin-function jumped to BEG, then the old state at BEG can - ;; depend on the text after BEG (which is presumably changed). So if - ;; BEG=(car (nth 10 syntax-ppss-last)) don't reuse that data because the - ;; assumed nil state at BEG may not be valid any more. - (if (<= beg (or (syntax-ppss-toplevel-pos (cdr syntax-ppss-last)) - (nth 3 syntax-ppss-last) - 0)) - (setq syntax-ppss-last nil) - (setcar syntax-ppss-last nil))) - ;; Unregister if there's no cache left. Sadly this doesn't work - ;; because `before-change-functions' is temporarily bound to nil here. - ;; (unless syntax-ppss-cache - ;; (remove-hook 'before-change-functions 'syntax-ppss-flush-cache t)) - ) + (dolist (cell (list syntax-ppss-wide syntax-ppss-narrow)) + (pcase cell + (`(,last . ,cache) + (while (and cache (> (caar cache) beg)) + (setq cache (cdr cache))) + ;; Throw away `last' value if made invalid. + (when (< beg (or (car last) 0)) + ;; If syntax-begin-function jumped to BEG, then the old state at BEG can + ;; depend on the text after BEG (which is presumably changed). So if + ;; BEG=(car (nth 10 syntax-ppss-last)) don't reuse that data because the + ;; assumed nil state at BEG may not be valid any more. + (if (<= beg (or (syntax-ppss-toplevel-pos (cdr last)) + (nth 3 last) + 0)) + (setq last nil) + (setcar last nil))) + ;; Unregister if there's no cache left. Sadly this doesn't work + ;; because `before-change-functions' is temporarily bound to nil here. + ;; (unless cache + ;; (remove-hook 'before-change-functions 'syntax-ppss-flush-cache t)) + (setcar cell last) + (setcdr cell cache))) + )) (defvar syntax-ppss-stats [(0 . 0.0) (0 . 0.0) (0 . 0.0) (0 . 0.0) (0 . 0.0) (1 . 2500.0)]) @@ -423,6 +444,17 @@ point (where the PPSS is equivalent to nil).") (defvar-local syntax-ppss-table nil "Syntax-table to use during `syntax-ppss', if any.") +(defun syntax-ppss--data () + (if (eq (point-min) 1) + (progn + (unless syntax-ppss-wide + (setq syntax-ppss-wide (cons nil nil))) + syntax-ppss-wide) + (unless (eq syntax-ppss-narrow-start (point-min)) + (setq syntax-ppss-narrow-start (point-min)) + (setq syntax-ppss-narrow (cons nil nil))) + syntax-ppss-narrow)) + (defun syntax-ppss (&optional pos) "Parse-Partial-Sexp State at POS, defaulting to point. The returned value is the same as that of `parse-partial-sexp' @@ -439,10 +471,13 @@ running the hook." (syntax-propertize pos) ;; (with-syntax-table (or syntax-ppss-table (syntax-table)) - (let ((old-ppss (cdr syntax-ppss-last)) - (old-pos (car syntax-ppss-last)) - (ppss nil) - (pt-min (point-min))) + (let* ((cell (syntax-ppss--data)) + (ppss-last (car cell)) + (ppss-cache (cdr cell)) + (old-ppss (cdr ppss-last)) + (old-pos (car ppss-last)) + (ppss nil) + (pt-min (point-min))) (if (and old-pos (> old-pos pos)) (setq old-pos nil)) ;; Use the OLD-POS if usable and close. Don't update the `last' cache. (condition-case nil @@ -475,7 +510,7 @@ running the hook." ;; The OLD-* data can't be used. Consult the cache. (t (let ((cache-pred nil) - (cache syntax-ppss-cache) + (cache ppss-cache) (pt-min (point-min)) ;; I differentiate between PT-MIN and PT-BEST because ;; I feel like it might be important to ensure that the @@ -491,7 +526,7 @@ running the hook." (if cache (setq pt-min (caar cache) ppss (cdar cache))) ;; Setup the before-change function if necessary. - (unless (or syntax-ppss-cache syntax-ppss-last) + (unless (or ppss-cache ppss-last) (add-hook 'before-change-functions 'syntax-ppss-flush-cache t t)) @@ -541,7 +576,7 @@ running the hook." pt-min (setq pt-min (/ (+ pt-min pos) 2)) nil nil ppss)) (push (cons pt-min ppss) - (if cache-pred (cdr cache-pred) syntax-ppss-cache))) + (if cache-pred (cdr cache-pred) ppss-cache))) ;; Compute the actual return value. (setq ppss (parse-partial-sexp pt-min pos nil nil ppss)) @@ -562,13 +597,15 @@ running the hook." (if (> (- (caar cache-pred) pos) syntax-ppss-max-span) (push pair (cdr cache-pred)) (setcar cache-pred pair)) - (if (or (null syntax-ppss-cache) - (> (- (caar syntax-ppss-cache) pos) + (if (or (null ppss-cache) + (> (- (caar ppss-cache) pos) syntax-ppss-max-span)) - (push pair syntax-ppss-cache) - (setcar syntax-ppss-cache pair))))))))) + (push pair ppss-cache) + (setcar ppss-cache pair))))))))) - (setq syntax-ppss-last (cons pos ppss)) + (setq ppss-last (cons pos ppss)) + (setcar cell ppss-last) + (setcdr cell ppss-cache) ppss) (args-out-of-range ;; If the buffer is more narrowed than when we built the cache, @@ -582,7 +619,7 @@ running the hook." (defun syntax-ppss-debug () (let ((pt nil) (min-diffs nil)) - (dolist (x (append syntax-ppss-cache (list (cons (point-min) nil)))) + (dolist (x (append (cdr (syntax-ppss--data)) (list (cons (point-min) nil)))) (when pt (push (- pt (car x)) min-diffs)) (setq pt (car x))) min-diffs)) diff --git a/lisp/emacs-lisp/timer-list.el b/lisp/emacs-lisp/timer-list.el index 44a315f9806..69c67419835 100644 --- a/lisp/emacs-lisp/timer-list.el +++ b/lisp/emacs-lisp/timer-list.el @@ -25,7 +25,7 @@ ;;; Code: ;;;###autoload -(defun timer-list (&optional _ignore-auto _nonconfirm) +(defun list-timers (&optional _ignore-auto _nonconfirm) "List all timers in a buffer." (interactive) (pop-to-buffer-same-window (get-buffer-create "*timer-list*")) @@ -67,7 +67,7 @@ (goto-char (point-min))) ;; This command can be destructive if they don't know what they are ;; doing. Kids, don't try this at home! -;;;###autoload (put 'timer-list 'disabled "Beware: manually canceling timers can ruin your Emacs session.") +;;;###autoload (put 'list-timers 'disabled "Beware: manually canceling timers can ruin your Emacs session.") (defvar timer-list-mode-map (let ((map (make-sparse-keymap))) @@ -84,7 +84,7 @@ (setq bidi-paragraph-direction 'left-to-right) (setq truncate-lines t) (buffer-disable-undo) - (setq-local revert-buffer-function 'timer-list) + (setq-local revert-buffer-function #'list-timers) (setq buffer-read-only t) (setq header-line-format (format "%4s %10s %8s %s" |