From bb15864e05c2fb668e1bd718feb93b804bd29999 Mon Sep 17 00:00:00 2001 From: Gary Trakhman Date: Wed, 30 Oct 2024 15:56:40 -0400 Subject: [PATCH 1/7] add ert bootstrap WIP --- lisp/bootstrap.el | 2 + lisp/emacs-lisp/backtrace.el | 917 +++++++++++ lisp/emacs-lisp/debug.el | 867 ++++++++++ lisp/emacs-lisp/ert.el | 3002 ++++++++++++++++++++++++++++++++++ lisp/emacs-lisp/ewoc.el | 589 +++++++ lisp/emacs-lisp/find-func.el | 841 ++++++++++ lisp/emacs-lisp/map.el | 647 ++++++++ lisp/emacs-lisp/pp.el | 669 ++++++++ src/fileio.rs | 18 + 9 files changed, 7552 insertions(+) create mode 100644 lisp/emacs-lisp/backtrace.el create mode 100644 lisp/emacs-lisp/debug.el create mode 100644 lisp/emacs-lisp/ert.el create mode 100644 lisp/emacs-lisp/ewoc.el create mode 100644 lisp/emacs-lisp/find-func.el create mode 100644 lisp/emacs-lisp/map.el create mode 100644 lisp/emacs-lisp/pp.el diff --git a/lisp/bootstrap.el b/lisp/bootstrap.el index 8fdcf4aa..b5adcdb7 100644 --- a/lisp/bootstrap.el +++ b/lisp/bootstrap.el @@ -4,6 +4,8 @@ (load "cconv") (load "warnings") ;; should be autoloaded (load "bytecomp") +(defvar source-directory nil) +(load "ert") ;; check bytecodes diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el new file mode 100644 index 00000000..120972d6 --- /dev/null +++ b/lisp/emacs-lisp/backtrace.el @@ -0,0 +1,917 @@ +;;; backtrace.el --- generic major mode for Elisp backtraces -*- lexical-binding: t -*- + +;; Copyright (C) 2018-2024 Free Software Foundation, Inc. + +;; Author: Gemini Lasswell +;; Keywords: lisp, tools, maint +;; Version: 1.0 + +;; 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 GNU Emacs. If not, see . + +;;; Commentary: + +;; This file defines Backtrace mode, a generic major mode for displaying +;; Elisp stack backtraces, which can be used as is or inherited from +;; by another mode. + +;; For usage information, see the documentation of `backtrace-mode'. + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'pcase)) +(eval-when-compile (require 'subr-x)) ; if-let +(require 'find-func) +(require 'help-mode) ; Define `help-function-def' button type. +(require 'lisp-mode) + +;;; Options + +(defgroup backtrace nil + "Viewing of Elisp backtraces." + :group 'lisp) + +(defcustom backtrace-fontify t + "If non-nil, fontify Backtrace buffers. +Set to nil to disable fontification, which may be necessary in +order to debug the code that does fontification." + :type 'boolean + :group 'backtrace + :version "27.1") + +(defcustom backtrace-line-length 5000 + "Target length for lines in Backtrace buffers. +Backtrace mode will attempt to abbreviate printing of backtrace +frames by setting `print-level' and `print-length' to make them +shorter than this, but success is not guaranteed. If set to nil +or zero, backtrace mode will not abbreviate the forms it prints." + :type '(choice natnum + (const :value nil :tag "Don't abbreviate")) + :group 'backtrace + :version "27.1") + +;;; Backtrace frame data structure + +(cl-defstruct + (backtrace-frame + (:constructor backtrace-make-frame)) + evald ; Non-nil if argument evaluation is complete. + fun ; The function called/to call in this frame. + args ; Either evaluated or unevaluated arguments to the function. + flags ; A plist, possible properties are :debug-on-exit and :source-available. + locals ; An alist containing variable names and values. + buffer ; If non-nil, the buffer in use by eval-buffer or eval-region. + pos ; The position in the buffer. + ) + +(cl-defun backtrace-get-frames + (&optional base &key (constructor #'backtrace-make-frame)) + "Collect all frames of current backtrace into a list. +The list will contain objects made by CONSTRUCTOR, which +defaults to `backtrace-make-frame' and which, if provided, should +be the constructor of a structure which includes +`backtrace-frame'. If non-nil, BASE should be a function, and +frames before its nearest activation frame are discarded." + (let ((frames nil) + (eval-buffers eval-buffer-list)) + (mapbacktrace (lambda (evald fun args flags) + (push (funcall constructor + :evald evald :fun fun + :args args :flags flags) + frames)) + (or base 'backtrace-get-frames)) + (setq frames (nreverse frames)) + ;; Add local variables to each frame, and the buffer position + ;; to frames containing eval-buffer or eval-region. + (dotimes (idx (length frames)) + (let ((frame (nth idx frames))) + ;; `backtrace--locals' gives an error when idx is 0. But the + ;; locals for frame 0 are not needed, because when we get here + ;; from debug-on-entry, the locals aren't bound yet, and when + ;; coming from Edebug or ERT there is an Edebug or ERT + ;; function at frame 0. + (when (> idx 0) + (setf (backtrace-frame-locals frame) + (backtrace--locals idx (or base 'backtrace-get-frames)))) + (when (and eval-buffers (memq (backtrace-frame-fun frame) + '(eval-buffer eval-region))) + ;; 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) + (setf (backtrace-frame-buffer frame) (current-buffer)) + (setf (backtrace-frame-pos frame) (point)))))) + frames)) + +;; Button definition for jumping to a buffer position. + +(define-button-type 'backtrace-buffer-pos + 'action #'backtrace--pop-to-buffer-pos + 'help-echo "mouse-2, RET: Show reading position") + +(defun backtrace--pop-to-buffer-pos (button) + "Pop to the buffer and position for the BUTTON at point." + (let* ((buffer (button-get button 'backtrace-buffer)) + (pos (button-get button 'backtrace-pos))) + (if (buffer-live-p buffer) + (progn + (pop-to-buffer buffer) + (goto-char (max (point-min) (min (point-max) pos)))) + (message "Buffer has been killed")))) + +;; Font Locking support + +(defconst backtrace--font-lock-keywords + '() + "Expressions to fontify in Backtrace mode. +Fontify these in addition to the expressions Emacs Lisp mode +fontifies.") + +(defconst backtrace-font-lock-keywords + (append lisp-el-font-lock-keywords-for-backtraces + backtrace--font-lock-keywords) + "Default expressions to highlight in Backtrace mode.") +(defconst backtrace-font-lock-keywords-1 + (append lisp-el-font-lock-keywords-for-backtraces-1 + backtrace--font-lock-keywords) + "Subdued level highlighting for Backtrace mode.") +(defconst backtrace-font-lock-keywords-2 + (append lisp-el-font-lock-keywords-for-backtraces-2 + backtrace--font-lock-keywords) + "Gaudy level highlighting for Backtrace mode.") + +;;; Xref support + +(defun backtrace--xref-backend () 'elisp) + +;;; Backtrace mode variables + +(defvar-local backtrace-frames nil + "Stack frames displayed in the current Backtrace buffer. +This should be a list of `backtrace-frame' objects.") + +(defvar-local backtrace-view nil + "A plist describing how to render backtrace frames. +Possible entries are :show-flags, :show-locals, :print-circle +and :print-gensym.") + +(defvar-local backtrace-insert-header-function nil + "Function for inserting a header for the current Backtrace buffer. +If nil, no header will be created. Note that Backtrace buffers +are fontified as in Emacs Lisp Mode, the header text included.") + +(defvar backtrace-revert-hook nil + "Hook run before reverting a Backtrace buffer. +This is commonly used to recompute `backtrace-frames'.") + +(defvar-local backtrace-print-function #'cl-prin1 + "Function used to print values in the current Backtrace buffer.") + +(defvar backtrace-goto-source-functions nil + "Abnormal hook used to jump to the source code for the current frame. +Each hook function is called with no argument, and should return +non-nil if it is able to switch to the buffer containing the +source code. Execution of the hook will stop if one of the +functions returns non-nil. When adding a function to this hook, +you should also set the :source-available flag for the backtrace +frames where the source code location is known.") + +(defvar-keymap backtrace-mode-map + :doc "Local keymap for `backtrace-mode' buffers." + :parent (make-composed-keymap special-mode-map + button-buffer-map) + "n" #'backtrace-forward-frame + "p" #'backtrace-backward-frame + "v" #'backtrace-toggle-locals + "#" #'backtrace-toggle-print-circle + ":" #'backtrace-toggle-print-gensym + "RET" #'backtrace-help-follow-symbol + "+" #'backtrace-multi-line + "-" #'backtrace-single-line + "." #'backtrace-expand-ellipses + "" 'mouse-face + "" #'mouse-select-window + + :menu + '("Backtrace" + ["Next Frame" backtrace-forward-frame + :help "Move cursor forwards to the start of a backtrace frame"] + ["Previous Frame" backtrace-backward-frame + :help "Move cursor backwards to the start of a backtrace frame"] + "--" + ["Show Variables" backtrace-toggle-locals + :style toggle + :active (backtrace-get-index) + :selected (plist-get (backtrace-get-view) :show-locals) + :help "Show or hide the local variables for the frame at point"] + ["Show Circular Structures" backtrace-toggle-print-circle + :style toggle + :active (backtrace-get-index) + :selected (plist-get (backtrace-get-view) :print-circle) + :help + "Condense or expand shared or circular structures in the frame at point"] + ["Show Uninterned Symbols" backtrace-toggle-print-gensym + :style toggle + :active (backtrace-get-index) + :selected (plist-get (backtrace-get-view) :print-gensym) + :help + "Toggle unique printing of uninterned symbols in the frame at point"] + ["Expand \"...\"s" backtrace-expand-ellipses + :help "Expand all the abbreviated forms in the current frame"] + ["Show on Multiple Lines" backtrace-multi-line + :help "Use line breaks and indentation to make a form more readable"] + ["Show on Single Line" backtrace-single-line] + "--" + ["Go to Source" backtrace-goto-source + :active (and (backtrace-get-index) + (plist-get (backtrace-frame-flags + (nth (backtrace-get-index) backtrace-frames)) + :source-available)) + :help "Show the source code for the current frame"] + ["Help for Symbol" backtrace-help-follow-symbol + :help "Show help for symbol at point"] + ["Describe Backtrace Mode" describe-mode + :help "Display documentation for backtrace-mode"])) + +(defconst backtrace--flags-width 2 + "Width in characters of the flags for a backtrace frame.") + +;;; Navigation and Text Properties + +;; This mode uses the following text properties: +;; backtrace-index: The index into the buffer-local variable +;; `backtrace-frames' for the frame at point, or nil if outside of a +;; frame (in the buffer header). +;; backtrace-view: A plist describing how the frame is printed. See +;; the docstring for the buffer-local variable `backtrace-view. +;; backtrace-section: The part of a frame which point is in. Either +;; `func' or `locals'. At the moment just used to show and hide the +;; local variables. Derived modes which do additional printing +;; could define their own frame sections. +;; backtrace-form: A value applied to each printed representation of a +;; top-level s-expression, which needs to be different for sexps +;; printed adjacent to each other, so the limits can be quickly +;; found for pretty-printing. + +(defsubst backtrace-get-index (&optional pos) + "Return the index of the backtrace frame at POS. +The value is an index into `backtrace-frames', or nil. +POS, if omitted or nil, defaults to point." + (get-text-property (or pos (point)) 'backtrace-index)) + +(defsubst backtrace-get-section (&optional pos) + "Return the section of a backtrace frame at POS. +POS, if omitted or nil, defaults to point." + (get-text-property (or pos (point)) 'backtrace-section)) + +(defsubst backtrace-get-view (&optional pos) + "Return the view plist of the backtrace frame at POS. +POS, if omitted or nil, defaults to point." + (get-text-property (or pos (point)) 'backtrace-view)) + +(defsubst backtrace-get-form (&optional pos) + "Return the backtrace form data for the form printed at POS. +POS, if omitted or nil, defaults to point." + (get-text-property (or pos (point)) 'backtrace-form)) + +(defun backtrace-get-frame-start (&optional pos) + "Return the beginning position of the frame at POS in the buffer. +POS, if omitted or nil, defaults to point." + (let ((posn (or pos (point)))) + (if (or (= (point-min) posn) + (not (eq (backtrace-get-index posn) + (backtrace-get-index (1- posn))))) + posn + (previous-single-property-change posn 'backtrace-index nil (point-min))))) + +(defun backtrace-get-frame-end (&optional pos) + "Return the position of the end of the frame at POS in the buffer. +POS, if omitted or nil, defaults to point." + (next-single-property-change (or pos (point)) + 'backtrace-index nil (point-max))) + +(defun backtrace-forward-frame () + "Move forward to the beginning of the next frame." + (interactive) + (let ((max (backtrace-get-frame-end))) + (when (= max (point-max)) + (user-error "No next stack frame")) + (goto-char max))) + +(defun backtrace-backward-frame () + "Move backward to the start of a stack frame." + (interactive) + (let ((current-index (backtrace-get-index)) + (min (backtrace-get-frame-start))) + (if (or (and (/= (point) (point-max)) (null current-index)) + (= min (point-min)) + (and (= min (point)) + (null (backtrace-get-index (1- min))))) + (user-error "No previous stack frame")) + (if (= min (point)) + (goto-char (backtrace-get-frame-start (1- min))) + (goto-char min)))) + +;; Other Backtrace mode commands + +(defun backtrace-revert (&rest _ignored) + "The `revert-buffer-function' for `backtrace-mode'. +It runs `backtrace-revert-hook', then calls `backtrace-print'." + (interactive) + (unless (derived-mode-p 'backtrace-mode) + (error "The current buffer is not in Backtrace mode")) + (run-hooks 'backtrace-revert-hook) + (backtrace-print t)) + +(defmacro backtrace--with-output-variables (view &rest body) + "Bind output variables according to VIEW and execute BODY." + (declare (indent 1)) + `(let ((print-escape-control-characters t) + (print-escape-newlines t) + (print-circle (plist-get ,view :print-circle)) + (print-gensym (plist-get ,view :print-gensym)) + (standard-output (current-buffer))) + ,@body)) + +(defun backtrace-toggle-locals (&optional all) + "Toggle the display of local variables for the backtrace frame at point. +With prefix argument ALL, toggle the value of :show-locals in +`backtrace-view', which affects all of the backtrace frames in +the buffer." + (interactive "P") + (if all + (let ((pos (make-marker)) + (visible (not (plist-get backtrace-view :show-locals)))) + (setq backtrace-view (plist-put backtrace-view :show-locals visible)) + (set-marker-insertion-type pos t) + (set-marker pos (point)) + (goto-char (point-min)) + ;; Skip the header. + (unless (backtrace-get-index) + (goto-char (backtrace-get-frame-end))) + (while (< (point) (point-max)) + (backtrace--set-frame-locals-visible visible) + (goto-char (backtrace-get-frame-end))) + (goto-char pos) + (when (invisible-p pos) + (goto-char (backtrace-get-frame-start)))) + (let ((index (backtrace-get-index))) + (unless index + (user-error "Not in a stack frame")) + (backtrace--set-frame-locals-visible + (not (plist-get (backtrace-get-view) :show-locals)))))) + +(defun backtrace--set-frame-locals-visible (visible) + "Set the visibility of the local vars for the frame at point to VISIBLE." + (let ((pos (point)) + (index (backtrace-get-index)) + (start (backtrace-get-frame-start)) + (end (backtrace-get-frame-end)) + (view (copy-sequence (backtrace-get-view))) + (inhibit-read-only t)) + (setq view (plist-put view :show-locals visible)) + (goto-char (backtrace-get-frame-start)) + (while (not (or (= (point) end) + (eq (backtrace-get-section) 'locals))) + (goto-char (next-single-property-change (point) + 'backtrace-section nil end))) + (cond + ((and (= (point) end) visible) + ;; The locals section doesn't exist so create it. + (let ((standard-output (current-buffer))) + (backtrace--with-output-variables view + (backtrace--print-locals + (nth index backtrace-frames) view)) + (add-text-properties end (point) `(backtrace-index ,index)) + (goto-char pos))) + ((/= (point) end) + ;; The locals section does exist, so add or remove the overlay. + (backtrace--set-locals-visible-overlay (point) end visible) + (goto-char (if (invisible-p pos) start pos)))) + (add-text-properties start (backtrace-get-frame-end) + `(backtrace-view ,view)))) + +(defun backtrace--set-locals-visible-overlay (beg end visible) + (backtrace--change-button-skip beg end (not visible)) + (if visible + (remove-overlays beg end 'invisible t) + (let ((o (make-overlay beg end))) + (overlay-put o 'invisible t) + (overlay-put o 'evaporate t)))) + +(defun backtrace--change-button-skip (beg end value) + "Change the `skip' property on all buttons between BEG and END. +Set it to VALUE unless the button is a `cl-print-ellipsis' button." + (let ((inhibit-read-only t)) + (setq beg (next-button beg)) + (while (and beg (< beg end)) + (unless (eq (button-type beg) 'cl-print-ellipsis) + (button-put beg 'skip value)) + (setq beg (next-button beg))))) + +(defun backtrace-toggle-print-circle (&optional all) + "Toggle `print-circle' for the backtrace frame at point. +With prefix argument ALL, toggle the default value bound to +`print-circle' for all the frames in the buffer." + (interactive "P") + (backtrace--toggle-feature :print-circle all)) + +(defun backtrace-toggle-print-gensym (&optional all) + "Toggle `print-gensym' for the backtrace frame at point. +With prefix argument ALL, toggle the default value bound to +`print-gensym' for all the frames in the buffer." + (interactive "P") + (backtrace--toggle-feature :print-gensym all)) + +(defun backtrace--toggle-feature (feature all) + "Toggle FEATURE for the current backtrace frame or for the buffer. +FEATURE should be one of the options in `backtrace-view'. If ALL +is non-nil, toggle FEATURE for all frames in the buffer. After +toggling the feature, reprint the affected frame(s). Afterwards +position point at the start of the frame it was in before." + (if all + (let ((index (backtrace-get-index)) + (pos (point)) + (at-end (= (point) (point-max))) + (value (not (plist-get backtrace-view feature)))) + (setq backtrace-view (plist-put backtrace-view feature value)) + (goto-char (point-min)) + ;; Skip the header. + (unless (backtrace-get-index) + (goto-char (backtrace-get-frame-end))) + (while (< (point) (point-max)) + (backtrace--set-feature feature value) + (goto-char (backtrace-get-frame-end))) + (if (not index) + (goto-char (if at-end (point-max) pos)) + (goto-char (point-min)) + (while (and (not (eql index (backtrace-get-index))) + (< (point) (point-max))) + (goto-char (backtrace-get-frame-end)))) + (message "%s is now %s for all frames" + (substring (symbol-name feature) 1) value)) + (unless (backtrace-get-index) + (user-error "Not in a stack frame")) + (let ((value (not (plist-get (backtrace-get-view) feature)))) + (backtrace--set-feature feature value) + (message "%s is now %s for this frame" + (substring (symbol-name feature) 1) value)))) + +(defun backtrace--set-feature (feature value) + "Set FEATURE in the view plist of the frame at point to VALUE. +Reprint the frame with the new view plist." + (let ((inhibit-read-only t) + (view (copy-sequence (backtrace-get-view))) + (index (backtrace-get-index)) + (min (backtrace-get-frame-start)) + (max (backtrace-get-frame-end))) + (setq view (plist-put view feature value)) + (delete-region min max) + (goto-char min) + (backtrace-print-frame (nth index backtrace-frames) view) + (add-text-properties min (point) + `(backtrace-index ,index backtrace-view ,view)) + (goto-char min))) + +(defun backtrace--expand-ellipsis (orig-fun begin end val _length &rest args) + "Wrapper to expand an ellipsis. +For use on `cl-print-expand-ellipsis-function'." + (let* ((props (backtrace-get-text-properties begin)) + (inhibit-read-only t)) + (backtrace--with-output-variables (backtrace-get-view) + (let ((end (apply orig-fun begin end val backtrace-line-length args))) + (add-text-properties begin end props) + end)))) + +(defun backtrace-expand-ellipses (&optional no-limit) + "Expand display of all \"...\"s in the backtrace frame at point. +\\ +Each ellipsis will be limited to `backtrace-line-length' +characters in its expansion. With optional prefix argument +NO-LIMIT, do not limit the number of characters. Note that with +or without the argument, using this command can result in very +long lines and very poor display performance. If this happens +and is a problem, use `\\[revert-buffer]' to return to the +initial state of the Backtrace buffer." + (interactive "P") + (save-excursion + (let ((start (backtrace-get-frame-start)) + (end (backtrace-get-frame-end)) + (backtrace-line-length (unless no-limit backtrace-line-length))) + (goto-char end) + (while (> (point) start) + (let ((next (previous-single-property-change (point) 'cl-print-ellipsis + nil start))) + (when (get-text-property (point) 'cl-print-ellipsis) + (push-button (point))) + (goto-char next)))))) + +(defun backtrace-multi-line () + "Show the top level s-expression at point on multiple lines with indentation." + (interactive) + (backtrace--reformat-sexp #'backtrace--multi-line)) + +(defun backtrace--multi-line () + "Pretty print the current buffer, then remove the trailing newline." + (set-syntax-table emacs-lisp-mode-syntax-table) + (pp-buffer) + (goto-char (1- (point-max))) + (delete-char 1)) + +(defun backtrace-single-line () + "Show the top level s-expression at point on one line." + (interactive) + (backtrace--reformat-sexp #'backtrace--single-line)) + +(defun backtrace--single-line () + "Replace line breaks and following indentation with spaces. +Works on the current buffer." + (goto-char (point-min)) + (while (re-search-forward "\n[[:blank:]]*" nil t) + (replace-match " "))) + +(defun backtrace--reformat-sexp (format-function) + "Reformat the top level sexp at point. +Locate the top level sexp at or following point on the same line, +and reformat it with FORMAT-FUNCTION, preserving the location of +point within the sexp. If no sexp is found before the end of +the line or buffer, signal an error. + +FORMAT-FUNCTION will be called without arguments, with the +current buffer set to a temporary buffer containing only the +content of the sexp." + (let* ((orig-pos (point)) + (pos (point)) + (tag (backtrace-get-form pos)) + (end (next-single-property-change pos 'backtrace-form)) + (begin (previous-single-property-change end 'backtrace-form + nil (point-min)))) + (unless tag + (when (or (= end (point-max)) (> end (line-end-position))) + (user-error "No form here to reformat")) + (goto-char end) + (setq pos end + end (next-single-property-change pos 'backtrace-form) + begin (previous-single-property-change end 'backtrace-form + nil (point-min)))) + (let* ((offset (when (>= orig-pos begin) (- orig-pos begin))) + (offset-marker (when offset (make-marker))) + (content (buffer-substring begin end)) + (props (backtrace-get-text-properties begin)) + (inhibit-read-only t)) + (delete-region begin end) + (insert (with-temp-buffer + (insert content) + (when offset + (set-marker-insertion-type offset-marker t) + (set-marker offset-marker (+ (point-min) offset))) + (funcall format-function) + (when offset + (setq offset (- (marker-position offset-marker) (point-min)))) + (buffer-string))) + (when offset + (set-marker offset-marker (+ begin offset))) + (save-excursion + (goto-char begin) + (indent-sexp)) + (add-text-properties begin (point) props) + (if offset + (goto-char (marker-position offset-marker)) + (goto-char orig-pos))))) + +(defun backtrace-get-text-properties (pos) + "Return a plist of backtrace-mode's text properties at POS." + (apply #'append + (mapcar (lambda (prop) + (list prop (get-text-property pos prop))) + '(backtrace-section backtrace-index backtrace-view + backtrace-form)))) + +(defun backtrace-goto-source () + "If its location is known, jump to the source code for the frame at point." + (interactive) + (let* ((index (or (backtrace-get-index) (user-error "Not in a stack frame"))) + (frame (nth index backtrace-frames)) + (source-available (plist-get (backtrace-frame-flags frame) + :source-available))) + (unless (and source-available + (run-hook-with-args-until-success + 'backtrace-goto-source-functions)) + (user-error "Source code location not known")))) + +(defun backtrace-help-follow-symbol (&optional pos) + "Follow cross-reference at POS, defaulting to point. +For the cross-reference format, see `help-make-xrefs'." + (interactive "d") + (unless pos + (setq pos (point))) + (unless (push-button pos) + ;; Check if the symbol under point is a function or variable. + (let ((sym + (intern + (save-excursion + (goto-char pos) (skip-syntax-backward "w_") + (buffer-substring (point) + (progn (skip-syntax-forward "w_") + (point))))))) + (when (or (boundp sym) (fboundp sym) (facep sym)) + (describe-symbol sym))))) + +;; Print backtrace frames + +(defun backtrace-print (&optional remember-pos) + "Populate the current Backtrace mode buffer. +This erases the buffer and inserts printed representations of the +frames. Optional argument REMEMBER-POS, if non-nil, means to +move point to the entry with the same ID element as the current +line and recenter window line accordingly." + (let ((inhibit-read-only t) + entry-index saved-pt window-line) + (and remember-pos + (setq entry-index (backtrace-get-index)) + (when (eq (window-buffer) (current-buffer)) + (setq window-line + (count-screen-lines (window-start) (point))))) + (erase-buffer) + (when backtrace-insert-header-function + (funcall backtrace-insert-header-function)) + (dotimes (idx (length backtrace-frames)) + (let ((beg (point)) + (elt (nth idx backtrace-frames))) + (and entry-index + (equal entry-index idx) + (setq entry-index nil + saved-pt (point))) + (backtrace-print-frame elt backtrace-view) + (add-text-properties + beg (point) + `(backtrace-index ,idx backtrace-view ,backtrace-view)))) + (set-buffer-modified-p nil) + ;; If REMEMBER-POS was specified, move to the "old" location. + (if saved-pt + (progn (goto-char saved-pt) + (when window-line + (recenter window-line))) + (goto-char (point-min))))) + +(defun backtrace-print-to-string (obj &optional limit) + "Return a printed representation of OBJ formatted for backtraces. +Attempt to get the length of the returned string under LIMIT +characters with appropriate settings of `print-level' and +`print-length.' LIMIT defaults to `backtrace-line-length'." + (backtrace--with-output-variables backtrace-view + (backtrace--print-to-string obj limit))) + +(defun backtrace--print-to-string (sexp &optional limit) + ;; This is for use by callers who wrap the call with + ;; backtrace--with-output-variables. + (propertize (cl-print-to-string-with-limit #'backtrace--print sexp + (or limit backtrace-line-length)) + ;; Add a unique backtrace-form property. + 'backtrace-form (gensym))) + +(defun backtrace-print-frame (frame view) + "Insert a backtrace FRAME at point formatted according to VIEW. +Tag the sections of the frame with the `backtrace-section' text +property for use by navigation." + (backtrace--with-output-variables view + (backtrace--print-flags frame view) + (backtrace--print-func-and-args frame view) + (backtrace--print-locals frame view))) + +(defun backtrace--print-flags (frame view) + "Print the flags of a backtrace FRAME if enabled in VIEW." + (let ((beg (point)) + (flag (plist-get (backtrace-frame-flags frame) :debug-on-exit)) + (source (plist-get (backtrace-frame-flags frame) :source-available))) + (when (plist-get view :show-flags) + (when source (insert ">")) + (when flag (insert "*"))) + (insert (make-string (- backtrace--flags-width (- (point) beg)) ?\s)) + (put-text-property beg (point) 'backtrace-section 'func))) + +(defun backtrace--line-length-or-nil () + "Return `backtrace-line-length' if valid, nil else." + ;; mirror the logic in `cl-print-to-string-with-limit' + (and (natnump backtrace-line-length) + (not (zerop backtrace-line-length)) + backtrace-line-length)) + +(defun backtrace--print-func-and-args (frame _view) + "Print the function, arguments and buffer position of a backtrace FRAME. +Format it according to VIEW." + (let* ((beg (point)) + (evald (backtrace-frame-evald frame)) + (fun (backtrace-frame-fun frame)) + (args (backtrace-frame-args frame)) + (def (find-function-advised-original fun)) + (fun-file (or (symbol-file fun 'defun) + (and (subrp def) + (not (special-form-p def)) + (find-lisp-object-file-name fun def)))) + (fun-beg (point)) + (fun-end nil)) + (cond + ((and evald (not debugger-stack-frame-as-list)) + (if (atom fun) + (funcall backtrace-print-function fun) + (insert + (backtrace--print-to-string + fun + (when (and args (backtrace--line-length-or-nil)) + (/ backtrace-line-length 2))))) + (setq fun-end (point)) + (if args + (insert (backtrace--print-to-string + args + (if (backtrace--line-length-or-nil) + (max (truncate (/ backtrace-line-length 5)) + (- backtrace-line-length (- (point) beg)))))) + ;; The backtrace-form property is so that backtrace-multi-line + ;; will find it. backtrace-multi-line doesn't do anything + ;; useful with it, just being consistent. + (let ((start (point))) + (insert "()") + (put-text-property start (point) 'backtrace-form t)))) + (t + (let ((fun-and-args (cons fun args))) + (insert (backtrace--print-to-string fun-and-args))) + ;; Skip the open-paren. + (cl-incf fun-beg))) + (when fun-file + (make-text-button fun-beg + (or fun-end + (+ fun-beg + ;; FIXME: `backtrace--print-to-string' will + ;; not necessarily print FUN in the same way + ;; as it did when it was in FUN-AND-ARGS! + (length (backtrace--print-to-string fun)))) + :type 'help-function-def + 'help-args (list fun fun-file))) + ;; After any frame that uses eval-buffer, insert a comment that + ;; states the buffer position it's reading at. + (when (backtrace-frame-pos frame) + (insert " ; Reading at ") + (let ((pos (point))) + (insert (format "buffer position %d" (backtrace-frame-pos frame))) + (make-button pos (point) :type 'backtrace-buffer-pos + 'backtrace-buffer (backtrace-frame-buffer frame) + 'backtrace-pos (backtrace-frame-pos frame)))) + (insert "\n") + (put-text-property beg (point) 'backtrace-section 'func))) + +(defun backtrace--print-locals (frame view) + "Print a backtrace FRAME's local variables according to VIEW. +Print them only if :show-locals is non-nil in the VIEW plist." + (when (plist-get view :show-locals) + (let* ((beg (point)) + (locals (backtrace-frame-locals frame))) + (if (null locals) + (insert " [no locals]\n") + (pcase-dolist (`(,symbol . ,value) locals) + (insert " ") + (backtrace--print symbol) + (insert " = ") + (insert (backtrace--print-to-string value)) + (insert "\n"))) + (put-text-property beg (point) 'backtrace-section 'locals)))) + +(defun backtrace--print (obj &optional stream) + "Attempt to print OBJ to STREAM using `backtrace-print-function'. +Fall back to `prin1' if there is an error." + (condition-case err + (funcall backtrace-print-function obj stream) + (error + (message "Error in backtrace printer: %S" err) + (prin1 obj stream)))) + +(defun backtrace-update-flags () + "Update the display of the flags in the backtrace frame at point." + (let ((view (backtrace-get-view)) + (begin (backtrace-get-frame-start))) + (when (plist-get view :show-flags) + (save-excursion + (goto-char begin) + (let ((props (backtrace-get-text-properties begin)) + (inhibit-read-only t) + (standard-output (current-buffer))) + (delete-char backtrace--flags-width) + (backtrace--print-flags (nth (backtrace-get-index) backtrace-frames) + view) + (add-text-properties begin (point) props)))))) + +(defun backtrace--filter-visible (beg end &optional _delete) + "Return the visible text between BEG and END." + (let ((result "")) + (while (< beg end) + (let ((next (next-single-char-property-change beg 'invisible))) + (unless (get-char-property beg 'invisible) + (setq result (concat result (buffer-substring beg (min end next))))) + (setq beg next))) + result)) + +;;; The mode definition + +(define-derived-mode backtrace-mode special-mode "Backtrace" + "Generic major mode for examining an Elisp stack backtrace. +This mode can be used directly, or other major modes can be +derived from it, using `define-derived-mode'. + +In this major mode, the buffer contains some optional lines of +header text followed by backtrace frames, each consisting of one +or more whole lines. + +Letters in this mode do not insert themselves; instead they are +commands. +\\ +\\{backtrace-mode-map} + +A mode which inherits from Backtrace mode, or a command which +creates a `backtrace-mode' buffer, should usually do the following: + + - Set `backtrace-revert-hook', if the buffer contents need + to be specially recomputed prior to `revert-buffer'. + - Maybe set `backtrace-insert-header-function' to a function to create + header text for the buffer. + - Set `backtrace-frames' (see below). + - Maybe modify `backtrace-view' (see below). + - Maybe set `backtrace-print-function'. + +A command which creates or switches to a Backtrace mode buffer, +such as `ert-results-pop-to-backtrace-for-test-at-point', should +initialize `backtrace-frames' to a list of `backtrace-frame' +objects (`backtrace-get-frames' is provided for that purpose, if +desired), and may optionally modify `backtrace-view', which is a +plist describing the appearance of the backtrace. Finally, it +should call `backtrace-print'. + +`backtrace-print' calls `backtrace-insert-header-function' +followed by `backtrace-print-frame', once for each stack frame." + :syntax-table emacs-lisp-mode-syntax-table + (when backtrace-fontify + (setq font-lock-defaults + '((backtrace-font-lock-keywords + backtrace-font-lock-keywords-1 + backtrace-font-lock-keywords-2) + nil nil nil nil + (font-lock-syntactic-face-function + . lisp-font-lock-syntactic-face-function)))) + (setq truncate-lines t) + (buffer-disable-undo) + ;; In debug.el, from 1998 to 2009 this was set to nil, reason stated + ;; was because of bytecode. Since 2009 it's been set to t, but the + ;; default is t so I think this isn't necessary. + ;; (set-buffer-multibyte t) + (setq-local revert-buffer-function #'backtrace-revert) + (setq-local filter-buffer-substring-function #'backtrace--filter-visible) + (setq-local indent-line-function 'lisp-indent-line) + (setq-local indent-region-function 'lisp-indent-region) + (add-function :around (local 'cl-print-expand-ellipsis-function) + #'backtrace--expand-ellipsis) + (add-hook 'xref-backend-functions #'backtrace--xref-backend nil t)) + +(put 'backtrace-mode 'mode-class 'special) + +;;; Backtrace printing + +;;;###autoload +(defun backtrace () + "Print a trace of Lisp function calls currently active. +Output stream used is value of `standard-output'." + (princ (backtrace-to-string (backtrace-get-frames 'backtrace))) + nil) + +(defun backtrace-to-string (&optional frames) + "Format FRAMES, a list of `backtrace-frame' objects, for output. +Return the result as a string. If FRAMES is nil, use all +function calls currently active." + (substring-no-properties + (backtrace--to-string + (or frames (backtrace-get-frames 'backtrace-to-string))))) + +(defun backtrace--to-string (frames) + (let ((backtrace-fontify nil)) + (with-temp-buffer + (backtrace-mode) + (setq backtrace-view '(:show-flags t) + backtrace-frames frames + backtrace-print-function #'cl-prin1) + (backtrace-print) + (filter-buffer-substring (point-min) (point-max))))) + +(provide 'backtrace) + +;;; backtrace.el ends here diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el new file mode 100644 index 00000000..ec947c12 --- /dev/null +++ b/lisp/emacs-lisp/debug.el @@ -0,0 +1,867 @@ +;;; debug.el --- debuggers and related commands for Emacs -*- lexical-binding: t -*- + +;; Copyright (C) 1985-1986, 1994, 2001-2024 Free Software Foundation, +;; Inc. + +;; Maintainer: emacs-devel@gnu.org +;; Keywords: lisp, tools, maint + +;; 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 GNU Emacs. If not, see . + +;;; Commentary: + +;; This is a major mode documented in the Emacs Lisp manual. + +;;; Code: + +(require 'cl-lib) +(require 'backtrace) + +(defgroup debugger nil + "Debuggers and related commands for Emacs." + :prefix "debugger-" + :group 'debug) + +(defcustom debugger-mode-hook nil + "Hooks run when `debugger-mode' is turned on." + :type 'hook + :group 'debugger + :version "20.3") + +(defcustom debugger-batch-max-lines 40 + "Maximum lines to show in debugger buffer in a noninteractive Emacs. +When the debugger is entered and Emacs is running in batch mode, +if the backtrace text has more than this many lines, +the middle is discarded, and just the beginning and end are displayed." + :type 'integer + :group 'debugger + :version "21.1") + +(defcustom debugger-print-function #'cl-prin1 + "Function used to print values in the debugger backtraces." + :type '(choice (const cl-prin1) + (const prin1) + function) + :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 +previously showing the debugger buffer. + +nil means that if its window is not deleted when exiting the + debugger, invoking `switch-to-prev-buffer' will usually show + the debugger buffer again. + +`append' means that if the window is not deleted, the debugger + buffer moves to the end of the window's previous buffers so + it's less likely that a future invocation of + `switch-to-prev-buffer' will switch to it. Also, it moves the + buffer to the end of the frame's buffer list. + +`bury' means that if the window is not deleted, its buffer is + removed from the window's list of previous buffers. Also, it + moves the buffer to the end of the frame's buffer list. This + value provides the most reliable remedy to not have + `switch-to-prev-buffer' switch to the debugger buffer again + without killing the buffer. + +`kill' means to kill the debugger buffer. + +The value used here is passed to `quit-restore-window'." + :type '(choice + (const :tag "Keep alive" nil) + (const :tag "Append" append) + (const :tag "Bury" bury) + (const :tag "Kill" kill)) + :group 'debugger + :version "24.3") + +(defcustom debug-allow-recursive-debug nil + "If non-nil, erroring in debug and edebug won't recursively debug." + :type 'boolean + :version "29.1") + +(defvar debugger-step-after-exit nil + "Non-nil means \"single-step\" after the debugger exits.") + +(defvar debugger-value nil + "This is the value for the debugger to return, when it returns.") + +(defvar debugger-old-buffer nil + "This is the buffer that was current when the debugger was entered.") + +(defvar debugger-previous-window nil + "This is the window last showing the debugger buffer.") + +(defvar debugger-previous-window-height nil + "The last recorded height of `debugger-previous-window'.") + +(defvar debugger-outer-match-data) +(defvar debugger-will-be-back nil + "Non-nil if we expect to get back in the debugger soon.") + +(defvar inhibit-debug-on-entry nil + "Non-nil means that `debug-on-entry' is disabled.") + +(defvar debugger-jumping-flag nil + "Non-nil means that `debug-on-entry' is disabled. +This variable is used by `debugger-jump', `debugger-step-through', +and `debugger-reenable' to temporarily disable `debug-on-entry'.") + +(defvar inhibit-trace) ;Not yet implemented. + +(defvar debugger-args nil + "Arguments with which the debugger was called. +It is a list expected to take the form (CAUSE . REST) +where CAUSE can be: +- debug: called for entry to a flagged function. +- t: called because of `debug-on-next-call'. +- lambda: same thing but via `funcall'. +- exit: called because of exit of a flagged function. +- error: called because of `debug-on-error'.") + +(cl-defstruct (debugger--buffer-state + (:constructor debugger--save-buffer-state + (&aux (mode major-mode) + (header backtrace-insert-header-function) + (frames backtrace-frames) + (content (buffer-string)) + (pos (point))))) + mode header frames content pos) + +(defun debugger--restore-buffer-state (state) + (unless (derived-mode-p (debugger--buffer-state-mode state)) + (funcall (debugger--buffer-state-mode state))) + (setq backtrace-insert-header-function (debugger--buffer-state-header state) + backtrace-frames (debugger--buffer-state-frames state)) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert (debugger--buffer-state-content state))) + (goto-char (debugger--buffer-state-pos state))) + +(defvar debugger--last-error nil) + +(defun debugger--duplicate-p (args) + (pcase args + (`(error ,err . ,_) (and (consp err) (eq err debugger--last-error))))) + +;;;###autoload +(setq debugger 'debug) +;;;###autoload +(defun debug (&rest args) + "Enter debugger. \\`\\[debugger-continue]' returns from the debugger. + +In interactive sessions, this switches to a backtrace buffer and shows +the Lisp backtrace of function calls there. In batch mode (more accurately, +when `noninteractive' is non-nil), it shows the Lisp backtrace on the +standard error stream (unless `backtrace-on-error-noninteractive' is nil), +and then kills Emacs, causing it to exit with a negative exit code. + +Arguments are mainly for use when this is called from the internals +of the evaluator. + +You may call with no args, or you may pass nil as the first arg and +any other args you like. In that case, the list of args after the +first will be printed into the backtrace buffer. + +If `inhibit-redisplay' is non-nil when this function is called, +the debugger will not be entered." + (interactive) + (if (or inhibit-redisplay + (debugger--duplicate-p args)) + ;; Don't really try to enter debugger within an eval from redisplay + ;; or if we already popper into the debugger for this error, + ;; which can happen when we have several nested `handler-bind's that + ;; want to invoke the debugger. + debugger-value + (setq debugger--last-error nil) + (let ((non-interactive-frame + (or noninteractive ;FIXME: Presumably redundant. + ;; If we're in the initial-frame (where `message' just + ;; outputs to stdout) so there's no tty or GUI frame to + ;; display the backtrace and interact with it: just dump a + ;; backtrace to stdout. This happens for example while + ;; handling an error in code from early-init.el with + ;; --debug-init. + (and (eq t (framep (selected-frame))) + (equal "initial_terminal" (terminal-name))))) + ;; Don't let `inhibit-message' get in our way (especially important if + ;; `non-interactive-frame' evaluated to a non-nil value. + (inhibit-message nil) + ;; We may be entering the debugger from a context that has + ;; let-bound `inhibit-read-only', which means that all + ;; buffers would be read/write while the debugger is running. + (inhibit-read-only nil)) + (unless non-interactive-frame + (message "Entering debugger...")) + (let (debugger-value + (debugger-previous-state + (if (get-buffer "*Backtrace*") + (with-current-buffer "*Backtrace*" + (debugger--save-buffer-state)))) + (debugger-args args) + (debugger-buffer (get-buffer-create "*Backtrace*")) + (debugger-old-buffer (current-buffer)) + (debugger-window nil) + (debugger-step-after-exit nil) + (debugger-will-be-back nil) + ;; Don't keep reading from an executing kbd macro! + (executing-kbd-macro nil) + ;; Save the outer values of these vars for the `e' command + ;; before we replace the values. + (debugger-outer-match-data (match-data)) + (debugger-with-timeout-suspend (with-timeout-suspend))) + ;; Set this instead of binding it, so that `q' + ;; will not restore it. + (setq overriding-terminal-local-map nil) + ;; Don't let these magic variables affect the debugger itself. + (let ((last-command nil) this-command track-mouse + (inhibit-trace t) + unread-command-events + unread-post-input-method-events + last-input-event last-command-event last-nonmenu-event + last-event-frame + overriding-local-map + (load-read-function #'read) + ;; If we are inside a minibuffer, allow nesting + ;; so that we don't get an error from the `e' command. + (enable-recursive-minibuffers + (or enable-recursive-minibuffers (> (minibuffer-depth) 0))) + (standard-input t) (standard-output t) + inhibit-redisplay + (cursor-in-echo-area nil) + (window-configuration (current-window-configuration))) + (unwind-protect + (save-excursion + (when (eq (car debugger-args) 'debug) + (let ((base (debugger--backtrace-base))) + (backtrace-debug 1 t base) ;FIXME! + ;; Place an extra debug-on-exit for macro's. + (when (eq 'lambda (car-safe (cadr (backtrace-frame 1 base)))) + (backtrace-debug 2 t base)))) + (with-current-buffer debugger-buffer + (unless (derived-mode-p 'debugger-mode) + (debugger-mode)) + (debugger-setup-buffer debugger-args) + (when non-interactive-frame + ;; If the backtrace is long, save the beginning + ;; and the end, but discard the middle. + (let ((inhibit-read-only t)) + (when (> (count-lines (point-min) (point-max)) + debugger-batch-max-lines) + (goto-char (point-min)) + (forward-line (/ debugger-batch-max-lines 2)) + (let ((middlestart (point))) + (goto-char (point-max)) + (forward-line (- (/ debugger-batch-max-lines 2))) + (delete-region middlestart (point))) + (insert "...\n"))) + (message "%s" (buffer-string)) + (kill-emacs -1))) + (pop-to-buffer + debugger-buffer + `((display-buffer-reuse-window + display-buffer-in-previous-window + display-buffer-below-selected) + . ((window-min-height . 10) + (window-height . fit-window-to-buffer) + ,@(when (and (window-live-p debugger-previous-window) + (frame-visible-p + (window-frame debugger-previous-window))) + `((previous-window . ,debugger-previous-window)))))) + (setq debugger-window (selected-window)) + (when debugger-jumping-flag + ;; Try to restore previous height of debugger + ;; window. + (condition-case nil + (window-resize + debugger-window + (- debugger-previous-window-height + (window-total-height debugger-window))) + (error nil)) + (setq debugger-previous-window debugger-window)) + (message "") + (let ((standard-output nil) + (buffer-read-only t)) + (message "") + ;; Make sure we unbind buffer-read-only in the right buffer. + (save-excursion + (recursive-edit)))) + (when (and (window-live-p debugger-window) + (eq (window-buffer debugger-window) debugger-buffer)) + ;; Record height of debugger window. + (setq debugger-previous-window-height + (window-total-height debugger-window))) + (if debugger-will-be-back + ;; Restore previous window configuration (Bug#12623). + (set-window-configuration window-configuration) + (when (and (window-live-p debugger-window) + (eq (window-buffer debugger-window) debugger-buffer)) + (progn + ;; Unshow debugger-buffer. + (quit-restore-window debugger-window debugger-bury-or-kill) + ;; Restore current buffer (Bug#12502). + (set-buffer debugger-old-buffer))) + ;; Forget debugger window, it won't be back (Bug#17882). + (setq debugger-previous-window nil)) + ;; Restore previous state of debugger-buffer in case we + ;; were in a recursive invocation of the debugger, + ;; otherwise just exit (after changing the mode, since we + ;; can't interact with the buffer in the same way). + (when (buffer-live-p debugger-buffer) + (with-current-buffer debugger-buffer + (if debugger-previous-state + (debugger--restore-buffer-state debugger-previous-state) + (backtrace-mode)))) + (with-timeout-unsuspend debugger-with-timeout-suspend) + (set-match-data debugger-outer-match-data))) + (when (eq 'error (car-safe debugger-args)) + ;; Remember the error we just debugged, to avoid re-entering + ;; the debugger if some higher-up `handler-bind' invokes us + ;; again, oblivious that the error was already debugged from + ;; a more deeply nested `handler-bind'. + (setq debugger--last-error (nth 1 debugger-args))) + (setq debug-on-next-call debugger-step-after-exit) + debugger-value)))) + +(defun debugger--print (obj &optional stream) + (condition-case err + (funcall debugger-print-function obj stream) + (error + (message "Error in debug printer: %S" err) + (prin1 obj stream)))) + +(make-obsolete 'debugger-insert-backtrace + "use a `backtrace-mode' buffer or `backtrace-to-string'." + "27.1") + +(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." + (insert (if do-xrefs + (backtrace--to-string frames) + (backtrace-to-string frames)))) + +(defun debugger-setup-buffer (args) + "Initialize the `*Backtrace*' buffer for entry to the debugger. +That buffer should be current already and in `debugger-mode'." + (setq backtrace-frames + ;; The `base' frame is the one that gets index 0 and it is the entry to + ;; the debugger, so drop it with `cdr'. + (cdr (backtrace-get-frames (debugger--backtrace-base)))) + (when (eq (car-safe args) 'exit) + (setq debugger-value (nth 1 args)) + (setf (cl-getf (backtrace-frame-flags (car backtrace-frames)) + :debug-on-exit) + nil)) + + (setq backtrace-view (plist-put backtrace-view :show-flags t) + backtrace-insert-header-function (lambda () + (debugger--insert-header args)) + backtrace-print-function debugger-print-function) + (backtrace-print) + ;; Place point on "stack frame 0" (bug#15101). + (goto-char (point-min)) + (search-forward ":" (line-end-position) t) + (when (and (< (point) (line-end-position)) + (= (char-after) ?\s)) + (forward-char))) + +(defun debugger--insert-header (args) + "Insert the header for the debugger's Backtrace buffer. +Include the reason for debugger entry from ARGS." + (insert "Debugger entered") + (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")) + ;; Exiting a function. + ('exit + (insert "--returning value: ") + (insert (backtrace-print-to-string debugger-value)) + (insert ?\n)) + ;; Watchpoint triggered. + ((and 'watchpoint (let `(,symbol ,newval . ,details) (cdr args))) + (insert + "--" + (pcase details + ('(makunbound nil) (format "making %s void" symbol)) + (`(makunbound ,buffer) (format "killing local value of %s in buffer %s" + symbol buffer)) + (`(defvaralias ,_) (format "aliasing %s to %s" symbol newval)) + (`(let ,_) (format "let-binding %s to %s" symbol + (backtrace-print-to-string newval))) + (`(unlet ,_) (format "ending let-binding of %s" symbol)) + ('(set nil) (format "setting %s to %s" symbol + (backtrace-print-to-string newval))) + (`(set ,buffer) (format "setting %s in buffer %s to %s" + symbol buffer + (backtrace-print-to-string newval))) + (_ (error "Unrecognized watchpoint triggered %S" (cdr args)))) + ": ") + (insert ?\n)) + ;; Debugger entered for an error. + ('error + (insert "--Lisp error: ") + (insert (backtrace-print-to-string (nth 1 args))) + (insert ?\n)) + ;; debug-on-call, when the next thing is an eval. + ('t + (insert "--beginning evaluation of function call form:\n")) + ;; User calls debug directly. + (_ + (insert ": ") + (insert (backtrace-print-to-string (if (eq (car args) 'nil) + (cdr args) args))) + (insert ?\n)))) + + +(defun debugger-step-through () + "Proceed, stepping through subexpressions of this expression. +Enter another debugger on next entry to eval, apply or funcall." + (interactive) + (setq debugger-step-after-exit t) + (setq debugger-jumping-flag t) + (setq debugger-will-be-back t) + (add-hook 'post-command-hook 'debugger-reenable) + (message "Proceeding, will debug on next eval or call.") + (exit-recursive-edit)) + +(defun debugger-continue () + "Continue, evaluating this expression without stopping." + (interactive) + (unless debugger-may-continue + (error "Cannot continue")) + (message "Continuing.") + + ;; Check to see if we've flagged some frame for debug-on-exit, in which + ;; case we'll probably come back to the debugger soon. + (dolist (frame backtrace-frames) + (when (plist-get (backtrace-frame-flags frame) :debug-on-exit) + (setq debugger-will-be-back t))) + (exit-recursive-edit)) + +(defun debugger-return-value (val) + "Continue, specifying value to return. +This is only useful when the value returned from the debugger +will be used, such as in a debug on exit from a frame." + (interactive "XReturn value (evaluated): ") + (when (memq (car debugger-args) '(t lambda error debug)) + (error "Cannot return a value %s" + (if (eq (car debugger-args) 'error) + "from an error" "at function entrance"))) + (setq debugger-value val) + (princ "Returning " t) + (debugger--print debugger-value) + ;; Check to see if we've flagged some frame for debug-on-exit, in which + ;; case we'll probably come back to the debugger soon. + (dolist (frame backtrace-frames) + (when (plist-get (backtrace-frame-flags frame) :debug-on-exit) + (setq debugger-will-be-back t))) + (exit-recursive-edit)) + +(defun debugger-jump () + "Continue to exit from this frame, with all `debug-on-entry' suspended." + (interactive) + (debugger-frame) + (setq debugger-jumping-flag t) + (add-hook 'post-command-hook 'debugger-reenable) + (message "Continuing through this frame") + (setq debugger-will-be-back t) + (exit-recursive-edit)) + +(defun debugger-reenable () + "Turn all `debug-on-entry' functions back on. +This function is put on `post-command-hook' by `debugger-jump' and +removes itself from that hook." + (setq debugger-jumping-flag nil) + (remove-hook 'post-command-hook 'debugger-reenable)) + +(defun debugger-frame-number () + "Return number of frames in backtrace before the one point points at." + (let ((index (backtrace-get-index))) + (unless index + (error "This line is not a function call")) + ;; We have 3 representations of the backtrace: the real in C in `specpdl', + ;; the one stored in `backtrace-frames' and the textual version in + ;; the buffer. Check here that the one from `backtrace-frames' is in sync + ;; with the one from `specpdl'. + (cl-assert (equal (backtrace-frame-fun (nth index backtrace-frames)) + (nth 1 (backtrace-frame (1+ index) + (debugger--backtrace-base))))) + ;; The `base' frame is the one that gets index 0 and it is the entry to + ;; the debugger, so the first non-debugger frame is 1. + ;; This `+1' skips the same frame as the `cdr' in + ;; `debugger-setup-buffer'. + (1+ index))) + +(defun debugger-frame () + "Request entry to debugger when this frame exits. +Applies to the frame whose line point is on in the backtrace." + (interactive) + (backtrace-debug (debugger-frame-number) t (debugger--backtrace-base)) + (setf + (cl-getf (backtrace-frame-flags (nth (backtrace-get-index) backtrace-frames)) + :debug-on-exit) + t) + (backtrace-update-flags)) + +(defun debugger-frame-clear () + "Do not enter debugger when this frame exits. +Applies to the frame whose line point is on in the backtrace." + (interactive) + (backtrace-debug (debugger-frame-number) nil (debugger--backtrace-base)) + (setf + (cl-getf (backtrace-frame-flags (nth (backtrace-get-index) backtrace-frames)) + :debug-on-exit) + nil) + (backtrace-update-flags)) + +(defmacro debugger-env-macro (&rest body) + "Run BODY in original environment." + (declare (indent 0)) + `(progn + (set-match-data debugger-outer-match-data) + (prog1 + (progn ,@body) + (setq debugger-outer-match-data (match-data))))) + +(defun debugger--backtrace-base () + "Return the function name that marks the top of the backtrace. +See `backtrace-frame'." + (or (cadr (memq :backtrace-base debugger-args)) + #'debug)) + +(defun debugger-eval-expression (exp &optional nframe) + "Eval an expression, in an environment like that outside the debugger. +The environment used is the one when entering the activation frame at point." + (interactive + (list (read--expression "Eval in stack frame: "))) + (let ((nframe (or nframe + (condition-case nil (debugger-frame-number) + (error 0)))) ;; If on first line. + (base (debugger--backtrace-base))) + (debugger-env-macro + (let* ((errored nil) + (val (if debug-allow-recursive-debug + (backtrace-eval exp nframe base) + (condition-case err + (backtrace-eval exp nframe base) + (error (setq errored + (format "%s: %s" + (get (car err) 'error-message) + (car (cdr err))))))))) + (if errored + (progn + (message "Error: %s" errored) + nil) + (prog1 + (debugger--print val t) + (let ((str (eval-expression-print-format val))) + (if str (princ str t))))))))) + +(define-obsolete-function-alias 'debugger-toggle-locals + 'backtrace-toggle-locals "28.1") + + +(defvar-keymap debugger-mode-map + :full t + :parent backtrace-mode-map + "b" #'debugger-frame + "c" #'debugger-continue + "j" #'debugger-jump + "r" #'debugger-return-value + "u" #'debugger-frame-clear + "d" #'debugger-step-through + "l" #'debugger-list-functions + "q" #'debugger-quit + "e" #'debugger-eval-expression + "R" #'debugger-record-expression + + "" #'push-button + + :menu + '("Debugger" + ["Step through" debugger-step-through + :help "Proceed, stepping through subexpressions of this expression"] + ["Continue" debugger-continue + :help "Continue, evaluating this expression without stopping"] + ["Jump" debugger-jump + :help "Continue to exit from this frame, with all debug-on-entry suspended"] + ["Eval Expression..." debugger-eval-expression + :help "Eval an expression, in an environment like that outside the debugger"] + ["Display and Record Expression" debugger-record-expression + :help "Display a variable's value and record it in `*Backtrace-record*' buffer"] + ["Return value..." debugger-return-value + :help "Continue, specifying value to return."] + "--" + ["Debug frame" debugger-frame + :help "Request entry to debugger when this frame exits"] + ["Cancel debug frame" debugger-frame-clear + :help "Do not enter debugger when this frame exits"] + ["List debug on entry functions" debugger-list-functions + :help "Display a list of all the functions now set to debug on entry"] + "--" + ["Next Line" next-line + :help "Move cursor down"] + ["Help for Symbol" backtrace-help-follow-symbol + :help "Show help for symbol at point"] + ["Describe Debugger Mode" describe-mode + :help "Display documentation for debugger-mode"] + "--" + ["Quit" debugger-quit + :help "Quit debugging and return to top level"])) + +(put 'debugger-mode 'mode-class 'special) + +(define-derived-mode debugger-mode backtrace-mode "Debugger" + "Mode for debugging Emacs Lisp using a backtrace. +\\ +A frame marked with `*' in the backtrace means that exiting that +frame will enter the debugger. You can flag frames to enter the +debugger when frame is exited with \\[debugger-frame], and remove +the flag with \\[debugger-frame-clear]. + +When in debugger invoked due to exiting a frame which was flagged +with a `*', you can use the \\[debugger-return-value] command to +override the value being returned from that frame when the debugger +exits. + +Use \\[debug-on-entry] and \\[cancel-debug-on-entry] to control +which functions will enter the debugger when called. + +Complete list of commands: +\\{debugger-mode-map}" + (add-hook 'kill-buffer-hook + (lambda () (if (> (recursion-depth) 0) (top-level))) + nil t) + (use-local-map debugger-mode-map)) + +(defcustom debugger-record-buffer "*Debugger-record*" + "Buffer name for expression values, for \\[debugger-record-expression]." + :type 'string + :group 'debugger + :version "20.3") + +(defun debugger-record-expression (exp) + "Display a variable's value and record it in `*Backtrace-record*' buffer." + (interactive + (list (read--expression "Record Eval: "))) + (let* ((buffer (get-buffer-create debugger-record-buffer)) + (standard-output buffer)) + (princ (format "Debugger Eval (%s): " exp)) + (princ (debugger-eval-expression exp)) + (terpri)) + + (with-current-buffer debugger-record-buffer + (message "%s" + (buffer-substring (line-beginning-position 0) + (line-end-position 0))))) + +(define-obsolete-function-alias 'debug-help-follow + 'backtrace-help-follow-symbol "28.1") + + +;; When you change this, you may also need to change the number of +;; frames that the debugger skips. +(defun debug--implement-debug-on-entry (&rest _ignore) + "Conditionally call the debugger. +A call to this function is inserted by `debug-on-entry' to cause +functions to break on entry." + (if (or inhibit-debug-on-entry debugger-jumping-flag) + nil + (let ((inhibit-debug-on-entry t)) + (funcall debugger 'debug :backtrace-base + ;; An offset of 1 because we need to skip the advice + ;; OClosure that called us. + '(1 . debug--implement-debug-on-entry))))) + +;;;###autoload +(defun debug-on-entry (function) + "Request FUNCTION to invoke debugger each time it is called. + +When called interactively, prompt for FUNCTION in the minibuffer. + +This works by modifying the definition of FUNCTION. If you tell the +debugger to continue, FUNCTION's execution proceeds. If FUNCTION is a +normal function or a macro written in Lisp, you can also step through +its execution. FUNCTION can also be a primitive that is not a special +form, in which case stepping is not possible. Break-on-entry for +primitive functions only works when that function is called from Lisp. + +Use \\[cancel-debug-on-entry] to cancel the effect of this command. +Redefining FUNCTION also cancels it." + (interactive + (let ((fn (function-called-at-point)) val) + (when (special-form-p fn) + (setq fn nil)) + (setq val (completing-read + (format-prompt "Debug on entry to function" fn) + obarray + #'(lambda (symbol) + (and (fboundp symbol) + (not (special-form-p symbol)))) + 'confirm nil nil (symbol-name fn))) + (list (if (equal val "") fn (intern val))))) + (advice-add function :before #'debug--implement-debug-on-entry + '((depth . -100))) + function) + +(defun debug--function-list () + "List of functions currently set for debug on entry." + (let ((funs '())) + (mapatoms + (lambda (s) + (when (advice-member-p #'debug--implement-debug-on-entry s) + (push s funs)))) + funs)) + +;;;###autoload +(defun cancel-debug-on-entry (&optional function) + "Undo effect of \\[debug-on-entry] on FUNCTION. +If FUNCTION is nil, cancel `debug-on-entry' for all functions. +When called interactively, prompt for FUNCTION in the minibuffer. +To specify a nil argument interactively, exit with an empty minibuffer." + (interactive + (list (let ((name + (completing-read + (format-prompt "Cancel debug on entry to function" + "all functions") + (mapcar #'symbol-name (debug--function-list)) nil t))) + (when name + (unless (string= name "") + (intern name)))))) + (if function + (progn + (advice-remove function #'debug--implement-debug-on-entry) + function) + (message "Canceling debug-on-entry for all functions") + (mapcar #'cancel-debug-on-entry (debug--function-list)))) + +(defun debugger-list-functions () + "Display a list of all the functions now set to debug on entry." + (interactive) + (require 'help-mode) + (help-setup-xref '(debugger-list-functions) + (called-interactively-p 'interactive)) + (with-output-to-temp-buffer (help-buffer) + (with-current-buffer standard-output + (let ((funs (debug--function-list))) + (if (null funs) + (princ "No debug-on-entry functions now\n") + (princ "Functions set to debug on entry:\n\n") + (dolist (fun funs) + (make-text-button (point) (progn (prin1 fun) (point)) + 'type 'help-function + 'help-args (list fun)) + (terpri)) + ;; 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 debugger-quit () + "Quit debugging and return to the top level." + (interactive) + (if (= (recursion-depth) 0) + (quit-window) + (top-level))) + +(defun debug--implement-debug-watch (symbol newval op where) + "Conditionally call the debugger. +This function is called when SYMBOL's value is modified." + (if (or inhibit-debug-on-entry debugger-jumping-flag) + nil + (let ((inhibit-debug-on-entry t)) + (funcall debugger 'watchpoint symbol newval op where)))) + +;;;###autoload +(defun debug-on-variable-change (variable) + "Trigger a debugger invocation when VARIABLE is changed. + +When called interactively, prompt for VARIABLE in the minibuffer. + +This works by calling `add-variable-watcher' on VARIABLE. If you +quit from the debugger, this will abort the change (unless the +change is caused by the termination of a let-binding). + +The watchpoint may be circumvented by C code that changes the +variable directly (i.e., not via `set'). Changing the value of +the variable (e.g., `setcar' on a list variable) will not trigger +watchpoint. + +Use \\[cancel-debug-on-variable-change] to cancel the effect of +this command. Uninterning VARIABLE or making it an alias of +another symbol also cancels it." + (interactive + (let* ((var-at-point (variable-at-point)) + (var (and (symbolp var-at-point) var-at-point)) + (val (completing-read + (format-prompt "Debug when setting variable" var) + obarray #'boundp + t nil nil (and var (symbol-name var))))) + (list (if (equal val "") var (intern val))))) + (add-variable-watcher variable #'debug--implement-debug-watch)) + +;;;###autoload +(defalias 'debug-watch #'debug-on-variable-change) + + +(defun debug--variable-list () + "List of variables currently set for debug on set." + (let ((vars '())) + (mapatoms + (lambda (s) + (when (memq #'debug--implement-debug-watch + (get s 'watchers)) + (push s vars)))) + vars)) + +;;;###autoload +(defun cancel-debug-on-variable-change (&optional variable) + "Undo effect of \\[debug-on-variable-change] on VARIABLE. +If VARIABLE is nil, cancel `debug-on-variable-change' for all variables. +When called interactively, prompt for VARIABLE in the minibuffer. +To specify a nil argument interactively, exit with an empty minibuffer." + (interactive + (list (let ((name + (completing-read + (format-prompt "Cancel debug on set for variable" + "all variables") + (mapcar #'symbol-name (debug--variable-list)) nil t))) + (when name + (unless (string= name "") + (intern name)))))) + (if variable + (remove-variable-watcher variable #'debug--implement-debug-watch) + (message "Canceling debug-watch for all variables") + (mapc #'cancel-debug-watch (debug--variable-list)))) + +;;;###autoload +(defalias 'cancel-debug-watch #'cancel-debug-on-variable-change) + +(make-obsolete-variable 'debugger-previous-backtrace + "no longer used." "29.1") +(defvar debugger-previous-backtrace nil) + +(provide 'debug) + +;;; debug.el ends here diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el new file mode 100644 index 00000000..fa1b7a60 --- /dev/null +++ b/lisp/emacs-lisp/ert.el @@ -0,0 +1,3002 @@ +;;; ert.el --- Emacs Lisp Regression Testing -*- lexical-binding: t -*- + +;; Copyright (C) 2007-2024 Free Software Foundation, Inc. + +;; Author: Christian Ohler +;; Keywords: lisp, tools + +;; 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 GNU Emacs. If not, see . + +;;; Commentary: + +;; ERT is a tool for automated testing in Emacs Lisp. Its main +;; features are facilities for defining and running test cases and +;; reporting the results as well as for debugging test failures +;; interactively. +;; +;; The main entry points are `ert-deftest', which is similar to +;; `defun' but defines a test, and `ert-run-tests-interactively', +;; which runs tests and offers an interactive interface for inspecting +;; results and debugging. There is also +;; `ert-run-tests-batch-and-exit' for non-interactive use. +;; +;; The body of `ert-deftest' forms resembles a function body, but the +;; additional operators `should', `should-not', `should-error', +;; `skip-when' and `skip-unless' are available. `should' is similar +;; to cl's `assert', but signals a different error when its condition +;; is violated that is caught and processed by ERT. In addition, it +;; analyzes its argument form and records information that helps +;; debugging (`cl-assert' tries to do something similar when its +;; second argument SHOW-ARGS is true, but `should' is more +;; sophisticated). For information on `should-not' and +;; `should-error', see their docstrings. The `skip-when' and +;; `skip-unless' forms skip the test immediately, which is useful for +;; checking the test environment (like availability of features, +;; external binaries, etc). +;; +;; See ERT's Info manual `(ert) Top' as well as the docstrings for +;; more details. To see some examples of tests written in ERT, see +;; the test suite distributed with the Emacs source distribution (in +;; the "test" directory). + +;;; Code: + +(require 'cl-lib) +(require 'debug) +(require 'backtrace) +(require 'ewoc) +(require 'find-func) +(require 'pp) +(require 'map) + +(autoload 'xml-escape-string "xml.el") + +;;; UI customization options. + +(defgroup ert () + "ERT, the Emacs Lisp regression testing tool." + :prefix "ert-" + :group 'lisp) + +(defcustom ert-batch-backtrace-right-margin 70 + "Maximum length of lines in ERT backtraces in batch mode. +Use nil for no limit (caution: backtrace lines can be very long)." + :type '(choice (const :tag "No truncation" nil) integer)) + +(defvar ert-batch-print-length 10 + "`print-length' setting used in `ert-run-tests-batch'. + +When formatting lists in test conditions, `print-length' will be +temporarily set to this value. See also +`ert-batch-backtrace-line-length' for its effect on stack +traces.") + +(defvar ert-batch-print-level 5 + "`print-level' setting used in `ert-run-tests-batch'. + +When formatting lists in test conditions, `print-level' will be +temporarily set to this value. See also +`ert-batch-backtrace-line-length' for its effect on stack +traces.") + +(defvar ert-batch-backtrace-line-length t + "Target length for lines in ERT batch backtraces. + +Even modest settings for `print-length' and `print-level' can +produce extremely long lines in backtraces and lengthy delays in +forming them. This variable governs the target maximum line +length by manipulating these two variables while printing stack +traces. Setting this variable to t will reuse the value of +`backtrace-line-length' while printing stack traces in ERT batch +mode. Any other value will be temporarily bound to +`backtrace-line-length' when producing stack traces in batch +mode.") + +(defface ert-test-result-expected '((((class color) (background light)) + :background "green1") + (((class color) (background dark)) + :background "green3")) + "Face used for expected results in the ERT results buffer.") + +(defface ert-test-result-unexpected '((((class color) (background light)) + :background "red1") + (((class color) (background dark)) + :background "red3")) + "Face used for unexpected results in the ERT results buffer.") + +;;; Defining and locating tests. + +;; The data structure that represents a test case. +(cl-defstruct ert-test + (name nil) + (documentation nil) + (body (cl-assert nil)) + (most-recent-result nil) + (expected-result-type ':passed) + (tags '()) + (file-name nil)) + +(defun ert-test-boundp (symbol) + "Return non-nil if SYMBOL names a test." + (and (get symbol 'ert--test) t)) + +(defun ert-get-test (symbol) + "If SYMBOL names a test, return that. Signal an error otherwise." + (unless (ert-test-boundp symbol) (error "No test named `%S'" symbol)) + (get symbol 'ert--test)) + +(defun ert-set-test (symbol definition) + "Make SYMBOL name the test DEFINITION, and return DEFINITION." + (when (eq symbol 'nil) + ;; We disallow nil since `ert-test-at-point' and related functions + ;; want to return a test name, but also need an out-of-band value + ;; on failure. Nil is the most natural out-of-band value; using 0 + ;; or "" or signaling an error would be too awkward. + ;; + ;; Note that nil is still a valid value for the `name' slot in + ;; ert-test objects. It designates an anonymous test. + (error "Attempt to define a test named nil")) + (when (and noninteractive (get symbol 'ert--test)) + ;; Make sure duplicated tests are discovered since the older test would + ;; be ignored silently otherwise. + (error "Test `%s' redefined (or loaded twice)" symbol)) + (define-symbol-prop symbol 'ert--test definition) + definition) + +(defun ert-make-test-unbound (symbol) + "Make SYMBOL name no test. Return SYMBOL." + (cl-remprop symbol 'ert--test) + symbol) + +(defun ert--parse-keys-and-body (keys-and-body) + "Split KEYS-AND-BODY into keyword-and-value pairs and the remaining body. + +KEYS-AND-BODY should have the form of a property list, with the +exception that only keywords are permitted as keys and that the +tail -- the body -- is a list of forms that does not start with a +keyword. + +Returns a two-element list containing the keys-and-values plist +and the body." + (let ((extracted-key-accu '()) + (remaining keys-and-body)) + (while (keywordp (car-safe remaining)) + (let ((keyword (pop remaining))) + (unless (consp remaining) + (error "Value expected after keyword %S in %S" + keyword keys-and-body)) + (when (assoc keyword extracted-key-accu) + (warn "Keyword %S appears more than once in %S" keyword + keys-and-body)) + (push (cons keyword (pop remaining)) extracted-key-accu))) + (setq extracted-key-accu (nreverse extracted-key-accu)) + (list (cl-loop for (key . value) in extracted-key-accu + collect key + collect value) + remaining))) + +;;;###autoload +(cl-defmacro ert-deftest (name () &body docstring-keys-and-body) + "Define NAME (a symbol) as a test. + +BODY is evaluated as a `progn' when the test is run. It should +signal a condition on failure or just return if the test passes. + +`should', `should-not', `should-error', `skip-when', and +`skip-unless' are useful for assertions in BODY. + +Use `ert' to run tests interactively. + +Tests that are expected to fail can be marked as such +using :expected-result. See `ert-test-result-type-p' for a +description of valid values for RESULT-TYPE. + +Macros in BODY are expanded when the test is defined, not when it +is run. If a macro (possibly with side effects) is to be tested, +it has to be wrapped in `(eval (quote ...))'. + +If NAME is already defined as a test and Emacs is running +in batch mode, an error is signaled. + +\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ +[:tags \\='(TAG...)] BODY...)" + (declare (debug (&define [&name "test@" symbolp] + sexp [&optional stringp] + [&rest keywordp sexp] def-body)) + (doc-string 3) + (indent 2)) + (let ((documentation nil) + (documentation-supplied-p nil)) + (when (stringp (car docstring-keys-and-body)) + (setq documentation (pop docstring-keys-and-body) + documentation-supplied-p t)) + (cl-destructuring-bind + ((&key (expected-result nil expected-result-supplied-p) + (tags nil tags-supplied-p)) + body) + (ert--parse-keys-and-body docstring-keys-and-body) + `(cl-macrolet ((skip-when (form) `(ert--skip-when ,form)) + (skip-unless (form) `(ert--skip-unless ,form))) + (ert-set-test ',name + (make-ert-test + :name ',name + ,@(when documentation-supplied-p + `(:documentation ,documentation)) + ,@(when expected-result-supplied-p + `(:expected-result-type ,expected-result)) + ,@(when tags-supplied-p + `(:tags ,tags)) + ;; Add `nil' after the body to enable compiler warnings + ;; about unused computations at the end. + :body (lambda () ,@body nil) + :file-name ,(or (macroexp-file-name) buffer-file-name))) + ',name)))) + +(defvar ert--find-test-regexp + (concat "^\\s-*(ert-deftest" + find-function-space-re + "%s\\(\\s-\\|$\\)") + "The regexp the `find-function' mechanisms use for finding test definitions.") + +(define-error 'ert-test-failed "Test failed") +(define-error 'ert-test-skipped "Test skipped") + +(defun ert-pass () + "Terminate the current test and mark it passed. Does not return." + (throw 'ert--pass nil)) + +(defun ert-fail (data) + "Terminate the current test and mark it failed. Does not return. +DATA is displayed to the user and should state the reason of the failure." + (signal 'ert-test-failed (list data))) + +(defun ert-skip (data) + "Terminate the current test and mark it skipped. Does not return. +DATA is displayed to the user and should state the reason for skipping." + (signal 'ert-test-skipped (list data))) + + +;;; The `should' macros. + +(defvar ert--should-execution-observer nil) + +(defun ert--signal-should-execution (form-description) + "Tell the current `should' form observer (if any) about FORM-DESCRIPTION." + (when ert--should-execution-observer + (funcall ert--should-execution-observer form-description))) + +(defun ert--special-operator-p (thing) + "Return non-nil if THING is a symbol naming a special operator." + (and (symbolp thing) + (let ((definition (indirect-function thing))) + (and (subrp definition) + (eql (cdr (subr-arity definition)) 'unevalled))))) + +;; FIXME: Code inside of here should probably be evaluated like it is +;; outside of tests, with the sole exception of error handling +(defun ert--expand-should-1 (whole form inner-expander) + "Helper function for the `should' macro and its variants." + (let ((form + ;; catch macroexpansion errors + (condition-case err + (macroexpand-all form macroexpand-all-environment) + (error `(signal ',(car err) ',(cdr err)))))) + (cond + ((or (atom form) (ert--special-operator-p (car form))) + (let ((value (gensym "value-"))) + `(let ((,value (gensym "ert-form-evaluation-aborted-"))) + ,(funcall inner-expander + `(setq ,value ,form) + `(list ',whole :form ',form :value ,value) + value) + ,value))) + (t + (let ((fn-name (car form)) + (arg-forms (cdr form))) + (cl-assert (or (symbolp fn-name) + (and (consp fn-name) + (eql (car fn-name) 'lambda) + (listp (cdr fn-name))))) + (let ((fn (gensym "fn-")) + (args (gensym "args-")) + (value (gensym "value-")) + (default-value (gensym "ert-form-evaluation-aborted-"))) + `(let* ((,fn (function ,fn-name)) + (,args (condition-case err + (list ,@arg-forms) + (error (progn (setq ,fn #'signal) + (list (car err) + (cdr err))))))) + (let ((,value ',default-value)) + ,(funcall inner-expander + `(setq ,value (apply ,fn ,args)) + `(nconc (list ',whole) + (list :form `(,,fn ,@,args)) + (unless (eql ,value ',default-value) + (list :value ,value)) + (unless (eql ,value ',default-value) + (when-let ((-explainer- + (ert--get-explainer ',fn-name))) + (list :explanation + (apply -explainer- ,args))))) + value) + ,value)))))))) + +(defun ert--get-explainer (fn-name) + (when (symbolp fn-name) + (cl-loop for fn in (cons fn-name (function-alias-p fn-name)) + for explainer = (get fn 'ert-explainer) + when explainer + return explainer))) + +(defun ert--expand-should (whole form inner-expander) + "Helper function for the `should' macro and its variants. + +Analyzes FORM and returns an expression that has the same +semantics under evaluation but records additional debugging +information. + +INNER-EXPANDER should be a function and is called with two +arguments: INNER-FORM and FORM-DESCRIPTION-FORM, where INNER-FORM +is an expression equivalent to FORM, and FORM-DESCRIPTION-FORM is +an expression that returns a description of FORM. INNER-EXPANDER +should return code that calls INNER-FORM and performs the checks +and error signaling specific to the particular variant of +`should'. The code that INNER-EXPANDER returns must not call +FORM-DESCRIPTION-FORM before it has called INNER-FORM." + (ert--expand-should-1 + whole form + (lambda (inner-form form-description-form value-var) + (let ((form-description (gensym "form-description-"))) + `(let (,form-description) + ,(funcall inner-expander + `(unwind-protect + ,inner-form + (setq ,form-description ,form-description-form) + (ert--signal-should-execution ,form-description)) + `,form-description + value-var)))))) + +(cl-defmacro should (form) + "Evaluate FORM. If it returns nil, abort the current test as failed. + +Returns the value of FORM." + (declare (debug t)) + (ert--expand-should `(should ,form) form + (lambda (inner-form form-description-form _value-var) + `(unless ,inner-form + (ert-fail ,form-description-form))))) + +(cl-defmacro should-not (form) + "Evaluate FORM. If it returns non-nil, abort the current test as failed. + +Returns nil." + (declare (debug t)) + (ert--expand-should `(should-not ,form) form + (lambda (inner-form form-description-form _value-var) + `(unless (not ,inner-form) + (ert-fail ,form-description-form))))) + +(defun ert--should-error-handle-error (form-description-fn + condition type exclude-subtypes) + "Helper function for `should-error'. + +Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES, +and aborts the current test as failed if it doesn't." + (let ((signaled-conditions (get (car condition) 'error-conditions)) + (handled-conditions (pcase-exhaustive type + ((pred listp) type) + ((pred symbolp) (list type))))) + (cl-assert signaled-conditions) + (unless (cl-intersection signaled-conditions handled-conditions) + (ert-fail (append + (funcall form-description-fn) + (list + :condition condition + :fail-reason (concat "the error signaled did not" + " have the expected type"))))) + (when exclude-subtypes + (unless (member (car condition) handled-conditions) + (ert-fail (append + (funcall form-description-fn) + (list + :condition condition + :fail-reason (concat "the error signaled was a subtype" + " of the expected type")))))))) + +;; FIXME: The expansion will evaluate the keyword args (if any) in +;; nonstandard order. +(cl-defmacro should-error (form &rest keys &key type exclude-subtypes) + "Evaluate FORM and check that it signals an error. + +The error signaled needs to match TYPE. TYPE should be a list +of condition names. (It can also be a non-nil symbol, which is +equivalent to a singleton list containing that symbol.) If +EXCLUDE-SUBTYPES is nil, the error matches TYPE if one of its +condition names is an element of TYPE. If EXCLUDE-SUBTYPES is +non-nil, the error matches TYPE if it is an element of TYPE. + +If the error matches, returns (ERROR-SYMBOL . DATA) from the +error. If not, or if no error was signaled, abort the test as +failed." + (declare (debug t)) + (unless type (setq type ''error)) + (ert--expand-should + `(should-error ,form ,@keys) + form + (lambda (inner-form form-description-form value-var) + (let ((errorp (gensym "errorp")) + (form-description-fn (gensym "form-description-fn-"))) + `(let ((,errorp nil) + (,form-description-fn (lambda () ,form-description-form))) + (condition-case -condition- + ,inner-form + ;; We can't use ,type here because we want to evaluate it. + (error + (setq ,errorp t) + (ert--should-error-handle-error ,form-description-fn + -condition- + ,type ,exclude-subtypes) + (setq ,value-var -condition-))) + (unless ,errorp + (ert-fail (append + (funcall ,form-description-fn) + (list + :fail-reason "did not signal an error"))))))))) + +(cl-defmacro ert--skip-when (form) + "Evaluate FORM. If it returns t, skip the current test. +Errors during evaluation are caught and handled like t." + (declare (debug t)) + (ert--expand-should `(skip-when ,form) form + (lambda (inner-form form-description-form _value-var) + `(when (condition-case nil ,inner-form (t t)) + (ert-skip ,form-description-form))))) + +(cl-defmacro ert--skip-unless (form) + "Evaluate FORM. If it returns nil, skip the current test. +Errors during evaluation are caught and handled like nil." + (declare (debug t)) + (ert--expand-should `(skip-unless ,form) form + (lambda (inner-form form-description-form _value-var) + `(unless (ignore-errors ,inner-form) + (ert-skip ,form-description-form))))) + + +;;; Explanation of `should' failures. + +;; TODO(ohler): Rework explanations so that they are displayed in a +;; similar way to `ert-info' messages; in particular, allow text +;; buttons in explanations that give more detail or open an ediff +;; buffer. Perhaps explanations should be reported through `ert-info' +;; rather than as part of the condition. + +(defun ert--explain-format-atom (x) + "Format the atom X for `ert--explain-equal'." + (pcase x + ((pred characterp) (list x (format "#x%x" x) (format "?%c" x))) + ((pred integerp) (list x (format "#x%x" x))) + (_ x))) + +(defun ert--explain-equal-rec (a b) + "Return a programmer-readable explanation of why A and B are not `equal'. +Return nil if they are." + (if (not (eq (type-of a) (type-of b))) + `(different-types ,a ,b) + (pcase a + ((pred consp) + (let ((a-length (proper-list-p a)) + (b-length (proper-list-p b))) + (if (not (eq (not a-length) (not b-length))) + `(one-list-proper-one-improper ,a ,b) + (if a-length + (if (/= a-length b-length) + `(proper-lists-of-different-length ,a-length ,b-length + ,a ,b + first-mismatch-at + ,(cl-mismatch a b :test 'equal)) + (cl-loop for i from 0 + for ai in a + for bi in b + for xi = (ert--explain-equal-rec ai bi) + do (when xi (cl-return `(list-elt ,i ,xi))) + finally (cl-assert (equal a b) t))) + (let ((car-x (ert--explain-equal-rec (car a) (car b)))) + (if car-x + `(car ,car-x) + (let ((cdr-x (ert--explain-equal-rec (cdr a) (cdr b)))) + (if cdr-x + `(cdr ,cdr-x) + (cl-assert (equal a b) t) + nil)))))))) + ((pred cl-struct-p) + (cl-loop for slot in (cl-struct-slot-info (type-of a)) + for ai across a + for bi across b + for xf = (ert--explain-equal-rec ai bi) + do (when xf (cl-return `(struct-field ,(car slot) ,xf))) + finally (cl-assert (equal a b) t))) + ((or (pred arrayp) (pred recordp)) + ;; For mixed unibyte/multibyte string comparisons, make both multibyte. + (when (and (stringp a) + (xor (multibyte-string-p a) (multibyte-string-p b))) + (setq a (string-to-multibyte a)) + (setq b (string-to-multibyte b))) + (if (/= (length a) (length b)) + `(arrays-of-different-length ,(length a) ,(length b) + ,a ,b + ,@(unless (char-table-p a) + `(first-mismatch-at + ,(cl-mismatch a b :test 'equal)))) + (cl-loop for i from 0 + for ai across a + for bi across b + for xi = (ert--explain-equal-rec ai bi) + do (when xi (cl-return `(array-elt ,i ,xi))) + finally (cl-assert (equal a b) t)))) + (_ + (if (not (equal a b)) + (if (and (symbolp a) (symbolp b) (string= a b)) + `(different-symbols-with-the-same-name ,a ,b) + `(different-atoms ,(ert--explain-format-atom a) + ,(ert--explain-format-atom b))) + nil))))) + +(defun ert--explain-equal (a b) + "Explainer function for `equal'." + ;; Do a quick comparison in C to avoid running our expensive + ;; comparison when possible. + (if (equal a b) + nil + (ert--explain-equal-rec a b))) +(put 'equal 'ert-explainer 'ert--explain-equal) + +(defun ert--explain-string-equal (a b) + "Explainer function for `string-equal'." + ;; Convert if they are symbols. + (if (string-equal a b) + nil + (let ((as (if (symbolp a) (symbol-name a) a)) + (bs (if (symbolp b) (symbol-name b) b))) + (ert--explain-equal-rec as bs)))) +(put 'string-equal 'ert-explainer 'ert--explain-string-equal) + +(defun ert--significant-plist-keys (plist) + "Return the keys of PLIST that have non-null values, in order." + (cl-assert (zerop (mod (length plist) 2)) t) + (cl-loop for (key value . rest) on plist by #'cddr + unless (or (null value) (memq key accu)) collect key into accu + finally (cl-return accu))) + +(defun ert--plist-difference-explanation (a b) + "Return a programmer-readable explanation of why A and B are different plists. + +Returns nil if they are equivalent, i.e., have the same value for +each key, where absent values are treated as nil. The order of +key/value pairs in each list does not matter." + (cl-assert (zerop (mod (length a) 2)) t) + (cl-assert (zerop (mod (length b) 2)) t) + ;; Normalizing the plists would be another way to do this but it + ;; requires a total ordering on all lisp objects (since any object + ;; is valid as a text property key). Perhaps defining such an + ;; ordering is useful in other contexts, too, but it's a lot of + ;; work, so let's punt on it for now. + (let* ((keys-a (ert--significant-plist-keys a)) + (keys-b (ert--significant-plist-keys b)) + (keys-in-a-not-in-b (cl-set-difference keys-a keys-b :test 'eq)) + (keys-in-b-not-in-a (cl-set-difference keys-b keys-a :test 'eq))) + (cl-flet ((explain-with-key (key) + (let ((value-a (plist-get a key)) + (value-b (plist-get b key))) + (cl-assert (not (equal value-a value-b)) t) + `(different-properties-for-key + ,key ,(ert--explain-equal-including-properties value-a + value-b))))) + (cond (keys-in-a-not-in-b + (explain-with-key (car keys-in-a-not-in-b))) + (keys-in-b-not-in-a + (explain-with-key (car keys-in-b-not-in-a))) + (t + (cl-loop for key in keys-a + when (not (equal (plist-get a key) (plist-get b key))) + return (explain-with-key key))))))) + +(defun ert--abbreviate-string (s len suffixp) + "Shorten string S to at most LEN chars. + +If SUFFIXP is non-nil, returns a suffix of S, otherwise a prefix." + (let ((n (length s))) + (cond ((< n len) + s) + (suffixp + (substring s (- n len))) + (t + (substring s 0 len))))) + +(defun ert--explain-equal-including-properties-rec (a b) + "Return explanation of why A and B are not `equal-including-properties'. +Return nil if they are." + (if (not (equal a b)) + (ert--explain-equal a b) + (cl-assert (stringp a) t) + (cl-assert (stringp b) t) + (cl-assert (eql (length a) (length b)) t) + (cl-loop for i from 0 to (length a) + for props-a = (text-properties-at i a) + for props-b = (text-properties-at i b) + for difference = (ert--plist-difference-explanation + props-a props-b) + do (when difference + (cl-return `(char ,i ,(substring-no-properties a i (1+ i)) + ,difference + context-before + ,(ert--abbreviate-string + (substring-no-properties a 0 i) + 10 t) + context-after + ,(ert--abbreviate-string + (substring-no-properties a (1+ i)) + 10 nil)))) + finally (cl-assert (equal-including-properties a b) t)))) + +(defun ert--explain-equal-including-properties (a b) + "Explainer function for `equal-including-properties'." + ;; Do a quick comparison in C to avoid running our expensive + ;; comparison when possible. + (if (equal-including-properties a b) + nil + (ert--explain-equal-including-properties-rec a b))) +(put 'equal-including-properties 'ert-explainer + 'ert--explain-equal-including-properties) + +;;; Implementation of `ert-info'. + +;; TODO(ohler): The name `info' clashes with +;; `ert--test-execution-info'. One or both should be renamed. +(defvar ert--infos '() + "The stack of `ert-info' infos that currently apply. + +Bound dynamically. This is a list of (PREFIX . MESSAGE) pairs.") + +(cl-defmacro ert-info ((message-form &key ((:prefix prefix-form) "Info: ")) + &body body) + "Evaluate MESSAGE-FORM and BODY, and report the message if BODY fails. + +To be used within ERT tests. MESSAGE-FORM should evaluate to a +string that will be displayed together with the test result if +the test fails. MESSAGE-FORM can also evaluate to a function; in +this case, it will be called when displaying the info. + +PREFIX-FORM should evaluate to a string as well and is displayed +in front of the value of MESSAGE-FORM." + (declare (debug ((form &rest [sexp form]) body)) + (indent 1)) + `(let ((ert--infos (cons (cons ,prefix-form ,message-form) ert--infos))) + ,@body)) + + +;;; Facilities for running a single test. + +(defvar ert-debug-on-error nil + "Non-nil means enter debugger when a test fails or terminates with an error.") + +;; The data structures that represent the result of running a test. +(cl-defstruct ert-test-result + (messages nil) + (should-forms nil) + (duration 0) + ) +(cl-defstruct (ert-test-passed (:include ert-test-result))) +(cl-defstruct (ert-test-result-with-condition (:include ert-test-result)) + (condition (cl-assert nil)) + (backtrace (cl-assert nil)) + (infos (cl-assert nil))) +(cl-defstruct (ert-test-quit (:include ert-test-result-with-condition))) +(cl-defstruct (ert-test-failed (:include ert-test-result-with-condition))) +(cl-defstruct (ert-test-skipped (:include ert-test-result-with-condition))) +(cl-defstruct (ert-test-aborted-with-non-local-exit + (:include ert-test-result))) + +;; A container for the state of the execution of a single test and +;; environment data needed during its execution. +(cl-defstruct ert--test-execution-info + (test (cl-assert nil)) + (result (cl-assert nil)) + ;; A thunk that may be called when RESULT has been set to its final + ;; value and test execution should be terminated. Should not + ;; return. + (exit-continuation (cl-assert nil)) + ;; The binding of `ert-debug-on-error' that is in effect for the + ;; execution of the current test. We store it to avoid being + ;; affected by any new bindings the test itself may establish. (I + ;; don't remember whether this feature is important.) + ert-debug-on-error) + +(defun ert--run-test-debugger (info condition debugfun) + "Error handler used during the test run. + +This function records failures and errors and either terminates +the test silently or calls the interactive debugger, as +appropriate. + +INFO is the `ert--test-execution-info' corresponding to this test run. +ERR is the error object." + (let* ((type (cl-case (car condition) + ((quit) 'quit) + ((ert-test-skipped) 'skipped) + (otherwise 'failed))) + ;; 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-at-point-debugging-errors', + ;; (i.e., when running interactively) but having the + ;; backtrace ready for printing is important for batch + ;; use. + ;; + ;; Grab the frames above ourselves. + (backtrace (cdr (backtrace-get-frames debugfun))) + (infos (reverse ert--infos))) + (setf (ert--test-execution-info-result info) + (cl-ecase type + (quit + (make-ert-test-quit :condition condition + :backtrace backtrace + :infos infos)) + (skipped + (make-ert-test-skipped :condition condition + :backtrace backtrace + :infos infos)) + (failed + (make-ert-test-failed :condition condition + :backtrace backtrace + :infos infos)))) + ;; FIXME: We should probably implement more fine-grained + ;; control a la non-t `debug-on-error' here. + (cond + ((ert--test-execution-info-ert-debug-on-error info) + ;; The `debugfun' arg tells `debug' which backtrace frame starts + ;; the "entering the debugger" code so it can hide those frames + ;; from the backtrace. + (funcall debugger 'error condition :backtrace-base debugfun)) + (t)) + (funcall (ert--test-execution-info-exit-continuation info)))) + +(defun ert--run-test-internal (test-execution-info) + "Low-level function to run a test according to TEST-EXECUTION-INFO. + +This mainly sets up debugger-related bindings." + (setf (ert--test-execution-info-ert-debug-on-error test-execution-info) + ert-debug-on-error) + (catch 'ert--pass + ;; For now, each test gets its own temp buffer and its own + ;; window excursion, just to be safe. If this turns out to be + ;; too expensive, we can remove it. + (with-temp-buffer + (save-window-excursion + (let ((lexical-binding t) ;;FIXME: Why? + (ert--infos '())) + (letrec ((debugfun (lambda (err) + (ert--run-test-debugger test-execution-info + err debugfun)))) + (handler-bind (((error quit) debugfun)) + (funcall (ert-test-body (ert--test-execution-info-test + test-execution-info)))))))) + (ert-pass)) + (setf (ert--test-execution-info-result test-execution-info) + (make-ert-test-passed)) + nil) + +(defun ert--force-message-log-buffer-truncation () + "Immediately truncate *Messages* buffer according to `message-log-max'. + +This can be useful after reducing the value of `message-log-max'." + (with-current-buffer (messages-buffer) + ;; This is a reimplementation of this part of message_dolog() in xdisp.c: + ;; if (FIXNATP (Vmessage_log_max)) + ;; { + ;; scan_newline (Z, Z_BYTE, BEG, BEG_BYTE, + ;; -XFIXNAT (Vmessage_log_max) - 1, false); + ;; del_range_both (BEG, BEG_BYTE, PT, PT_BYTE, false); + ;; } + (when (natnump message-log-max) + (let ((begin (point-min)) + (end (save-excursion + (goto-char (point-max)) + (forward-line (- message-log-max)) + (point))) + (inhibit-read-only t)) + (delete-region begin end))))) + +(defvar ert--running-tests nil + "List of tests that are currently in execution. + +This list is empty while no test is running, has one element +while a test is running, two elements while a test run from +inside a test is running, etc. The list is in order of nesting, +innermost test first. + +The elements are of type `ert-test'.") + +(defun ert-run-test (ert-test) + "Run ERT-TEST. + +Returns the result and stores it in ERT-TEST's `most-recent-result' slot." + (setf (ert-test-most-recent-result ert-test) nil) + (cl-block error + (let ((begin-marker + (with-current-buffer (messages-buffer) + (point-max-marker)))) + (unwind-protect + (let ((info (make-ert--test-execution-info + :test ert-test + :result + (make-ert-test-aborted-with-non-local-exit) + :exit-continuation (lambda () + (cl-return-from error nil)))) + (should-form-accu (list))) + (unwind-protect + (let ((ert--should-execution-observer + (lambda (form-description) + (push form-description should-form-accu))) + (message-log-max t) + (ert--running-tests (cons ert-test ert--running-tests))) + (ert--run-test-internal info)) + (let ((result (ert--test-execution-info-result info))) + (setf (ert-test-result-messages result) + (with-current-buffer (messages-buffer) + (buffer-substring begin-marker (point-max)))) + (ert--force-message-log-buffer-truncation) + (setq should-form-accu (nreverse should-form-accu)) + (setf (ert-test-result-should-forms result) + should-form-accu) + (setf (ert-test-most-recent-result ert-test) result)))) + (set-marker begin-marker nil)))) + (ert-test-most-recent-result ert-test)) + +(defun ert-running-test () + "Return the top-level test currently executing." + (car (last ert--running-tests))) + + +;;; Test selectors. + +(defun ert-test-result-type-p (result result-type) + "Return non-nil if RESULT matches type RESULT-TYPE. + +Valid result types: + +nil -- Never matches. +t -- Always matches. +:failed, :passed, :skipped -- Matches corresponding results. +\(and TYPES...) -- Matches if all TYPES match. +\(or TYPES...) -- Matches if some TYPES match. +\(not TYPE) -- Matches if TYPE does not match. +\(satisfies PREDICATE) -- Matches if PREDICATE returns true when called with + RESULT." + ;; It would be easy to add `member' and `eql' types etc., but I + ;; haven't bothered yet. + (pcase-exhaustive result-type + ('nil nil) + ('t t) + (:failed (ert-test-failed-p result)) + (:passed (ert-test-passed-p result)) + (:skipped (ert-test-skipped-p result)) + (`(,operator . ,operands) + (cl-ecase operator + (and + (cl-case (length operands) + (0 t) + (t + (and (ert-test-result-type-p result (car operands)) + (ert-test-result-type-p result `(and ,@(cdr operands))))))) + (or + (cl-case (length operands) + (0 nil) + (t + (or (ert-test-result-type-p result (car operands)) + (ert-test-result-type-p result `(or ,@(cdr operands))))))) + (not + (cl-assert (eql (length operands) 1)) + (not (ert-test-result-type-p result (car operands)))) + (satisfies + (cl-assert (eql (length operands) 1)) + (funcall (car operands) result)))))) + +(defun ert-test-result-expected-p (test result) + "Return non-nil if TEST's expected result type matches RESULT." + (or + (ert-test-result-type-p result :skipped) + (ert-test-result-type-p result (ert-test-expected-result-type test)))) + +(defun ert-select-tests (selector universe) + "Return a list of tests that match SELECTOR. + +UNIVERSE specifies the set of tests to select from; it should be a list +of tests, or t, which refers to all tests named by symbols in `obarray'. + +Valid SELECTORs: + +nil -- Selects the empty set. +t -- Selects all of UNIVERSE. If UNIVERSE is t, selects all tests. +:new -- Selects all tests that have not been run yet. +:failed, :passed -- Select tests according to their most recent result. +:expected, :unexpected -- Select tests according to their most recent result. +a string -- A regular expression selecting all tests with matching names. +a test -- (i.e., an object of the `ert-test' data-type) Selects that test. +a symbol -- Selects the test named by the symbol, signals an + `ert-test-unbound' error if no such test. +\(member TESTS...) -- Selects the elements of TESTS, a list of tests + or symbols naming tests. +\(eql TEST) -- Selects TEST, a test or a symbol naming a test. +\(and SELECTORS...) -- Selects the tests that match all SELECTORS. +\(or SELECTORS...) -- Selects the tests that match any of the SELECTORS. +\(not SELECTOR) -- Selects all tests that do not match SELECTOR. +\(tag TAG) -- Selects all tests that have TAG on their tags list. + A tag is an arbitrary label you can apply when you define a test. +\(satisfies PREDICATE) -- Selects all tests that satisfy PREDICATE. + PREDICATE is a function that takes an ert-test object as argument, + and returns non-nil if it is selected. + +Only selectors that require a superset of tests, such +as (satisfies ...), strings, :new, etc. make use of UNIVERSE. +Selectors that do not, such as (member ...), just return the +set implied by them without checking whether it is really +contained in UNIVERSE." + ;; This code needs to match the cases in + ;; `ert--insert-human-readable-selector'. + (pcase-exhaustive selector + ('nil nil) + ('t (pcase-exhaustive universe + ((pred listp) universe) + (`t (ert-select-tests "" universe)))) + (:new (ert-select-tests + `(satisfies ,(lambda (test) + (null (ert-test-most-recent-result test)))) + universe)) + (:failed (ert-select-tests + `(satisfies ,(lambda (test) + (ert-test-result-type-p + (ert-test-most-recent-result test) + ':failed))) + universe)) + (:passed (ert-select-tests + `(satisfies ,(lambda (test) + (ert-test-result-type-p + (ert-test-most-recent-result test) + ':passed))) + universe)) + (:expected (ert-select-tests + `(satisfies + ,(lambda (test) + (ert-test-result-expected-p + test + (ert-test-most-recent-result test)))) + universe)) + (:unexpected (ert-select-tests '(not :expected) universe)) + ((pred stringp) + (pcase-exhaustive universe + (`t (mapcar #'ert-get-test + (apropos-internal selector #'ert-test-boundp))) + ((pred listp) + (cl-remove-if-not (lambda (test) + (and (ert-test-name test) + (string-match selector + (symbol-name + (ert-test-name test))))) + universe)))) + ((pred ert-test-p) (list selector)) + ((pred symbolp) + (unless (ert-test-boundp selector) + (signal 'ert-test-unbound (list selector))) + (list (ert-get-test selector))) + (`(member . ,operands) + (mapcar (lambda (purported-test) + (pcase-exhaustive purported-test + ((pred symbolp) + (unless (ert-test-boundp purported-test) + (signal 'ert-test-unbound + (list purported-test))) + (ert-get-test purported-test)) + ((pred ert-test-p) purported-test))) + operands)) + (`(eql ,operand) + (ert-select-tests `(member ,operand) universe)) + ;; Do these definitions of AND, NOT and OR satisfy de Morgan's + ;; laws? Should they? + (`(and) + (ert-select-tests 't universe)) + (`(and ,first . ,rest) + (ert-select-tests `(and ,@rest) + (ert-select-tests first universe))) + (`(not ,operand) + (let ((all-tests (ert-select-tests 't universe))) + (cl-set-difference all-tests + (ert-select-tests operand all-tests)))) + (`(or) + (ert-select-tests 'nil universe)) + (`(or ,first . ,rest) + (cl-union (ert-select-tests first universe) + (ert-select-tests `(or ,@rest) universe))) + (`(tag ,tag) + (ert-select-tests `(satisfies + ,(lambda (test) + (member tag (ert-test-tags test)))) + universe)) + (`(satisfies ,predicate) + (cl-remove-if-not predicate + (ert-select-tests 't universe))))) + +(define-error 'ert-test-unbound "ERT test is unbound") + +(defun ert--insert-human-readable-selector (selector) + "Insert a human-readable presentation of SELECTOR into the current buffer." + ;; This is needed to avoid printing the (huge) contents of the + ;; `backtrace' slot of the result objects in the + ;; `most-recent-result' slots of test case objects in (eql ...) or + ;; (member ...) selectors. + (cl-labels ((rec (selector) + ;; This code needs to match the cases in + ;; `ert-select-tests'. + (pcase-exhaustive selector + ((or + ;; 'nil 't :new :failed :passed :expected :unexpected + (pred stringp) + (pred symbolp)) + selector) + ((pred ert-test-p) + (if (ert-test-name selector) + (make-symbol (format "<%S>" (ert-test-name selector))) + (make-symbol ""))) + (`(,operator . ,operands) + (pcase operator + ((or 'member 'eql 'and 'not 'or) + `(,operator ,@(mapcar #'rec operands))) + ((or 'tag 'satisfies) + selector)))))) + (insert (format "%S" (rec selector))))) + + +;;; Facilities for running a whole set of tests. + +;; The data structure that contains the set of tests being executed +;; during one particular test run, their results, the state of the +;; execution, and some statistics. +;; +;; The data about results and expected results of tests may seem +;; redundant here, since the test objects also carry such information. +;; However, the information in the test objects may be more recent, it +;; may correspond to a different test run. We need the information +;; that corresponds to this run in order to be able to update the +;; statistics correctly when a test is re-run interactively and has a +;; different result than before. +(cl-defstruct ert--stats + (selector (cl-assert nil)) + ;; The tests, in order. + (tests (cl-assert nil) :type vector) + ;; A map of test names (or the test objects themselves for unnamed + ;; tests) to indices into the `tests' vector. + (test-map (cl-assert nil) :type hash-table) + ;; The results of the tests during this run, in order. + (test-results (cl-assert nil) :type vector) + ;; The start times of the tests, in order, as reported by + ;; `current-time'. + (test-start-times (cl-assert nil) :type vector) + ;; The end times of the tests, in order, as reported by + ;; `current-time'. + (test-end-times (cl-assert nil) :type vector) + (passed-expected 0) + (passed-unexpected 0) + (failed-expected 0) + (failed-unexpected 0) + (skipped 0) + (start-time nil) + (end-time nil) + (aborted-p nil) + (current-test nil) + ;; The time at or after which the next redisplay should occur, as a + ;; float. + (next-redisplay 0.0)) + +(defun ert-stats-completed-expected (stats) + "Return the number of tests in STATS that had expected results." + (+ (ert--stats-passed-expected stats) + (ert--stats-failed-expected stats))) + +(defun ert-stats-completed-unexpected (stats) + "Return the number of tests in STATS that had unexpected results." + (+ (ert--stats-passed-unexpected stats) + (ert--stats-failed-unexpected stats))) + +(defun ert-stats-skipped (stats) + "Number of tests in STATS that have skipped." + (ert--stats-skipped stats)) + +(defun ert-stats-completed (stats) + "Number of tests in STATS that have run so far." + (+ (ert-stats-completed-expected stats) + (ert-stats-completed-unexpected stats) + (ert-stats-skipped stats))) + +(defun ert-stats-total (stats) + "Number of tests in STATS, regardless of whether they have run yet." + (length (ert--stats-tests stats))) + +;; The stats object of the current run, dynamically bound. This is +;; used for the mode line progress indicator. +(defvar ert--current-run-stats nil) + +(defun ert--stats-test-key (test) + "Return the key used for TEST in the test map of ert--stats objects. + +Returns the name of TEST if it has one, or TEST itself otherwise." + (or (ert-test-name test) test)) + +(defun ert--stats-set-test-and-result (stats pos test result) + "Change STATS by replacing the test at position POS with TEST and RESULT. + +Also changes the counters in STATS to match." + (let* ((tests (ert--stats-tests stats)) + (results (ert--stats-test-results stats)) + (old-test (aref tests pos)) + (map (ert--stats-test-map stats))) + (cl-flet ((update (d) + (if (ert-test-result-expected-p (aref tests pos) + (aref results pos)) + (cl-etypecase (aref results pos) + (ert-test-passed + (cl-incf (ert--stats-passed-expected stats) d)) + (ert-test-failed + (cl-incf (ert--stats-failed-expected stats) d)) + (ert-test-skipped + (cl-incf (ert--stats-skipped stats) d)) + (null) + (ert-test-aborted-with-non-local-exit) + (ert-test-quit)) + (cl-etypecase (aref results pos) + (ert-test-passed + (cl-incf (ert--stats-passed-unexpected stats) d)) + (ert-test-failed + (cl-incf (ert--stats-failed-unexpected stats) d)) + (ert-test-skipped + (cl-incf (ert--stats-skipped stats) d)) + (null) + (ert-test-aborted-with-non-local-exit) + (ert-test-quit))))) + ;; Adjust counters to remove the result that is currently in stats. + (update -1) + ;; Put new test and result into stats. + (setf (aref tests pos) test + (aref results pos) result) + (remhash (ert--stats-test-key old-test) map) + (setf (gethash (ert--stats-test-key test) map) pos) + ;; Adjust counters to match new result. + (update +1) + nil))) + +(defun ert--make-stats (tests selector) + "Create a new `ert--stats' object for running TESTS. + +SELECTOR is the selector that was used to select TESTS." + (setq tests (cl-coerce tests 'vector)) + (let ((map (make-hash-table :size (length tests)))) + (cl-loop for i from 0 + for test across tests + for key = (ert--stats-test-key test) do + (cl-assert (not (gethash key map))) + (setf (gethash key map) i)) + (make-ert--stats :selector selector + :tests tests + :test-map map + :test-results (make-vector (length tests) nil) + :test-start-times (make-vector (length tests) nil) + :test-end-times (make-vector (length tests) nil)))) + +(defun ert-run-or-rerun-test (stats test listener) + ;; checkdoc-order: nil + "Run the single test TEST and record the result using STATS and LISTENER." + (let ((ert--current-run-stats stats) + (pos (ert--stats-test-pos stats test))) + (ert--stats-set-test-and-result stats pos test nil) + ;; Call listener after setting/before resetting + ;; (ert--stats-current-test stats); the listener might refresh the + ;; mode line display, and if the value is not set yet/any more + ;; during this refresh, the mode line will flicker unnecessarily. + (setf (ert--stats-current-test stats) test) + (funcall listener 'test-started stats test) + (setf (ert-test-most-recent-result test) nil) + (setf (aref (ert--stats-test-start-times stats) pos) (current-time)) + (unwind-protect + (ert-run-test test) + (setf (aref (ert--stats-test-end-times stats) pos) (current-time)) + (let ((result (ert-test-most-recent-result test))) + (setf (ert-test-result-duration result) + (float-time + (time-subtract + (aref (ert--stats-test-end-times stats) pos) + (aref (ert--stats-test-start-times stats) pos)))) + (ert--stats-set-test-and-result stats pos test result) + (funcall listener 'test-ended stats test result)) + (setf (ert--stats-current-test stats) nil)))) + +(defun ert-run-tests (selector listener &optional interactively) + "Run the tests specified by SELECTOR, sending progress updates to LISTENER." + (let* ((tests (ert-select-tests selector t)) + (stats (ert--make-stats tests selector))) + (setf (ert--stats-start-time stats) (current-time)) + (funcall listener 'run-started stats) + (let ((abortedp t)) + (unwind-protect + (let ((ert--current-run-stats stats)) + (force-mode-line-update) + (unwind-protect + (cl-loop for test in tests do + (ert-run-or-rerun-test stats test listener) + (when (and interactively + (ert-test-quit-p + (ert-test-most-recent-result test)) + (y-or-n-p "Abort testing? ")) + (cl-return)) + finally (setq abortedp nil)) + (setf (ert--stats-aborted-p stats) abortedp) + (setf (ert--stats-end-time stats) (current-time)) + (funcall listener 'run-ended stats abortedp))) + (force-mode-line-update)) + stats))) + +(defun ert--stats-test-pos (stats test) + ;; checkdoc-order: nil + "Return the position (index) of TEST in the run represented by STATS." + (gethash (ert--stats-test-key test) (ert--stats-test-map stats))) + + +;;; Formatting functions shared across UIs. + +(defun ert--format-time-iso8601 (time) + "Format TIME in the variant of ISO 8601 used for timestamps in ERT." + (format-time-string "%Y-%m-%d %T%z" time)) + +(defun ert-char-for-test-result (result expectedp) + "Return a character that represents the test result RESULT. + +EXPECTEDP specifies whether the result was expected." + (let ((s (cl-etypecase result + (ert-test-passed ".P") + (ert-test-failed "fF") + (ert-test-skipped "sS") + (null "--") + (ert-test-aborted-with-non-local-exit "aA") + (ert-test-quit "qQ")))) + (elt s (if expectedp 0 1)))) + +(defun ert-string-for-test-result (result expectedp) + "Return a string that represents the test result RESULT. + +EXPECTEDP specifies whether the result was expected." + (let ((s (cl-etypecase result + (ert-test-passed '("passed" "PASSED")) + (ert-test-failed '("failed" "FAILED")) + (ert-test-skipped '("skipped" "SKIPPED")) + (null '("unknown" "UNKNOWN")) + (ert-test-aborted-with-non-local-exit '("aborted" "ABORTED")) + (ert-test-quit '("quit" "QUIT"))))) + (elt s (if expectedp 0 1)))) + +(defun ert-reason-for-test-result (result) + "Return the reason given for RESULT, as a string. + +The reason is the argument given when invoking `ert-fail' or `ert-skip'. +It is output using `prin1' prefixed by two spaces. + +If no reason was given, or for a successful RESULT, return the +empty string." + (let ((reason + (and + (ert-test-result-with-condition-p result) + (cadr (ert-test-result-with-condition-condition result)))) + (print-escape-newlines t) + (print-level 6) + (print-length 10)) + (if reason (format " %S" reason) ""))) + +(defun ert--pp-with-indentation-and-newline (object) + "Pretty-print OBJECT, indenting it to the current column of point. +Ensures a final newline is inserted." + (let ((pp-escape-newlines t) + (print-escape-control-characters t)) + (pp object (current-buffer)))) + +(defun ert--insert-infos (result) + "Insert `ert-info' infos from RESULT into current buffer. + +RESULT must be an `ert-test-result-with-condition'." + (cl-check-type result ert-test-result-with-condition) + (dolist (info (ert-test-result-with-condition-infos result)) + (cl-destructuring-bind (prefix . message) info + (let ((begin (point)) + (indentation (make-string (+ (length prefix) 4) ?\s)) + (end nil)) + (unwind-protect + (progn + (when (functionp message) + (setq message (funcall message))) + (insert message "\n") + (setq end (point-marker)) + (goto-char begin) + (insert " " prefix) + (forward-line 1) + (while (< (point) end) + (insert indentation) + (forward-line 1))) + (when end (set-marker end nil))))))) + + +;;; Running tests in batch mode. + +(defvar ert-quiet nil + "Non-nil makes ERT only print important information in batch mode.") + +(defun ert-test-location (test) + "Return a string description the source location of TEST." + (when-let ((loc + (ignore-errors + (find-function-search-for-symbol + (ert-test-name test) 'ert-deftest (ert-test-file-name test))))) + (let* ((buffer (car loc)) + (point (cdr loc)) + (file (file-relative-name (buffer-file-name buffer))) + (line (with-current-buffer buffer + (line-number-at-pos point)))) + (format "at %s:%s" file line)))) + +(defvar ert-batch-backtrace-right-margin 70 + "The maximum line length for printing backtraces in `ert-run-tests-batch'.") + +;;;###autoload +(defun ert-run-tests-batch (&optional selector) + "Run the tests specified by SELECTOR, printing results to the terminal. + +SELECTOR selects which tests to run as described in `ert-select-tests' when +called with its second argument t, except if SELECTOR is nil, in which case +all tests rather than none will be run; this makes the command line + \"emacs -batch -l my-tests.el -f ert-run-tests-batch-and-exit\" useful. + +Returns the stats object." + (unless selector (setq selector 't)) + (ert-run-tests + selector + (lambda (event-type &rest event-args) + (cl-ecase event-type + (run-started + (unless ert-quiet + (cl-destructuring-bind (stats) event-args + (message "Running %s tests (%s, selector `%S')" + (length (ert--stats-tests stats)) + (ert--format-time-iso8601 (ert--stats-start-time stats)) + selector)))) + (run-ended + (cl-destructuring-bind (stats abortedp) event-args + (let ((unexpected (ert-stats-completed-unexpected stats)) + (skipped (ert-stats-skipped stats)) + (expected-failures (ert--stats-failed-expected stats))) + (message "\n%sRan %s tests, %s results as expected, %s unexpected%s (%s, %f sec)%s\n" + (if (not abortedp) + "" + "Aborted: ") + (ert-stats-total stats) + (ert-stats-completed-expected stats) + unexpected + (if (zerop skipped) + "" + (format ", %s skipped" skipped)) + (ert--format-time-iso8601 (ert--stats-end-time stats)) + (float-time + (time-subtract + (ert--stats-end-time stats) + (ert--stats-start-time stats))) + (if (zerop expected-failures) + "" + (format "\n%s expected failures" expected-failures))) + (unless (zerop unexpected) + (message "%s unexpected results:" unexpected) + (cl-loop for test across (ert--stats-tests stats) + for result = (ert-test-most-recent-result test) do + (when (not (ert-test-result-expected-p test result)) + (message "%9s %S%s" + (ert-string-for-test-result result nil) + (ert-test-name test) + (if (cl-plusp + (length (getenv "EMACS_TEST_VERBOSE"))) + (ert-reason-for-test-result result) + "")))) + (message "%s" "")) + (unless (zerop skipped) + (message "%s skipped results:" skipped) + (cl-loop for test across (ert--stats-tests stats) + for result = (ert-test-most-recent-result test) do + (when (ert-test-result-type-p result :skipped) + (message "%9s %S%s" + (ert-string-for-test-result result nil) + (ert-test-name test) + (if (cl-plusp + (length (getenv "EMACS_TEST_VERBOSE"))) + (ert-reason-for-test-result result) + "")))) + (message "%s" "")) + (when (getenv "EMACS_TEST_JUNIT_REPORT") + (ert-write-junit-test-report stats))))) + (test-started) + (test-ended + (cl-destructuring-bind (stats test result) event-args + (unless (ert-test-result-expected-p test result) + (cl-etypecase result + (ert-test-passed + (message "Test %S passed unexpectedly" (ert-test-name test))) + (ert-test-result-with-condition + (message "Test %S backtrace:" (ert-test-name test)) + (with-temp-buffer + (let ((backtrace-line-length + (if (eq ert-batch-backtrace-line-length t) + backtrace-line-length + ert-batch-backtrace-line-length)) + (print-level ert-batch-print-level) + (print-length ert-batch-print-length)) + (insert (backtrace-to-string + (ert-test-result-with-condition-backtrace result)))) + (if (not ert-batch-backtrace-right-margin) + (message "%s" + (buffer-substring-no-properties (point-min) + (point-max))) + (goto-char (point-min)) + (while (not (eobp)) + (let ((start (point)) + (end (line-end-position))) + (setq end (min end + (+ start + ert-batch-backtrace-right-margin))) + (message "%s" (buffer-substring-no-properties + start end))) + (forward-line 1)))) + (with-temp-buffer + (ert--insert-infos result) + (insert " ") + (let ((print-escape-newlines t) + (print-level ert-batch-print-level) + (print-length ert-batch-print-length)) + (ert--pp-with-indentation-and-newline + (ert-test-result-with-condition-condition result))) + (goto-char (1- (point-max))) + (cl-assert (looking-at "\n")) + (delete-char 1) + (message "Test %S condition:" (ert-test-name test)) + (message "%s" (buffer-string)))) + (ert-test-aborted-with-non-local-exit + (message "Test %S aborted with non-local exit" + (ert-test-name test))) + (ert-test-quit + (message "Quit during %S" (ert-test-name test))))) + (unless ert-quiet + (let* ((max (prin1-to-string (length (ert--stats-tests stats)))) + (format-string (concat "%9s %" + (prin1-to-string (length max)) + "s/" max " %S (%f sec)%s"))) + (message format-string + (ert-string-for-test-result result + (ert-test-result-expected-p + test result)) + (1+ (ert--stats-test-pos stats test)) + (ert-test-name test) + (ert-test-result-duration result) + (if (ert-test-result-expected-p test result) + "" + (concat " " (ert-test-location test)))))))))) + nil)) + +;;;###autoload +(defun ert-run-tests-batch-and-exit (&optional selector) + "Like `ert-run-tests-batch', but exits Emacs when done. + +The exit status will be 0 if all test results were as expected, 1 +on unexpected results, or 2 if the tool detected an error outside +of the tests (e.g. invalid SELECTOR or bug in the code that runs +the tests)." + (or noninteractive + (user-error "This function is only for use in batch mode")) + (let ((eln-dir (and (featurep 'native-compile) + (make-temp-file "test-nativecomp-cache-" t)))) + (when eln-dir + (startup-redirect-eln-cache eln-dir)) + ;; Better crash loudly than attempting to recover from undefined + ;; behavior. + (setq attempt-stack-overflow-recovery nil + attempt-orderly-shutdown-on-fatal-signal nil) + (unwind-protect + (let ((stats (ert-run-tests-batch selector))) + (when eln-dir + (ignore-errors + (delete-directory eln-dir t))) + (kill-emacs (if (zerop (ert-stats-completed-unexpected stats)) 0 1))) + (unwind-protect + (progn + (message "Error running tests") + (backtrace)) + (when eln-dir + (ignore-errors + (delete-directory eln-dir t))) + (kill-emacs 2))))) + +(defvar ert-load-file-name nil + "The name of the loaded ERT test file, a string. +Usually, it is not needed to be defined, but if different ERT +test packages depend on each other, it might be helpful.") + +(defun ert-write-junit-test-report (stats) + "Write a JUnit test report, generated from STATS." + ;; https://www.ibm.com/docs/en/developer-for-zos/14.1.0?topic=formats-junit-xml-format + ;; https://llg.cubic.org/docs/junit/ + (when-let ((symbol (car (apropos-internal "" #'ert-test-boundp))) + (test-file (symbol-file symbol 'ert--test)) + (test-report + (file-name-with-extension + (or ert-load-file-name test-file) "xml"))) + (with-temp-file test-report + (insert "\n") + (insert (format "\n" + (file-name-nondirectory test-report) + (ert-stats-total stats) + (if (ert--stats-aborted-p stats) 1 0) + (ert-stats-completed-unexpected stats) + (ert-stats-skipped stats) + (float-time + (time-subtract + (ert--stats-end-time stats) + (ert--stats-start-time stats))))) + (insert (format " \n" + (file-name-nondirectory test-report) + (ert-stats-total stats) + (if (ert--stats-aborted-p stats) 1 0) + (ert-stats-completed-unexpected stats) + (ert-stats-skipped stats) + (float-time + (time-subtract + (ert--stats-end-time stats) + (ert--stats-start-time stats))) + (ert--format-time-iso8601 (ert--stats-end-time stats)))) + ;; If the test has aborted, `ert--stats-selector' might return + ;; huge junk. Skip this. + (when (< (length (format "%s" (ert--stats-selector stats))) 1024) + (insert " \n" + (format " \n" + (xml-escape-string + (format "%s" (ert--stats-selector stats)) 'noerror)) + " \n")) + (cl-loop for test across (ert--stats-tests stats) + for result = (ert-test-most-recent-result test) do + (insert (format " \n") + (insert ">\n") + (cond + ((ert-test-skipped-p result) + (insert (format " \n" + (xml-escape-string + (string-trim + (ert-reason-for-test-result result)) + 'noerror) + (ert-string-for-test-result + result + (ert-test-result-expected-p + test result))) + (xml-escape-string + (string-trim + (ert-reason-for-test-result result)) + 'noerror) + "\n" + " \n")) + ((ert-test-aborted-with-non-local-exit-p result) + (insert (format " \n" + (file-name-nondirectory test-report) + (ert-string-for-test-result + result + (ert-test-result-expected-p + test result))) + (format "Test %s aborted with non-local exit\n" + (xml-escape-string + (symbol-name (ert-test-name test)) 'noerror)) + " \n")) + ((not (ert-test-result-type-p + result (ert-test-expected-result-type test))) + (insert (format " \n" + (xml-escape-string + (string-trim + (ert-reason-for-test-result result)) + 'noerror) + (ert-string-for-test-result + result + (ert-test-result-expected-p + test result))) + (xml-escape-string + (string-trim + (ert-reason-for-test-result result)) + 'noerror) + "\n" + " \n"))) + (unless (zerop (length (ert-test-result-messages result))) + (insert " \n" + (xml-escape-string + (ert-test-result-messages result) 'noerror) + " \n")) + (insert " \n"))) + (insert " \n") + (insert "\n")))) + +(defun ert-write-junit-test-summary-report (&rest logfiles) + "Write a JUnit summary test report, generated from LOGFILES." + (let ((report (file-name-with-extension + (getenv "EMACS_TEST_JUNIT_REPORT") "xml")) + (tests 0) (errors 0) (failures 0) (skipped 0) (time 0) (id 0)) + (with-temp-file report + (dolist (logfile logfiles) + (let ((test-report (file-name-with-extension logfile "xml"))) + (if (not (file-readable-p test-report)) + (let* ((logfile (file-name-with-extension logfile "log")) + (logfile-contents + (when (file-readable-p logfile) + (with-temp-buffer + (insert-file-contents-literally logfile) + (buffer-string))))) + (unless + ;; No defined tests, perhaps a helper file. + (and logfile-contents + (string-match-p "^Running 0 tests" logfile-contents)) + (insert (format " \n" + id test-report + (ert--format-time-iso8601 nil))) + (insert (format " \n" + (file-name-nondirectory test-report))) + (insert (format " \n" + (file-name-nondirectory test-report))) + (when logfile-contents + (insert (xml-escape-string logfile-contents 'noerror))) + (insert " \n" + " \n" + " \n") + (cl-incf errors 1) + (cl-incf id 1))) + + (insert-file-contents-literally test-report) + (when (looking-at-p + (regexp-quote "")) + (delete-region (point) (line-beginning-position 2))) + (when (looking-at + "") + (cl-incf tests (string-to-number (match-string 1))) + (cl-incf errors (string-to-number (match-string 2))) + (cl-incf failures (string-to-number (match-string 3))) + (cl-incf skipped (string-to-number (match-string 4))) + (cl-incf time (string-to-number (match-string 5))) + (delete-region (point) (line-beginning-position 2))) + (when (looking-at " ") + (delete-region (point) (line-beginning-position 2)))) + + (narrow-to-region (point-max) (point-max)))) + + (insert "\n") + (widen) + (goto-char (point-min)) + (insert "\n") + (insert (format "\n" + (file-name-nondirectory report) + tests errors failures skipped time))))) + +(defun ert-summarize-tests-batch-and-exit (&optional high) + "Summarize the results of testing. +Expects to be called in batch mode, with logfiles as command-line arguments. +The logfiles should have the `ert-run-tests-batch' format. When finished, +this exits Emacs, with status as per `ert-run-tests-batch-and-exit'. + +If HIGH is a natural number, the HIGH long lasting tests are summarized." + (or noninteractive + (user-error "This function is only for use in batch mode")) + (or (natnump high) (setq high 0)) + ;; Better crash loudly than attempting to recover from undefined + ;; behavior. + (setq attempt-stack-overflow-recovery nil + attempt-orderly-shutdown-on-fatal-signal nil) + (when (getenv "EMACS_TEST_JUNIT_REPORT") + (apply #'ert-write-junit-test-summary-report command-line-args-left)) + (let ((nlogs (length command-line-args-left)) + (ntests 0) (nrun 0) (nexpected 0) (nunexpected 0) (nskipped 0) + nnotrun logfile notests badtests unexpected skipped tests) + (with-temp-buffer + (while (setq logfile (pop command-line-args-left)) + (erase-buffer) + (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)))) + (if (not (re-search-forward "^\\(Aborted: \\)?\ +Ran \\([0-9]+\\) tests, \\([0-9]+\\) results as expected\ +\\(?:, \\([0-9]+\\) unexpected\\)?\ +\\(?:, \\([0-9]+\\) skipped\\)?" nil t)) + (push logfile badtests) + (if (match-string 1) (push logfile badtests)) + (setq nrun (+ nrun (string-to-number (match-string 2))) + nexpected (+ nexpected (string-to-number (match-string 3)))) + (when (match-string 4) + (let ((n (string-to-number (match-string 4)))) + (unless (zerop n) + (push logfile unexpected) + (setq nunexpected (+ nunexpected n))))) + (when (match-string 5) + (push logfile skipped) + (setq nskipped (+ nskipped + (string-to-number (match-string 5))))) + (unless (zerop high) + (goto-char (point-min)) + (while (< (point) (point-max)) + (if (looking-at "^\\s-+\\w+\\s-+[[:digit:]]+/[[:digit:]]+\\s-+\\S-+\\s-+(\\([.[:digit:]]+\\)\\s-+sec)$") + (push (cons (string-to-number (match-string 1)) + (match-string 0)) + tests)) + (forward-line))))))) + (setq nnotrun (- ntests nrun)) + (message "\nSUMMARY OF TEST RESULTS") + (message "-----------------------") + (message "Files examined: %d" nlogs) + (message "Ran %d tests%s, %d results as expected, %d unexpected, %d skipped" + nrun + (if (zerop nnotrun) "" (format ", %d failed to run" nnotrun)) + nexpected nunexpected nskipped) + (when notests + (message "%d files did not contain any tests:" (length notests)) + (mapc (lambda (l) (message " %s" l)) notests)) + (when badtests + (message "%d files did not finish:" (length badtests)) + (mapc (lambda (l) (message " %s" l)) badtests) + (if (or (getenv "EMACS_HYDRA_CI") (getenv "EMACS_EMBA_CI")) + (with-temp-buffer + (dolist (f badtests) + (erase-buffer) + (insert-file-contents f) + (message "Contents of unfinished file %s:" f) + (message "-----\n%s\n-----" (buffer-string)))))) + (when unexpected + (message "%d files contained unexpected results:" (length unexpected)) + (mapc (lambda (l) (message " %s" l)) unexpected)) + (unless (or (null tests) (zerop high)) + (message "\nLONG-RUNNING TESTS") + (message "------------------") + (setq tests (ntake high (sort tests (lambda (x y) (> (car x) (car y)))))) + (message "%s" (mapconcat #'cdr tests "\n"))) + ;; More details on hydra and emba, where the logs are harder to get to. + (when (and (or (getenv "EMACS_HYDRA_CI") (getenv "EMACS_EMBA_CI")) + (not (zerop (+ nunexpected nskipped)))) + (message "\nDETAILS") + (message "-------") + (with-temp-buffer + (dolist (x (list (list skipped "skipped" "SKIPPED") + (list unexpected "unexpected" + "\\(?:FAILED\\|PASSED\\)"))) + (mapc (lambda (l) + (erase-buffer) + (insert-file-contents l) + (message "%s:" l) + (when (re-search-forward (format "^[ \t]*[0-9]+ %s results:" + (nth 1 x)) + nil t) + (while (and (zerop (forward-line 1)) + (looking-at (format "^[ \t]*%s" (nth 2 x)))) + (message "%s" (buffer-substring (line-beginning-position) + (line-end-position)))))) + (car x))))) + (kill-emacs (cond ((or notests badtests (not (zerop nnotrun))) 2) + (unexpected 1) + (t 0))))) + +;;; Utility functions for load/unload actions. + +(defun ert--activate-font-lock-keywords () + "Activate font-lock keywords for some of ERT's symbols." + (font-lock-add-keywords + nil + '(("(\\(\\\\s *\\(\\(?:\\sw\\|\\s_\\)+\\)?" + (1 font-lock-keyword-face nil t) + (2 font-lock-function-name-face nil t))))) + +(cl-defun ert--remove-from-list (list-var element &key key test) + "Remove ELEMENT from the value of LIST-VAR if present. + +This can be used as an inverse of `add-to-list'." + (unless key (setq key #'identity)) + (unless test (setq test #'equal)) + (setf (symbol-value list-var) + (cl-remove element + (symbol-value list-var) + :key key + :test test))) + + +;;; Some basic interactive functions. + +(defun ert-read-test-name (prompt &optional default history + add-default-to-prompt) + "Read the name of a test and return it as a symbol. + +Prompt with PROMPT. If DEFAULT is a valid test name, use it as a +default. HISTORY is the history to use; see `completing-read'. +If ADD-DEFAULT-TO-PROMPT is non-nil, PROMPT will be modified to +include the default, if any. + +Signals an error if no test name was read." + (cl-etypecase default + (string (let ((symbol (intern-soft default))) + (unless (and symbol (ert-test-boundp symbol)) + (setq default nil)))) + (symbol (setq default + (if (ert-test-boundp default) + (symbol-name default) + nil))) + (ert-test (setq default (ert-test-name default)))) + (when add-default-to-prompt + (setq prompt (format-prompt prompt default))) + (let ((input (completing-read prompt obarray #'ert-test-boundp + t nil history default nil))) + ;; completing-read returns an empty string if default was nil and + ;; the user just hit enter. + (let ((sym (intern-soft input))) + (if (ert-test-boundp sym) + sym + (user-error "Input does not name a test"))))) + +(defun ert-read-test-name-at-point (prompt) + "Read the name of a test and return it as a symbol. +As a default, use the symbol at point, or the test at point if in +the ERT results buffer. Prompt with PROMPT, augmented with the +default (if any)." + (ert-read-test-name prompt (ert-test-at-point) nil t)) + +(defun ert-find-test-other-window (test-name) + "Find, in another window, the definition of TEST-NAME." + (interactive (list (ert-read-test-name-at-point "Find test definition"))) + (find-function-do-it test-name 'ert--test 'switch-to-buffer-other-window)) + +(defun ert-delete-test (test-name) + "Make the test TEST-NAME unbound. + +Nothing more than an interactive interface to `ert-make-test-unbound'." + (interactive (list (ert-read-test-name-at-point "Delete test"))) + (ert-make-test-unbound test-name)) + +(defun ert-delete-all-tests () + "Make all symbols in `obarray' name no test." + (interactive) + (when (called-interactively-p 'any) + (unless (y-or-n-p "Delete all tests? ") + (user-error "Aborted"))) + ;; We can't use `ert-select-tests' here since that gives us only + ;; test objects, and going from them back to the test name symbols + ;; can fail if the `ert-test' defstruct has been redefined. + (mapc #'ert-make-test-unbound (apropos-internal "" #'ert-test-boundp)) + t) + + +;;; Display of test progress and results. + +;; An entry in the results buffer ewoc. There is one entry per test. +(cl-defstruct ert--ewoc-entry + (test (cl-assert nil)) + ;; If the result of this test was expected, its ewoc entry is hidden + ;; initially. + (hidden-p (cl-assert nil)) + ;; An ewoc entry may be collapsed to hide details such as the error + ;; condition. + ;; + ;; I'm not sure the ability to expand and collapse entries is still + ;; a useful feature. + (expanded-p t) + ;; By default, the ewoc entry presents the error condition with + ;; certain limits on how much to print (`print-level', + ;; `print-length'). The user can interactively switch to a set of + ;; higher limits. + (extended-printer-limits-p nil)) + +;; Variables local to the results buffer. + +;; The ewoc. +(defvar ert--results-ewoc) +;; The stats object. +(defvar ert--results-stats) +;; A string with one character per test. Each character represents +;; the result of the corresponding test. The string is displayed near +;; the top of the buffer and serves as a progress bar. +(defvar ert--results-progress-bar-string) +;; The position where the progress bar button begins. +(defvar ert--results-progress-bar-button-begin) +;; The test result listener that updates the buffer when tests are run. +(defvar ert--results-listener) + +(defun ert-insert-test-name-button (test-name) + "Insert a button that links to TEST-NAME." + (insert-text-button (format "%S" test-name) + :type 'ert--test-name-button + 'ert-test-name test-name)) + +(defun ert--results-format-expected-unexpected (expected unexpected) + "Return a string indicating EXPECTED expected results, UNEXPECTED unexpected." + (if (zerop unexpected) + (format "%s" expected) + (format "%s (%s unexpected)" (+ expected unexpected) unexpected))) + +(defun ert--results-update-ewoc-hf (ewoc stats) + "Update the header and footer of EWOC to show certain information from STATS. + +Also sets `ert--results-progress-bar-button-begin'." + (let ((run-count (ert-stats-completed stats)) + (results-buffer (current-buffer)) + ;; Need to save buffer-local value. + (font-lock font-lock-mode)) + (ewoc-set-hf + ewoc + ;; header + (with-temp-buffer + (insert "Selector: ") + (ert--insert-human-readable-selector (ert--stats-selector stats)) + (insert "\n") + (insert + (format (concat "Passed: %s\n" + "Failed: %s\n" + "Skipped: %s\n" + "Total: %s/%s\n\n") + (ert--results-format-expected-unexpected + (ert--stats-passed-expected stats) + (ert--stats-passed-unexpected stats)) + (ert--results-format-expected-unexpected + (ert--stats-failed-expected stats) + (ert--stats-failed-unexpected stats)) + (ert-stats-skipped stats) + run-count + (ert-stats-total stats))) + (insert + (format "Started at: %s\n" + (ert--format-time-iso8601 (ert--stats-start-time stats)))) + ;; FIXME: This is ugly. Need to properly define invariants of + ;; the `stats' data structure. + (let ((state (cond ((ert--stats-aborted-p stats) 'aborted) + ((ert--stats-current-test stats) 'running) + ((ert--stats-end-time stats) 'finished) + (t 'preparing)))) + (cl-ecase state + (preparing + (insert "")) + (aborted + (cond ((ert--stats-current-test stats) + (insert "Aborted during test: ") + (ert-insert-test-name-button + (ert-test-name (ert--stats-current-test stats)))) + (t + (insert "Aborted.")))) + (running + (cl-assert (ert--stats-current-test stats)) + (insert "Running test: ") + (ert-insert-test-name-button (ert-test-name + (ert--stats-current-test stats)))) + (finished + (cl-assert (not (ert--stats-current-test stats))) + (insert "Finished."))) + (insert "\n") + (if (ert--stats-end-time stats) + (insert + (format "%s%s\n" + (if (ert--stats-aborted-p stats) + "Aborted at: " + "Finished at: ") + (ert--format-time-iso8601 (ert--stats-end-time stats)))) + (insert "\n")) + (insert "\n")) + (let ((progress-bar-string (with-current-buffer results-buffer + ert--results-progress-bar-string))) + (let ((progress-bar-button-begin + (insert-text-button progress-bar-string + :type 'ert--results-progress-bar-button + 'face (or (and font-lock + (ert-face-for-stats stats)) + 'button)))) + ;; The header gets copied verbatim to the results buffer, + ;; and all positions remain the same, so + ;; `progress-bar-button-begin' will be the right position + ;; even in the results buffer. + (with-current-buffer results-buffer + (setq-local ert--results-progress-bar-button-begin + progress-bar-button-begin)))) + (insert "\n\n") + (buffer-string)) + ;; footer + ;; + ;; We actually want an empty footer, but that would trigger a bug + ;; in ewoc, sometimes clearing the entire buffer. (It's possible + ;; that this bug has been fixed since this has been tested; we + ;; should test it again.) + "\n"))) + +(defvar ert-test-run-redisplay-interval-secs .1 + "How many seconds ERT should wait between redisplays while running tests. + +While running tests, ERT shows the current progress, and this variable +determines how frequently the progress display is updated.") + +(defun ert--results-update-stats-display (ewoc stats) + "Update EWOC and the mode line to show data from STATS." + ;; TODO(ohler): investigate using `make-progress-reporter'. + (ert--results-update-ewoc-hf ewoc stats) + (force-mode-line-update) + (redisplay t) + (setf (ert--stats-next-redisplay stats) + (float-time (time-add nil ert-test-run-redisplay-interval-secs)))) + +(defun ert--results-update-stats-display-maybe (ewoc stats) + "Call `ert--results-update-stats-display' if not called recently. + +EWOC and STATS are arguments for `ert--results-update-stats-display'." + (unless (time-less-p nil (ert--stats-next-redisplay stats)) + (ert--results-update-stats-display ewoc stats))) + +(defun ert--tests-running-mode-line-indicator () + "Return a string for the mode line that shows the test run progress." + (let* ((stats ert--current-run-stats) + (tests-total (ert-stats-total stats)) + (tests-completed (ert-stats-completed stats))) + (if (>= tests-completed tests-total) + (format " ERT(%s/%s,finished)" tests-completed tests-total) + (format " ERT(%s/%s):%s" + (1+ tests-completed) + tests-total + (if (null (ert--stats-current-test stats)) + "?" + (format "%S" + (ert-test-name (ert--stats-current-test stats)))))))) + +(defun ert--make-xrefs-region (begin end) + "Attach cross-references to function names between BEGIN and END. + +BEGIN and END specify a region in the current buffer." + (save-excursion + (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. + +The return value does not include the line terminator." + (substring s 0 (cl-position ?\n s))) + +(defun ert-face-for-test-result (expectedp) + "Return a face that shows whether a test result was expected or unexpected. + +If EXPECTEDP is nil, returns the face for unexpected results; if +non-nil, returns the face for expected results.." + (if expectedp 'ert-test-result-expected 'ert-test-result-unexpected)) + +(defun ert-face-for-stats (stats) + "Return a face that represents STATS." + (cond ((ert--stats-aborted-p stats) 'nil) + ((cl-plusp (ert-stats-completed-unexpected stats)) + (ert-face-for-test-result nil)) + ((eql (ert-stats-completed-expected stats) (ert-stats-total stats)) + (ert-face-for-test-result t)) + (t 'nil))) + +(defun ert--print-test-for-ewoc (entry) + "The ewoc print function for ewoc test entries. ENTRY is the entry to print." + (let* ((test (ert--ewoc-entry-test entry)) + (stats ert--results-stats) + (result (let ((pos (ert--stats-test-pos stats test))) + (cl-assert pos) + (aref (ert--stats-test-results stats) pos))) + (hiddenp (ert--ewoc-entry-hidden-p entry)) + (expandedp (ert--ewoc-entry-expanded-p entry)) + (extended-printer-limits-p (ert--ewoc-entry-extended-printer-limits-p + entry))) + (cond (hiddenp) + (t + (let ((expectedp (ert-test-result-expected-p test result))) + (insert-text-button (format "%c" (ert-char-for-test-result + result expectedp)) + :type 'ert--results-expand-collapse-button + 'face (or (and font-lock-mode + (ert-face-for-test-result + expectedp)) + 'button))) + (insert " ") + (ert-insert-test-name-button (ert-test-name test)) + (insert "\n") + (when (and expandedp (not (eql result 'nil))) + (when (ert-test-documentation test) + (insert " " + (propertize + (ert--string-first-line + (substitute-command-keys + (ert-test-documentation test))) + 'font-lock-face 'font-lock-doc-face) + "\n")) + (cl-etypecase result + (ert-test-passed + (if (ert-test-result-expected-p test result) + (insert " passed\n") + (insert " passed unexpectedly\n")) + (insert "")) + (ert-test-result-with-condition + (ert--insert-infos result) + (let ((print-escape-newlines t) + (print-level (if extended-printer-limits-p 12 6)) + (print-length (if extended-printer-limits-p 100 10))) + (insert " ") + (let ((begin (point))) + (ert--pp-with-indentation-and-newline + (ert-test-result-with-condition-condition result)) + (ert--make-xrefs-region begin (point))))) + (ert-test-aborted-with-non-local-exit + (insert " aborted\n")) + (ert-test-quit + (insert " quit\n"))) + (insert "\n"))))) + nil) + +(defun ert--results-font-lock-function (enabledp) + "Redraw the ERT results buffer after `font-lock-mode' was switched on or off. + +ENABLEDP is true if `font-lock-mode' is switched on, false +otherwise." + (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) + (ewoc-refresh ert--results-ewoc) + (font-lock-default-function enabledp)) + +(defvar ert--output-buffer-name "*ert*") + +(defun ert--setup-results-buffer (stats listener) + "Set up a test results buffer. + +STATS is the stats object; LISTENER is the results listener." + (let ((buffer (get-buffer-create ert--output-buffer-name))) + (with-current-buffer buffer + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-results-mode) + ;; Erase buffer again in case switching out of the previous + ;; mode inserted anything. (This happens e.g. when switching + ;; from ert-results-mode to ert-results-mode when + ;; font-lock-mode turns itself off in change-major-mode-hook.) + (erase-buffer) + (setq-local font-lock-function + 'ert--results-font-lock-function) + (let ((ewoc (ewoc-create 'ert--print-test-for-ewoc nil nil t))) + (setq-local ert--results-ewoc ewoc) + (setq-local ert--results-stats stats) + (setq-local ert--results-progress-bar-string + (make-string (ert-stats-total stats) + (ert-char-for-test-result nil t))) + (setq-local ert--results-listener listener) + (cl-loop for test across (ert--stats-tests stats) do + (ewoc-enter-last ewoc + (make-ert--ewoc-entry :test test + :hidden-p t))) + (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) + (goto-char (1- (point-max))) + buffer))))) + +(defvar ert--selector-history nil + "List of recent test selectors read from terminal.") + +;;;###autoload +(defun ert-run-tests-interactively (selector) + "Run the tests specified by SELECTOR and display the results in a buffer. + +SELECTOR selects which tests to run as described in `ert-select-tests' +when called with its second argument t. Interactively, prompt for +SELECTOR; the default t means run all the defined tests." + (interactive + (list (let ((default (if ert--selector-history + ;; Can't use `first' here as this form is + ;; not compiled, and `first' is not + ;; defined without cl. + (car ert--selector-history) + "t"))) + (read + (completing-read (format-prompt "Run tests" default) + obarray #'ert-test-boundp nil nil + 'ert--selector-history default nil))))) + (let (buffer listener) + (setq listener + (lambda (event-type &rest event-args) + (cl-ecase event-type + (run-started + (cl-destructuring-bind (stats) event-args + (setq buffer (ert--setup-results-buffer stats listener)) + (pop-to-buffer buffer))) + (run-ended + (cl-destructuring-bind (stats abortedp) event-args + (message + "%sRan %s tests, %s results were as expected%s%s" + (if (not abortedp) + "" + "Aborted: ") + (ert-stats-total stats) + (ert-stats-completed-expected stats) + (let ((unexpected + (ert-stats-completed-unexpected stats))) + (if (zerop unexpected) + "" + (format ", %s unexpected" unexpected))) + (let ((skipped + (ert-stats-skipped stats))) + (if (zerop skipped) + "" + (format ", %s skipped" skipped)))) + (ert--results-update-stats-display (with-current-buffer buffer + ert--results-ewoc) + stats))) + (test-started + (cl-destructuring-bind (stats test) event-args + (with-current-buffer buffer + (let* ((ewoc ert--results-ewoc) + (pos (ert--stats-test-pos stats test)) + (node (ewoc-nth ewoc pos))) + (cl-assert node) + (setf (ert--ewoc-entry-test (ewoc-data node)) test) + (aset ert--results-progress-bar-string pos + (ert-char-for-test-result nil t)) + (ert--results-update-stats-display-maybe ewoc stats) + (ewoc-invalidate ewoc node))))) + (test-ended + (cl-destructuring-bind (stats test result) event-args + (with-current-buffer buffer + (let* ((ewoc ert--results-ewoc) + (pos (ert--stats-test-pos stats test)) + (node (ewoc-nth ewoc pos))) + (when (ert--ewoc-entry-hidden-p (ewoc-data node)) + (setf (ert--ewoc-entry-hidden-p (ewoc-data node)) + (ert-test-result-expected-p test result))) + (aset ert--results-progress-bar-string pos + (ert-char-for-test-result result + (ert-test-result-expected-p + test result))) + (ert--results-update-stats-display-maybe ewoc stats) + (ewoc-invalidate ewoc node)))))))) + (ert-run-tests selector listener t))) + +;;;###autoload +(defalias 'ert #'ert-run-tests-interactively) + + +;;; Simple view mode for auxiliary information like stack traces or +;;; messages. Mainly binds "q" for quit. + +(define-derived-mode ert-simple-view-mode special-mode "ERT-View" + "Major mode for viewing auxiliary information in ERT.") + +;;; Commands and button actions for the results buffer. + +(define-derived-mode ert-results-mode special-mode "ERT-Results" + "Major mode for viewing results of ERT test runs." + :interactive nil + (setq-local revert-buffer-function + (lambda (&rest _) (ert-results-rerun-all-tests)))) + +(cl-loop for (key binding) in + '( ;; Stuff that's not in the menu. + ("\t" forward-button) + ([backtab] backward-button) + ("j" ert-results-jump-between-summary-and-result) + ("L" ert-results-toggle-printer-limits-for-test-at-point) + ("n" ert-results-next-test) + ("p" ert-results-previous-test) + ;; Stuff that is in the menu. + ("R" ert-results-rerun-all-tests) + ("r" ert-results-rerun-test-at-point) + ("d" ert-results-rerun-test-at-point-debugging-errors) + ("." ert-results-find-test-at-point-other-window) + ("b" ert-results-pop-to-backtrace-for-test-at-point) + ("m" ert-results-pop-to-messages-for-test-at-point) + ("l" ert-results-pop-to-should-forms-for-test-at-point) + ("h" ert-results-describe-test-at-point) + ("D" ert-delete-test) + ("T" ert-results-pop-to-timings) + ) + do + (define-key ert-results-mode-map key binding)) + +(easy-menu-define ert-results-mode-menu ert-results-mode-map + "Menu for `ert-results-mode'." + '("ERT Results" + ["Re-run all tests" ert-results-rerun-all-tests] + "--" + ;; FIXME? Why are there (at least) 3 different ways to decide if + ;; there is a test at point? + ["Re-run test" ert-results-rerun-test-at-point + :active (car (ert--results-test-at-point-allow-redefinition))] + ["Debug test" ert-results-rerun-test-at-point-debugging-errors + :active (car (ert--results-test-at-point-allow-redefinition))] + ["Show test definition" ert-results-find-test-at-point-other-window + :active (ert-test-at-point)] + "--" + ["Show backtrace" ert-results-pop-to-backtrace-for-test-at-point + :active (ert--results-test-at-point-no-redefinition)] + ["Show messages" ert-results-pop-to-messages-for-test-at-point + :active (ert--results-test-at-point-no-redefinition)] + ["Show `should' forms" ert-results-pop-to-should-forms-for-test-at-point + :active (ert--results-test-at-point-no-redefinition)] + ["Describe test" ert-results-describe-test-at-point + :active (ert--results-test-at-point-no-redefinition)] + "--" + ["Delete test" ert-delete-test] + "--" + ["Show execution time of each test" ert-results-pop-to-timings] + )) + +(define-button-type 'ert--results-progress-bar-button + 'action #'ert--results-progress-bar-button-action + 'help-echo "mouse-2, RET: Reveal test result") + +(define-button-type 'ert--test-name-button + 'action #'ert--test-name-button-action + 'help-echo "mouse-2, RET: Find test definition") + +(define-button-type 'ert--results-expand-collapse-button + 'action #'ert--results-expand-collapse-button-action + 'help-echo "mouse-2, RET: Expand/collapse test result") + +(defun ert--results-test-node-or-null-at-point () + "If point is on a valid ewoc node, return it; return nil otherwise. + +To be used in the ERT results buffer." + (let* ((ewoc ert--results-ewoc) + (node (ewoc-locate ewoc))) + ;; `ewoc-locate' will return an arbitrary node when point is on + ;; header or footer, or when all nodes are invisible. So we need + ;; to validate its return value here. + ;; + ;; Update: I'm seeing nil being returned in some cases now, + ;; perhaps this has been changed? + (if (and node + (>= (point) (ewoc-location node)) + (not (ert--ewoc-entry-hidden-p (ewoc-data node)))) + node + nil))) + +(defun ert--results-test-node-at-point () + "If point is on a valid ewoc node, return it; signal an error otherwise. + +To be used in the ERT results buffer." + (or (ert--results-test-node-or-null-at-point) + (user-error "No test at point"))) + +(defun ert-results-next-test () + "Move point to the next test. + +To be used in the ERT results buffer." + (interactive nil ert-results-mode) + (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-next + "No tests below")) + +(defun ert-results-previous-test () + "Move point to the previous test. + +To be used in the ERT results buffer." + (interactive nil ert-results-mode) + (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-prev + "No tests above")) + +(defun ert--results-move (node ewoc-fn error-message) + "Move point from NODE to the previous or next node. + +EWOC-FN specifies the direction and should be either `ewoc-prev' +or `ewoc-next'. If there are no more nodes in that direction, a +user-error is signaled with the message ERROR-MESSAGE." + (cl-loop + (setq node (funcall ewoc-fn ert--results-ewoc node)) + (when (null node) + (user-error "%s" error-message)) + (unless (ert--ewoc-entry-hidden-p (ewoc-data node)) + (goto-char (ewoc-location node)) + (cl-return)))) + +(defun ert--results-expand-collapse-button-action (_button) + "Expand or collapse the test node BUTTON belongs to." + (let* ((ewoc ert--results-ewoc) + (node (save-excursion + (goto-char (ert--button-action-position)) + (ert--results-test-node-at-point))) + (entry (ewoc-data node))) + (setf (ert--ewoc-entry-expanded-p entry) + (not (ert--ewoc-entry-expanded-p entry))) + (ewoc-invalidate ewoc node))) + +(defun ert-results-find-test-at-point-other-window () + "Find the definition of the test at point in another window. + +To be used in the ERT results buffer." + (interactive nil ert-results-mode) + (let ((name (ert-test-at-point))) + (unless name + (user-error "No test at point")) + (ert-find-test-other-window name))) + +(defun ert--test-name-button-action (button) + "Find the definition of the test BUTTON belongs to, in another window." + (let ((name (button-get button 'ert-test-name))) + (ert-find-test-other-window name))) + +(defun ert--ewoc-position (ewoc node) + ;; checkdoc-order: nil + "Return the position of NODE in EWOC, or nil if NODE is not in EWOC." + (cl-loop for i from 0 + for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here) + do (when (eql node node-here) + (cl-return i)) + finally (cl-return nil))) + +(defun ert-results-jump-between-summary-and-result () + "Jump back and forth between the test run summary and individual test results. + +From an ewoc node, jumps to the character that represents the +same test in the progress bar, and vice versa. + +To be used in the ERT results buffer." + ;; Maybe this command isn't actually needed much, but if it is, it + ;; seems like an indication that the UI design is not optimal. If + ;; jumping back and forth between a summary at the top of the buffer + ;; and the error log in the remainder of the buffer is useful, then + ;; the summary apparently needs to be easily accessible from the + ;; error log, and perhaps it would be better to have it in a + ;; separate buffer to keep it visible. + (interactive nil ert-results-mode) + (let ((ewoc ert--results-ewoc) + (progress-bar-begin ert--results-progress-bar-button-begin)) + (cond ((ert--results-test-node-or-null-at-point) + (let* ((node (ert--results-test-node-at-point)) + (pos (ert--ewoc-position ewoc node))) + (goto-char (+ progress-bar-begin pos)))) + ((and (<= progress-bar-begin (point)) + (< (point) (button-end (button-at progress-bar-begin)))) + (let* ((node (ewoc-nth ewoc (- (point) progress-bar-begin))) + (entry (ewoc-data node))) + (when (ert--ewoc-entry-hidden-p entry) + (setf (ert--ewoc-entry-hidden-p entry) nil) + (ewoc-invalidate ewoc node)) + (ewoc-goto-node ewoc node))) + (t + (goto-char progress-bar-begin))))) + +(defun ert-test-at-point () + "Return the name of the test at point as a symbol, or nil if none." + (or (and (eql major-mode 'ert-results-mode) + (let ((test (ert--results-test-at-point-no-redefinition))) + (and test (ert-test-name test)))) + (let* ((thing (thing-at-point 'symbol)) + (sym (intern-soft thing))) + (and (ert-test-boundp sym) + sym)))) + +(defun ert--results-test-at-point-no-redefinition (&optional error) + "Return the test at point, or nil. +If optional argument ERROR is non-nil, signal an error rather than return nil. +To be used in the ERT results buffer." + (cl-assert (eql major-mode 'ert-results-mode)) + (or + (if (ert--results-test-node-or-null-at-point) + (let* ((node (ert--results-test-node-at-point)) + (test (ert--ewoc-entry-test (ewoc-data node)))) + test) + (let ((progress-bar-begin ert--results-progress-bar-button-begin)) + (when (and (<= progress-bar-begin (point)) + (< (point) (button-end (button-at progress-bar-begin)))) + (let* ((test-index (- (point) progress-bar-begin)) + (test (aref (ert--stats-tests ert--results-stats) + test-index))) + test)))) + (if error (user-error "No test at point")))) + +(defun ert--results-test-at-point-allow-redefinition () + "Look up the test at point, and check whether it has been redefined. + +To be used in the ERT results buffer. + +Returns a list of two elements: the test (or nil) and a symbol +specifying whether the test has been redefined. + +If a new test has been defined with the same name as the test at +point, replaces the test at point with the new test, and returns +the new test and the symbol `redefined'. + +If the test has been deleted, returns the old test and the symbol +`deleted'. + +If the test is still current, returns the test and the symbol nil. + +If there is no test at point, returns a list with two nils." + (let ((test (ert--results-test-at-point-no-redefinition))) + (cond ((null test) + `(nil nil)) + ((null (ert-test-name test)) + `(,test nil)) + (t + (let* ((name (ert-test-name test)) + (new-test (and (ert-test-boundp name) + (ert-get-test name)))) + (cond ((eql test new-test) + `(,test nil)) + ((null new-test) + `(,test deleted)) + (t + (ert--results-update-after-test-redefinition + (ert--stats-test-pos ert--results-stats test) + new-test) + `(,new-test redefined)))))))) + +(defun ert--results-update-after-test-redefinition (pos new-test) + "Update results buffer after the test at pos POS has been redefined. + +Also updates the stats object. NEW-TEST is the new test +definition." + (let* ((stats ert--results-stats) + (ewoc ert--results-ewoc) + (node (ewoc-nth ewoc pos)) + (entry (ewoc-data node))) + (ert--stats-set-test-and-result stats pos new-test nil) + (setf (ert--ewoc-entry-test entry) new-test + (aref ert--results-progress-bar-string pos) (ert-char-for-test-result + nil t)) + (ewoc-invalidate ewoc node)) + nil) + +(defun ert--button-action-position () + "The buffer position where the last button action was triggered." + (cond ((integerp last-command-event) + (point)) + ((eventp last-command-event) + (posn-point (event-start last-command-event))) + (t (cl-assert nil)))) + +(defun ert--results-progress-bar-button-action (_button) + "Jump to details for the test represented by the character clicked in BUTTON." + (goto-char (ert--button-action-position)) + (ert-results-jump-between-summary-and-result)) + +(defun ert-results-rerun-all-tests () + "Re-run all tests, using the same selector. + +To be used in the ERT results buffer." + (interactive nil ert-results-mode) + (cl-assert (eql major-mode 'ert-results-mode)) + (let ((selector (ert--stats-selector ert--results-stats))) + (ert-run-tests-interactively selector))) + +(defun ert-results-rerun-test-at-point () + "Re-run the test at point. + +To be used in the ERT results buffer." + (interactive nil ert-results-mode) + (cl-destructuring-bind (test redefinition-state) + (ert--results-test-at-point-allow-redefinition) + (when (null test) + (user-error "No test at point")) + (let* ((stats ert--results-stats) + (progress-message (format "Running %stest %S" + (cl-ecase redefinition-state + ((nil) "") + (redefined "new definition of ") + (deleted "deleted ")) + (ert-test-name test)))) + ;; Need to save and restore point manually here: When point is on + ;; the first visible ewoc entry while the header is updated, point + ;; moves to the top of the buffer. This is undesirable, and a + ;; simple `save-excursion' doesn't prevent it. + (let ((point (point))) + (unwind-protect + (unwind-protect + (progn + (message "%s..." progress-message) + (ert-run-or-rerun-test stats test + ert--results-listener)) + (ert--results-update-stats-display ert--results-ewoc stats) + (message "%s...%s" + progress-message + (let ((result (ert-test-most-recent-result test))) + (ert-string-for-test-result + result (ert-test-result-expected-p test result))))) + (goto-char point)))))) + +(defun ert-results-rerun-test-at-point-debugging-errors () + "Re-run the test at point with `ert-debug-on-error' bound to t. + +To be used in the ERT results buffer." + (interactive nil ert-results-mode) + (let ((ert-debug-on-error t)) + (ert-results-rerun-test-at-point))) + +(defun ert-results-pop-to-backtrace-for-test-at-point () + "Display the backtrace for the test at point. + +To be used in the ERT results buffer." + (interactive nil ert-results-mode) + (let* ((test (ert--results-test-at-point-no-redefinition t)) + (stats ert--results-stats) + (pos (ert--stats-test-pos stats test)) + (result (aref (ert--stats-test-results stats) pos))) + (cl-etypecase result + (ert-test-passed (error "Test passed, no backtrace available")) + (ert-test-result-with-condition + (let ((buffer (get-buffer-create "*ERT Backtrace*"))) + (pop-to-buffer buffer) + (unless (derived-mode-p 'backtrace-mode) + (backtrace-mode)) + (setq backtrace-insert-header-function + (lambda () (ert--insert-backtrace-header (ert-test-name test))) + backtrace-frames (ert-test-result-with-condition-backtrace result)) + (backtrace-print) + (goto-char (point-min))))))) + +(defun ert--insert-backtrace-header (name) + (insert (substitute-command-keys "Backtrace for test `")) + (ert-insert-test-name-button name) + (insert (substitute-command-keys "':\n"))) + +(defun ert-results-pop-to-messages-for-test-at-point () + "Display the part of the *Messages* buffer generated during the test at point. + +To be used in the ERT results buffer." + (interactive nil ert-results-mode) + (let* ((test (ert--results-test-at-point-no-redefinition t)) + (stats ert--results-stats) + (pos (ert--stats-test-pos stats test)) + (result (aref (ert--stats-test-results stats) pos))) + (let ((buffer (get-buffer-create "*ERT Messages*"))) + (pop-to-buffer buffer) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + (insert (ert-test-result-messages result)) + (goto-char (point-min)) + (insert (substitute-command-keys "Messages for test `")) + (ert-insert-test-name-button (ert-test-name test)) + (insert (substitute-command-keys "':\n")))))) + +(defun ert-results-pop-to-should-forms-for-test-at-point () + "Display the list of `should' forms executed during the test at point. + +To be used in the ERT results buffer." + (interactive nil ert-results-mode) + (let* ((test (ert--results-test-at-point-no-redefinition t)) + (stats ert--results-stats) + (pos (ert--stats-test-pos stats test)) + (result (aref (ert--stats-test-results stats) pos))) + (let ((buffer (get-buffer-create "*ERT list of should forms*"))) + (pop-to-buffer buffer) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + (if (null (ert-test-result-should-forms result)) + (insert "\n(No should forms during this test.)\n") + (cl-loop for form-description + in (ert-test-result-should-forms result) + for i from 1 do + (insert "\n") + (insert (format "%s: " i)) + (let ((begin (point))) + (ert--pp-with-indentation-and-newline form-description) + (ert--make-xrefs-region begin (point))))) + (goto-char (point-min)) + (insert (substitute-command-keys + "`should' forms executed during test `")) + (ert-insert-test-name-button (ert-test-name test)) + (insert (substitute-command-keys "':\n")) + (insert "\n") + (insert (concat "(Values are shallow copies and may have " + "looked different during the test if they\n" + "have been modified destructively.)\n")) + (forward-line 1))))) + +(defun ert-results-toggle-printer-limits-for-test-at-point () + "Toggle how much of the condition to print for the test at point. + +To be used in the ERT results buffer." + (interactive nil ert-results-mode) + (let* ((ewoc ert--results-ewoc) + (node (ert--results-test-node-at-point)) + (entry (ewoc-data node))) + (setf (ert--ewoc-entry-extended-printer-limits-p entry) + (not (ert--ewoc-entry-extended-printer-limits-p entry))) + (ewoc-invalidate ewoc node))) + +(defun ert-results-pop-to-timings () + "Display test timings for the last run. + +To be used in the ERT results buffer." + (interactive nil ert-results-mode) + (let* ((stats ert--results-stats) + (buffer (get-buffer-create "*ERT timings*")) + (data (cl-loop for test across (ert--stats-tests stats) + for start-time across (ert--stats-test-start-times + stats) + for end-time across (ert--stats-test-end-times stats) + collect (list test + (float-time (time-subtract + end-time start-time)))))) + (setq data (sort data (lambda (a b) + (> (cl-second a) (cl-second b))))) + (pop-to-buffer buffer) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + (if (null data) + (insert "(No data)\n") + (insert (format "%-3s %8s %8s\n" "" "time" "cumul")) + (cl-loop for (test time) in data + for cumul-time = time then (+ cumul-time time) + for i from 1 do + (progn + (insert (format "%3s: %8.3f %8.3f " i time cumul-time)) + (ert-insert-test-name-button (ert-test-name test)) + (insert "\n")))) + (goto-char (point-min)) + (insert "Tests by run time (seconds):\n\n") + (forward-line 1)))) + +;;;###autoload +(defun ert-describe-test (test-or-test-name) + "Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test)." + (interactive (list (ert-read-test-name-at-point "Describe test"))) + (let (test-name + test-definition) + (cl-etypecase test-or-test-name + (symbol (setq test-name test-or-test-name + test-definition (ert-get-test test-or-test-name))) + (ert-test (setq test-name (ert-test-name test-or-test-name) + test-definition test-or-test-name))) + (help-setup-xref (list #'ert-describe-test test-or-test-name) + (called-interactively-p 'interactive)) + (save-excursion + (with-help-window (help-buffer) + (with-current-buffer (help-buffer) + (insert (if test-name (format "%S" test-name) "")) + (insert " is a test") + (let ((file-name (and test-name + (symbol-file test-name 'ert--test)))) + (when file-name + (insert (format-message " defined in `%s'" + (file-name-nondirectory file-name))) + (save-excursion + (re-search-backward (substitute-command-keys "`\\([^`']+\\)'")) + (help-xref-button 1 'help-function-def test-name file-name))) + (insert ".") + (fill-region-as-paragraph (point-min) (point)) + (insert "\n\n") + (unless (and (ert-test-boundp test-name) + (eql (ert-get-test test-name) test-definition)) + (let ((begin (point))) + (insert "Note: This test has been redefined or deleted, " + "this documentation refers to an old definition.") + (fill-region-as-paragraph begin (point))) + (insert "\n\n")) + (insert (substitute-command-keys + (or (ert-test-documentation test-definition) + "It is not documented.")) + "\n") + ;; For describe-symbol-backends. + (buffer-string))))))) + +(defun ert-results-describe-test-at-point () + "Display the documentation of the test at point. + +To be used in the ERT results buffer." + (interactive nil ert-results-mode) + (ert-describe-test (ert--results-test-at-point-no-redefinition t))) + + +;;; Actions on load/unload. + +(require 'help-mode) +(add-to-list 'describe-symbol-backends + `("ERT test" ,#'ert-test-boundp + ,(lambda (s _b _f) (ert-describe-test s)))) + +(add-to-list 'find-function-regexp-alist '(ert--test . ert--find-test-regexp)) +(add-to-list 'minor-mode-alist '(ert--current-run-stats + (:eval + (ert--tests-running-mode-line-indicator)))) +(add-hook 'emacs-lisp-mode-hook #'ert--activate-font-lock-keywords) + +(defun ert--unload-function () + "Unload function to undo the side-effects of loading ert.el." + (ert--remove-from-list 'find-function-regexp-alist 'ert-deftest :key #'car) + (ert--remove-from-list 'minor-mode-alist 'ert--current-run-stats :key #'car) + (ert--remove-from-list 'emacs-lisp-mode-hook + 'ert--activate-font-lock-keywords) + nil) + +(defun ert-test-erts-file (file &optional transform) + "Parse FILE as a file containing before/after parts (an erts file). + +This function puts the \"before\" section of an .erts file into a +temporary buffer, calls the TRANSFORM function, and then compares +the result with the \"after\" section. + +See Info node `(ert) erts files' for more information on how to +write erts files." + (with-temp-buffer + (insert-file-contents file) + (let ((gen-specs (list (cons 'dummy t) + (cons 'code transform)))) + ;; Find the start of a test. + (while (re-search-forward "^=-=\n" nil t) + (setq gen-specs (ert-test--erts-test gen-specs file)) + ;; Search to the end of the test. + (re-search-forward "^=-=-=\n"))))) + +(defun ert-test--erts-test (gen-specs file) + (let* ((file-buffer (current-buffer)) + (specs (ert--erts-specifications (match-beginning 0))) + (name (cdr (assq 'name specs))) + (start-before (point)) + (end-after (if (re-search-forward "^=-=-=\n" nil t) + (match-beginning 0) + (point-max))) + (skip (cdr (assq 'skip specs))) + end-before start-after + after after-point) + (unless name + (error "No name for test case")) + (if (and skip + (eval (car (read-from-string skip)))) + ;; Skipping this test. + () + ;; Do the test. + (goto-char end-after) + ;; We have a separate after section. + (if (re-search-backward "^=-=\n" start-before t) + (setq end-before (match-beginning 0) + start-after (match-end 0)) + (setq end-before end-after + start-after start-before)) + ;; Update persistent specs. + (when-let ((point-char (assq 'point-char specs))) + (setq gen-specs + (map-insert gen-specs 'point-char (cdr point-char)))) + (when-let ((code (cdr (assq 'code specs)))) + (setq gen-specs + (map-insert gen-specs 'code (car (read-from-string code))))) + ;; Get the "after" strings. + (with-temp-buffer + (insert-buffer-substring file-buffer start-after end-after) + (ert--erts-unquote) + ;; Remove the newline at the end of the buffer. + (when-let ((no-newline (cdr (assq 'no-after-newline specs)))) + (goto-char (point-min)) + (when (re-search-forward "\n\\'" nil t) + (delete-region (match-beginning 0) (match-end 0)))) + ;; Get the expected "after" point. + (when-let ((point-char (cdr (assq 'point-char gen-specs)))) + (goto-char (point-min)) + (when (search-forward point-char nil t) + (delete-region (match-beginning 0) (match-end 0)) + (setq after-point (point)))) + (setq after (buffer-string))) + ;; Do the test. + (with-temp-buffer + (insert-buffer-substring file-buffer start-before end-before) + (ert--erts-unquote) + ;; Remove the newline at the end of the buffer. + (when-let ((no-newline (cdr (assq 'no-before-newline specs)))) + (goto-char (point-min)) + (when (re-search-forward "\n\\'" nil t) + (delete-region (match-beginning 0) (match-end 0)))) + (goto-char (point-min)) + ;; Place point in the specified place. + (when-let ((point-char (cdr (assq 'point-char gen-specs)))) + (when (search-forward point-char nil t) + (delete-region (match-beginning 0) (match-end 0)))) + (let ((code (cdr (assq 'code gen-specs)))) + (unless code + (error "No code to run the transform")) + (funcall code)) + (unless (equal (buffer-string) after) + (ert-fail (list (format "Mismatch in test \"%s\", file %s" + name file) + (buffer-string) + after))) + (when (and after-point + (not (= after-point (point)))) + (ert-fail (list (format "Point wrong in test \"%s\", expected point %d, actual %d, file %s" + name + after-point (point) + file) + (buffer-string))))))) + ;; Return the new value of the general specifications. + gen-specs) + +(defun ert--erts-unquote () + (goto-char (point-min)) + (while (re-search-forward "^\\=-=\\(-=\\)$" nil t) + (delete-region (match-beginning 0) (1+ (match-beginning 0))))) + +(defun ert--erts-specifications (end) + "Find specifications before point (back to the previous test)." + (save-excursion + (goto-char end) + (goto-char + (if (re-search-backward "^=-=-=\n" nil t) + (match-end 0) + (point-min))) + (let ((specs nil)) + (while (< (point) end) + (if (looking-at "\\([^ \n\t:]+\\):\\([ \t]+\\)?\\(.*\\)") + (let ((name (intern (downcase (match-string 1)))) + (value (match-string 3))) + (forward-line 1) + (while (looking-at "[ \t]+\\(.*\\)") + (setq value (concat value (match-string 1))) + (forward-line 1)) + (push (cons name (substring-no-properties value)) specs)) + (forward-line 1))) + (nreverse specs)))) + +(defvar ert-unload-hook ()) +(add-hook 'ert-unload-hook #'ert--unload-function) + +;;; Obsolete + +(define-obsolete-function-alias 'ert-equal-including-properties + #'equal-including-properties "29.1") +(put 'ert-equal-including-properties 'ert-explainer + 'ert--explain-equal-including-properties) + +(provide 'ert) + +;;; ert.el ends here diff --git a/lisp/emacs-lisp/ewoc.el b/lisp/emacs-lisp/ewoc.el new file mode 100644 index 00000000..da481c98 --- /dev/null +++ b/lisp/emacs-lisp/ewoc.el @@ -0,0 +1,589 @@ +;;; ewoc.el --- utility to maintain a view of a list of objects in a buffer -*- lexical-binding: t -*- + +;; Copyright (C) 1991-2024 Free Software Foundation, Inc. + +;; Author: Per Cederqvist +;; Inge Wallin +;; Maintainer: Stefan Monnier +;; Created: 3 Aug 1992 +;; Keywords: extensions, lisp + +;; 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 GNU Emacs. If not, see . + +;;; Commentary: + +;; Ewoc Was Once Cookie +;; But now it's Emacs's Widget for Object Collections + +;; As the name implies this derives from the `cookie' package (part +;; of Elib). The changes are pervasive though mostly superficial: + +;; - uses CL (and its `defstruct') +;; - separate from Elib. +;; - uses its own version of a doubly-linked list which allows us +;; to merge the elib-wrapper and the elib-node structures into ewoc-node +;; - dropping functions not used by PCL-CVS (the only client of ewoc at the +;; time of writing) +;; - removing unused arguments +;; - renaming: +;; elib-node ==> ewoc--node +;; collection ==> ewoc +;; tin ==> ewoc--node +;; cookie ==> data or element or elem + +;; Introduction +;; ============ +;; +;; Ewoc is a package that implements a connection between an +;; dll (a doubly linked list) and the contents of a buffer. +;; Possible uses are Dired (have all files in a list, and show them), +;; buffer-list, kom-prioritize (in the LysKOM elisp client) and +;; others. pcl-cvs.el and vc.el use ewoc.el. +;; +;; Ewoc can be considered as the `view' part of a model-view-controller. +;; +;; An `element' can be any Lisp object. When you use the ewoc +;; package you specify a pretty-printer, a function that inserts +;; a printable representation of the element in the buffer. (The +;; pretty-printer should use "insert" and not +;; "insert-before-markers"). +;; +;; A `ewoc' consists of a doubly linked list of elements, a +;; header, a footer and a pretty-printer. It is displayed at a +;; certain point in a certain buffer. (The buffer and point are +;; fixed when the ewoc is created). The header and the footer +;; are constant strings. They appear before and after the elements. +;; +;; Ewoc does not affect the mode of the buffer in any way. It +;; merely makes it easy to connect an underlying data representation +;; to the buffer contents. +;; +;; A `ewoc--node' is an object that contains one element. There are +;; functions in this package that given an ewoc--node extract the data, or +;; give the next or previous ewoc--node. (All ewoc--nodes are linked together +;; in a doubly linked list. The `previous' ewoc--node is the one that appears +;; before the other in the buffer.) You should not do anything with +;; an ewoc--node except pass it to the functions in this package. +;; +;; An ewoc is a very dynamic thing. You can easily add or delete elements. +;; You can apply a function to all elements in an ewoc, etc, etc. +;; +;; Remember that an element can be anything. Your imagination is the +;; limit! It is even possible to have another ewoc as an +;; element. In that way some kind of tree hierarchy can be created. +;; +;; The Emacs Lisp Reference Manual documents ewoc.el's "public interface". + +;; Coding conventions +;; ================== +;; +;; All functions of course start with `ewoc'. Functions and macros +;; starting with the prefix `ewoc--' are meant for internal use, +;; while those starting with `ewoc-' are exported for public use. + +;;; Code: + +(eval-when-compile (require 'cl-lib)) + +;; The doubly linked list is implemented as a circular list with a dummy +;; node first and last. The dummy node is used as "the dll". +(cl-defstruct (ewoc--node + (:type vector) ;ewoc--node-nth needs this + (:constructor nil) + (:constructor ewoc--node-create (start-marker data))) + left right data start-marker) + +(defun ewoc--node-next (dll node) + "Return the node after NODE, or nil if NODE is the last node." + (let ((R (ewoc--node-right node))) + (unless (eq dll R) R))) + +(defun ewoc--node-prev (dll node) + "Return the node before NODE, or nil if NODE is the first node." + (let ((L (ewoc--node-left node))) + (unless (eq dll L) L))) + +(defun ewoc--node-nth (dll n) + "Return the Nth node from the doubly linked list DLL. +N counts from zero. If N is negative, return the -(N+1)th last element. +If N is out of range, return nil. +Thus, (ewoc--node-nth dll 0) returns the first node, +and (ewoc--node-nth dll -1) returns the last node." + ;; Presuming a node is ":type vector", starting with `left' and `right': + ;; Branch 0 ("follow left pointer") is used when n is negative. + ;; Branch 1 ("follow right pointer") is used otherwise. + (let* ((branch (if (< n 0) 0 1)) + (node (aref dll branch))) + (if (< n 0) (setq n (- -1 n))) + (while (and (not (eq dll node)) (> n 0)) + (setq node (aref node branch)) + (setq n (1- n))) + (unless (eq dll node) node))) + +(defun ewoc-location (node) + "Return the start location of NODE." + (ewoc--node-start-marker node)) + + +;;; The ewoc data type + +(cl-defstruct (ewoc + (:constructor nil) + (:constructor ewoc--create (buffer pretty-printer dll)) + (:conc-name ewoc--)) + buffer pretty-printer header footer dll last-node hf-pp) + +(defmacro ewoc--set-buffer-bind-dll-let* (ewoc varlist &rest forms) + "Execute FORMS with `ewoc--buffer' selected as current buffer, +`dll' bound to the dll, and VARLIST bound as in a let*. +`dll' will be bound when VARLIST is initialized, but +the current buffer will *not* have been changed. +Return value of last form in FORMS." + (let ((hnd (make-symbol "ewoc"))) + `(let* ((,hnd ,ewoc) + (dll (ewoc--dll ,hnd)) + ,@varlist) + (with-current-buffer (ewoc--buffer ,hnd) + ,@forms)))) + +(defmacro ewoc--set-buffer-bind-dll (ewoc &rest forms) + `(ewoc--set-buffer-bind-dll-let* ,ewoc nil ,@forms)) + +(defsubst ewoc--filter-hf-nodes (ewoc node) + "Evaluate NODE once and return it. +BUT if it is the header or the footer in EWOC return nil instead." + (unless (or (eq node (ewoc--header ewoc)) + (eq node (ewoc--footer ewoc))) + node)) + +(defun ewoc--adjust (beg end node dll) + ;; "Manually reseat" markers for NODE and its successors (including footer + ;; and dll), in the case where they originally shared start position with + ;; BEG, to END. BEG and END are buffer positions describing NODE's left + ;; neighbor. This operation is functionally equivalent to temporarily + ;; setting these nodes' markers' insertion type to t around the pretty-print + ;; call that precedes the call to `ewoc--adjust', and then changing them back + ;; to nil. + (when (< beg end) + (let (m) + (while (and (= beg (setq m (ewoc--node-start-marker node))) + ;; The "dummy" node `dll' actually holds the marker that + ;; points to the end of the footer, so we check `dll' + ;; *after* reseating the marker. + (progn + (set-marker m end) + (not (eq dll node)))) + (setq node (ewoc--node-right node)))))) + +(defun ewoc--insert-new-node (node data pretty-printer dll) + "Insert before NODE a new node for DATA, displayed by PRETTY-PRINTER. +Fourth arg DLL -- from `(ewoc--dll EWOC)' -- is for internal purposes. +Call PRETTY-PRINTER with point at NODE's start, thus pushing back +NODE and leaving the new node's start there. Return the new node." + (save-excursion + (let ((elemnode (ewoc--node-create + (copy-marker (ewoc--node-start-marker node)) data))) + (setf (ewoc--node-left elemnode) (ewoc--node-left node) + (ewoc--node-right elemnode) node + (ewoc--node-right (ewoc--node-left node)) elemnode + (ewoc--node-left node) elemnode) + (ewoc--refresh-node pretty-printer elemnode dll) + elemnode))) + +(defun ewoc--refresh-node (pp node dll) + "Redisplay the element represented by NODE using the pretty-printer PP." + (let* ((m (ewoc--node-start-marker node)) + (R (ewoc--node-right node)) + (end (ewoc--node-start-marker R)) + (inhibit-read-only t) + (offset (if (= (point) end) + 'end + (when (< m (point) end) + (- (point) m))))) + (save-excursion + ;; First, remove the string from the buffer: + (delete-region m end) + ;; Calculate and insert the string. + (goto-char m) + (funcall pp (ewoc--node-data node)) + (setq end (point)) + (ewoc--adjust m (point) R dll)) + (when offset + (goto-char (if (eq offset 'end) + end + (min (+ m offset) (1- end))))))) + +(defun ewoc--wrap (func) + (lambda (data) + (funcall func data) + (insert "\n"))) + + +;;; =========================================================================== +;;; Public members of the Ewoc package + +;;;###autoload +(defun ewoc-create (pretty-printer &optional header footer nosep) + "Create an empty ewoc. + +The ewoc will be inserted in the current buffer at the current position. + +PRETTY-PRINTER should be a function that takes one argument, an +element, and inserts a string representing it in the buffer (at +point). The string PRETTY-PRINTER inserts may be empty or span +several lines. The PRETTY-PRINTER should use `insert', and not +`insert-before-markers'. + +Optional second and third arguments HEADER and FOOTER are strings, +possibly empty, that will always be present at the top and bottom, +respectively, of the ewoc. + +Normally, a newline is automatically inserted after the header, +the footer and every node's printed representation. Optional +fourth arg NOSEP non-nil inhibits this." + (let* ((dummy-node (ewoc--node-create 'DL-LIST 'DL-LIST)) + (dll (progn (setf (ewoc--node-right dummy-node) dummy-node) + (setf (ewoc--node-left dummy-node) dummy-node) + dummy-node)) + (wrap (if nosep 'identity 'ewoc--wrap)) + (new-ewoc (ewoc--create (current-buffer) + (funcall wrap pretty-printer) + dll)) + (hf-pp (funcall wrap 'insert)) + (pos (point)) + head foot) + (ewoc--set-buffer-bind-dll new-ewoc + ;; Set default values + (unless header (setq header "")) + (unless footer (setq footer "")) + (setf (ewoc--node-start-marker dll) (copy-marker pos) + foot (ewoc--insert-new-node dll footer hf-pp dll) + head (ewoc--insert-new-node foot header hf-pp dll) + (ewoc--hf-pp new-ewoc) hf-pp + (ewoc--footer new-ewoc) foot + (ewoc--header new-ewoc) head)) + ;; Return the ewoc + new-ewoc)) + +(defalias 'ewoc-data 'ewoc--node-data + "Extract the data encapsulated by NODE and return it. + +\(fn NODE)") + +(defun ewoc-set-data (node data) + "Set NODE to encapsulate DATA." + (setf (ewoc--node-data node) data)) + +(defun ewoc-enter-first (ewoc data) + "Enter DATA first in EWOC. +Return the new node." + (ewoc--set-buffer-bind-dll ewoc + (ewoc-enter-after ewoc (ewoc--node-nth dll 0) data))) + +(defun ewoc-enter-last (ewoc data) + "Enter DATA last in EWOC. +Return the new node." + (ewoc--set-buffer-bind-dll ewoc + (ewoc-enter-before ewoc (ewoc--node-nth dll -1) data))) + +(defun ewoc-enter-after (ewoc node data) + "Enter a new element DATA after NODE in EWOC. +Return the new node." + (ewoc--set-buffer-bind-dll ewoc + (ewoc-enter-before ewoc (ewoc--node-next dll node) data))) + +(defun ewoc-enter-before (ewoc node data) + "Enter a new element DATA before NODE in EWOC. +Return the new node." + (ewoc--set-buffer-bind-dll ewoc + (ewoc--insert-new-node node data (ewoc--pretty-printer ewoc) dll))) + +(defun ewoc-next (ewoc node) + "Return the node in EWOC that follows NODE. +Return nil if NODE is nil or the last element." + (when node + (ewoc--filter-hf-nodes + ewoc (ewoc--node-next (ewoc--dll ewoc) node)))) + +(defun ewoc-prev (ewoc node) + "Return the node in EWOC that precedes NODE. +Return nil if NODE is nil or the first element." + (when node + (ewoc--filter-hf-nodes + ewoc (ewoc--node-prev (ewoc--dll ewoc) node)))) + +(defun ewoc-nth (ewoc n) + "Return the Nth node. +N counts from zero. Return nil if there is less than N elements. +If N is negative, return the -(N+1)th last element. +Thus, (ewoc-nth ewoc 0) returns the first node, +and (ewoc-nth ewoc -1) returns the last node. +Use `ewoc-data' to extract the data from the node." + ;; Skip the header (or footer, if n is negative). + (setq n (if (< n 0) (1- n) (1+ n))) + (ewoc--filter-hf-nodes ewoc + (ewoc--node-nth (ewoc--dll ewoc) n))) + +(defun ewoc-map (map-function ewoc &rest args) + "Apply MAP-FUNCTION to all elements in EWOC. +MAP-FUNCTION is applied to the first element first. +If MAP-FUNCTION returns non-nil the element will be refreshed (its +pretty-printer will be called once again). + +Note that the buffer for EWOC will be the current buffer when +MAP-FUNCTION is called. MAP-FUNCTION must restore the current +buffer before it returns, if it changes it. + +If more than two arguments are given, the remaining +arguments will be passed to MAP-FUNCTION." + (ewoc--set-buffer-bind-dll-let* ewoc + ((footer (ewoc--footer ewoc)) + (pp (ewoc--pretty-printer ewoc)) + (node (ewoc--node-nth dll 1))) + (while (not (eq node footer)) + (if (apply map-function (ewoc--node-data node) args) + (ewoc--refresh-node pp node dll)) + (setq node (ewoc--node-next dll node))))) + +(defun ewoc-delete (ewoc &rest nodes) + "Delete NODES from EWOC." + (ewoc--set-buffer-bind-dll-let* ewoc + ((L nil) (R nil) (last (ewoc--last-node ewoc))) + (dolist (node nodes) + ;; If we are about to delete the node pointed at by last-node, + ;; set last-node to nil. + (when (eq last node) + (setf last nil (ewoc--last-node ewoc) nil)) + (delete-region (ewoc--node-start-marker node) + (ewoc--node-start-marker (ewoc--node-next dll node))) + (set-marker (ewoc--node-start-marker node) nil) + (setf L (ewoc--node-left node) + R (ewoc--node-right node) + ;; Link neighbors to each other. + (ewoc--node-right L) R + (ewoc--node-left R) L + ;; Forget neighbors. + (ewoc--node-left node) nil + (ewoc--node-right node) nil)))) + +(defun ewoc-filter (ewoc predicate &rest args) + "Remove all elements in EWOC for which PREDICATE returns nil. +Note that the buffer for EWOC will be the current buffer when PREDICATE +is called. PREDICATE must restore the current buffer before it returns +if it changes it. +The PREDICATE is called with the element as its first argument. If any +ARGS are given they will be passed to the PREDICATE." + (ewoc--set-buffer-bind-dll-let* ewoc + ((node (ewoc--node-nth dll 1)) + (footer (ewoc--footer ewoc)) + (goodbye nil) + (inhibit-read-only t)) + (while (not (eq node footer)) + (unless (apply predicate (ewoc--node-data node) args) + (push node goodbye)) + (setq node (ewoc--node-next dll node))) + (apply 'ewoc-delete ewoc goodbye))) + +(defun ewoc-locate (ewoc &optional pos guess) + "Return the node that POS (a buffer position) is within. +POS may be a marker or an integer. It defaults to point. +GUESS should be a node that it is likely to be near POS. + +If POS points before the first element, the first node is returned. +If POS points after the last element, the last node is returned. +If the EWOC is empty, nil is returned." + (unless pos (setq pos (point))) + (ewoc--set-buffer-bind-dll ewoc + + (cond + ;; Nothing present? + ((eq (ewoc--node-nth dll 1) (ewoc--node-nth dll -1)) + nil) + + ;; Before second elem? + ((< pos (ewoc--node-start-marker (ewoc--node-nth dll 2))) + (ewoc--node-nth dll 1)) + + ;; After one-before-last elem? + ((>= pos (ewoc--node-start-marker (ewoc--node-nth dll -2))) + (ewoc--node-nth dll -2)) + + ;; We now know that pos is within an elem. + (t + ;; Make an educated guess about which of the three known + ;; node'es (the first, the last, or GUESS) is nearest. + (let* ((best-guess (ewoc--node-nth dll 1)) + (distance (abs (- pos (ewoc--node-start-marker best-guess))))) + (when guess + (let ((d (abs (- pos (ewoc--node-start-marker guess))))) + (when (< d distance) + (setq distance d) + (setq best-guess guess)))) + + (let* ((g (ewoc--node-nth dll -1)) ;Check the last elem + (d (abs (- pos (ewoc--node-start-marker g))))) + (when (< d distance) + (setq distance d) + (setq best-guess g))) + + (when (ewoc--last-node ewoc) ;Check "previous". + (let* ((g (ewoc--last-node ewoc)) + (d (abs (- pos (ewoc--node-start-marker g))))) + (when (< d distance) + (setq distance d) + (setq best-guess g)))) + + ;; best-guess is now a "best guess". + ;; Find the correct node. First determine in which direction + ;; it lies, and then move in that direction until it is found. + + (cond + ;; Is pos after the guess? + ((>= pos + (ewoc--node-start-marker best-guess)) + ;; Loop until we are exactly one node too far down... + (while (>= pos (ewoc--node-start-marker best-guess)) + (setq best-guess (ewoc--node-next dll best-guess))) + ;; ...and return the previous node. + (ewoc--node-prev dll best-guess)) + + ;; Pos is before best-guess + (t + (while (< pos (ewoc--node-start-marker best-guess)) + (setq best-guess (ewoc--node-prev dll best-guess))) + best-guess))))))) + +(defun ewoc-invalidate (ewoc &rest nodes) + "Call EWOC's pretty-printer for each element in NODES. +Delete current text first, thus effecting a \"refresh\"." + (ewoc--set-buffer-bind-dll-let* ewoc + ((pp (ewoc--pretty-printer ewoc))) + (dolist (node nodes) + (ewoc--refresh-node pp node dll)))) + +(defun ewoc-goto-prev (ewoc arg) + "Move point to the ARGth previous element in EWOC. +Don't move if we are at the first element, or if EWOC is empty. +Return the node we moved to." + (ewoc--set-buffer-bind-dll-let* ewoc + ((node (ewoc-locate ewoc (point)))) + (when node + ;; If we were past the last element, first jump to it. + (when (>= (point) (ewoc--node-start-marker (ewoc--node-right node))) + (setq arg (1- arg))) + (while (and node (> arg 0)) + (setq arg (1- arg)) + (setq node (ewoc--node-prev dll node))) + ;; Never step above the first element. + (unless (ewoc--filter-hf-nodes ewoc node) + (setq node (ewoc--node-nth dll 1))) + (ewoc-goto-node ewoc node)))) + +(defun ewoc-goto-next (ewoc arg) + "Move point to the ARGth next element in EWOC. +Return the node (or nil if we just passed the last node)." + (ewoc--set-buffer-bind-dll-let* ewoc + ((node (ewoc-locate ewoc (point)))) + (while (and node (> arg 0)) + (setq arg (1- arg)) + (setq node (ewoc--node-next dll node))) + ;; Never step below the first element. + ;; (unless (ewoc--filter-hf-nodes ewoc node) + ;; (setq node (ewoc--node-nth dll -2))) + (unless node + (error "No next")) + (ewoc-goto-node ewoc node))) + +(defun ewoc-goto-node (ewoc node) + "Move point to NODE in EWOC." + (with-current-buffer (ewoc--buffer ewoc) + (goto-char (ewoc--node-start-marker node)) + (if goal-column (move-to-column goal-column)) + (setf (ewoc--last-node ewoc) node))) + +(defun ewoc-refresh (ewoc) + "Refresh all data in EWOC. +The pretty-printer that was specified when the EWOC was created +will be called for all elements in EWOC. +Note that `ewoc-invalidate' is more efficient if only a small +number of elements needs to be refreshed." + (ewoc--set-buffer-bind-dll-let* ewoc + ((footer (ewoc--footer ewoc))) + (let ((inhibit-read-only t)) + (delete-region (ewoc--node-start-marker (ewoc--node-nth dll 1)) + (ewoc--node-start-marker footer)) + (goto-char (ewoc--node-start-marker footer)) + (let ((pp (ewoc--pretty-printer ewoc)) + (node (ewoc--node-nth dll 1))) + (while (not (eq node footer)) + (set-marker (ewoc--node-start-marker node) (point)) + (funcall pp (ewoc--node-data node)) + (setq node (ewoc--node-next dll node))))) + (set-marker (ewoc--node-start-marker footer) (point)))) + +(defun ewoc-collect (ewoc predicate &rest args) + "Select elements from EWOC using PREDICATE. +Return a list of all selected data elements. +PREDICATE is a function that takes a data element as its first +argument. The elements on the returned list will appear in the +same order as in the buffer. You should not rely on the order of +calls to PREDICATE. +Note that the buffer the EWOC is displayed in is the current +buffer when PREDICATE is called. PREDICATE must restore it if it +changes it. +If more than two arguments are given the +remaining arguments will be passed to PREDICATE." + (ewoc--set-buffer-bind-dll-let* ewoc + ((header (ewoc--header ewoc)) + (node (ewoc--node-nth dll -2)) + result) + (while (not (eq node header)) + (if (apply predicate (ewoc--node-data node) args) + (push (ewoc--node-data node) result)) + (setq node (ewoc--node-prev dll node))) + result)) + +(defun ewoc-buffer (ewoc) + "Return the buffer that is associated with EWOC. +Return nil if the buffer has been deleted." + (let ((buf (ewoc--buffer ewoc))) + (when (buffer-name buf) buf))) + +(defun ewoc-get-hf (ewoc) + "Return a cons cell containing the (HEADER . FOOTER) of EWOC." + (cons (ewoc--node-data (ewoc--header ewoc)) + (ewoc--node-data (ewoc--footer ewoc)))) + +(defun ewoc-set-hf (ewoc header footer) + "Set the HEADER and FOOTER of EWOC." + (ewoc--set-buffer-bind-dll-let* ewoc + ((head (ewoc--header ewoc)) + (foot (ewoc--footer ewoc)) + (hf-pp (ewoc--hf-pp ewoc))) + (setf (ewoc--node-data head) header + (ewoc--node-data foot) footer) + (ewoc--refresh-node hf-pp head dll) + (ewoc--refresh-node hf-pp foot dll))) + + +(provide 'ewoc) + +;; Local Variables: +;; eval: (put 'ewoc--set-buffer-bind-dll 'lisp-indent-hook 1) +;; eval: (put 'ewoc--set-buffer-bind-dll-let* 'lisp-indent-hook 2) +;; End: + +;;; ewoc.el ends here diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el new file mode 100644 index 00000000..f3ddf9f8 --- /dev/null +++ b/lisp/emacs-lisp/find-func.el @@ -0,0 +1,841 @@ +;;; find-func.el --- find the definition of the Emacs Lisp function near point -*- lexical-binding:t -*- + +;; Copyright (C) 1997, 1999, 2001-2024 Free Software Foundation, Inc. + +;; Author: Jens Petersen +;; Keywords: emacs-lisp, functions, variables +;; Created: 97/07/25 + +;; 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 GNU Emacs. If not, see . + +;;; Commentary: +;; +;; The funniest thing about this is that I can't imagine why a package +;; so obviously useful as this hasn't been written before!! +;; ;;; find-func +;; (find-function-mode 1) +;; +;; or just: +;; +;; (load "find-func") +;; +;; if you don't like the given keybindings and away you go! It does +;; pretty much what you would expect, putting the cursor at the +;; definition of the function or variable at point. +;; +;; The code started out from `describe-function', `describe-key' +;; ("help.el") and `fff-find-loaded-emacs-lisp-function' (Noah Friedman's +;; "fff.el"). + +;;; Code: + +;;; User variables: + +(defgroup find-function nil + "Finds the definition of the Emacs Lisp symbol near point." +;; :prefix "find-function" + :group 'lisp) + +(defconst find-function-space-re "\\(?:\\s-\\|\n\\|;.*\n\\)+") + +(defcustom find-function-regexp + ;; Match things like (defun foo ...), (defmacro foo ...), + ;; (define-skeleton foo ...), (define-generic-mode 'foo ...), + ;; (define-derived-mode foo ...), (define-minor-mode foo) + (concat + "^\\s-*(\\(def\\(ine-skeleton\\|ine-generic-mode\\|ine-derived-mode\\|\ +ine\\(?:-global\\)?-minor-mode\\|ine-compilation-mode\\|un-cvs-mode\\|\ +foo\\|\\(?:[^icfgv]\\|g[^r]\\)\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\ +cl-\\(?:defun\\|defmethod\\|defgeneric\\)\\|\ +transient-define-\\(?:prefix\\|suffix\\|infix\\|argument\\)\\|\ +menu-bar-make-toggle\\|menu-bar-make-toggle-command\\)" + find-function-space-re + "\\('\\|(quote \\)?%s\\(\\s-\\|$\\|[()]\\)") + "The regexp used by `find-function' to search for a function definition. +Note it must contain a `%s' at the place where `format' +should insert the function name. The default value avoids `defconst', +`defgroup', `defvar', `defface'. + +Please send improvements and fixes to the maintainer." + :type 'regexp + :group 'find-function + :version "21.1") + +(defcustom find-variable-regexp + (concat + "^\\s-*(\\(def[^fumag]\\(\\w\\|\\s_\\)+\\*?\\|\ +easy-mmode-def\\(map\\|syntax\\)\\|easy-menu-define\\)" + find-function-space-re + "%s\\(\\s-\\|$\\)") + "The regexp used by `find-variable' to search for a variable definition. +Note it must contain a `%s' at the place where `format' +should insert the variable name. The default value +avoids `defun', `defmacro', `defalias', `defadvice', `defgroup', `defface'. + +Please send improvements and fixes to the maintainer." + :type 'regexp + :group 'find-function + :version "21.1") + +(defcustom find-face-regexp + (concat"^\\s-*(defface" find-function-space-re "%s\\(\\s-\\|$\\)") + "The regexp used by `find-face' to search for a face definition. +Note it must contain a `%s' at the place where `format' +should insert the face name. + +Please send improvements and fixes to the maintainer." + :type 'regexp + :group 'find-function + :version "22.1") + +(defcustom find-feature-regexp + (concat ";;; Code:") + "Regexp used by `xref-find-definitions' when searching for a feature definition. +Note it may contain up to one `%s' at the place where `format' +should insert the feature name." + ;; We search for ";;; Code" rather than (feature '%s) because the + ;; former is near the start of the code, and the latter is very + ;; uninteresting. If the regexp is not found, just goes to + ;; (point-min), which is acceptable in this case. + :type 'regexp + :group 'xref + :version "25.1") + +(defcustom find-alias-regexp + "(defalias +'%s" + "The regexp used by `xref-find-definitions' to search for an alias definition. +Note it must contain a `%s' at the place where `format' +should insert the feature name." + :type 'regexp + :group 'xref + :version "25.1") + +(defcustom find-ert-deftest-regexp + "(ert-deftest +'%s" + "The regexp used to search for an `ert-deftest' definition. +Note it must contain a `%s' at the place where `format' +should insert the feature name." + :type 'regexp + :group 'xref + :version "29.1") + +(defun find-function--defface (symbol) + (catch 'found + (while (re-search-forward (format find-face-regexp symbol) nil t) + (unless (ppss-comment-or-string-start + (save-excursion (syntax-ppss (match-beginning 0)))) + ;; We're not in a comment or a string. + (throw 'found t))))) + +(defvar find-function-regexp-alist + '((nil . find-function-regexp) + (defvar . find-variable-regexp) + (defface . find-function--defface) + (feature . find-feature-regexp) + (defalias . find-alias-regexp) + (ert-deftest . find-ert-deftest-regexp)) + "Alist mapping definition types into regexp variables. +Each regexp variable's value should actually be a format string +to be used to substitute the desired symbol name into the regexp. +Instead of regexp variable, types can be mapped to functions as well, +in which case the function is called with one argument (the object +we're looking for) and it should search for it.") +(put 'find-function-regexp-alist 'risky-local-variable t) + +(define-obsolete-variable-alias 'find-function-source-path + 'find-library-source-path "28.1") +(defcustom find-library-source-path nil + "The default list of directories where `find-library' searches. + +If this variable is nil then `find-library' searches `load-path' by +default." + :type '(repeat directory) + :group 'find-function + :version "28.1") + +(defcustom find-function-recenter-line 1 + "The window line-number from which to start displaying a symbol definition. +A value of nil implies center the beginning of the definition. +See `find-function' and `find-variable'." + :type '(choice (const :tag "Center" nil) + integer) + :group 'find-function + :version "20.3") + +(defcustom find-function-after-hook nil + "Hook run after finding symbol definition. + +See the functions `find-function' and `find-variable'." + :type 'hook + :group 'find-function + :version "20.3") + +(defcustom find-library-include-other-files t + "If non-nil, `read-library-name' will also include non-library files. +This affects commands like `read-library'. + +If nil, only library files (i.e., \".el\" files) will be offered +for completion." + :type 'boolean + :version "29.1" + :group 'find-function) + +;;; Functions: + +(defun find-library-suffixes () + (let ((suffixes nil)) + (dolist (suffix (get-load-suffixes) (nreverse suffixes)) + (unless (string-match "elc" suffix) (push suffix suffixes))))) + +(defun find-library--load-name (library) + (let ((name library)) + (dolist (dir load-path) + (let ((rel (file-relative-name library dir))) + (if (and (not (string-match "\\`\\.\\./" rel)) + (< (length rel) (length name))) + (setq name rel)))) + (unless (equal name library) name))) + +(defvar comp-eln-to-el-h) + +(defun find-library-name (library) + "Return the absolute file name of the Emacs Lisp source of LIBRARY. +LIBRARY should be a string (the name of the library)." + ;; If the library is byte-compiled, try to find a source library by + ;; the same name. + (cond + ((string-match "\\.el\\(c\\(\\..*\\)?\\)\\'" library) + (setq library (replace-match "" t t library))) + ((string-match "\\.eln\\'" library) + (setq library (gethash (file-name-nondirectory library) comp-eln-to-el-h)))) + (or + (locate-file library + (or find-library-source-path load-path) + (find-library-suffixes)) + (locate-file library + (or find-library-source-path load-path) + load-file-rep-suffixes) + (when (file-name-absolute-p library) + (let ((rel (find-library--load-name library))) + (when rel + (or + (locate-file rel + (or find-library-source-path load-path) + (find-library-suffixes)) + (locate-file rel + (or find-library-source-path load-path) + load-file-rep-suffixes))))) + (find-library--from-load-history library) + (signal 'file-error (list "Can't find library" library)))) + +(defun find-library--from-load-history (library) + ;; In `load-history', the file may be ".elc", ".el", ".el.gz", and + ;; LIBRARY may be "foo.el" or "foo". + (let ((load-re + (concat "\\(" (regexp-quote (file-name-sans-extension library)) "\\)" + (regexp-opt (get-load-suffixes)) "\\'")) + (alist load-history) + elt file found) + (while (and alist (null found)) + (setq elt (car alist) + alist (cdr alist) + file (car elt) + found (and (stringp file) (string-match load-re file) + (let ((dir (substring file 0 (match-beginning 1))) + (basename (match-string 1 file))) + (locate-file basename (list dir) + (find-library-suffixes)))))) + found)) + +(defvar find-function-C-source-directory + (let ((dir (expand-file-name "src" source-directory))) + (if (file-accessible-directory-p dir) dir)) + "Directory where the C source files of Emacs can be found. +If nil, do not try to find the source code of functions and variables +defined in C.") + +(declare-function ad-get-advice-info "advice" (function)) + +(defun find-function-advised-original (func) + "Return the original function definition of an advised function FUNC. +If FUNC is not a symbol, return it. Else, if it's not advised, +return the symbol's function definition." + (or (and (symbolp func) + (advice--cd*r (symbol-function func))) + func)) + +(defun find-function-C-source (fun-or-var file type) + "Find the source location where FUN-OR-VAR is defined in FILE. +TYPE should be nil to find a function, or `defvar' to find a variable." + (let ((dir (or find-function-C-source-directory + (read-directory-name "Emacs C source dir: " nil nil t)))) + (setq file (expand-file-name file dir)) + (if (file-readable-p file) + (if (null find-function-C-source-directory) + (setq find-function-C-source-directory dir)) + (error "The C source file %s is not available" + (file-name-nondirectory file)))) + (unless type + ;; Either or both an alias and its target might be advised. + (setq fun-or-var (find-function-advised-original + (indirect-function + (find-function-advised-original fun-or-var))))) + (with-current-buffer (find-file-noselect file) + (goto-char (point-min)) + (unless (re-search-forward + (if type + (concat "DEFVAR[A-Z_]*[ \t\n]*([ \t\n]*\"" + (regexp-quote (symbol-name fun-or-var)) + "\"") + (concat "DEFUN[ \t\n]*([ \t\n]*\"" + (regexp-quote (subr-name (advice--cd*r fun-or-var))) + "\"")) + nil t) + (error "Can't find source for %s" fun-or-var)) + (cons (current-buffer) (match-beginning 0)))) + +;;;###autoload +(defun find-library (library) + "Find the Emacs Lisp source of LIBRARY. + +Interactively, prompt for LIBRARY using the one at or near point. + +This function searches `find-library-source-path' if non-nil, and +`load-path' otherwise. + +See the `find-library-include-other-files' user option for +customizing the candidate completions." + (interactive (list (read-library-name))) + (prog1 + (switch-to-buffer (find-file-noselect (find-library-name library))) + (run-hooks 'find-function-after-hook))) + +(defvar find-function--read-history-library nil) + +;;;###autoload +(defun read-library-name () + "Read and return a library name, defaulting to the one near point. + +A library name is the filename of an Emacs Lisp library located +in a directory under `load-path' (or `find-library-source-path', +if non-nil)." + (let* ((dirs (or find-library-source-path load-path)) + (suffixes (find-library-suffixes)) + (def (if (eq (function-called-at-point) 'require) + ;; `function-called-at-point' may return 'require + ;; with `point' anywhere on this line. So wrap the + ;; `save-excursion' below in a `condition-case' to + ;; avoid reporting a scan-error here. + (condition-case nil + (save-excursion + (backward-up-list) + (forward-char) + (forward-sexp 2) + (thing-at-point 'symbol)) + (error nil)) + (thing-at-point 'symbol)))) + (if find-library-include-other-files + (let ((table (apply-partially #'locate-file-completion-table + dirs suffixes))) + (when (and def (not (test-completion def table))) + (setq def nil)) + (completing-read (format-prompt "Library name" def) + table nil nil nil + 'find-function--read-history-library def)) + (let ((files (read-library-name--find-files dirs suffixes))) + (when (and def (not (member def files))) + (setq def nil)) + (completing-read (format-prompt "Library name" def) + files nil t nil + 'find-function--read-history-library def))))) + +(defun read-library-name--find-files (dirs suffixes) + "Return a list of all files in DIRS that match SUFFIXES." + (let ((files nil) + (regexp (concat (regexp-opt suffixes) "\\'"))) + (dolist (dir dirs) + (dolist (file (ignore-errors (directory-files dir nil regexp t))) + (and (string-match regexp file) + (push (substring file 0 (match-beginning 0)) files)))) + files)) + +;;;###autoload +(defun find-library-other-window (library) + "Find the Emacs Lisp source of LIBRARY in another window. + +See `find-library' for more details." + (interactive (list (read-library-name))) + (prog1 + (switch-to-buffer-other-window (find-file-noselect + (find-library-name library))) + (run-hooks 'find-function-after-hook))) + +;;;###autoload +(defun find-library-other-frame (library) + "Find the Emacs Lisp source of LIBRARY in another frame. + +See `find-library' for more details." + (interactive (list (read-library-name))) + (prog1 + (switch-to-buffer-other-frame (find-file-noselect + (find-library-name library))) + (run-hooks 'find-function-after-hook))) + +;;;###autoload +(defun find-function-search-for-symbol (symbol type library) + "Search for SYMBOL's definition of type TYPE in LIBRARY. +Visit the library in a buffer, and return a cons cell (BUFFER . POSITION), +or just (BUFFER . nil) if the definition can't be found in the file. + +If TYPE is nil, look for a function definition. +Otherwise, TYPE specifies the kind of definition, +and it is interpreted via `find-function-regexp-alist'. +The search is done in the source for library LIBRARY." + (if (null library) + (error "Don't know where `%s' is defined" symbol)) + ;; Some functions are defined as part of the construct + ;; that defines something else. + (while (and (symbolp symbol) (get symbol 'definition-name)) + (setq symbol (get symbol 'definition-name))) + (if (string-match "\\`src/\\(.*\\.\\(c\\|m\\)\\)\\'" library) + (find-function-C-source symbol (match-string 1 library) type) + (when (string-match "\\.el\\(c\\)\\'" library) + (setq library (substring library 0 (match-beginning 1)))) + ;; Strip extension from .emacs.el to make sure symbol is searched in + ;; .emacs too. + (when (string-match "\\.emacs\\(.el\\)\\'" library) + (setq library (substring library 0 (match-beginning 1)))) + (let* ((filename (find-library-name library)) + (regexp-symbol (cdr (assq type find-function-regexp-alist)))) + (with-current-buffer (find-file-noselect filename) + (let ((regexp (if (functionp regexp-symbol) regexp-symbol + (format (symbol-value regexp-symbol) + ;; Entry for ` (backquote) macro in loaddefs.el, + ;; (defalias (quote \`)..., has a \ but + ;; (symbol-name symbol) doesn't. Add an + ;; optional \ to catch this. + (concat "\\\\?" + (regexp-quote (symbol-name symbol)))))) + (case-fold-search)) + (save-restriction + (widen) + (with-syntax-table emacs-lisp-mode-syntax-table + (goto-char (point-min)) + (if (if (functionp regexp) + (funcall regexp symbol) + (or (re-search-forward regexp nil t) + ;; `regexp' matches definitions using known forms like + ;; `defun', or `defvar'. But some functions/variables + ;; are defined using special macros (or functions), so + ;; if `regexp' can't find the definition, we look for + ;; something of the form "(SOMETHING ...)". + ;; This fails to distinguish function definitions from + ;; variable declarations (or even uses thereof), but is + ;; a good pragmatic fallback. + (re-search-forward + (concat "^([^ ]+" find-function-space-re "['(]?" + (regexp-quote (symbol-name symbol)) + "\\_>") + nil t))) + (progn + (beginning-of-line) + (cons (current-buffer) (point))) + ;; If the regexp search didn't find the location of + ;; the symbol (for example, because it is generated by + ;; a macro), try a slightly more expensive search that + ;; expands macros until it finds the symbol. + (cons (current-buffer) + (find-function--search-by-expanding-macros + (current-buffer) symbol type)))))))))) + +(defun find-function--try-macroexpand (form) + "Try to macroexpand FORM in full or partially. +This is a best-effort operation in which if macroexpansion fails, +this function returns FORM as is." + (ignore-errors + (or + (macroexpand-all form) + (macroexpand-1 form) + form))) + +(defun find-function--any-subform-p (form pred) + "Walk FORM and apply PRED to its subexpressions. +Return t if any PRED returns t." + (cond + ((not (consp form)) nil) + ((funcall pred form) t) + (t + (let ((left-child (car form)) + (right-child (cdr form))) + (or + (find-function--any-subform-p left-child pred) + (find-function--any-subform-p right-child pred)))))) + +(defun find-function--search-by-expanding-macros (buf symbol type) + "Expand macros in BUF to search for the definition of SYMBOL of TYPE." + (catch 'found + (with-current-buffer buf + (save-excursion + (goto-char (point-min)) + (condition-case nil + (while t + (let ((form (read (current-buffer))) + (expected-symbol-p + (lambda (form) + (cond + ((null type) + ;; Check if a given form is a `defalias' to + ;; SYM, the function name we are searching + ;; for. All functions in Emacs Lisp + ;; ultimately expand to a `defalias' form + ;; after several steps of macroexpansion. + (and (eq (car-safe form) 'defalias) + (equal (car-safe (cdr form)) + `(quote ,symbol)))) + ((eq type 'defvar) + ;; Variables generated by macros ultimately + ;; expand to `defvar'. + (and (eq (car-safe form) 'defvar) + (eq (car-safe (cdr form)) symbol))) + (t nil))))) + (when (find-function--any-subform-p + (find-function--try-macroexpand form) + expected-symbol-p) + ;; We want to return the location at the beginning + ;; of the macro, so move back one sexp. + (throw 'found (progn (backward-sexp) (point)))))) + (end-of-file nil)))))) + +(defun find-function-library (function &optional lisp-only verbose) + "Return the pair (ORIG-FUNCTION . LIBRARY) for FUNCTION. + +ORIG-FUNCTION is the original name, after resolving aliases. +LIBRARY is an absolute file name, a relative +file name inside the C sources directory, or a name of an +autoloaded feature. + +If ORIG-FUNCTION is a built-in function and LISP-ONLY is non-nil, +signal an error. + +If VERBOSE is non-nil, and FUNCTION is an alias, display a +message about the whole chain of aliases." + (let ((def (when (symbolp function) + (or (fboundp function) + (signal 'void-function (list function))) + (find-function-advised-original function))) + aliases) + ;; FIXME for completeness, it might be nice to print something like: + ;; foo (which is advised), which is an alias for bar (which is advised). + (while (and def (symbolp def)) + (or (eq def function) + (not verbose) + (setq aliases (if aliases + (concat aliases + (format-message + ", which is an alias for `%s'" + (symbol-name def))) + (format-message "`%s' is an alias for `%s'" + function (symbol-name def))))) + (setq function (find-function-advised-original function) + def (find-function-advised-original function))) + (if aliases + (message "%s" aliases)) + (cons function + (cond + ((autoloadp def) (nth 1 def)) + ((subr-primitive-p def) + (if lisp-only + (error "%s is a built-in function" function)) + (help-C-file-name def 'subr)) + ((symbol-file function 'defun)))))) + +;;;###autoload +(defun find-function-noselect (function &optional lisp-only) + "Return a pair (BUFFER . POINT) pointing to the definition of FUNCTION. + +Finds the source file containing the definition of FUNCTION +in a buffer and the point of the definition. The buffer is +not selected. If the function definition can't be found in +the buffer, returns (BUFFER). + +If FUNCTION is a built-in function, this function normally +attempts to find it in the Emacs C sources; however, if LISP-ONLY +is non-nil, signal an error instead." + (if (not function) + (error "You didn't specify a function")) + (let ((func-lib (find-function-library function lisp-only t))) + (find-function-search-for-symbol (car func-lib) nil (cdr func-lib)))) + +(defvar find-function--read-history-function nil) +(defvar find-function--read-history-variable nil) +(defvar find-function--read-history-face nil) + +(defun find-function-read (&optional type) + "Read and return an interned symbol, defaulting to the one near point. + +If TYPE is nil, insist on a symbol with a function definition. +Otherwise TYPE should be `defvar' or `defface'. +If TYPE is nil, defaults using `function-called-at-point', +otherwise uses `variable-at-point'." + (let* ((symb1 (cond ((null type) (function-called-at-point)) + ((eq type 'defvar) (variable-at-point)) + ((eq type 'defface) (face-at-point t)) + (t (variable-at-point t)))) + (symb (unless (eq symb1 0) symb1)) + (predicate (cdr (assq type '((nil . fboundp) + (defvar . boundp) + (defface . facep))))) + (prompt-type (cdr (assq type '((nil . "function") + (defvar . "variable") + (defface . "face"))))) + (enable-recursive-minibuffers t)) + (list (intern (completing-read + (format-prompt "Find %s" symb prompt-type) + obarray predicate + 'lambda nil + (intern (format "find-function--read-history-%s" prompt-type)) + (and symb (symbol-name symb))))))) + +(defun find-function-do-it (symbol type switch-fn) + "Find Emacs Lisp SYMBOL in a buffer and display it. +TYPE is nil to search for a function definition, +or else `defvar' or `defface'. + +The variable `find-function-recenter-line' controls how +to recenter the display. SWITCH-FN is the function to call +to display and select the buffer. +See also `find-function-after-hook'. + +Set mark before moving, if the buffer already existed." + (let* ((orig-point (point)) + (orig-buffers (buffer-list)) + (buffer-point (save-excursion + (find-definition-noselect symbol type))) + (new-buf (car buffer-point)) + (new-point (cdr buffer-point))) + (when buffer-point + (when (memq new-buf orig-buffers) + (push-mark orig-point)) + (funcall switch-fn new-buf) + (when new-point (goto-char new-point)) + (recenter find-function-recenter-line) + (run-hooks 'find-function-after-hook)))) + +;;;###autoload +(defun find-function (function) + "Find the definition of the FUNCTION near point. + +Finds the source file containing the definition of the function +near point (selected by `function-called-at-point') in a buffer and +places point before the definition. +Set mark before moving, if the buffer already existed. + +See also `find-function-recenter-line' and `find-function-after-hook'." + (interactive (find-function-read)) + (find-function-do-it function nil 'switch-to-buffer)) + +;;;###autoload +(defun find-function-other-window (function) + "Find, in another window, the definition of FUNCTION near point. + +See `find-function' for more details." + (interactive (find-function-read)) + (find-function-do-it function nil 'switch-to-buffer-other-window)) + +;;;###autoload +(defun find-function-other-frame (function) + "Find, in another frame, the definition of FUNCTION near point. + +See `find-function' for more details." + (interactive (find-function-read)) + (find-function-do-it function nil 'switch-to-buffer-other-frame)) + +;;;###autoload +(defun find-variable-noselect (variable &optional file) + "Return a pair `(BUFFER . POINT)' pointing to the definition of VARIABLE. + +Finds the library containing the definition of VARIABLE in a buffer and +the point of the definition. The buffer is not selected. +If the variable's definition can't be found in the buffer, return (BUFFER)." + (if (not variable) + (error "You didn't specify a variable") + (let ((library (or file + (symbol-file variable 'defvar) + (help-C-file-name variable 'var)))) + (find-function-search-for-symbol variable 'defvar library)))) + +;;;###autoload +(defun find-variable (variable) + "Find the definition of the VARIABLE at or before point. + +Finds the library containing the definition of the variable +near point (selected by `variable-at-point') in a buffer and +places point before the definition. + +Set mark before moving, if the buffer already existed. + +See also `find-function-recenter-line' and `find-function-after-hook'." + (interactive (find-function-read 'defvar)) + (find-function-do-it variable 'defvar 'switch-to-buffer)) + +;;;###autoload +(defun find-variable-other-window (variable) + "Find, in another window, the definition of VARIABLE near point. + +See `find-variable' for more details." + (interactive (find-function-read 'defvar)) + (find-function-do-it variable 'defvar 'switch-to-buffer-other-window)) + +;;;###autoload +(defun find-variable-other-frame (variable) + "Find, in another frame, the definition of VARIABLE near point. + +See `find-variable' for more details." + (interactive (find-function-read 'defvar)) + (find-function-do-it variable 'defvar 'switch-to-buffer-other-frame)) + +;;;###autoload +(defun find-definition-noselect (symbol type &optional file) + "Return a pair `(BUFFER . POINT)' pointing to the definition of SYMBOL. +If the definition can't be found in the buffer, return (BUFFER). +TYPE says what type of definition: nil for a function, `defvar' for a +variable, `defface' for a face. This function does not switch to the +buffer nor display it." + (cond + ((not symbol) + (error "You didn't specify a symbol")) + ((null type) + (find-function-noselect symbol)) + ((eq type 'defvar) + (find-variable-noselect symbol file)) + (t + (let ((library (or file (symbol-file symbol type)))) + (find-function-search-for-symbol symbol type library))))) + +;; For symmetry, this should be called find-face; but some programs +;; assume that, if that name is defined, it means something else. +;;;###autoload +(defun find-face-definition (face) + "Find the definition of FACE. FACE defaults to the name near point. + +Finds the Emacs Lisp library containing the definition of the face +near point (selected by `variable-at-point') in a buffer and +places point before the definition. + +Set mark before moving, if the buffer already existed. + +See also `find-function-recenter-line' and `find-function-after-hook'." + (interactive (find-function-read 'defface)) + (find-function-do-it face 'defface 'switch-to-buffer)) + +(defun find-function-on-key-do-it (key find-fn) + "Find the function that KEY invokes. KEY is a string. +Set mark before moving, if the buffer already existed. + +FIND-FN is the function to call to navigate to the function." + (let (defn) + (save-excursion + (let* ((event (and (eventp key) (aref key 0))) ; Null event OK below. + (start (event-start event)) + (modifiers (event-modifiers event)) + (window (and (or (memq 'click modifiers) (memq 'down modifiers) + (memq 'drag modifiers)) + (posn-window start)))) + ;; For a mouse button event, go to the button it applies to + ;; to get the right key bindings. And go to the right place + ;; in case the keymap depends on where you clicked. + (when (windowp window) + (set-buffer (window-buffer window)) + (goto-char (posn-point start))) + (setq defn (key-binding key)))) + (let ((key-desc (key-description key))) + (if (or (null defn) (integerp defn)) + (message "%s is unbound" key-desc) + (if (consp defn) + (message "%s runs %s" key-desc (prin1-to-string defn)) + (funcall find-fn defn)))))) + +;;;###autoload +(defun find-function-on-key (key) + "Find the function that KEY invokes. KEY is a string. +Set mark before moving, if the buffer already existed." + (interactive "kFind function on key: ") + (find-function-on-key-do-it key #'find-function)) + +;;;###autoload +(defun find-function-on-key-other-window (key) + "Find, in the other window, the function that KEY invokes. +See `find-function-on-key'." + (interactive "kFind function on key: ") + (find-function-on-key-do-it key #'find-function-other-window)) + +;;;###autoload +(defun find-function-on-key-other-frame (key) + "Find, in the other frame, the function that KEY invokes. +See `find-function-on-key'." + (interactive "kFind function on key: ") + (find-function-on-key-do-it key #'find-function-other-frame)) + +;;;###autoload +(defun find-function-at-point () + "Find directly the function at point in the other window." + (interactive) + (let ((symb (function-called-at-point))) + (when symb + (find-function-other-window symb)))) + +;;;###autoload +(defun find-variable-at-point () + "Find directly the variable at point in the other window." + (interactive) + (let ((symb (variable-at-point))) + (when (and symb (not (equal symb 0))) + (find-variable-other-window symb)))) + +;;;###autoload +(define-minor-mode find-function-mode + "Enable some key bindings for the `find-function' family of functions." + :group 'find-function :version "31.1" :global t :lighter nil + ;; For compatibility with the historical behavior of the old + ;; `find-function-setup-keys', define our bindings at the precedence + ;; level of the global map. + :keymap nil + (pcase-dolist (`(,map ,key ,cmd) + `((,ctl-x-map "F" find-function) + (,ctl-x-4-map "F" find-function-other-window) + (,ctl-x-5-map "F" find-function-other-frame) + (,ctl-x-map "K" find-function-on-key) + (,ctl-x-4-map "K" find-function-on-key-other-window) + (,ctl-x-5-map "K" find-function-on-key-other-frame) + (,ctl-x-map "V" find-variable) + (,ctl-x-4-map "V" find-variable-other-window) + (,ctl-x-5-map "V" find-variable-other-frame) + (,ctl-x-map "L" find-library) + (,ctl-x-4-map "L" find-library-other-window) + (,ctl-x-5-map "L" find-library-other-frame))) + (if find-function-mode + (keymap-set map key cmd) + (keymap-unset map key t)))) + +;;;###autoload +(defun find-function-setup-keys () + "Turn on `find-function-mode', which see." + (find-function-mode 1)) +(make-obsolete 'find-function-setup-keys 'find-function-mode "31.1") + +(provide 'find-func) + +;;; find-func.el ends here diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el new file mode 100644 index 00000000..d3d71a36 --- /dev/null +++ b/lisp/emacs-lisp/map.el @@ -0,0 +1,647 @@ +;;; map.el --- Map manipulation functions -*- lexical-binding: t; -*- + +;; Copyright (C) 2015-2024 Free Software Foundation, Inc. + +;; Author: Nicolas Petton +;; Maintainer: emacs-devel@gnu.org +;; Keywords: extensions, lisp +;; Version: 3.3.1 +;; Package-Requires: ((emacs "26")) + +;; This is a GNU ELPA :core package. Avoid functionality that is not +;; compatible with the version of Emacs recorded above. + +;; 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 . + +;;; Commentary: + +;; map.el provides generic map-manipulation functions that work on +;; alists, plists, hash-tables, and arrays. All functions are +;; prefixed with "map-". +;; +;; Functions taking a predicate or iterating over a map using a +;; function take the function as their first argument. All other +;; functions take the map as their first argument. + +;; TODO: +;; - Add support for char-tables +;; - Maybe add support for gv? +;; - See if we can integrate text-properties +;; - A macro similar to let-alist but working on any type of map could +;; be really useful + +;;; Code: + +(require 'seq) +(eval-when-compile (require 'cl-lib)) + +(pcase-defmacro map (&rest args) + "Build a `pcase' pattern matching map elements. + +ARGS is a list of elements to be matched in the map. + +Each element of ARGS can be of the form (KEY PAT [DEFAULT]), +which looks up KEY in the map and matches the associated value +against `pcase' pattern PAT. DEFAULT specifies the fallback +value to use when KEY is not present in the map. If omitted, it +defaults to nil. Both KEY and DEFAULT are evaluated. + +Each element can also be a SYMBOL, which is an abbreviation of +a (KEY PAT) tuple of the form (\\='SYMBOL SYMBOL). When SYMBOL +is a keyword, it is an abbreviation of the form (:SYMBOL SYMBOL), +useful for binding plist values. + +An element of ARGS fails to match if PAT does not match the +associated value or the default value. The overall pattern fails +to match if any element of ARGS fails to match." + `(and (pred mapp) + ,@(map--make-pcase-bindings args))) + +(defmacro map-let (keys map &rest body) + "Bind the variables in KEYS to the elements of MAP then evaluate BODY. + +KEYS can be a list of symbols, in which case each element will be +bound to the looked up value in MAP. + +KEYS can also be a list of (KEY VARNAME [DEFAULT]) sublists, in +which case KEY and DEFAULT are unquoted forms. + +MAP can be an alist, plist, hash-table, or array." + (declare (indent 2) + (debug ((&rest &or symbolp ([form symbolp &optional form])) + form body))) + `(pcase-let ((,(map--make-pcase-patterns keys) ,map)) + ,@body)) + +(define-error 'map-not-inplace "Cannot modify map in-place") + +(defsubst map--plist-p (list) + "Return non-nil if LIST is the start of a nonempty plist map." + (and (consp list) (atom (car list)))) + +(defconst map--plist-has-predicate + (condition-case nil + (with-no-warnings (plist-get () nil #'eq) t) + (wrong-number-of-arguments)) + "Non-nil means `plist-get' & co. accept a predicate in Emacs 29+. +Note that support for this predicate in map.el is patchy and +deprecated.") + +(defun map--plist-member-1 (plist prop &optional predicate) + "Compatibility shim for the PREDICATE argument of `plist-member'. +Assumes non-nil PLIST satisfies `map--plist-p'." + (if (or (memq predicate '(nil eq)) (null plist)) + (plist-member plist prop) + (let ((tail plist) found) + (while (and (not (setq found (funcall predicate (car tail) prop))) + (consp (setq tail (cdr tail))) + (consp (setq tail (cdr tail))))) + (and tail (not found) + (signal 'wrong-type-argument `(plistp ,plist))) + tail))) + +(defalias 'map--plist-member + (if map--plist-has-predicate #'plist-member #'map--plist-member-1) + "Compatibility shim for `plist-member' in Emacs 29+. +\n(fn PLIST PROP &optional PREDICATE)") + +(defun map--plist-put-1 (plist prop val &optional predicate) + "Compatibility shim for the PREDICATE argument of `plist-put'. +Assumes non-nil PLIST satisfies `map--plist-p'." + (if (or (memq predicate '(nil eq)) (null plist)) + (plist-put plist prop val) + (let ((tail plist) prev found) + (while (and (consp (cdr tail)) + (not (setq found (funcall predicate (car tail) prop))) + (consp (setq prev tail tail (cddr tail))))) + (cond (found (setcar (cdr tail) val)) + (tail (signal 'wrong-type-argument `(plistp ,plist))) + (prev (setcdr (cdr prev) (cons prop (cons val (cddr prev))))) + ((setq plist (cons prop (cons val plist))))) + plist))) + +(defalias 'map--plist-put + (if map--plist-has-predicate #'plist-put #'map--plist-put-1) + "Compatibility shim for `plist-put' in Emacs 29+. +\n(fn PLIST PROP VAL &optional PREDICATE)") + +(cl-defgeneric map-elt (map key &optional default testfn) + "Look up KEY in MAP and return its associated value. +If KEY is not found, return DEFAULT which defaults to nil. + +TESTFN is the function to use for comparing keys. It is +deprecated because its default and valid values depend on the MAP +argument, and it was never consistently supported by the map.el +API. Generally, alist keys are compared with `equal', plist keys +with `eq', and hash-table keys with the hash-table's test +function. + +In the base definition, MAP can be an alist, plist, hash-table, +or array." + (declare + ;; `testfn' is deprecated. + (advertised-calling-convention (map key &optional default) "27.1") + (gv-expander + (lambda (do) + (gv-letplace (mgetter msetter) `(gv-delay-error ,map) + (macroexp-let2* nil + ;; Eval them once and for all in the right order. + ((key key) (default default) (testfn testfn)) + (funcall do + `(map-elt ,mgetter ,key ,default ,@(and testfn `(,testfn))) + (lambda (v) + (macroexp-let2 nil v v + `(condition-case nil + ;; Silence warnings about the hidden 4th arg. + (with-no-warnings + (map-put! ,mgetter ,key ,v ,testfn)) + (map-not-inplace + ,(funcall msetter + `(map-insert ,mgetter ,key ,v)) + ;; Always return the value. + ,v))))))))))) + +(cl-defmethod map-elt ((map list) key &optional default testfn) + (if (map--plist-p map) + (let ((res (map--plist-member map key testfn))) + (if res (cadr res) default)) + (alist-get key map default nil (or testfn #'equal)))) + +(cl-defmethod map-elt ((map hash-table) key &optional default _testfn) + (gethash key map default)) + +(cl-defmethod map-elt ((map array) key &optional default _testfn) + (if (map-contains-key map key) + (aref map key) + default)) + +(defmacro map-put (map key value &optional testfn) + "Associate KEY with VALUE in MAP and return VALUE. +If KEY is already present in MAP, replace the associated value +with VALUE. +When MAP is an alist, test equality with TESTFN if non-nil, +otherwise use `equal'. + +MAP can be an alist, plist, hash-table, or array." + (declare + (obsolete "use `map-put!' or `(setf (map-elt ...) ...)' instead." "27.1")) + (if testfn + `(with-no-warnings + (setf (map-elt ,map ,key nil ,testfn) ,value)) + `(setf (map-elt ,map ,key) ,value))) + +(defun map--plist-delete (map key) + (let ((tail map) last) + (while (consp tail) + (cond + ((not (eq key (car tail))) + (setq last tail) + (setq tail (cddr last))) + (last + (setq tail (cddr tail)) + (setf (cddr last) tail)) + (t + (cl-assert (eq tail map)) + (setq map (cddr map)) + (setq tail map)))) + map)) + +(cl-defgeneric map-delete (map key) + "Delete KEY in-place from MAP and return MAP. +Keys not present in MAP are ignored. + +Note that if MAP is a list (either alist or plist), and you're +deleting the final element in the list, the list isn't actually +destructively modified (but the return value will reflect the +deletion). So if you're using this method on a list, you have to +say + + (setq map (map-delete map key)) + +for this to work reliably.") + +(cl-defmethod map-delete ((map list) key) + ;; FIXME: Signal map-not-inplace i.s.o returning a different list? + (if (map--plist-p map) + (map--plist-delete map key) + (setf (alist-get key map nil t #'equal) nil) + map)) + +(cl-defmethod map-delete ((map hash-table) key) + (remhash key map) + map) + +(cl-defmethod map-delete ((map array) key) + "Store nil at index KEY." + (when (map-contains-key map key) + (aset map key nil)) + map) + +(defun map-nested-elt (map keys &optional default) + "Traverse MAP using KEYS and return the looked up value or DEFAULT if nil. + +MAP can be a nested map composed of alists, plists, hash-tables, +and arrays." + (or (seq-reduce (lambda (acc key) + (when (mapp acc) + (map-elt acc key))) + keys + map) + default)) + +(cl-defgeneric map-keys (map) + "Return the list of keys in MAP. +The default implementation delegates to `map-apply'." + (map-apply (lambda (key _) key) map)) + +(cl-defgeneric map-values (map) + "Return the list of values in MAP. +The default implementation delegates to `map-apply'." + (map-apply (lambda (_ value) value) map)) + +(cl-defmethod map-values ((map array)) + "Convert MAP into a list." + (append map ())) + +(cl-defgeneric map-pairs (map) + "Return the key/value pairs in MAP as an alist. +The default implementation delegates to `map-apply'." + (map-apply #'cons map)) + +(cl-defgeneric map-length (map) + ;; FIXME: Should we rename this to `map-size'? + "Return the number of key/value pairs in MAP. +Note that this does not always reflect the number of unique keys. +The default implementation delegates to `map-do'." + (let ((size 0)) + (map-do (lambda (_k _v) (setq size (1+ size))) map) + size)) + +(cl-defmethod map-length ((map hash-table)) + (hash-table-count map)) + +(cl-defmethod map-length ((map list)) + (if (map--plist-p map) + (/ (length map) 2) + (length map))) + +(cl-defmethod map-length ((map array)) + (length map)) + +(cl-defgeneric map-copy (map) + "Return a copy of MAP.") + +(cl-defmethod map-copy ((map list)) + "Use `copy-alist' on alists and `copy-sequence' on plists." + (if (map--plist-p map) + (copy-sequence map) + (copy-alist map))) + +(cl-defmethod map-copy ((map hash-table)) + (copy-hash-table map)) + +(cl-defmethod map-copy ((map array)) + (copy-sequence map)) + +(cl-defgeneric map-apply (function map) + "Apply FUNCTION to each element of MAP and return the result as a list. +FUNCTION is called with two arguments, the key and the value. +The default implementation delegates to `map-do'." + (let ((res '())) + (map-do (lambda (k v) (push (funcall function k v) res)) map) + (nreverse res))) + +(cl-defgeneric map-do (function map) + "Apply FUNCTION to each element of MAP and return nil. +FUNCTION is called with two arguments, the key and the value.") + +;; FIXME: I wish there was a way to avoid this η-redex! +(cl-defmethod map-do (function (map hash-table)) (maphash function map)) + +(cl-defgeneric map-keys-apply (function map) + "Return the result of applying FUNCTION to each key in MAP. +The default implementation delegates to `map-apply'." + (map-apply (lambda (key _) + (funcall function key)) + map)) + +(cl-defgeneric map-values-apply (function map) + "Return the result of applying FUNCTION to each value in MAP. +The default implementation delegates to `map-apply'." + (map-apply (lambda (_ val) + (funcall function val)) + map)) + +(cl-defmethod map-values-apply (function (map array)) + (mapcar function map)) + +(cl-defgeneric map-filter (pred map) + "Return an alist of key/val pairs for which (PRED key val) is non-nil in MAP. +The default implementation delegates to `map-apply'." + (delq nil (map-apply (lambda (key val) + (and (funcall pred key val) + (cons key val))) + map))) + +(cl-defgeneric map-remove (pred map) + "Return an alist of the key/val pairs for which (PRED key val) is nil in MAP. +The default implementation delegates to `map-filter'." + (map-filter (lambda (key val) (not (funcall pred key val))) + map)) + +(cl-defgeneric mapp (map) + "Return non-nil if MAP is a map (alist/plist, hash-table, array, ...)." + (or (listp map) + (hash-table-p map) + (arrayp map))) + +(cl-defgeneric map-empty-p (map) + "Return non-nil if MAP is empty. +The default implementation delegates to `map-length'." + (zerop (map-length map))) + +(cl-defmethod map-empty-p ((map list)) + (null map)) + +(cl-defgeneric map-contains-key (map key &optional testfn) + ;; FIXME: The test function to use generally depends on the map object, + ;; so specifying `testfn' here is problematic: e.g. for hash-tables + ;; we shouldn't use `gethash' unless `testfn' is the same as the map's own + ;; test function! + "Return non-nil if and only if MAP contains KEY. +TESTFN is deprecated. Its default depends on MAP. +The default implementation delegates to `map-some'." + (declare (advertised-calling-convention (map key) "27.1")) + (unless testfn (setq testfn #'equal)) + (map-some (lambda (k _v) (funcall testfn key k)) map)) + +(cl-defmethod map-contains-key ((map list) key &optional testfn) + "Return non-nil if MAP contains KEY. +If MAP is an alist, TESTFN defaults to `equal'. +If MAP is a plist, TESTFN defaults to `eq'." + (if (map--plist-p map) + (map--plist-member map key testfn) + (let ((v '(nil))) + (not (eq v (alist-get key map v nil (or testfn #'equal))))))) + +(cl-defmethod map-contains-key ((map array) key &optional _testfn) + "Return non-nil if KEY is an index of MAP, ignoring TESTFN." + (and (natnump key) (< key (length map)))) + +(cl-defmethod map-contains-key ((map hash-table) key &optional _testfn) + "Return non-nil if MAP contains KEY, ignoring TESTFN." + (let ((v '(nil))) + (not (eq v (gethash key map v))))) + +(cl-defgeneric map-some (pred map) + "Return the first non-nil (PRED key val) in MAP. +Return nil if no such element is found. +The default implementation delegates to `map-do'." + ;; FIXME: Not sure if there's much benefit to defining it as defgeneric, + ;; since as defined, I can't think of a map-type where we could provide an + ;; algorithmically more efficient algorithm than the default. + (catch 'map--break + (map-do (lambda (key value) + (let ((result (funcall pred key value))) + (when result + (throw 'map--break result)))) + map) + nil)) + +(cl-defgeneric map-every-p (pred map) + "Return non-nil if (PRED key val) is non-nil for all elements of MAP. +The default implementation delegates to `map-do'." + ;; FIXME: Not sure if there's much benefit to defining it as defgeneric, + ;; since as defined, I can't think of a map-type where we could provide an + ;; algorithmically more efficient algorithm than the default. + (catch 'map--break + (map-do (lambda (key value) + (or (funcall pred key value) + (throw 'map--break nil))) + map) + t)) + +(defun map--merge (merge type &rest maps) + "Merge into a map of TYPE all the key/value pairs in MAPS. +MERGE is a function that takes the target MAP, a KEY, and a +VALUE, merges KEY and VALUE into MAP, and returns the result. +MAP may be of a type other than TYPE." + ;; Use a hash table internally if `type' is a list. This avoids + ;; both quadratic lookup behavior and the type ambiguity of nil. + (let* ((tolist (memq type '(list alist plist))) + (result (map-into (pop maps) + ;; Use same testfn as `map-elt' gv setter. + (cond ((eq type 'plist) '(hash-table :test eq)) + (tolist '(hash-table :test equal)) + (type))))) + (dolist (map maps) + (map-do (lambda (key value) + (setq result (funcall merge result key value))) + map)) + ;; Convert internal representation to desired type. + (if tolist (map-into result type) result))) + +(defun map-merge (type &rest maps) + "Merge into a map of TYPE all the key/value pairs in MAPS. +See `map-into' for all supported values of TYPE." + (apply #'map--merge + (lambda (result key value) + (setf (map-elt result key) value) + result) + type maps)) + +(defun map-merge-with (type function &rest maps) + "Merge into a map of TYPE all the key/value pairs in MAPS. +When two maps contain the same key, call FUNCTION on the two +values and use the value returned by it. +Each of MAPS can be an alist, plist, hash-table, or array. +See `map-into' for all supported values of TYPE." + (let ((not-found (list nil))) + (apply #'map--merge + (lambda (result key value) + (cl-callf (lambda (old) + (if (eql old not-found) + value + (funcall function old value))) + (map-elt result key not-found)) + result) + type maps))) + +(cl-defgeneric map-into (map type) + "Convert MAP into a map of TYPE.") + +;; FIXME: I wish there was a way to avoid this η-redex! +(cl-defmethod map-into (map (_type (eql list))) + "Convert MAP into an alist." + (map-pairs map)) + +(cl-defmethod map-into (map (_type (eql alist))) + "Convert MAP into an alist." + (map-pairs map)) + +(cl-defmethod map-into (map (_type (eql plist))) + "Convert MAP into a plist." + (let (plist) + (map-do (lambda (k v) (setq plist `(,v ,k ,@plist))) map) + (nreverse plist))) + +(cl-defgeneric map-put! (map key value &optional testfn) + "Associate KEY with VALUE in MAP. +If KEY is already present in MAP, replace the associated value +with VALUE. +This operates by modifying MAP in place. +If it cannot do that, it signals a `map-not-inplace' error. +To insert an element without modifying MAP, use `map-insert'." + ;; `testfn' only exists for backward compatibility with `map-put'! + (declare (advertised-calling-convention (map key value) "27.1"))) + +(cl-defmethod map-put! ((map list) key value &optional testfn) + (if (map--plist-p map) + (map--plist-put map key value testfn) + (let ((oldmap map)) + (setf (alist-get key map key nil (or testfn #'equal)) value) + (unless (eq oldmap map) + (signal 'map-not-inplace (list oldmap))))) + ;; Always return the value. + value) + +(cl-defmethod map-put! ((map hash-table) key value &optional _testfn) + (puthash key value map)) + +(cl-defmethod map-put! ((map array) key value &optional _testfn) + ;; FIXME: If `key' is too large, should we signal `map-not-inplace' + ;; and let `map-insert' grow the array? + (aset map key value)) + +;; There shouldn't be old source code referring to `map--put', yet we do +;; need to keep it for backward compatibility with .elc files where the +;; expansion of `setf' may call this function. +(define-obsolete-function-alias 'map--put #'map-put! "27.1") + +(cl-defgeneric map-insert (map key value) + "Return a new map like MAP except that it associates KEY with VALUE. +This does not modify MAP. +If you want to insert an element in place, use `map-put!'. +The default implementation defaults to `map-copy' and `map-put!'." + (let ((copy (map-copy map))) + (map-put! copy key value) + copy)) + +(cl-defmethod map-insert ((map list) key value) + "Cons KEY and VALUE to the front of MAP." + (if (map--plist-p map) + (cons key (cons value map)) + (cons (cons key value) map))) + +(cl-defmethod map-apply (function (map list)) + (if (map--plist-p map) + (cl-call-next-method) + (mapcar (lambda (pair) + (funcall function (car pair) (cdr pair))) + map))) + +(cl-defmethod map-apply (function (map hash-table)) + (let (result) + (maphash (lambda (key value) + (push (funcall function key value) result)) + map) + (nreverse result))) + +(cl-defmethod map-apply (function (map array)) + (seq-map-indexed (lambda (elt index) + (funcall function index elt)) + map)) + +(cl-defmethod map-do (function (map list)) + (if (map--plist-p map) + (while map + (funcall function (pop map) (pop map))) + (mapc (lambda (pair) + (funcall function (car pair) (cdr pair))) + map) + nil)) + +(cl-defmethod map-do (function (map array)) + (seq-do-indexed (lambda (elt index) + (funcall function index elt)) + map)) + +(defun map--into-hash (map keyword-args) + "Convert MAP into a hash-table. +KEYWORD-ARGS are forwarded to `make-hash-table'." + (let ((ht (apply #'make-hash-table keyword-args))) + (map-do (lambda (key value) + (puthash key value ht)) + map) + ht)) + +(cl-defmethod map-into (map (_type (eql hash-table))) + "Convert MAP into a hash-table with keys compared with `equal'." + (map--into-hash map (list :size (map-length map) :test #'equal))) + +(cl-defmethod map-into (map (type (head hash-table))) + "Convert MAP into a hash-table. +TYPE is a list whose car is `hash-table' and cdr a list of +keyword-args forwarded to `make-hash-table'. + +Example: + (map-into \\='((1 . 3)) \\='(hash-table :test eql))" + (map--into-hash map (cdr type))) + +(defmacro map--pcase-map-elt (key default map) + "A macro to make MAP the last argument to `map-elt'. + +This allows using default values for `map-elt', which can't be +done using `pcase--flip'. + +KEY is the key sought in the map. DEFAULT is the default value." + ;; It's obsolete in Emacs>29, but `map.el' is distributed via GNU ELPA + ;; for earlier Emacsen. + (declare (obsolete _ "30.1")) + `(map-elt ,map ,key ,default)) + +(defun map--make-pcase-bindings (args) + "Return a list of pcase bindings from ARGS to the elements of a map." + (mapcar (if (< emacs-major-version 30) + (lambda (elt) + (cond ((consp elt) + `(app (map--pcase-map-elt ,(car elt) ,(caddr elt)) + ,(cadr elt))) + ((keywordp elt) + (let ((var (intern (substring (symbol-name elt) 1)))) + `(app (pcase--flip map-elt ,elt) ,var))) + (t `(app (pcase--flip map-elt ',elt) ,elt)))) + (lambda (elt) + (cond ((consp elt) + `(app (map-elt _ ,(car elt) ,(caddr elt)) + ,(cadr elt))) + ((keywordp elt) + (let ((var (intern (substring (symbol-name elt) 1)))) + `(app (map-elt _ ,elt) ,var))) + (t `(app (map-elt _ ',elt) ,elt))))) + args)) + +(defun map--make-pcase-patterns (args) + "Return a list of `(map ...)' pcase patterns built from ARGS." + (cons 'map + (mapcar (lambda (elt) + (if (eq (car-safe elt) 'map) + (map--make-pcase-patterns elt) + elt)) + args))) + +(provide 'map) +;;; map.el ends here diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el new file mode 100644 index 00000000..12346b3d --- /dev/null +++ b/lisp/emacs-lisp/pp.el @@ -0,0 +1,669 @@ +;;; pp.el --- pretty printer for Emacs Lisp -*- lexical-binding: t -*- + +;; Copyright (C) 1989, 1993, 2001-2024 Free Software Foundation, Inc. + +;; Author: Randal Schwartz +;; Keywords: lisp + +;; 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 GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'cl-lib) + +(defgroup pp nil + "Pretty printer for Emacs Lisp." + :prefix "pp-" + :group 'lisp) + +(defcustom pp-escape-newlines t + "Value of `print-escape-newlines' used by pp-* functions." + :type 'boolean) + +(defcustom pp-max-width t + "Max width to use when formatting. +If nil, there's no max width. If t, use the window width. +Otherwise this should be a number." + :type '(choice (const :tag "none" nil) + (const :tag "window width" t) + number) + :version "29.1") + +(defcustom pp-use-max-width nil + "If non-nil, `pp'-related functions will try to fold lines. +The target width is given by the `pp-max-width' variable. +Note that this could slow down `pp' considerably when formatting +large lists." + :type 'boolean + :version "29.1") +(make-obsolete-variable 'pp-use-max-width 'pp-default-function "30.1") + +(defcustom pp-default-function #'pp-fill + ;; FIXME: The best pretty printer to use depends on the use-case + ;; so maybe we should allow callers to specify what they want (maybe with + ;; options like `fast', `compact', `code', `data', ...) and these + ;; can then be mapped to actual pretty-printing algorithms. + ;; Then again, callers can just directly call the corresponding function. + "Function that `pp' should dispatch to for pretty printing. +That function can be called in one of two ways: +- with a single argument, which it should insert and pretty-print at point. +- with two arguments which delimit a region containing Lisp sexps + which should be pretty-printed. +In both cases, the function can presume that the buffer is setup for +Lisp syntax." + :type '(choice + (const :tag "Fit within `fill-column'" pp-fill) + (const :tag "Emacs<29 algorithm, fast and good enough" pp-28) + (const :tag "Work hard for code (slow on large inputs)" + pp-emacs-lisp-code) + (const :tag "`pp-emacs-lisp-code' if `pp-use-max-width' else `pp-28'" + pp-29) + function) + :version "30.1") + +(defvar pp--inhibit-function-formatting nil) + +;; There are basically two APIs for a pretty-printing function: +;; +;; - either the function takes an object (and prints it in addition to +;; prettifying it). +;; - or the function takes a region containing an already printed object +;; and prettifies its content. +;; +;; `pp--object' and `pp--region' are helper functions to convert one +;; API to the other. + + +(defun pp--object (object region-function) + "Pretty-print OBJECT at point. +The prettifying is done by REGION-FUNCTION which is +called with two positions as arguments and should fold lines +within that region. Returns the result as a string." + (let ((print-escape-newlines pp-escape-newlines) + (print-quoted t) + (beg (point))) + ;; FIXME: In many cases it would be preferable to use `cl-prin1' here. + (prin1 object (current-buffer)) + (funcall region-function beg (point)))) + +(defun pp--region (beg end object-function) + "Pretty-print the object(s) contained within BEG..END. +OBJECT-FUNCTION is called with a single object as argument +and should pretty print it at point into the current buffer." + (save-excursion + (with-restriction beg end + (goto-char (point-min)) + (while + (progn + ;; We'll throw away all the comments within objects, but let's + ;; try at least to preserve the comments between objects. + (forward-comment (point-max)) + (let ((beg (point)) + (object (ignore-error end-of-buffer + (list (read (current-buffer)))))) + (when (consp object) + (delete-region beg (point)) + (funcall object-function (car object)) + t))))))) + +(defun pp-29 (beg-or-sexp &optional end) ;FIXME: Better name? + "Prettify the current region with printed representation of a Lisp object. +Uses the pretty-printing algorithm that was standard in Emacs-29, +which, depending on `pp-use-max-width', will either use `pp-28' +or `pp-emacs-lisp-code'." + (if pp-use-max-width + (let ((pp--inhibit-function-formatting t)) ;FIXME: Why? + (pp-emacs-lisp-code beg-or-sexp end)) + (pp-28 beg-or-sexp end))) + +;;;###autoload +(defun pp-to-string (object &optional pp-function) + "Return a string containing the pretty-printed representation of OBJECT. +OBJECT can be any Lisp object. Quoting characters are used as needed +to make output that `read' can handle, whenever this is possible. +Optional argument PP-FUNCTION overrides `pp-default-function'." + (with-temp-buffer + (lisp-mode-variables nil) + (set-syntax-table emacs-lisp-mode-syntax-table) + (funcall (or pp-function pp-default-function) object) + ;; Preserve old behavior of (usually) finishing with a newline. + (unless (bolp) (insert "\n")) + (buffer-string))) + +(defun pp--within-fill-column-p () + "Return non-nil if point is within `fill-column'." + ;; Try and make it O(fill-column) rather than O(current-column), + ;; so as to avoid major slowdowns on long lines. + ;; FIXME: This doesn't account for invisible text or `display' properties :-( + (and (save-excursion + (re-search-backward + "^\\|\n" (max (point-min) (- (point) fill-column)) t)) + (<= (current-column) fill-column))) + +(defun pp-fill (beg &optional end) + "Break lines in Lisp code between BEG and END so it fits within `fill-column'. +Presumes the current buffer has syntax and indentation properly +configured for that. +Designed under the assumption that the region occupies a single line, +tho it should also work if that's not the case. +Can also be called with a single argument, in which case +it inserts and pretty-prints that arg at point." + (interactive "r") + (if (null end) (pp--object beg #'pp-fill) + (goto-char beg) + (let* ((end (copy-marker end t)) + (avoid-unbreakable + (lambda () + (and (memq (char-before) '(?# ?s ?f)) + (memq (char-after) '(?\[ ?\()) + (looking-back "#[sf]?" (- (point) 2)) + (goto-char (match-beginning 0))))) + (newline (lambda () + (skip-chars-forward ")]}") + (unless (save-excursion (skip-chars-forward " \t") (eolp)) + (funcall avoid-unbreakable) + (insert "\n") + (indent-according-to-mode))))) + (while (progn (forward-comment (point-max)) + (< (point) end)) + (let ((beg (point)) + ;; Whether we're in front of an element with paired delimiters. + ;; Can be something funky like #'(lambda ..) or ,'#s(...) + ;; Or also #^[..]. + (paired (when (looking-at "['`,#]*[[:alpha:]^]*\\([({[\"]\\)") + (match-beginning 1)))) + ;; Go to the end of the sexp. + (goto-char (or (scan-sexps (or paired (point)) 1) end)) + (unless + (and + ;; The sexp is all on a single line. + (save-excursion (not (search-backward "\n" beg t))) + ;; And its end is within `fill-column'. + (or (pp--within-fill-column-p) + ;; If the end of the sexp is beyond `fill-column', + ;; try to move the sexp to its own line. + (and + (save-excursion + (goto-char beg) + ;; We skip backward over open parens because cutting + ;; the line right after an open paren does not help + ;; reduce the indentation depth. + ;; Similarly, we prefer to cut before a "." than after + ;; it because it reduces the indentation depth. + (while + (progn + (funcall avoid-unbreakable) + (not (zerop (skip-chars-backward " \t({[',."))))) + (if (bolp) + ;; The sexp already starts on its own line. + (progn (goto-char beg) nil) + (setq beg (copy-marker beg t)) + (if paired (setq paired (copy-marker paired t))) + ;; We could try to undo this insertion if it + ;; doesn't reduce the indentation depth, but I'm + ;; not sure it's worth the trouble. + (insert "\n") (indent-according-to-mode) + t)) + ;; Check again if we moved the whole exp to a new line. + (pp--within-fill-column-p)))) + ;; The sexp is spread over several lines, and/or its end is + ;; (still) beyond `fill-column'. + (when (and paired (not (eq ?\" (char-after paired)))) + ;; The sexp has sub-parts, so let's try and spread + ;; them over several lines. + (save-excursion + (goto-char beg) + (when (looking-at "(\\([^][()\" \t\n;']+\\)") + ;; Inside an expression of the form (SYM ARG1 + ;; ARG2 ... ARGn) where SYM has a `lisp-indent-function' + ;; property that's a number, insert a newline after + ;; the corresponding ARGi, because it tends to lead to + ;; more natural and less indented code. + (let* ((sym (intern-soft (match-string 1))) + (lif (and sym (get sym 'lisp-indent-function)))) + (if (eq lif 'defun) (setq lif 2)) + (when (natnump lif) + (goto-char (match-end 0)) + ;; Do nothing if there aren't enough args. + (ignore-error scan-error + (forward-sexp lif) + (funcall newline)))))) + (save-excursion + (pp-fill (1+ paired) (1- (point))))) + ;; Now the sexp either ends beyond `fill-column' or is + ;; spread over several lines (or both). Either way, the + ;; rest of the line should be moved to its own line. + (funcall newline))))))) + +;;;###autoload +(defun pp-buffer () + "Prettify the current buffer with printed representation of a Lisp object." + (interactive) + ;; The old code used `indent-sexp' which mostly works "anywhere", + ;; so let's make sure we also work right in buffers that aren't + ;; setup specifically for Lisp. + (if (and (eq (syntax-table) emacs-lisp-mode-syntax-table) + (eq indent-line-function #'lisp-indent-line)) + (funcall pp-default-function (point-min) (point-max)) + (with-syntax-table emacs-lisp-mode-syntax-table + (let ((indent-line-function #'lisp-indent-line)) + (funcall pp-default-function (point-min) (point-max))))) + ;; Preserve old behavior of (usually) finishing with a newline and + ;; with point at BOB. + (goto-char (point-max)) + (unless (bolp) (insert "\n")) + (goto-char (point-min))) + +(defun pp-28 (beg &optional end) ;FIXME: Better name? + "Prettify the current region with printed representation of a Lisp object. +Uses the pretty-printing algorithm that was standard before Emacs-30. +Non-interactively can also be called with a single argument, in which +case that argument will be inserted pretty-printed at point." + (interactive "r") + (if (null end) (pp--object beg #'pp-29) + (with-restriction beg end + (goto-char (point-min)) + (while (not (eobp)) + (cond + ((ignore-errors (down-list 1) t) + (save-excursion + (backward-char 1) + (skip-chars-backward "'`#^") + (when (and (not (bobp)) (memq (char-before) '(?\s ?\t ?\n))) + (delete-region + (point) + (progn (skip-chars-backward " \t\n") (point))) + (insert "\n")))) + ((ignore-errors (up-list 1) t) + (skip-syntax-forward ")") + (delete-region + (point) + (progn (skip-chars-forward " \t\n") (point))) + (insert ?\n)) + (t (goto-char (point-max))))) + (goto-char (point-min)) + (indent-sexp)))) + +;;;###autoload +(defun pp (object &optional stream) + "Output the pretty-printed representation of OBJECT, any Lisp object. +Quoting characters are printed as needed to make output that `read' +can handle, whenever this is possible. + +Uses the pretty-printing code specified in `pp-default-function'. + +Output stream is STREAM, or value of `standard-output' (which see)." + (let ((stream (or stream standard-output))) + (cond + ((and (eq stream (current-buffer)) + ;; Make sure the current buffer is setup sanely. + (eq (syntax-table) emacs-lisp-mode-syntax-table) + (eq indent-line-function #'lisp-indent-line)) + ;; Skip the buffer->string->buffer middle man. + (funcall pp-default-function object) + ;; Preserve old behavior of (usually) finishing with a newline. + (unless (bolp) (insert "\n"))) + (t + (save-current-buffer + (when (bufferp stream) (set-buffer stream)) + (let ((begin (point)) + (cols (current-column))) + (princ (pp-to-string object) (or stream standard-output)) + (when (and (> cols 0) (bufferp stream)) + (indent-rigidly begin (point) cols)))))))) + +;;;###autoload +(defun pp-display-expression (expression out-buffer-name &optional lisp) + "Prettify and display EXPRESSION in an appropriate way, depending on length. +If LISP, format with `pp-emacs-lisp-code'; use `pp' otherwise. + +If a temporary buffer is needed for representation, it will be named +after OUT-BUFFER-NAME." + (let* ((lexical lexical-binding) + (old-show-function temp-buffer-show-function) + ;; Use this function to display the buffer. + ;; This function either decides not to display it at all + ;; or displays it in the usual way. + (temp-buffer-show-function + (lambda (buf) + (with-current-buffer buf + (goto-char (point-min)) + (end-of-line 1) + (if (or (< (1+ (point)) (point-max)) + (>= (- (point) (point-min)) (frame-width))) + (let ((temp-buffer-show-function old-show-function) + (old-selected (selected-window)) + (window (display-buffer buf))) + (goto-char (point-min)) ; expected by some hooks ... + (make-frame-visible (window-frame window)) + (unwind-protect + (progn + (select-window window) + (run-hooks 'temp-buffer-show-hook)) + (when (window-live-p old-selected) + (select-window old-selected)))) + (message "%s" (buffer-substring (point-min) (point)))))))) + (with-output-to-temp-buffer out-buffer-name + (if lisp + (with-current-buffer standard-output + (pp-emacs-lisp-code expression)) + (pp expression)) + (with-current-buffer standard-output + (emacs-lisp-mode) + (setq lexical-binding lexical) + (setq buffer-read-only nil) + (setq-local font-lock-verbose nil))))) + +(defun pp-insert-short-sexp (sexp &optional width) + "Insert a short description of SEXP in the current buffer. +WIDTH is the maximum width to use for it and it defaults to the +space available between point and the window margin." + (let ((printed (format "%S" sexp))) + (if (and (not (string-search "\n" printed)) + (<= (string-width printed) + (or width (- (window-width) (current-column))))) + (insert printed) + (insert-text-button + "[Show]" + 'follow-link t + 'action (lambda (&rest _ignore) + ;; FIXME: Why "eval output"? + (pp-display-expression sexp "*Pp Eval Output*")) + 'help-echo "mouse-2, RET: pretty print value in another buffer")))) + +;;;###autoload +(defun pp-eval-expression (expression) + "Evaluate EXPRESSION and pretty-print its value. +Also add the value to the front of the list in the variable `values'." + (interactive + (list (read--expression "Eval: "))) + (message "Evaluating...") + (let ((result (eval expression lexical-binding))) + (values--store-value result) + (pp-display-expression result "*Pp Eval Output*" pp-use-max-width))) + +;;;###autoload +(defun pp-macroexpand-expression (expression) + "Macroexpand EXPRESSION and pretty-print its value." + (interactive + (list (read--expression "Macroexpand: "))) + (pp-display-expression (macroexpand-1 expression) "*Pp Macroexpand Output*" + pp-use-max-width)) + +(defun pp-last-sexp () + "Read sexp before point. Ignore leading comment characters." + (with-syntax-table emacs-lisp-mode-syntax-table + (let ((pt (point))) + (save-excursion + (forward-sexp -1) + ;; Make `pp-eval-last-sexp' work the same way `eval-last-sexp' + ;; does. + (when (looking-at ",@?") + (goto-char (match-end 0))) + (read + ;; If first line is commented, ignore all leading comments: + (if (save-excursion (beginning-of-line) (looking-at-p "[ \t]*;")) + (let ((exp (buffer-substring (point) pt)) + (start nil)) + (while (string-match "\n[ \t]*;+" exp start) + (setq start (1+ (match-beginning 0)) + exp (concat (substring exp 0 start) + (substring exp (match-end 0))))) + exp) + (current-buffer))))))) + +;;;###autoload +(defun pp-eval-last-sexp (arg) + "Run `pp-eval-expression' on sexp before point. +With ARG, pretty-print output into current buffer. +Ignores leading comment characters." + (interactive "P") + (if arg + (insert (pp-to-string (eval (elisp--eval-defun-1 + (macroexpand (pp-last-sexp))) + lexical-binding))) + (pp-eval-expression (elisp--eval-defun-1 + (macroexpand (pp-last-sexp)))))) + +;;;###autoload +(defun pp-macroexpand-last-sexp (arg) + "Run `pp-macroexpand-expression' on sexp before point. +With ARG, pretty-print output into current buffer. +Ignores leading comment characters." + (interactive "P") + (if arg + (insert (pp-to-string (macroexpand-1 (pp-last-sexp)))) + (pp-macroexpand-expression (pp-last-sexp)))) + +;;;###autoload +(defun pp-emacs-lisp-code (sexp &optional end) + "Insert SEXP into the current buffer, formatted as Emacs Lisp code. +Use the `pp-max-width' variable to control the desired line length. +Note that this could be slow for large SEXPs. +Can also be called with two arguments, in which case they're taken to be +the bounds of a region containing Lisp code to pretty-print." + (require 'edebug) + (if end (pp--region sexp end #'pp-emacs-lisp-code) + (let ((obuf (current-buffer))) + (with-temp-buffer + (emacs-lisp-mode) + (pp--insert-lisp sexp) + (insert "\n") + (goto-char (point-min)) + (indent-sexp) + (while (re-search-forward " +$" nil t) + (replace-match "")) + (insert-into-buffer obuf))))) + +(defvar pp--quoting-syntaxes + `((quote . "'") + (function . "#'") + (,backquote-backquote-symbol . "`") + (,backquote-unquote-symbol . ",") + (,backquote-splice-symbol . ",@"))) + +(defun pp--quoted-or-unquoted-form-p (cons) + ;; Return non-nil when CONS has one of the forms 'X, `X, ,X or ,@X + (let ((head (car cons))) + (and (symbolp head) + (assq head pp--quoting-syntaxes) + (let ((rest (cdr cons))) + (and (consp rest) (null (cdr rest))))))) + +(defun pp--insert-lisp (sexp) + (cl-case (type-of sexp) + (vector (pp--format-vector sexp)) + (cons (cond + ((consp (cdr sexp)) + (let ((head (car sexp))) + (if-let (((null (cddr sexp))) + (syntax-entry (assq head pp--quoting-syntaxes))) + (progn + (insert (cdr syntax-entry)) + (pp--insert-lisp (cadr sexp))) + (pp--format-list sexp)))) + (t + (pp--format-list sexp)))) + ;; Print some of the smaller integers as characters, perhaps? + (integer + (if (<= ?0 sexp ?z) + (princ (prin1-char sexp) (current-buffer)) + (prin1 sexp (current-buffer)))) + (string + (let ((print-escape-newlines t)) + (prin1 sexp (current-buffer)))) + (otherwise (prin1 sexp (current-buffer))))) + +(defun pp--format-vector (sexp) + (insert "[") + (cl-loop for i from 0 + for element across sexp + do (pp--insert (and (> i 0) " ") element)) + (insert "]")) + +(defun pp--format-list (sexp &optional start) + (if (not (let ((head (car sexp))) + (or pp--inhibit-function-formatting + (not (symbolp head)) + (keywordp head) + (let ((l sexp)) + (catch 'not-funcall + (while l + (when (or + (atom l) ; SEXP is a dotted list + ;; Does SEXP have a form like (ELT... . ,X) ? + (pp--quoted-or-unquoted-form-p l)) + (throw 'not-funcall t)) + (setq l (cdr l))) + nil))))) + (pp--format-function sexp) + (insert "(") + (pp--insert start (pop sexp)) + (while sexp + (if (consp sexp) + (if (not (pp--quoted-or-unquoted-form-p sexp)) + (pp--insert " " (pop sexp)) + (pp--insert " . " sexp) + (setq sexp nil)) + (pp--insert " . " sexp) + (setq sexp nil))) + (insert ")"))) + +(defun pp--format-function (sexp) + (let* ((sym (car sexp)) + (edebug (get sym 'edebug-form-spec)) + (indent (get sym 'lisp-indent-function)) + (doc (get sym 'doc-string-elt))) + (when (eq indent 'defun) + (setq indent 2)) + ;; We probably want to keep all the elements before the doc string + ;; on a single line. + (when doc + (setq indent (1- doc))) + ;; Special-case closures -- these shouldn't really exist in actual + ;; source code, so there's no indentation information. But make + ;; them output slightly better. + (when (and (not indent) + (eq sym 'closure)) + (setq indent 0)) + (pp--insert "(" sym) + (pop sexp) + ;; Get the first entries on the first line. + (if indent + (pp--format-definition sexp indent edebug) + (let ((prev 0)) + (while sexp + (let ((start (point))) + ;; Don't put sexps on the same line as a multi-line sexp + ;; preceding it. + (pp--insert (if (> prev 1) "\n" " ") + (pop sexp)) + (setq prev (count-lines start (point))))))) + (insert ")"))) + +(defun pp--format-definition (sexp indent edebug) + (while (and (cl-plusp indent) + sexp) + (insert " ") + ;; We don't understand all the edebug specs. + (unless (consp edebug) + (setq edebug nil)) + (if (and (consp (car edebug)) + (eq (caar edebug) '&rest) + (proper-list-p (car sexp))) + (pp--insert-binding (pop sexp)) + (if (null (car sexp)) + (insert "()") + (pp--insert-lisp (car sexp))) + (pop sexp)) + (pop edebug) + (cl-decf indent)) + (when (stringp (car sexp)) + (insert "\n") + (prin1 (pop sexp) (current-buffer))) + ;; Then insert the rest with line breaks before each form. + (while sexp + (insert "\n") + (if (keywordp (car sexp)) + (progn + (pp--insert-lisp (pop sexp)) + (when sexp + (pp--insert " " (pop sexp)))) + (pp--insert-lisp (pop sexp))))) + +(defun pp--insert-binding (sexp) + (insert "(") + (while sexp + (if (consp (car sexp)) + ;; Newlines after each (...) binding. + (progn + (pp--insert-lisp (car sexp)) + (when (cdr sexp) + (insert "\n"))) + ;; Keep plain symbols on the same line. + (pp--insert " " (car sexp))) + (pop sexp)) + (insert ")")) + +(defun pp--insert (delim &rest things) + (let ((start (if (markerp delim) + (prog1 + delim + (setq delim nil)) + (point-marker)))) + (when delim + (insert delim)) + (dolist (thing things) + (pp--insert-lisp thing)) + ;; We need to indent what we have so far to see if we have to fold. + (pp--indent-buffer) + (when (> (current-column) (pp--max-width)) + (save-excursion + (goto-char start) + (unless (looking-at "[ \t]+$") + (insert "\n")) + (pp--indent-buffer) + (goto-char (point-max)) + ;; If we're still too wide, then go up one step and try to + ;; insert a newline there. + (when (> (current-column) (pp--max-width)) + (condition-case () + (backward-up-list 1) + (:success (when (and (not (bobp)) (looking-back " " 2)) + (insert "\n"))) + (error nil))))))) + +(defun pp--max-width () + (cond ((numberp pp-max-width) + pp-max-width) + ((null pp-max-width) + most-positive-fixnum) + ((eq pp-max-width t) + (window-width)) + (t + (error "Invalid pp-max-width value: %s" pp-max-width)))) + +(defun pp--indent-buffer () + (goto-char (point-min)) + (while (not (eobp)) + (lisp-indent-line) + (forward-line 1))) + +(provide 'pp) ; so (require 'pp) works + +;;; pp.el ends here diff --git a/src/fileio.rs b/src/fileio.rs index 094c4922..64c90a5f 100644 --- a/src/fileio.rs +++ b/src/fileio.rs @@ -45,6 +45,24 @@ fn car_less_than_car(a: &Cons, b: &Cons) -> Result { Ok(a.val() < b.val()) } +#[defun] +/* Return t if FILENAME names a directory you can open. +This means that FILENAME must specify the name of a directory, and the +directory must allow you to open files in it. If this isn't the case, +return nil. + +FILENAME can either be a directory name (eg. \"/tmp/foo/\") or the +file name of a file which is a directory (eg. \"/tmp/foo\", without +the final slash). + +In order to use a directory as a buffer's current directory, this +predicate must return true. */ +fn file_accessible_directory_p(filename: &str) -> bool { + let path = Path::new(filename); + path.exists() && path.is_dir() +} + + #[defun] fn file_name_as_directory(filename: &str) -> String { if filename.ends_with(MAIN_SEPARATOR) { From b090e6b90fc4ddc0a9cbb70be69347c60b0e74c8 Mon Sep 17 00:00:00 2001 From: Troy Hinckley Date: Thu, 31 Oct 2024 22:48:19 -0500 Subject: [PATCH 2/7] Remove define-minor-mode for bootstrap --- lisp/emacs-lisp/find-func.el | 49 ++++++++++++++++++------------------ 1 file changed, 25 insertions(+), 24 deletions(-) diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index f3ddf9f8..8eafdef9 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -805,30 +805,31 @@ See `find-function-on-key'." (when (and symb (not (equal symb 0))) (find-variable-other-window symb)))) -;;;###autoload -(define-minor-mode find-function-mode - "Enable some key bindings for the `find-function' family of functions." - :group 'find-function :version "31.1" :global t :lighter nil - ;; For compatibility with the historical behavior of the old - ;; `find-function-setup-keys', define our bindings at the precedence - ;; level of the global map. - :keymap nil - (pcase-dolist (`(,map ,key ,cmd) - `((,ctl-x-map "F" find-function) - (,ctl-x-4-map "F" find-function-other-window) - (,ctl-x-5-map "F" find-function-other-frame) - (,ctl-x-map "K" find-function-on-key) - (,ctl-x-4-map "K" find-function-on-key-other-window) - (,ctl-x-5-map "K" find-function-on-key-other-frame) - (,ctl-x-map "V" find-variable) - (,ctl-x-4-map "V" find-variable-other-window) - (,ctl-x-5-map "V" find-variable-other-frame) - (,ctl-x-map "L" find-library) - (,ctl-x-4-map "L" find-library-other-window) - (,ctl-x-5-map "L" find-library-other-frame))) - (if find-function-mode - (keymap-set map key cmd) - (keymap-unset map key t)))) +;; RUNE-BOOTSTRAP +;; ;;;###autoload +;; (define-minor-mode find-function-mode +;; "Enable some key bindings for the `find-function' family of functions." +;; :group 'find-function :version "31.1" :global t :lighter nil +;; ;; For compatibility with the historical behavior of the old +;; ;; `find-function-setup-keys', define our bindings at the precedence +;; ;; level of the global map. +;; :keymap nil +;; (pcase-dolist (`(,map ,key ,cmd) +;; `((,ctl-x-map "F" find-function) +;; (,ctl-x-4-map "F" find-function-other-window) +;; (,ctl-x-5-map "F" find-function-other-frame) +;; (,ctl-x-map "K" find-function-on-key) +;; (,ctl-x-4-map "K" find-function-on-key-other-window) +;; (,ctl-x-5-map "K" find-function-on-key-other-frame) +;; (,ctl-x-map "V" find-variable) +;; (,ctl-x-4-map "V" find-variable-other-window) +;; (,ctl-x-5-map "V" find-variable-other-frame) +;; (,ctl-x-map "L" find-library) +;; (,ctl-x-4-map "L" find-library-other-window) +;; (,ctl-x-5-map "L" find-library-other-frame))) +;; (if find-function-mode +;; (keymap-set map key cmd) +;; (keymap-unset map key t)))) ;;;###autoload (defun find-function-setup-keys () From 7c5be7f242820b597857aaa206577466d8b005a8 Mon Sep 17 00:00:00 2001 From: Gary Trakhman Date: Wed, 6 Nov 2024 23:28:22 -0500 Subject: [PATCH 3/7] remove docstring --- src/fileio.rs | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/src/fileio.rs b/src/fileio.rs index 64c90a5f..55cf5622 100644 --- a/src/fileio.rs +++ b/src/fileio.rs @@ -46,17 +46,6 @@ fn car_less_than_car(a: &Cons, b: &Cons) -> Result { } #[defun] -/* Return t if FILENAME names a directory you can open. -This means that FILENAME must specify the name of a directory, and the -directory must allow you to open files in it. If this isn't the case, -return nil. - -FILENAME can either be a directory name (eg. \"/tmp/foo/\") or the -file name of a file which is a directory (eg. \"/tmp/foo\", without -the final slash). - -In order to use a directory as a buffer's current directory, this -predicate must return true. */ fn file_accessible_directory_p(filename: &str) -> bool { let path = Path::new(filename); path.exists() && path.is_dir() From fd5dffe6f52f3363eade32a25e6abc2c30e24e52 Mon Sep 17 00:00:00 2001 From: Gary Trakhman Date: Wed, 6 Nov 2024 23:28:31 -0500 Subject: [PATCH 4/7] pull 29.1 elisp --- lisp/emacs-lisp/backtrace.el | 100 ++++++--- lisp/emacs-lisp/debug.el | 96 +++----- lisp/emacs-lisp/ert.el | 220 ++++++++++--------- lisp/emacs-lisp/ewoc.el | 2 +- lisp/emacs-lisp/find-func.el | 90 +++----- lisp/emacs-lisp/map.el | 62 ++---- lisp/emacs-lisp/pp.el | 412 +++++++---------------------------- 7 files changed, 349 insertions(+), 633 deletions(-) diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el index 120972d6..53e17693 100644 --- a/lisp/emacs-lisp/backtrace.el +++ b/lisp/emacs-lisp/backtrace.el @@ -1,6 +1,6 @@ ;;; backtrace.el --- generic major mode for Elisp backtraces -*- lexical-binding: t -*- -;; Copyright (C) 2018-2024 Free Software Foundation, Inc. +;; Copyright (C) 2018-2023 Free Software Foundation, Inc. ;; Author: Gemini Lasswell ;; Keywords: lisp, tools, maint @@ -135,7 +135,8 @@ frames before its nearest activation frame are discarded." ;; Font Locking support (defconst backtrace--font-lock-keywords - '() + '((backtrace--match-ellipsis-in-string + (1 'button prepend))) "Expressions to fontify in Backtrace mode. Fontify these in addition to the expressions Emacs Lisp mode fontifies.") @@ -153,6 +154,16 @@ fontifies.") backtrace--font-lock-keywords) "Gaudy level highlighting for Backtrace mode.") +(defun backtrace--match-ellipsis-in-string (bound) + ;; Fontify ellipses within strings as buttons. + ;; This is necessary because ellipses are text property buttons + ;; instead of overlay buttons, which is done because there could + ;; be a large number of them. + (when (re-search-forward "\\(\\.\\.\\.\\)\"" bound t) + (and (get-text-property (- (point) 2) 'cl-print-ellipsis) + (get-text-property (- (point) 3) 'cl-print-ellipsis) + (get-text-property (- (point) 4) 'cl-print-ellipsis)))) + ;;; Xref support (defun backtrace--xref-backend () 'elisp) @@ -413,12 +424,12 @@ the buffer." (overlay-put o 'evaporate t)))) (defun backtrace--change-button-skip (beg end value) - "Change the `skip' property on all buttons between BEG and END. -Set it to VALUE unless the button is a `cl-print-ellipsis' button." + "Change the skip property on all buttons between BEG and END. +Set it to VALUE unless the button is a `backtrace-ellipsis' button." (let ((inhibit-read-only t)) (setq beg (next-button beg)) (while (and beg (< beg end)) - (unless (eq (button-type beg) 'cl-print-ellipsis) + (unless (eq (button-type beg) 'backtrace-ellipsis) (button-put beg 'skip value)) (setq beg (next-button beg))))) @@ -486,15 +497,34 @@ Reprint the frame with the new view plist." `(backtrace-index ,index backtrace-view ,view)) (goto-char min))) -(defun backtrace--expand-ellipsis (orig-fun begin end val _length &rest args) - "Wrapper to expand an ellipsis. -For use on `cl-print-expand-ellipsis-function'." - (let* ((props (backtrace-get-text-properties begin)) +(defun backtrace-expand-ellipsis (button) + "Expand display of the elided form at BUTTON." + (interactive) + (goto-char (button-start button)) + (unless (get-text-property (point) 'cl-print-ellipsis) + (if (and (> (point) (point-min)) + (get-text-property (1- (point)) 'cl-print-ellipsis)) + (backward-char) + (user-error "No ellipsis to expand here"))) + (let* ((end (next-single-property-change (point) 'cl-print-ellipsis)) + (begin (previous-single-property-change end 'cl-print-ellipsis)) + (value (get-text-property begin 'cl-print-ellipsis)) + (props (backtrace-get-text-properties begin)) (inhibit-read-only t)) (backtrace--with-output-variables (backtrace-get-view) - (let ((end (apply orig-fun begin end val backtrace-line-length args))) - (add-text-properties begin end props) - end)))) + (delete-region begin end) + (insert (cl-print-to-string-with-limit #'cl-print-expand-ellipsis value + backtrace-line-length)) + (setq end (point)) + (goto-char begin) + (while (< (point) end) + (let ((next (next-single-property-change (point) 'cl-print-ellipsis + nil end))) + (when (get-text-property (point) 'cl-print-ellipsis) + (make-text-button (point) next :type 'backtrace-ellipsis)) + (goto-char next))) + (goto-char begin) + (add-text-properties begin end props)))) (defun backtrace-expand-ellipses (&optional no-limit) "Expand display of all \"...\"s in the backtrace frame at point. @@ -667,6 +697,13 @@ line and recenter window line accordingly." (recenter window-line))) (goto-char (point-min))))) +;; Define button type used for ...'s. +;; Set skip property so you don't have to TAB through 100 of them to +;; get to the next function name. +(define-button-type 'backtrace-ellipsis + 'skip t 'action #'backtrace-expand-ellipsis + 'help-echo "mouse-2, RET: expand this ellipsis") + (defun backtrace-print-to-string (obj &optional limit) "Return a printed representation of OBJ formatted for backtraces. Attempt to get the length of the returned string under LIMIT @@ -678,10 +715,21 @@ characters with appropriate settings of `print-level' and (defun backtrace--print-to-string (sexp &optional limit) ;; This is for use by callers who wrap the call with ;; backtrace--with-output-variables. - (propertize (cl-print-to-string-with-limit #'backtrace--print sexp - (or limit backtrace-line-length)) - ;; Add a unique backtrace-form property. - 'backtrace-form (gensym))) + (setq limit (or limit backtrace-line-length)) + (with-temp-buffer + (insert (cl-print-to-string-with-limit #'backtrace--print sexp limit)) + ;; Add a unique backtrace-form property. + (put-text-property (point-min) (point) 'backtrace-form (gensym)) + ;; Make buttons from all the "..."s. Since there might be many of + ;; them, use text property buttons. + (goto-char (point-min)) + (while (< (point) (point-max)) + (let ((end (next-single-property-change (point) 'cl-print-ellipsis + nil (point-max)))) + (when (get-text-property (point) 'cl-print-ellipsis) + (make-text-button (point) end :type 'backtrace-ellipsis)) + (goto-char end))) + (buffer-string))) (defun backtrace-print-frame (frame view) "Insert a backtrace FRAME at point formatted according to VIEW. @@ -720,10 +768,9 @@ Format it according to VIEW." (def (find-function-advised-original fun)) (fun-file (or (symbol-file fun 'defun) (and (subrp def) - (not (special-form-p def)) + (not (eq 'unevalled (cdr (subr-arity def)))) (find-lisp-object-file-name fun def)))) - (fun-beg (point)) - (fun-end nil)) + (fun-pt (point))) (cond ((and evald (not debugger-stack-frame-as-list)) (if (atom fun) @@ -733,7 +780,6 @@ Format it according to VIEW." fun (when (and args (backtrace--line-length-or-nil)) (/ backtrace-line-length 2))))) - (setq fun-end (point)) (if args (insert (backtrace--print-to-string args @@ -749,16 +795,10 @@ Format it according to VIEW." (t (let ((fun-and-args (cons fun args))) (insert (backtrace--print-to-string fun-and-args))) - ;; Skip the open-paren. - (cl-incf fun-beg))) + (cl-incf fun-pt))) (when fun-file - (make-text-button fun-beg - (or fun-end - (+ fun-beg - ;; FIXME: `backtrace--print-to-string' will - ;; not necessarily print FUN in the same way - ;; as it did when it was in FUN-AND-ARGS! - (length (backtrace--print-to-string fun)))) + (make-text-button fun-pt (+ fun-pt + (length (backtrace--print-to-string fun))) :type 'help-function-def 'help-args (list fun fun-file))) ;; After any frame that uses eval-buffer, insert a comment that @@ -879,8 +919,6 @@ followed by `backtrace-print-frame', once for each stack frame." (setq-local filter-buffer-substring-function #'backtrace--filter-visible) (setq-local indent-line-function 'lisp-indent-line) (setq-local indent-region-function 'lisp-indent-region) - (add-function :around (local 'cl-print-expand-ellipsis-function) - #'backtrace--expand-ellipsis) (add-hook 'xref-backend-functions #'backtrace--xref-backend nil t)) (put 'backtrace-mode 'mode-class 'special) diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index ec947c12..dc23b071 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -1,6 +1,6 @@ ;;; debug.el --- debuggers and related commands for Emacs -*- lexical-binding: t -*- -;; Copyright (C) 1985-1986, 1994, 2001-2024 Free Software Foundation, +;; Copyright (C) 1985-1986, 1994, 2001-2023 Free Software Foundation, ;; Inc. ;; Maintainer: emacs-devel@gnu.org @@ -153,24 +153,11 @@ where CAUSE can be: (insert (debugger--buffer-state-content state))) (goto-char (debugger--buffer-state-pos state))) -(defvar debugger--last-error nil) - -(defun debugger--duplicate-p (args) - (pcase args - (`(error ,err . ,_) (and (consp err) (eq err debugger--last-error))))) - ;;;###autoload (setq debugger 'debug) ;;;###autoload (defun debug (&rest args) "Enter debugger. \\`\\[debugger-continue]' returns from the debugger. - -In interactive sessions, this switches to a backtrace buffer and shows -the Lisp backtrace of function calls there. In batch mode (more accurately, -when `noninteractive' is non-nil), it shows the Lisp backtrace on the -standard error stream (unless `backtrace-on-error-noninteractive' is nil), -and then kills Emacs, causing it to exit with a negative exit code. - Arguments are mainly for use when this is called from the internals of the evaluator. @@ -181,14 +168,9 @@ first will be printed into the backtrace buffer. If `inhibit-redisplay' is non-nil when this function is called, the debugger will not be entered." (interactive) - (if (or inhibit-redisplay - (debugger--duplicate-p args)) - ;; Don't really try to enter debugger within an eval from redisplay - ;; or if we already popper into the debugger for this error, - ;; which can happen when we have several nested `handler-bind's that - ;; want to invoke the debugger. + (if inhibit-redisplay + ;; Don't really try to enter debugger within an eval from redisplay. debugger-value - (setq debugger--last-error nil) (let ((non-interactive-frame (or noninteractive ;FIXME: Presumably redundant. ;; If we're in the initial-frame (where `message' just @@ -211,7 +193,7 @@ the debugger will not be entered." (let (debugger-value (debugger-previous-state (if (get-buffer "*Backtrace*") - (with-current-buffer "*Backtrace*" + (with-current-buffer (get-buffer "*Backtrace*") (debugger--save-buffer-state)))) (debugger-args args) (debugger-buffer (get-buffer-create "*Backtrace*")) @@ -248,11 +230,12 @@ the debugger will not be entered." (unwind-protect (save-excursion (when (eq (car debugger-args) 'debug) - (let ((base (debugger--backtrace-base))) - (backtrace-debug 1 t base) ;FIXME! - ;; Place an extra debug-on-exit for macro's. - (when (eq 'lambda (car-safe (cadr (backtrace-frame 1 base)))) - (backtrace-debug 2 t base)))) + ;; Skip the frames for backtrace-debug, byte-code, + ;; debug--implement-debug-on-entry and the advice's `apply'. + (backtrace-debug 4 t) + ;; Place an extra debug-on-exit for macro's. + (when (eq 'lambda (car-safe (cadr (backtrace-frame 4)))) + (backtrace-debug 5 t))) (with-current-buffer debugger-buffer (unless (derived-mode-p 'debugger-mode) (debugger-mode)) @@ -329,12 +312,6 @@ the debugger will not be entered." (backtrace-mode)))) (with-timeout-unsuspend debugger-with-timeout-suspend) (set-match-data debugger-outer-match-data))) - (when (eq 'error (car-safe debugger-args)) - ;; Remember the error we just debugged, to avoid re-entering - ;; the debugger if some higher-up `handler-bind' invokes us - ;; again, oblivious that the error was already debugged from - ;; a more deeply nested `handler-bind'. - (setq debugger--last-error (nth 1 debugger-args))) (setq debug-on-next-call debugger-step-after-exit) debugger-value)))) @@ -359,10 +336,11 @@ Make functions into cross-reference buttons if DO-XREFS is non-nil." (defun debugger-setup-buffer (args) "Initialize the `*Backtrace*' buffer for entry to the debugger. That buffer should be current already and in `debugger-mode'." - (setq backtrace-frames - ;; The `base' frame is the one that gets index 0 and it is the entry to - ;; the debugger, so drop it with `cdr'. - (cdr (backtrace-get-frames (debugger--backtrace-base)))) + (setq backtrace-frames (nthcdr + ;; Remove debug--implement-debug-on-entry and the + ;; advice's `apply' frame. + (if (eq (car args) 'debug) 3 1) + (backtrace-get-frames 'debug))) (when (eq (car-safe args) 'exit) (setq debugger-value (nth 1 args)) (setf (cl-getf (backtrace-frame-flags (car backtrace-frames)) @@ -492,29 +470,26 @@ removes itself from that hook." (setq debugger-jumping-flag nil) (remove-hook 'post-command-hook 'debugger-reenable)) -(defun debugger-frame-number () +(defun debugger-frame-number (&optional skip-base) "Return number of frames in backtrace before the one point points at." - (let ((index (backtrace-get-index))) + (let ((index (backtrace-get-index)) + (count 0)) (unless index (error "This line is not a function call")) - ;; We have 3 representations of the backtrace: the real in C in `specpdl', - ;; the one stored in `backtrace-frames' and the textual version in - ;; the buffer. Check here that the one from `backtrace-frames' is in sync - ;; with the one from `specpdl'. - (cl-assert (equal (backtrace-frame-fun (nth index backtrace-frames)) - (nth 1 (backtrace-frame (1+ index) - (debugger--backtrace-base))))) - ;; The `base' frame is the one that gets index 0 and it is the entry to - ;; the debugger, so the first non-debugger frame is 1. - ;; This `+1' skips the same frame as the `cdr' in - ;; `debugger-setup-buffer'. - (1+ index))) + (unless skip-base + (while (not (eq (cadr (backtrace-frame count)) 'debug)) + (setq count (1+ count))) + ;; Skip debug--implement-debug-on-entry frame. + (when (eq 'debug--implement-debug-on-entry + (cadr (backtrace-frame (1+ count)))) + (setq count (+ 2 count)))) + (+ count index))) (defun debugger-frame () "Request entry to debugger when this frame exits. Applies to the frame whose line point is on in the backtrace." (interactive) - (backtrace-debug (debugger-frame-number) t (debugger--backtrace-base)) + (backtrace-debug (debugger-frame-number) t) (setf (cl-getf (backtrace-frame-flags (nth (backtrace-get-index) backtrace-frames)) :debug-on-exit) @@ -525,7 +500,7 @@ Applies to the frame whose line point is on in the backtrace." "Do not enter debugger when this frame exits. Applies to the frame whose line point is on in the backtrace." (interactive) - (backtrace-debug (debugger-frame-number) nil (debugger--backtrace-base)) + (backtrace-debug (debugger-frame-number) nil) (setf (cl-getf (backtrace-frame-flags (nth (backtrace-get-index) backtrace-frames)) :debug-on-exit) @@ -544,8 +519,10 @@ Applies to the frame whose line point is on in the backtrace." (defun debugger--backtrace-base () "Return the function name that marks the top of the backtrace. See `backtrace-frame'." - (or (cadr (memq :backtrace-base debugger-args)) - #'debug)) + (cond ((eq 'debug--implement-debug-on-entry + (cadr (backtrace-frame 1 'debug))) + 'debug--implement-debug-on-entry) + (t 'debug))) (defun debugger-eval-expression (exp &optional nframe) "Eval an expression, in an environment like that outside the debugger. @@ -553,7 +530,7 @@ The environment used is the one when entering the activation frame at point." (interactive (list (read--expression "Eval in stack frame: "))) (let ((nframe (or nframe - (condition-case nil (debugger-frame-number) + (condition-case nil (1+ (debugger-frame-number 'skip-base)) (error 0)))) ;; If on first line. (base (debugger--backtrace-base))) (debugger-env-macro @@ -668,7 +645,7 @@ Complete list of commands: (princ (debugger-eval-expression exp)) (terpri)) - (with-current-buffer debugger-record-buffer + (with-current-buffer (get-buffer debugger-record-buffer) (message "%s" (buffer-substring (line-beginning-position 0) (line-end-position 0))))) @@ -686,10 +663,7 @@ functions to break on entry." (if (or inhibit-debug-on-entry debugger-jumping-flag) nil (let ((inhibit-debug-on-entry t)) - (funcall debugger 'debug :backtrace-base - ;; An offset of 1 because we need to skip the advice - ;; OClosure that called us. - '(1 . debug--implement-debug-on-entry))))) + (funcall debugger 'debug)))) ;;;###autoload (defun debug-on-entry (function) diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index fa1b7a60..be9f013e 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -1,6 +1,6 @@ ;;; ert.el --- Emacs Lisp Regression Testing -*- lexical-binding: t -*- -;; Copyright (C) 2007-2024 Free Software Foundation, Inc. +;; Copyright (C) 2007-2023 Free Software Foundation, Inc. ;; Author: Christian Ohler ;; Keywords: lisp, tools @@ -34,18 +34,17 @@ ;; `ert-run-tests-batch-and-exit' for non-interactive use. ;; ;; The body of `ert-deftest' forms resembles a function body, but the -;; additional operators `should', `should-not', `should-error', -;; `skip-when' and `skip-unless' are available. `should' is similar -;; to cl's `assert', but signals a different error when its condition -;; is violated that is caught and processed by ERT. In addition, it -;; analyzes its argument form and records information that helps -;; debugging (`cl-assert' tries to do something similar when its -;; second argument SHOW-ARGS is true, but `should' is more -;; sophisticated). For information on `should-not' and -;; `should-error', see their docstrings. The `skip-when' and -;; `skip-unless' forms skip the test immediately, which is useful for -;; checking the test environment (like availability of features, -;; external binaries, etc). +;; additional operators `should', `should-not', `should-error' and +;; `skip-unless' are available. `should' is similar to cl's `assert', +;; but signals a different error when its condition is violated that +;; is caught and processed by ERT. In addition, it analyzes its +;; argument form and records information that helps debugging +;; (`cl-assert' tries to do something similar when its second argument +;; SHOW-ARGS is true, but `should' is more sophisticated). For +;; information on `should-not' and `should-error', see their +;; docstrings. `skip-unless' skips the test immediately without +;; processing further, this is useful for checking the test +;; environment (like availability of features, external binaries, etc). ;; ;; See ERT's Info manual `(ert) Top' as well as the docstrings for ;; more details. To see some examples of tests written in ERT, see @@ -99,7 +98,7 @@ Even modest settings for `print-length' and `print-level' can produce extremely long lines in backtraces and lengthy delays in forming them. This variable governs the target maximum line length by manipulating these two variables while printing stack -traces. Setting this variable to t will reuse the value of +traces. Setting this variable to t will re-use the value of `backtrace-line-length' while printing stack traces in ERT batch mode. Any other value will be temporarily bound to `backtrace-line-length' when producing stack traces in batch @@ -152,7 +151,7 @@ mode.") (when (and noninteractive (get symbol 'ert--test)) ;; Make sure duplicated tests are discovered since the older test would ;; be ignored silently otherwise. - (error "Test `%s' redefined (or loaded twice)" symbol)) + (error "Test `%s' redefined" symbol)) (define-symbol-prop symbol 'ert--test definition) definition) @@ -195,8 +194,8 @@ and the body." BODY is evaluated as a `progn' when the test is run. It should signal a condition on failure or just return if the test passes. -`should', `should-not', `should-error', `skip-when', and -`skip-unless' are useful for assertions in BODY. +`should', `should-not', `should-error' and `skip-unless' are +useful for assertions in BODY. Use `ert' to run tests interactively. @@ -228,8 +227,7 @@ in batch mode, an error is signaled. (tags nil tags-supplied-p)) body) (ert--parse-keys-and-body docstring-keys-and-body) - `(cl-macrolet ((skip-when (form) `(ert--skip-when ,form)) - (skip-unless (form) `(ert--skip-unless ,form))) + `(cl-macrolet ((skip-unless (form) `(ert--skip-unless ,form))) (ert-set-test ',name (make-ert-test :name ',name @@ -239,9 +237,7 @@ in batch mode, an error is signaled. `(:expected-result-type ,expected-result)) ,@(when tags-supplied-p `(:tags ,tags)) - ;; Add `nil' after the body to enable compiler warnings - ;; about unused computations at the end. - :body (lambda () ,@body nil) + :body (lambda () ,@body) :file-name ,(or (macroexp-file-name) buffer-file-name))) ',name)))) @@ -278,6 +274,14 @@ DATA is displayed to the user and should state the reason for skipping." (when ert--should-execution-observer (funcall ert--should-execution-observer form-description))) +;; See Bug#24402 for why this exists +(defun ert--should-signal-hook (error-symbol data) + "Stupid hack to stop `condition-case' from catching ert signals. +It should only be stopped when ran from inside `ert--run-test-internal'." + (when (and (not (symbolp debugger)) ; only run on anonymous debugger + (memq error-symbol '(ert-test-failed ert-test-skipped))) + (funcall debugger 'error (cons error-symbol data)))) + (defun ert--special-operator-p (thing) "Return non-nil if THING is a symbol naming a special operator." (and (symbolp thing) @@ -316,7 +320,8 @@ DATA is displayed to the user and should state the reason for skipping." (default-value (gensym "ert-form-evaluation-aborted-"))) `(let* ((,fn (function ,fn-name)) (,args (condition-case err - (list ,@arg-forms) + (let ((signal-hook-function #'ert--should-signal-hook)) + (list ,@arg-forms)) (error (progn (setq ,fn #'signal) (list (car err) (cdr err))))))) @@ -457,15 +462,6 @@ failed." (list :fail-reason "did not signal an error"))))))))) -(cl-defmacro ert--skip-when (form) - "Evaluate FORM. If it returns t, skip the current test. -Errors during evaluation are caught and handled like t." - (declare (debug t)) - (ert--expand-should `(skip-when ,form) form - (lambda (inner-form form-description-form _value-var) - `(when (condition-case nil ,inner-form (t t)) - (ert-skip ,form-description-form))))) - (cl-defmacro ert--skip-unless (form) "Evaluate FORM. If it returns nil, skip the current test. Errors during evaluation are caught and handled like nil." @@ -719,68 +715,78 @@ in front of the value of MESSAGE-FORM." ;; value and test execution should be terminated. Should not ;; return. (exit-continuation (cl-assert nil)) + ;; The binding of `debugger' outside of the execution of the test. + next-debugger ;; The binding of `ert-debug-on-error' that is in effect for the ;; execution of the current test. We store it to avoid being ;; affected by any new bindings the test itself may establish. (I ;; don't remember whether this feature is important.) ert-debug-on-error) -(defun ert--run-test-debugger (info condition debugfun) - "Error handler used during the test run. +(defun ert--run-test-debugger (info args) + "During a test run, `debugger' is bound to a closure that calls this function. This function records failures and errors and either terminates the test silently or calls the interactive debugger, as appropriate. -INFO is the `ert--test-execution-info' corresponding to this test run. -ERR is the error object." - (let* ((type (cl-case (car condition) - ((quit) 'quit) - ((ert-test-skipped) 'skipped) - (otherwise 'failed))) - ;; 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-at-point-debugging-errors', - ;; (i.e., when running interactively) but having the - ;; backtrace ready for printing is important for batch - ;; use. - ;; - ;; Grab the frames above ourselves. - (backtrace (cdr (backtrace-get-frames debugfun))) - (infos (reverse ert--infos))) - (setf (ert--test-execution-info-result info) - (cl-ecase type - (quit - (make-ert-test-quit :condition condition - :backtrace backtrace - :infos infos)) - (skipped - (make-ert-test-skipped :condition condition - :backtrace backtrace - :infos infos)) - (failed - (make-ert-test-failed :condition condition - :backtrace backtrace - :infos infos)))) - ;; FIXME: We should probably implement more fine-grained - ;; control a la non-t `debug-on-error' here. - (cond - ((ert--test-execution-info-ert-debug-on-error info) - ;; The `debugfun' arg tells `debug' which backtrace frame starts - ;; the "entering the debugger" code so it can hide those frames - ;; from the backtrace. - (funcall debugger 'error condition :backtrace-base debugfun)) - (t)) - (funcall (ert--test-execution-info-exit-continuation info)))) +INFO is the ert--test-execution-info corresponding to this test +run. ARGS are the arguments to `debugger'." + (cl-destructuring-bind (first-debugger-arg &rest more-debugger-args) + args + (cl-ecase first-debugger-arg + ((lambda debug t exit nil) + (apply (ert--test-execution-info-next-debugger info) args)) + (error + (let* ((condition (car more-debugger-args)) + (type (cl-case (car condition) + ((quit) 'quit) + ((ert-test-skipped) 'skipped) + (otherwise 'failed))) + ;; 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-at-point-debugging-errors', + ;; (i.e., when running interactively) but having the + ;; backtrace ready for printing is important for batch + ;; use. + ;; + ;; Grab the frames above the debugger. + (backtrace (cdr (backtrace-get-frames debugger))) + (infos (reverse ert--infos))) + (setf (ert--test-execution-info-result info) + (cl-ecase type + (quit + (make-ert-test-quit :condition condition + :backtrace backtrace + :infos infos)) + (skipped + (make-ert-test-skipped :condition condition + :backtrace backtrace + :infos infos)) + (failed + (make-ert-test-failed :condition condition + :backtrace backtrace + :infos infos)))) + ;; Work around Emacs's heuristic (in eval.c) for detecting + ;; errors in the debugger. + (cl-incf num-nonmacro-input-events) + ;; FIXME: We should probably implement more fine-grained + ;; control a la non-t `debug-on-error' here. + (cond + ((ert--test-execution-info-ert-debug-on-error info) + (apply (ert--test-execution-info-next-debugger info) args)) + (t)) + (funcall (ert--test-execution-info-exit-continuation info))))))) (defun ert--run-test-internal (test-execution-info) "Low-level function to run a test according to TEST-EXECUTION-INFO. This mainly sets up debugger-related bindings." - (setf (ert--test-execution-info-ert-debug-on-error test-execution-info) + (setf (ert--test-execution-info-next-debugger test-execution-info) debugger + (ert--test-execution-info-ert-debug-on-error test-execution-info) ert-debug-on-error) (catch 'ert--pass ;; For now, each test gets its own temp buffer and its own @@ -788,14 +794,26 @@ This mainly sets up debugger-related bindings." ;; too expensive, we can remove it. (with-temp-buffer (save-window-excursion - (let ((lexical-binding t) ;;FIXME: Why? + ;; FIXME: Use `signal-hook-function' instead of `debugger' to + ;; handle ert errors. Once that's done, remove + ;; `ert--should-signal-hook'. See Bug#24402 and Bug#11218 for + ;; details. + (let ((lexical-binding t) + (debugger (lambda (&rest args) + (ert--run-test-debugger test-execution-info + args))) + (debug-on-error t) + ;; Don't infloop if the error being called is erroring + ;; out, and we have `debug-on-error' bound to nil inside + ;; the test. + (backtrace-on-error-noninteractive nil) + (debug-on-quit t) + ;; FIXME: Do we need to store the old binding of this + ;; and consider it in `ert--run-test-debugger'? + (debug-ignored-errors nil) (ert--infos '())) - (letrec ((debugfun (lambda (err) - (ert--run-test-debugger test-execution-info - err debugfun)))) - (handler-bind (((error quit) debugfun)) - (funcall (ert-test-body (ert--test-execution-info-test - test-execution-info)))))))) + (funcall (ert-test-body (ert--test-execution-info-test + test-execution-info)))))) (ert-pass)) (setf (ert--test-execution-info-result test-execution-info) (make-ert-test-passed)) @@ -932,14 +950,14 @@ of tests, or t, which refers to all tests named by symbols in `obarray'. Valid SELECTORs: nil -- Selects the empty set. -t -- Selects all of UNIVERSE. If UNIVERSE is t, selects all tests. +t -- Selects UNIVERSE. :new -- Selects all tests that have not been run yet. :failed, :passed -- Select tests according to their most recent result. :expected, :unexpected -- Select tests according to their most recent result. a string -- A regular expression selecting all tests with matching names. -a test -- (i.e., an object of the `ert-test' data-type) Selects that test. -a symbol -- Selects the test named by the symbol, signals an - `ert-test-unbound' error if no such test. +a test -- (i.e., an object of the ert-test data-type) Selects that test. +a symbol -- Selects the test that the symbol names, signals an + `ert-test-unbound' error if none. \(member TESTS...) -- Selects the elements of TESTS, a list of tests or symbols naming tests. \(eql TEST) -- Selects TEST, a test or a symbol naming a test. @@ -1316,9 +1334,14 @@ empty string." (defun ert--pp-with-indentation-and-newline (object) "Pretty-print OBJECT, indenting it to the current column of point. Ensures a final newline is inserted." - (let ((pp-escape-newlines t) + (let ((begin (point)) + (pp-escape-newlines t) (print-escape-control-characters t)) - (pp object (current-buffer)))) + (pp object (current-buffer)) + (unless (bolp) (insert "\n")) + (save-excursion + (goto-char begin) + (indent-sexp)))) (defun ert--insert-infos (result) "Insert `ert-info' infos from RESULT into current buffer. @@ -1370,10 +1393,10 @@ RESULT must be an `ert-test-result-with-condition'." (defun ert-run-tests-batch (&optional selector) "Run the tests specified by SELECTOR, printing results to the terminal. -SELECTOR selects which tests to run as described in `ert-select-tests' when -called with its second argument t, except if SELECTOR is nil, in which case -all tests rather than none will be run; this makes the command line - \"emacs -batch -l my-tests.el -f ert-run-tests-batch-and-exit\" useful. +SELECTOR works as described in `ert-select-tests', except if +SELECTOR is nil, in which case all tests rather than none will be +run; this makes the command line \"emacs -batch -l my-tests.el -f +ert-run-tests-batch-and-exit\" useful. Returns the stats object." (unless selector (setq selector 't)) @@ -2235,9 +2258,7 @@ STATS is the stats object; LISTENER is the results listener." (defun ert-run-tests-interactively (selector) "Run the tests specified by SELECTOR and display the results in a buffer. -SELECTOR selects which tests to run as described in `ert-select-tests' -when called with its second argument t. Interactively, prompt for -SELECTOR; the default t means run all the defined tests." +SELECTOR works as described in `ert-select-tests'." (interactive (list (let ((default (if ert--selector-history ;; Can't use `first' here as this form is @@ -2813,7 +2834,8 @@ To be used in the ERT results buffer." (insert (format-message " defined in `%s'" (file-name-nondirectory file-name))) (save-excursion - (re-search-backward (substitute-command-keys "`\\([^`']+\\)'")) + (re-search-backward (substitute-command-keys "`\\([^`']+\\)'") + nil t) (help-xref-button 1 'help-function-def test-name file-name))) (insert ".") (fill-region-as-paragraph (point-min) (point)) diff --git a/lisp/emacs-lisp/ewoc.el b/lisp/emacs-lisp/ewoc.el index da481c98..56527afc 100644 --- a/lisp/emacs-lisp/ewoc.el +++ b/lisp/emacs-lisp/ewoc.el @@ -1,6 +1,6 @@ ;;; ewoc.el --- utility to maintain a view of a list of objects in a buffer -*- lexical-binding: t -*- -;; Copyright (C) 1991-2024 Free Software Foundation, Inc. +;; Copyright (C) 1991-2023 Free Software Foundation, Inc. ;; Author: Per Cederqvist ;; Inge Wallin diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 8eafdef9..bf890fc3 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -1,6 +1,6 @@ ;;; find-func.el --- find the definition of the Emacs Lisp function near point -*- lexical-binding:t -*- -;; Copyright (C) 1997, 1999, 2001-2024 Free Software Foundation, Inc. +;; Copyright (C) 1997, 1999, 2001-2023 Free Software Foundation, Inc. ;; Author: Jens Petersen ;; Keywords: emacs-lisp, functions, variables @@ -26,7 +26,7 @@ ;; The funniest thing about this is that I can't imagine why a package ;; so obviously useful as this hasn't been written before!! ;; ;;; find-func -;; (find-function-mode 1) +;; (find-function-setup-keys) ;; ;; or just: ;; @@ -42,6 +42,8 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + ;;; User variables: (defgroup find-function nil @@ -60,7 +62,6 @@ ine\\(?:-global\\)?-minor-mode\\|ine-compilation-mode\\|un-cvs-mode\\|\ foo\\|\\(?:[^icfgv]\\|g[^r]\\)\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\ cl-\\(?:defun\\|defmethod\\|defgeneric\\)\\|\ -transient-define-\\(?:prefix\\|suffix\\|infix\\|argument\\)\\|\ menu-bar-make-toggle\\|menu-bar-make-toggle-command\\)" find-function-space-re "\\('\\|(quote \\)?%s\\(\\s-\\|$\\|[()]\\)") @@ -125,7 +126,7 @@ should insert the feature name." (defcustom find-ert-deftest-regexp "(ert-deftest +'%s" - "The regexp used to search for an `ert-deftest' definition. + "The regexp used to search for an ert-deftest definition. Note it must contain a `%s' at the place where `format' should insert the feature name." :type 'regexp @@ -246,19 +247,13 @@ LIBRARY should be a string (the name of the library)." ;; LIBRARY may be "foo.el" or "foo". (let ((load-re (concat "\\(" (regexp-quote (file-name-sans-extension library)) "\\)" - (regexp-opt (get-load-suffixes)) "\\'")) - (alist load-history) - elt file found) - (while (and alist (null found)) - (setq elt (car alist) - alist (cdr alist) - file (car elt) - found (and (stringp file) (string-match load-re file) - (let ((dir (substring file 0 (match-beginning 1))) - (basename (match-string 1 file))) - (locate-file basename (list dir) - (find-library-suffixes)))))) - found)) + (regexp-opt (get-load-suffixes)) "\\'"))) + (cl-loop + for (file . _) in load-history thereis + (and (stringp file) (string-match load-re file) + (let ((dir (substring file 0 (match-beginning 1))) + (basename (match-string 1 file))) + (locate-file basename (list dir) (find-library-suffixes))))))) (defvar find-function-C-source-directory (let ((dir (expand-file-name "src" source-directory))) @@ -323,8 +318,6 @@ customizing the candidate completions." (switch-to-buffer (find-file-noselect (find-library-name library))) (run-hooks 'find-function-after-hook))) -(defvar find-function--read-history-library nil) - ;;;###autoload (defun read-library-name () "Read and return a library name, defaulting to the one near point. @@ -353,14 +346,12 @@ if non-nil)." (when (and def (not (test-completion def table))) (setq def nil)) (completing-read (format-prompt "Library name" def) - table nil nil nil - 'find-function--read-history-library def)) + table nil nil nil nil def)) (let ((files (read-library-name--find-files dirs suffixes))) (when (and def (not (member def files))) (setq def nil)) (completing-read (format-prompt "Library name" def) - files nil t nil - 'find-function--read-history-library def))))) + files nil t nil nil def))))) (defun read-library-name--find-files (dirs suffixes) "Return a list of all files in DIRS that match SUFFIXES." @@ -478,8 +469,7 @@ Return t if any PRED returns t." ((not (consp form)) nil) ((funcall pred form) t) (t - (let ((left-child (car form)) - (right-child (cdr form))) + (cl-destructuring-bind (left-child . right-child) form (or (find-function--any-subform-p left-child pred) (find-function--any-subform-p right-child pred)))))) @@ -579,10 +569,6 @@ is non-nil, signal an error instead." (let ((func-lib (find-function-library function lisp-only t))) (find-function-search-for-symbol (car func-lib) nil (cdr func-lib)))) -(defvar find-function--read-history-function nil) -(defvar find-function--read-history-variable nil) -(defvar find-function--read-history-face nil) - (defun find-function-read (&optional type) "Read and return an interned symbol, defaulting to the one near point. @@ -605,9 +591,7 @@ otherwise uses `variable-at-point'." (list (intern (completing-read (format-prompt "Find %s" symb prompt-type) obarray predicate - 'lambda nil - (intern (format "find-function--read-history-%s" prompt-type)) - (and symb (symbol-name symb))))))) + t nil nil (and symb (symbol-name symb))))))) (defun find-function-do-it (symbol type switch-fn) "Find Emacs Lisp SYMBOL in a buffer and display it. @@ -805,37 +789,21 @@ See `find-function-on-key'." (when (and symb (not (equal symb 0))) (find-variable-other-window symb)))) -;; RUNE-BOOTSTRAP -;; ;;;###autoload -;; (define-minor-mode find-function-mode -;; "Enable some key bindings for the `find-function' family of functions." -;; :group 'find-function :version "31.1" :global t :lighter nil -;; ;; For compatibility with the historical behavior of the old -;; ;; `find-function-setup-keys', define our bindings at the precedence -;; ;; level of the global map. -;; :keymap nil -;; (pcase-dolist (`(,map ,key ,cmd) -;; `((,ctl-x-map "F" find-function) -;; (,ctl-x-4-map "F" find-function-other-window) -;; (,ctl-x-5-map "F" find-function-other-frame) -;; (,ctl-x-map "K" find-function-on-key) -;; (,ctl-x-4-map "K" find-function-on-key-other-window) -;; (,ctl-x-5-map "K" find-function-on-key-other-frame) -;; (,ctl-x-map "V" find-variable) -;; (,ctl-x-4-map "V" find-variable-other-window) -;; (,ctl-x-5-map "V" find-variable-other-frame) -;; (,ctl-x-map "L" find-library) -;; (,ctl-x-4-map "L" find-library-other-window) -;; (,ctl-x-5-map "L" find-library-other-frame))) -;; (if find-function-mode -;; (keymap-set map key cmd) -;; (keymap-unset map key t)))) - ;;;###autoload (defun find-function-setup-keys () - "Turn on `find-function-mode', which see." - (find-function-mode 1)) -(make-obsolete 'find-function-setup-keys 'find-function-mode "31.1") + "Define some key bindings for the `find-function' family of functions." + (define-key ctl-x-map "F" 'find-function) + (define-key ctl-x-4-map "F" 'find-function-other-window) + (define-key ctl-x-5-map "F" 'find-function-other-frame) + (define-key ctl-x-map "K" 'find-function-on-key) + (define-key ctl-x-4-map "K" 'find-function-on-key-other-window) + (define-key ctl-x-5-map "K" 'find-function-on-key-other-frame) + (define-key ctl-x-map "V" 'find-variable) + (define-key ctl-x-4-map "V" 'find-variable-other-window) + (define-key ctl-x-5-map "V" 'find-variable-other-frame) + (define-key ctl-x-map "L" 'find-library) + (define-key ctl-x-4-map "L" 'find-library-other-window) + (define-key ctl-x-5-map "L" 'find-library-other-frame)) (provide 'find-func) diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index d3d71a36..7a48ba47 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -1,6 +1,6 @@ ;;; map.el --- Map manipulation functions -*- lexical-binding: t; -*- -;; Copyright (C) 2015-2024 Free Software Foundation, Inc. +;; Copyright (C) 2015-2023 Free Software Foundation, Inc. ;; Author: Nicolas Petton ;; Maintainer: emacs-devel@gnu.org @@ -8,9 +8,6 @@ ;; Version: 3.3.1 ;; Package-Requires: ((emacs "26")) -;; This is a GNU ELPA :core package. Avoid functionality that is not -;; compatible with the version of Emacs recorded above. - ;; This file is part of GNU Emacs. ;; GNU Emacs is free software: you can redistribute it and/or modify @@ -53,20 +50,18 @@ ARGS is a list of elements to be matched in the map. -Each element of ARGS can be of the form (KEY PAT [DEFAULT]), -which looks up KEY in the map and matches the associated value -against `pcase' pattern PAT. DEFAULT specifies the fallback -value to use when KEY is not present in the map. If omitted, it -defaults to nil. Both KEY and DEFAULT are evaluated. +Each element of ARGS can be of the form (KEY PAT), in which case KEY is +evaluated and searched for in the map. The match fails if for any KEY +found in the map, the corresponding PAT doesn't match the value +associated with the KEY. Each element can also be a SYMBOL, which is an abbreviation of a (KEY PAT) tuple of the form (\\='SYMBOL SYMBOL). When SYMBOL is a keyword, it is an abbreviation of the form (:SYMBOL SYMBOL), useful for binding plist values. -An element of ARGS fails to match if PAT does not match the -associated value or the default value. The overall pattern fails -to match if any element of ARGS fails to match." +Keys in ARGS not found in the map are ignored, and the match doesn't +fail." `(and (pred mapp) ,@(map--make-pcase-bindings args))) @@ -76,13 +71,12 @@ to match if any element of ARGS fails to match." KEYS can be a list of symbols, in which case each element will be bound to the looked up value in MAP. -KEYS can also be a list of (KEY VARNAME [DEFAULT]) sublists, in -which case KEY and DEFAULT are unquoted forms. +KEYS can also be a list of (KEY VARNAME) pairs, in which case +KEY is an unquoted form. MAP can be an alist, plist, hash-table, or array." (declare (indent 2) - (debug ((&rest &or symbolp ([form symbolp &optional form])) - form body))) + (debug ((&rest &or symbolp ([form symbolp])) form body))) `(pcase-let ((,(map--make-pcase-patterns keys) ,map)) ,@body)) @@ -601,37 +595,15 @@ Example: (map-into \\='((1 . 3)) \\='(hash-table :test eql))" (map--into-hash map (cdr type))) -(defmacro map--pcase-map-elt (key default map) - "A macro to make MAP the last argument to `map-elt'. - -This allows using default values for `map-elt', which can't be -done using `pcase--flip'. - -KEY is the key sought in the map. DEFAULT is the default value." - ;; It's obsolete in Emacs>29, but `map.el' is distributed via GNU ELPA - ;; for earlier Emacsen. - (declare (obsolete _ "30.1")) - `(map-elt ,map ,key ,default)) - (defun map--make-pcase-bindings (args) "Return a list of pcase bindings from ARGS to the elements of a map." - (mapcar (if (< emacs-major-version 30) - (lambda (elt) - (cond ((consp elt) - `(app (map--pcase-map-elt ,(car elt) ,(caddr elt)) - ,(cadr elt))) - ((keywordp elt) - (let ((var (intern (substring (symbol-name elt) 1)))) - `(app (pcase--flip map-elt ,elt) ,var))) - (t `(app (pcase--flip map-elt ',elt) ,elt)))) - (lambda (elt) - (cond ((consp elt) - `(app (map-elt _ ,(car elt) ,(caddr elt)) - ,(cadr elt))) - ((keywordp elt) - (let ((var (intern (substring (symbol-name elt) 1)))) - `(app (map-elt _ ,elt) ,var))) - (t `(app (map-elt _ ',elt) ,elt))))) + (mapcar (lambda (elt) + (cond ((consp elt) + `(app (pcase--flip map-elt ,(car elt)) ,(cadr elt))) + ((keywordp elt) + (let ((var (intern (substring (symbol-name elt) 1)))) + `(app (pcase--flip map-elt ,elt) ,var))) + (t `(app (pcase--flip map-elt ',elt) ,elt)))) args)) (defun map--make-pcase-patterns (args) diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index 12346b3d..e6e3cd6c 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -1,6 +1,6 @@ ;;; pp.el --- pretty printer for Emacs Lisp -*- lexical-binding: t -*- -;; Copyright (C) 1989, 1993, 2001-2024 Free Software Foundation, Inc. +;; Copyright (C) 1989, 1993, 2001-2023 Free Software Foundation, Inc. ;; Author: Randal Schwartz ;; Keywords: lisp @@ -25,6 +25,7 @@ ;;; Code: (require 'cl-lib) +(defvar font-lock-verbose) (defgroup pp nil "Pretty printer for Emacs Lisp." @@ -51,253 +52,53 @@ Note that this could slow down `pp' considerably when formatting large lists." :type 'boolean :version "29.1") -(make-obsolete-variable 'pp-use-max-width 'pp-default-function "30.1") - -(defcustom pp-default-function #'pp-fill - ;; FIXME: The best pretty printer to use depends on the use-case - ;; so maybe we should allow callers to specify what they want (maybe with - ;; options like `fast', `compact', `code', `data', ...) and these - ;; can then be mapped to actual pretty-printing algorithms. - ;; Then again, callers can just directly call the corresponding function. - "Function that `pp' should dispatch to for pretty printing. -That function can be called in one of two ways: -- with a single argument, which it should insert and pretty-print at point. -- with two arguments which delimit a region containing Lisp sexps - which should be pretty-printed. -In both cases, the function can presume that the buffer is setup for -Lisp syntax." - :type '(choice - (const :tag "Fit within `fill-column'" pp-fill) - (const :tag "Emacs<29 algorithm, fast and good enough" pp-28) - (const :tag "Work hard for code (slow on large inputs)" - pp-emacs-lisp-code) - (const :tag "`pp-emacs-lisp-code' if `pp-use-max-width' else `pp-28'" - pp-29) - function) - :version "30.1") (defvar pp--inhibit-function-formatting nil) -;; There are basically two APIs for a pretty-printing function: -;; -;; - either the function takes an object (and prints it in addition to -;; prettifying it). -;; - or the function takes a region containing an already printed object -;; and prettifies its content. -;; -;; `pp--object' and `pp--region' are helper functions to convert one -;; API to the other. - - -(defun pp--object (object region-function) - "Pretty-print OBJECT at point. -The prettifying is done by REGION-FUNCTION which is -called with two positions as arguments and should fold lines -within that region. Returns the result as a string." - (let ((print-escape-newlines pp-escape-newlines) - (print-quoted t) - (beg (point))) - ;; FIXME: In many cases it would be preferable to use `cl-prin1' here. - (prin1 object (current-buffer)) - (funcall region-function beg (point)))) - -(defun pp--region (beg end object-function) - "Pretty-print the object(s) contained within BEG..END. -OBJECT-FUNCTION is called with a single object as argument -and should pretty print it at point into the current buffer." - (save-excursion - (with-restriction beg end - (goto-char (point-min)) - (while - (progn - ;; We'll throw away all the comments within objects, but let's - ;; try at least to preserve the comments between objects. - (forward-comment (point-max)) - (let ((beg (point)) - (object (ignore-error end-of-buffer - (list (read (current-buffer)))))) - (when (consp object) - (delete-region beg (point)) - (funcall object-function (car object)) - t))))))) - -(defun pp-29 (beg-or-sexp &optional end) ;FIXME: Better name? - "Prettify the current region with printed representation of a Lisp object. -Uses the pretty-printing algorithm that was standard in Emacs-29, -which, depending on `pp-use-max-width', will either use `pp-28' -or `pp-emacs-lisp-code'." - (if pp-use-max-width - (let ((pp--inhibit-function-formatting t)) ;FIXME: Why? - (pp-emacs-lisp-code beg-or-sexp end)) - (pp-28 beg-or-sexp end))) - ;;;###autoload -(defun pp-to-string (object &optional pp-function) +(defun pp-to-string (object) "Return a string containing the pretty-printed representation of OBJECT. OBJECT can be any Lisp object. Quoting characters are used as needed -to make output that `read' can handle, whenever this is possible. -Optional argument PP-FUNCTION overrides `pp-default-function'." - (with-temp-buffer - (lisp-mode-variables nil) - (set-syntax-table emacs-lisp-mode-syntax-table) - (funcall (or pp-function pp-default-function) object) - ;; Preserve old behavior of (usually) finishing with a newline. - (unless (bolp) (insert "\n")) - (buffer-string))) - -(defun pp--within-fill-column-p () - "Return non-nil if point is within `fill-column'." - ;; Try and make it O(fill-column) rather than O(current-column), - ;; so as to avoid major slowdowns on long lines. - ;; FIXME: This doesn't account for invisible text or `display' properties :-( - (and (save-excursion - (re-search-backward - "^\\|\n" (max (point-min) (- (point) fill-column)) t)) - (<= (current-column) fill-column))) - -(defun pp-fill (beg &optional end) - "Break lines in Lisp code between BEG and END so it fits within `fill-column'. -Presumes the current buffer has syntax and indentation properly -configured for that. -Designed under the assumption that the region occupies a single line, -tho it should also work if that's not the case. -Can also be called with a single argument, in which case -it inserts and pretty-prints that arg at point." - (interactive "r") - (if (null end) (pp--object beg #'pp-fill) - (goto-char beg) - (let* ((end (copy-marker end t)) - (avoid-unbreakable - (lambda () - (and (memq (char-before) '(?# ?s ?f)) - (memq (char-after) '(?\[ ?\()) - (looking-back "#[sf]?" (- (point) 2)) - (goto-char (match-beginning 0))))) - (newline (lambda () - (skip-chars-forward ")]}") - (unless (save-excursion (skip-chars-forward " \t") (eolp)) - (funcall avoid-unbreakable) - (insert "\n") - (indent-according-to-mode))))) - (while (progn (forward-comment (point-max)) - (< (point) end)) - (let ((beg (point)) - ;; Whether we're in front of an element with paired delimiters. - ;; Can be something funky like #'(lambda ..) or ,'#s(...) - ;; Or also #^[..]. - (paired (when (looking-at "['`,#]*[[:alpha:]^]*\\([({[\"]\\)") - (match-beginning 1)))) - ;; Go to the end of the sexp. - (goto-char (or (scan-sexps (or paired (point)) 1) end)) - (unless - (and - ;; The sexp is all on a single line. - (save-excursion (not (search-backward "\n" beg t))) - ;; And its end is within `fill-column'. - (or (pp--within-fill-column-p) - ;; If the end of the sexp is beyond `fill-column', - ;; try to move the sexp to its own line. - (and - (save-excursion - (goto-char beg) - ;; We skip backward over open parens because cutting - ;; the line right after an open paren does not help - ;; reduce the indentation depth. - ;; Similarly, we prefer to cut before a "." than after - ;; it because it reduces the indentation depth. - (while - (progn - (funcall avoid-unbreakable) - (not (zerop (skip-chars-backward " \t({[',."))))) - (if (bolp) - ;; The sexp already starts on its own line. - (progn (goto-char beg) nil) - (setq beg (copy-marker beg t)) - (if paired (setq paired (copy-marker paired t))) - ;; We could try to undo this insertion if it - ;; doesn't reduce the indentation depth, but I'm - ;; not sure it's worth the trouble. - (insert "\n") (indent-according-to-mode) - t)) - ;; Check again if we moved the whole exp to a new line. - (pp--within-fill-column-p)))) - ;; The sexp is spread over several lines, and/or its end is - ;; (still) beyond `fill-column'. - (when (and paired (not (eq ?\" (char-after paired)))) - ;; The sexp has sub-parts, so let's try and spread - ;; them over several lines. - (save-excursion - (goto-char beg) - (when (looking-at "(\\([^][()\" \t\n;']+\\)") - ;; Inside an expression of the form (SYM ARG1 - ;; ARG2 ... ARGn) where SYM has a `lisp-indent-function' - ;; property that's a number, insert a newline after - ;; the corresponding ARGi, because it tends to lead to - ;; more natural and less indented code. - (let* ((sym (intern-soft (match-string 1))) - (lif (and sym (get sym 'lisp-indent-function)))) - (if (eq lif 'defun) (setq lif 2)) - (when (natnump lif) - (goto-char (match-end 0)) - ;; Do nothing if there aren't enough args. - (ignore-error scan-error - (forward-sexp lif) - (funcall newline)))))) - (save-excursion - (pp-fill (1+ paired) (1- (point))))) - ;; Now the sexp either ends beyond `fill-column' or is - ;; spread over several lines (or both). Either way, the - ;; rest of the line should be moved to its own line. - (funcall newline))))))) +to make output that `read' can handle, whenever this is possible." + (if pp-use-max-width + (let ((pp--inhibit-function-formatting t)) + (with-temp-buffer + (pp-emacs-lisp-code object) + (buffer-string))) + (with-temp-buffer + (lisp-mode-variables nil) + (set-syntax-table emacs-lisp-mode-syntax-table) + (let ((print-escape-newlines pp-escape-newlines) + (print-quoted t)) + (prin1 object (current-buffer))) + (pp-buffer) + (buffer-string)))) ;;;###autoload (defun pp-buffer () "Prettify the current buffer with printed representation of a Lisp object." (interactive) - ;; The old code used `indent-sexp' which mostly works "anywhere", - ;; so let's make sure we also work right in buffers that aren't - ;; setup specifically for Lisp. - (if (and (eq (syntax-table) emacs-lisp-mode-syntax-table) - (eq indent-line-function #'lisp-indent-line)) - (funcall pp-default-function (point-min) (point-max)) - (with-syntax-table emacs-lisp-mode-syntax-table - (let ((indent-line-function #'lisp-indent-line)) - (funcall pp-default-function (point-min) (point-max))))) - ;; Preserve old behavior of (usually) finishing with a newline and - ;; with point at BOB. - (goto-char (point-max)) - (unless (bolp) (insert "\n")) - (goto-char (point-min))) - -(defun pp-28 (beg &optional end) ;FIXME: Better name? - "Prettify the current region with printed representation of a Lisp object. -Uses the pretty-printing algorithm that was standard before Emacs-30. -Non-interactively can also be called with a single argument, in which -case that argument will be inserted pretty-printed at point." - (interactive "r") - (if (null end) (pp--object beg #'pp-29) - (with-restriction beg end - (goto-char (point-min)) - (while (not (eobp)) - (cond - ((ignore-errors (down-list 1) t) - (save-excursion - (backward-char 1) - (skip-chars-backward "'`#^") - (when (and (not (bobp)) (memq (char-before) '(?\s ?\t ?\n))) - (delete-region - (point) - (progn (skip-chars-backward " \t\n") (point))) - (insert "\n")))) - ((ignore-errors (up-list 1) t) - (skip-syntax-forward ")") + (goto-char (point-min)) + (while (not (eobp)) + (cond + ((ignore-errors (down-list 1) t) + (save-excursion + (backward-char 1) + (skip-chars-backward "'`#^") + (when (and (not (bobp)) (memq (char-before) '(?\s ?\t ?\n))) (delete-region (point) - (progn (skip-chars-forward " \t\n") (point))) - (insert ?\n)) - (t (goto-char (point-max))))) - (goto-char (point-min)) - (indent-sexp)))) + (progn (skip-chars-backward " \t\n") (point))) + (insert "\n")))) + ((ignore-errors (up-list 1) t) + (skip-syntax-forward ")") + (delete-region + (point) + (progn (skip-chars-forward " \t\n") (point))) + (insert ?\n)) + (t (goto-char (point-max))))) + (goto-char (point-min)) + (indent-sexp)) ;;;###autoload (defun pp (object &optional stream) @@ -305,27 +106,14 @@ case that argument will be inserted pretty-printed at point." Quoting characters are printed as needed to make output that `read' can handle, whenever this is possible. -Uses the pretty-printing code specified in `pp-default-function'. +This function does not apply special formatting rules for Emacs +Lisp code. See `pp-emacs-lisp-code' instead. + +By default, this function won't limit the line length of lists +and vectors. Bind `pp-use-max-width' to a non-nil value to do so. Output stream is STREAM, or value of `standard-output' (which see)." - (let ((stream (or stream standard-output))) - (cond - ((and (eq stream (current-buffer)) - ;; Make sure the current buffer is setup sanely. - (eq (syntax-table) emacs-lisp-mode-syntax-table) - (eq indent-line-function #'lisp-indent-line)) - ;; Skip the buffer->string->buffer middle man. - (funcall pp-default-function object) - ;; Preserve old behavior of (usually) finishing with a newline. - (unless (bolp) (insert "\n"))) - (t - (save-current-buffer - (when (bufferp stream) (set-buffer stream)) - (let ((begin (point)) - (cols (current-column))) - (princ (pp-to-string object) (or stream standard-output)) - (when (and (> cols 0) (bufferp stream)) - (indent-rigidly begin (point) cols)))))))) + (princ (pp-to-string object) (or stream standard-output))) ;;;###autoload (defun pp-display-expression (expression out-buffer-name &optional lisp) @@ -334,8 +122,7 @@ If LISP, format with `pp-emacs-lisp-code'; use `pp' otherwise. If a temporary buffer is needed for representation, it will be named after OUT-BUFFER-NAME." - (let* ((lexical lexical-binding) - (old-show-function temp-buffer-show-function) + (let* ((old-show-function temp-buffer-show-function) ;; Use this function to display the buffer. ;; This function either decides not to display it at all ;; or displays it in the usual way. @@ -365,27 +152,9 @@ after OUT-BUFFER-NAME." (pp expression)) (with-current-buffer standard-output (emacs-lisp-mode) - (setq lexical-binding lexical) (setq buffer-read-only nil) (setq-local font-lock-verbose nil))))) -(defun pp-insert-short-sexp (sexp &optional width) - "Insert a short description of SEXP in the current buffer. -WIDTH is the maximum width to use for it and it defaults to the -space available between point and the window margin." - (let ((printed (format "%S" sexp))) - (if (and (not (string-search "\n" printed)) - (<= (string-width printed) - (or width (- (window-width) (current-column))))) - (insert printed) - (insert-text-button - "[Show]" - 'follow-link t - 'action (lambda (&rest _ignore) - ;; FIXME: Why "eval output"? - (pp-display-expression sexp "*Pp Eval Output*")) - 'help-echo "mouse-2, RET: pretty print value in another buffer")))) - ;;;###autoload (defun pp-eval-expression (expression) "Evaluate EXPRESSION and pretty-print its value. @@ -451,63 +220,51 @@ Ignores leading comment characters." (pp-macroexpand-expression (pp-last-sexp)))) ;;;###autoload -(defun pp-emacs-lisp-code (sexp &optional end) +(defun pp-emacs-lisp-code (sexp) "Insert SEXP into the current buffer, formatted as Emacs Lisp code. Use the `pp-max-width' variable to control the desired line length. -Note that this could be slow for large SEXPs. -Can also be called with two arguments, in which case they're taken to be -the bounds of a region containing Lisp code to pretty-print." +Note that this could be slow for large SEXPs." (require 'edebug) - (if end (pp--region sexp end #'pp-emacs-lisp-code) - (let ((obuf (current-buffer))) - (with-temp-buffer - (emacs-lisp-mode) - (pp--insert-lisp sexp) - (insert "\n") - (goto-char (point-min)) - (indent-sexp) - (while (re-search-forward " +$" nil t) - (replace-match "")) - (insert-into-buffer obuf))))) - -(defvar pp--quoting-syntaxes - `((quote . "'") - (function . "#'") - (,backquote-backquote-symbol . "`") - (,backquote-unquote-symbol . ",") - (,backquote-splice-symbol . ",@"))) - -(defun pp--quoted-or-unquoted-form-p (cons) - ;; Return non-nil when CONS has one of the forms 'X, `X, ,X or ,@X - (let ((head (car cons))) - (and (symbolp head) - (assq head pp--quoting-syntaxes) - (let ((rest (cdr cons))) - (and (consp rest) (null (cdr rest))))))) + (let ((obuf (current-buffer))) + (with-temp-buffer + (emacs-lisp-mode) + (pp--insert-lisp sexp) + (insert "\n") + (goto-char (point-min)) + (indent-sexp) + (while (re-search-forward " +$" nil t) + (replace-match "")) + (insert-into-buffer obuf)))) (defun pp--insert-lisp (sexp) (cl-case (type-of sexp) (vector (pp--format-vector sexp)) (cons (cond ((consp (cdr sexp)) - (let ((head (car sexp))) - (if-let (((null (cddr sexp))) - (syntax-entry (assq head pp--quoting-syntaxes))) - (progn - (insert (cdr syntax-entry)) - (pp--insert-lisp (cadr sexp))) - (pp--format-list sexp)))) + (if (and (length= sexp 2) + (memq (car sexp) '(quote function))) + (cond + ((symbolp (cadr sexp)) + (let ((print-quoted t)) + (prin1 sexp (current-buffer)))) + ((consp (cadr sexp)) + (insert (if (eq (car sexp) 'quote) + "'" "#'")) + (pp--format-list (cadr sexp) + (set-marker (make-marker) (1- (point)))))) + (pp--format-list sexp))) (t - (pp--format-list sexp)))) + (prin1 sexp (current-buffer))))) ;; Print some of the smaller integers as characters, perhaps? (integer (if (<= ?0 sexp ?z) - (princ (prin1-char sexp) (current-buffer)) - (prin1 sexp (current-buffer)))) + (let ((print-integers-as-characters t)) + (princ sexp (current-buffer))) + (princ sexp (current-buffer)))) (string (let ((print-escape-newlines t)) (prin1 sexp (current-buffer)))) - (otherwise (prin1 sexp (current-buffer))))) + (otherwise (princ sexp (current-buffer))))) (defun pp--format-vector (sexp) (insert "[") @@ -517,29 +274,15 @@ the bounds of a region containing Lisp code to pretty-print." (insert "]")) (defun pp--format-list (sexp &optional start) - (if (not (let ((head (car sexp))) - (or pp--inhibit-function-formatting - (not (symbolp head)) - (keywordp head) - (let ((l sexp)) - (catch 'not-funcall - (while l - (when (or - (atom l) ; SEXP is a dotted list - ;; Does SEXP have a form like (ELT... . ,X) ? - (pp--quoted-or-unquoted-form-p l)) - (throw 'not-funcall t)) - (setq l (cdr l))) - nil))))) + (if (and (symbolp (car sexp)) + (not pp--inhibit-function-formatting) + (not (keywordp (car sexp)))) (pp--format-function sexp) (insert "(") (pp--insert start (pop sexp)) (while sexp (if (consp sexp) - (if (not (pp--quoted-or-unquoted-form-p sexp)) - (pp--insert " " (pop sexp)) - (pp--insert " . " sexp) - (setq sexp nil)) + (pp--insert " " (pop sexp)) (pp--insert " . " sexp) (setq sexp nil))) (insert ")"))) @@ -584,8 +327,7 @@ the bounds of a region containing Lisp code to pretty-print." (unless (consp edebug) (setq edebug nil)) (if (and (consp (car edebug)) - (eq (caar edebug) '&rest) - (proper-list-p (car sexp))) + (eq (caar edebug) '&rest)) (pp--insert-binding (pop sexp)) (if (null (car sexp)) (insert "()") From 84ea51cf403a0f414dc7db10686f15f4c10957c4 Mon Sep 17 00:00:00 2001 From: Troy Hinckley Date: Thu, 7 Nov 2024 22:15:35 -0600 Subject: [PATCH 5/7] Fix safe-length function --- src/fns.rs | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/src/fns.rs b/src/fns.rs index 7fda7a58..091c001a 100644 --- a/src/fns.rs +++ b/src/fns.rs @@ -578,7 +578,10 @@ pub(crate) fn length(sequence: Object) -> Result { #[defun] pub(crate) fn safe_length(sequence: Object) -> usize { - length(sequence).unwrap_or(0) + match sequence.untag() { + ObjectType::Cons(cons) => cons.elements().take_while(|x| x.is_ok()).count(), + _ => 0, + } } #[defun] @@ -1161,6 +1164,17 @@ mod test { assert_lisp("(let ((h (make-hash-table))) (puthash 1 6 h) (puthash 2 8 h) (puthash 3 10 h) (maphash 'eq h))", "nil"); } + #[test] + fn test_legnth() { + assert_lisp("(length nil)", "0"); + assert_lisp("(length '(1 2 3))", "3"); + assert_lisp("(length \"hello\")", "5"); + assert_lisp("(length [1 2 3])", "3"); + assert_lisp("(safe-length '(1 . 2))", "1"); + assert_lisp("(safe-length '(1 2 3 . 4))", "3"); + assert_lisp("(safe-length 'foo)", "0"); + } + #[test] fn test_sort() { assert_lisp("(sort nil '<)", "nil"); From 5587dee1557ffa4fe36c95da7535faa5349c47d8 Mon Sep 17 00:00:00 2001 From: Troy Hinckley Date: Thu, 7 Nov 2024 22:52:13 -0600 Subject: [PATCH 6/7] Fix nthcdr function --- src/bytecode.rs | 2 +- src/core/object/tagged.rs | 12 +++++++++--- src/fileio.rs | 5 ++--- src/fns.rs | 22 +++++++++++++++++----- src/interpreter.rs | 2 +- 5 files changed, 30 insertions(+), 13 deletions(-) diff --git a/src/bytecode.rs b/src/bytecode.rs index 96a3232d..0602a4ea 100755 --- a/src/bytecode.rs +++ b/src/bytecode.rs @@ -718,7 +718,7 @@ impl<'ob> RootedVM<'_, '_, '_> { op::Nthcdr => { let list = self.env.stack.pop(cx); let top = self.env.stack.top(); - top.set(fns::nthcdr(top.bind_as(cx)?, list.try_into()?)?.copy_as_obj(cx)); + top.set(fns::nthcdr(top.bind_as(cx)?, list.try_into()?)?.as_obj_copy()); } op::Elt => { let n = self.env.stack.pop(cx); diff --git a/src/core/object/tagged.rs b/src/core/object/tagged.rs index a1f752a8..9f684f28 100755 --- a/src/core/object/tagged.rs +++ b/src/core/object/tagged.rs @@ -110,11 +110,17 @@ impl Gc { self.ptr == other.ptr } - pub(crate) fn copy_as_obj(self, _: &Block) -> Object { + pub(crate) fn as_obj(&self) -> Object<'_> { Gc::new(self.ptr) } +} - pub(crate) fn as_obj(&self) -> Object<'_> { +#[expect(clippy::wrong_self_convention)] +impl<'ob, T> Gc +where + T: 'ob, +{ + pub(crate) fn as_obj_copy(self) -> Object<'ob> { Gc::new(self.ptr) } } @@ -314,7 +320,7 @@ where fn into_obj(self, block: &Block) -> Gc> { match self { - Some(x) => x.into_obj(block).copy_as_obj(block), + Some(x) => unsafe { cast_gc(x.into_obj(block)) }, None => NIL, } } diff --git a/src/fileio.rs b/src/fileio.rs index 55cf5622..8859d0d4 100644 --- a/src/fileio.rs +++ b/src/fileio.rs @@ -47,11 +47,10 @@ fn car_less_than_car(a: &Cons, b: &Cons) -> Result { #[defun] fn file_accessible_directory_p(filename: &str) -> bool { - let path = Path::new(filename); - path.exists() && path.is_dir() + let path = Path::new(filename); + path.exists() && path.is_dir() } - #[defun] fn file_name_as_directory(filename: &str) -> String { if filename.ends_with(MAIN_SEPARATOR) { diff --git a/src/fns.rs b/src/fns.rs index 091c001a..6ba956d9 100644 --- a/src/fns.rs +++ b/src/fns.rs @@ -599,11 +599,18 @@ pub(crate) fn nth(n: usize, list: List) -> Result { } #[defun] -pub(crate) fn nthcdr(n: usize, list: List) -> Result { - match list.conses().fallible().nth(n)? { - Some(x) => Ok(x.into()), - None => Ok(ListType::empty()), +pub(crate) fn nthcdr(n: usize, list: List) -> Result { + let ListType::Cons(mut cons) = list.untag() else { return Ok(NIL) }; + let mut tail = list.as_obj_copy(); + for _ in 0..n { + tail = cons.cdr(); + if let ObjectType::Cons(next) = tail.untag() { + cons = next; + } else { + break; + } } + Ok(tail) } #[defun] @@ -979,9 +986,14 @@ mod test { #[test] fn test_nthcdr() { - assert_lisp("(nthcdr 1 '(1 2 3))", "(2 3)"); + assert_lisp("(nthcdr 0 nil)", "nil"); + assert_lisp("(nthcdr 3 nil)", "nil"); assert_lisp("(nthcdr 0 '(1 2 3))", "(1 2 3)"); + assert_lisp("(nthcdr 1 '(1 2 3))", "(2 3)"); + assert_lisp("(nthcdr 2 '(1 2 3))", "(3)"); assert_lisp("(nthcdr 3 '(1 2 3))", "nil"); + assert_lisp("(nthcdr 1 '(1 . 2))", "2"); + assert_lisp("(nthcdr 2 '(1 2 . 3))", "3"); } #[test] diff --git a/src/interpreter.rs b/src/interpreter.rs index b747c697..0e7f10ba 100755 --- a/src/interpreter.rs +++ b/src/interpreter.rs @@ -861,7 +861,7 @@ mod test { let obj = crate::reader::read(test_str, cx).unwrap().0; root!(obj, cx); let compare = rebind!(eval(obj, None, env, cx).unwrap()); - let expect: Object = expect.into_obj(cx).copy_as_obj(cx); + let expect: Object = expect.into_obj(cx).as_obj_copy(); assert_eq!(compare, expect); } From d7b9cd889d054c40aac8752c025e85eead60111d Mon Sep 17 00:00:00 2001 From: Troy Hinckley Date: Thu, 7 Nov 2024 23:02:14 -0600 Subject: [PATCH 7/7] Remove condition-case from internal-macroexpand-for-load This will make debug easier until we make this more stable --- lisp/emacs-lisp/macroexp.el | 17 +++++------------ 1 file changed, 5 insertions(+), 12 deletions(-) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 168de1bf..f1960b89 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -809,18 +809,11 @@ test of free variables in the following ways: (push 'skip macroexp--pending-eager-loads) form)) (t - (condition-case err - (let ((macroexp--pending-eager-loads - (cons load-file-name macroexp--pending-eager-loads))) - (if full-p - (macroexpand--all-toplevel form) - (macroexpand form))) - (error - ;; Hopefully this shouldn't happen thanks to the cycle detection, - ;; but in case it does happen, let's catch the error and give the - ;; code a chance to macro-expand later. - (error "Eager macro-expansion failure: %S" err) - form)))))) + (let ((macroexp--pending-eager-loads + (cons load-file-name macroexp--pending-eager-loads))) + (if full-p + (macroexpand--all-toplevel form) + (macroexpand form))))))) ;; ¡¡¡ Big Ugly Hack !!! ;; src/bootstrap-emacs is mostly used to compile .el files, so it needs