mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-17 03:10:58 -08:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into scratch/correct-warning-pos

Browse source
This commit is contained in:
Alan Mackenzie 2022-01-11 21:57:54 +00:00
commit 2128cd8c08
3085 changed files with 131927 additions and 16782 deletions
Download patch file Download diff file Expand all files Collapse all files

2
lisp/emacs-lisp/advice.el
View file

@ -1,6 +1,6 @@
;;; advice.el --- An overloading mechanism for Emacs Lisp functions -*- lexical-binding: t -*-
;; Copyright (C) 1993-1994, 2000-2021 Free Software Foundation, Inc.
;; Copyright (C) 1993-1994, 2000-2022 Free Software Foundation, Inc.
;; Author: Hans Chalupsky <hans@cs.buffalo.edu>
;; Maintainer: emacs-devel@gnu.org

20
lisp/emacs-lisp/autoload.el
View file

@ -1,6 +1,6 @@
;;; autoload.el --- maintain autoloads in loaddefs.el -*- lexical-binding: t -*-
;; Copyright (C) 1991-1997, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1991-1997, 2001-2022 Free Software Foundation, Inc.
;; Author: Roland McGrath <roland@gnu.org>
;; Keywords: maint
@ -32,7 +32,7 @@
(require 'lisp-mode) ;for `doc-string-elt' properties.
(require 'lisp-mnt)
(eval-when-compile (require 'cl-lib))
(require 'cl-lib)
(defvar generated-autoload-file nil
"File into which to write autoload definitions.
@ -393,7 +393,7 @@ FILE's name."
(concat ";;; " basename
" --- automatically extracted " (or type "autoloads")
" -*- lexical-binding: t -*-\n"
(when (equal basename "loaddefs.el")
(when (string-match "/lisp/loaddefs\\.el\\'" file)
";; This file will be copied to ldefs-boot.el and checked in periodically.\n")
";;\n"
";;; Code:\n\n"
@ -1196,9 +1196,17 @@ directory or directories specified."
(goto-char (point-max))
(search-backward "\f" nil t)
(autoload-insert-section-header
(current-buffer) nil nil no-autoloads (if autoload-timestamps
no-autoloads-time
autoload--non-timestamp))
(current-buffer) nil nil
;; Filter out the other loaddefs files, because it makes
;; the list unstable (and leads to spurious changes in
;; ldefs-boot.el) since the loaddef files can be created in
;; any order.
(seq-filter (lambda (file)
(not (string-match-p "[/-]loaddefs.el" file)))
no-autoloads)
(if autoload-timestamps
no-autoloads-time
autoload--non-timestamp))
(insert generate-autoload-section-trailer)))
;; Don't modify the file if its content has not been changed, so `make'

2
lisp/emacs-lisp/avl-tree.el
View file

@ -1,6 +1,6 @@
;;; avl-tree.el --- balanced binary trees, AVL-trees -*- lexical-binding:t -*-
;; Copyright (C) 1995, 2007-2021 Free Software Foundation, Inc.
;; Copyright (C) 1995, 2007-2022 Free Software Foundation, Inc.
;; Author: Per Cederqvist <ceder@lysator.liu.se>
;; Inge Wallin <inge@lysator.liu.se>

2
lisp/emacs-lisp/backquote.el
View file

@ -1,6 +1,6 @@
;;; backquote.el --- implement the ` Lisp construct -*- lexical-binding: t -*-
;; Copyright (C) 1990, 1992, 1994, 2001-2021 Free Software Foundation,
;; Copyright (C) 1990, 1992, 1994, 2001-2022 Free Software Foundation,
;; Inc.
;; Author: Rick Sladkey <jrs@world.std.com>

2
lisp/emacs-lisp/backtrace.el
View file

@ -1,6 +1,6 @@
;;; backtrace.el --- generic major mode for Elisp backtraces -*- lexical-binding: t -*-
;; Copyright (C) 2018-2021 Free Software Foundation, Inc.
;; Copyright (C) 2018-2022 Free Software Foundation, Inc.
;; Author: Gemini Lasswell
;; Keywords: lisp, tools, maint

2
lisp/emacs-lisp/benchmark.el
View file

@ -1,6 +1,6 @@
;;; benchmark.el --- support for benchmarking code -*- lexical-binding: t -*-
;; Copyright (C) 2003-2021 Free Software Foundation, Inc.
;; Copyright (C) 2003-2022 Free Software Foundation, Inc.
;; Author: Dave Love <fx@gnu.org>
;; Keywords: lisp, extensions

2
lisp/emacs-lisp/bindat.el
View file

@ -1,6 +1,6 @@
;;; bindat.el --- binary data structure packing and unpacking. -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
;; Copyright (C) 2002-2022 Free Software Foundation, Inc.
;; Author: Kim F. Storm <storm@cua.dk>
;; Assignment name: struct.el

12
lisp/emacs-lisp/byte-opt.el
View file

@ -1,6 +1,6 @@
;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler -*- lexical-binding: t -*-
;; Copyright (C) 1991, 1994, 2000-2021 Free Software Foundation, Inc.
;; Copyright (C) 1991, 1994, 2000-2022 Free Software Foundation, Inc.
;; Author: Jamie Zawinski <jwz@lucid.com>
;; Hallvard Furuseth <hbf@ulrik.uio.no>
@ -343,8 +343,12 @@ for speeding up processing.")
(numberp expr)
(stringp expr)
(and (consp expr)
(memq (car expr) '(quote function))
(symbolp (cadr expr)))
(or (and (memq (car expr) '(quote function))
(symbolp (cadr expr)))
;; (internal-get-closed-var N) can be considered constant for
;; const-prop purposes.
(and (eq (car expr) 'internal-get-closed-var)
(integerp (cadr expr)))))
(keywordp expr)))
(defmacro byte-optimize--pcase (exp &rest cases)
@ -1464,6 +1468,7 @@ See Info node `(elisp) Integer Basics'."
(let ((side-effect-free-fns
'(% * + - / /= 1+ 1- < <= = > >= abs acos append aref ash asin atan
assq
base64-decode-string base64-encode-string base64url-encode-string
bool-vector-count-consecutive bool-vector-count-population
bool-vector-subsetp
boundp buffer-file-name buffer-local-variables buffer-modified-p
@ -1620,6 +1625,7 @@ See Info node `(elisp) Integer Basics'."
assq rassq rassoc
plist-get lax-plist-get plist-member
aref elt
base64-decode-string base64-encode-string base64url-encode-string
bool-vector-subsetp
bool-vector-count-population bool-vector-count-consecutive
)))

3
lisp/emacs-lisp/byte-run.el
View file

@ -1,6 +1,6 @@
;;; byte-run.el --- byte-compiler support for inlining -*- lexical-binding: t -*-
;; Copyright (C) 1992, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1992, 2001-2022 Free Software Foundation, Inc.
;; Author: Jamie Zawinski <jwz@lucid.com>
;; Hallvard Furuseth <hbf@ulrik.uio.no>
@ -134,6 +134,7 @@ The return value of this function is not used."
:autoload-end
(eval-and-compile
(defun ,cfname (,@(car data) ,@args)
(ignore ,@(delq '&rest (delq '&optional (copy-sequence args))))
,@(cdr data))))))))
(defalias 'byte-run--set-doc-string

108
lisp/emacs-lisp/bytecomp.el
View file

@ -1,6 +1,6 @@
;;; bytecomp.el --- compilation of Lisp code into byte code -*- lexical-binding: t -*-
;; Copyright (C) 1985-1987, 1992, 1994, 1998, 2000-2021 Free Software
;; Copyright (C) 1985-1987, 1992, 1994, 1998, 2000-2022 Free Software
;; Foundation, Inc.
;; Author: Jamie Zawinski <jwz@lucid.com>
@ -344,6 +344,7 @@ suppress. For example, (not mapcar) will suppress warnings about mapcar."
(or (symbolp v)
(null (delq nil (mapcar (lambda (x) (not (symbolp x))) v))))))
;;;###autoload
(defun byte-compile-warning-enabled-p (warning &optional symbol)
"Return non-nil if WARNING is enabled, according to `byte-compile-warnings'."
(let ((suppress nil))
@ -516,15 +517,11 @@ Return the compile-time value of FORM."
;; Don't compile here, since we don't know
;; whether to compile as byte-compile-form
;; or byte-compile-file-form.
(let* ((print-symbols-bare t)
(expanded
(macroexpand-all
form
macroexpand-all-environment)))
(eval
(macroexp-strip-symbol-positions
expanded)
lexical-binding)
(let ((expanded
(macroexpand--all-toplevel
form
macroexpand-all-environment)))
(eval expanded lexical-binding)
expanded)))))
(with-suppressed-warnings
. ,(lambda (warnings &rest body)
@ -1790,7 +1787,7 @@ It is too wide if it has any lines longer than the largest of
(nth 2 form)))))
(when (and (consp name) (eq (car name) 'quote))
(setq name (cadr name)))
(setq name (if name (format " `%s'" name) ""))
(setq name (if name (format " `%s' " name) ""))
(when (and kind docs (stringp docs)
(byte-compile--wide-docstring-p docs col))
(byte-compile-warn-x
@ -2317,8 +2314,7 @@ With argument ARG, insert value in current buffer after the form."
(byte-compile-depth 0)
(byte-compile-maxdepth 0)
(byte-compile-output nil)
;; This allows us to get the positions of symbols read; it's
;; new in Emacs 22.1.
;; This allows us to get the positions of symbols read.
(read-with-symbol-positions inbuffer)
(read-symbol-positions-list nil)
;; #### This is bound in b-c-close-variables.
@ -2782,15 +2778,6 @@ list that represents a doc string reference.
(mapcar 'eval
(macroexp-strip-symbol-positions (cdr form))))))
;; This handler is not necessary, but it makes the output from dont-compile
;; and similar macros cleaner.
(put 'eval 'byte-hunk-handler 'byte-compile-file-form-eval)
(defun byte-compile-file-form-eval (form)
(if (and (eq (car-safe (nth 1 form)) 'quote)
(equal (nth 2 form) lexical-binding))
(nth 1 (nth 1 form))
(byte-compile-keep-pending form)))
(defun byte-compile-file-form-defmumble (name macro arglist body rest)
"Process a `defalias' for NAME.
If MACRO is non-nil, the definition is known to be a macro.
@ -5080,13 +5067,13 @@ binding slots have been popped."
;; if it weren't for the fact that we need to figure out when a defalias
;; defines a macro, so as to add it to byte-compile-macro-environment.
;;
;; FIXME: we also use this hunk-handler to implement the function's dynamic
;; docstring feature. We could actually implement it more elegantly in
;; byte-compile-lambda so it applies to all lambdas, but the problem is that
;; the resulting .elc format will not be recognized by make-docfile, so
;; either we stop using DOC for the docstrings of preloaded elc files (at the
;; cost of around 24KB on 32bit hosts, double on 64bit hosts) or we need to
;; build DOC in a more clever way (e.g. handle anonymous elements).
;; FIXME: we also use this hunk-handler to implement the function's
;; dynamic docstring feature (via byte-compile-file-form-defmumble).
;; We should actually implement it (more elegantly) in
;; byte-compile-lambda so it applies to all lambdas. We did it here
;; so the resulting .elc format was recognizable by make-docfile,
;; but since then we stopped using DOC for the docstrings of
;; preloaded elc files so that obstacle is gone.
(let ((byte-compile-free-references nil)
(byte-compile-free-assignments nil))
(pcase form
@ -5196,69 +5183,6 @@ binding slots have been popped."
(_ (byte-compile-keep-pending form))))
;; Key syntax warnings.
(mapc
(lambda (elem)
(put (car elem) 'byte-hunk-handler
(lambda (form)
(dolist (idx (cdr elem))
(let ((key (elt form idx)))
(when (or (vectorp key)
(and (stringp key)
(not (key-valid-p key))))
(byte-compile-warn-x form "Invalid `kbd' syntax: %S" key))))
form)))
;; Functions and the place(s) for the key definition(s).
'((keymap-set 2)
(keymap-global-set 1)
(keymap-local-set 1)
(keymap-unset 2)
(keymap-global-unset 1)
(keymap-local-unset 1)
(keymap-substitute 2 3)
(keymap-set-after 2)
(key-translate 1 2)
(keymap-lookup 2)
(keymap-global-lookup 1)
(keymap-local-lookup 1)))
(put 'define-keymap 'byte-hunk-handler #'byte-compile-define-keymap)
(defun byte-compile-define-keymap (form)
(let ((result nil)
(orig-form form))
(push (pop form) result)
(while (and form
(keywordp (car form))
(not (eq (car form) :menu)))
(unless (memq (car form)
'(:full :keymap :parent :suppress :name :prefix))
(byte-compile-warn-x (car form) "Invalid keyword: %s" (car form)))
(push (pop form) result)
(when (null form)
(byte-compile-warn-x orig-form "Uneven number of keywords in %S" form))
(push (pop form) result))
;; Bindings.
(while form
(let ((key (pop form)))
(when (stringp key)
(unless (key-valid-p key)
(byte-compile-warn-x form "Invalid `kbd' syntax: %S" key)))
;; No improvement.
(push key result))
(when (null form)
(byte-compile-warn-x form "Uneven number of key bindings in %S" form))
(push (pop form) result))
(macroexp-strip-symbol-positions orig-form)))
(put 'define-keymap--define 'byte-hunk-handler
#'byte-compile-define-keymap--define)
(defun byte-compile-define-keymap--define (form)
(when (consp (nth 1 form))
(byte-compile-define-keymap (nth 1 form)))
form)
;;; tags

44
lisp/emacs-lisp/cconv.el
View file

@ -1,6 +1,6 @@
;;; cconv.el --- Closure conversion for statically scoped Emacs Lisp. -*- lexical-binding: t -*-
;; Copyright (C) 2011-2021 Free Software Foundation, Inc.
;; Copyright (C) 2011-2022 Free Software Foundation, Inc.
;; Author: Igor Kuzmin <kzuminig@iro.umontreal.ca>
;; Maintainer: emacs-devel@gnu.org
@ -293,17 +293,31 @@ of converted forms."
(cconv-convert form env nil))
funcbody))
(if wrappers
(let ((special-forms '()))
;; Keep special forms at the beginning of the body.
(while (or (and (cdr funcbody) (stringp (car funcbody))) ;docstring.
(memq (car-safe (car funcbody))
'(interactive declare :documentation)))
(push (pop funcbody) special-forms))
(let ((body (macroexp-progn funcbody)))
(pcase-let ((`(,decls . ,body) (macroexp-parse-body funcbody)))
(let ((body (macroexp-progn body)))
(dolist (wrapper wrappers) (setq body (funcall wrapper body)))
`(,@(nreverse special-forms) ,@(macroexp-unprogn body))))
`(,@decls ,@(macroexp-unprogn body))))
funcbody)))
(defun cconv--lifted-arg (var env)
"The argument to use for VAR in λ-lifted calls according to ENV.
This is used when VAR is being shadowed; we may still need its value for
such calls."
(let ((mapping (cdr (assq var env))))
(pcase-exhaustive mapping
(`(internal-get-closed-var . ,_)
;; The variable is captured.
mapping)
(`(car-safe ,exp)
;; The variable is mutably captured; skip
;; the indirection step because the variable is
;; passed "by reference" to the λ-lifted function.
exp)
(_
;; The variable is not captured; use the (shadowed) variable value.
;; (If the mapping is `(car-safe SYMBOL)', SYMBOL is always VAR.
var))))
(defun cconv-convert (form env extend)
;; This function actually rewrites the tree.
"Return FORM with all its lambdas changed so they are closed.
@ -432,10 +446,11 @@ places where they originally did not directly appear."
;; One of the lambda-lifted vars is shadowed, so add
;; a reference to the outside binding and arrange to use
;; that reference.
(let ((closedsym (make-symbol (format "closed-%s" var))))
(let ((var-def (cconv--lifted-arg var env))
(closedsym (make-symbol (format "closed-%s" var))))
(setq new-env (cconv--remap-llv new-env var closedsym))
(setq new-extend (cons closedsym (remq var new-extend)))
(push `(,closedsym ,var) binders-new)))
(push `(,closedsym ,var-def) binders-new)))
;; We push the element after redefined free variables are
;; processed. This is important to avoid the bug when free
@ -453,14 +468,13 @@ places where they originally did not directly appear."
;; before we know that the var will be in `new-extend' (bug#24171).
(dolist (binder binders-new)
(when (memq (car-safe binder) new-extend)
;; One of the lambda-lifted vars is shadowed, so add
;; a reference to the outside binding and arrange to use
;; that reference.
;; One of the lambda-lifted vars is shadowed.
(let* ((var (car-safe binder))
(var-def (cconv--lifted-arg var env))
(closedsym (make-symbol (format "closed-%s" var))))
(setq new-env (cconv--remap-llv new-env var closedsym))
(setq new-extend (cons closedsym (remq var new-extend)))
(push `(,closedsym ,var) binders-new)))))
(push `(,closedsym ,var-def) binders-new)))))
`(,letsym ,(nreverse binders-new)
. ,(mapcar (lambda (form)

2
lisp/emacs-lisp/chart.el
View file

@ -1,6 +1,6 @@
;;; chart.el --- Draw charts (bar charts, etc) -*- lexical-binding: t -*-
;; Copyright (C) 1996, 1998-1999, 2001, 2004-2005, 2007-2021 Free
;; Copyright (C) 1996, 1998-1999, 2001, 2004-2005, 2007-2022 Free
;; Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>

2
lisp/emacs-lisp/check-declare.el
View file

@ -1,6 +1,6 @@
;;; check-declare.el --- Check declare-function statements -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
;; Copyright (C) 2007-2022 Free Software Foundation, Inc.
;; Author: Glenn Morris <rgm@gnu.org>
;; Maintainer: emacs-devel@gnu.org

3
lisp/emacs-lisp/checkdoc.el
View file

@ -1,6 +1,6 @@
;;; checkdoc.el --- check documentation strings for style requirements -*- lexical-binding:t -*-
;; Copyright (C) 1997-1998, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1997-1998, 2001-2022 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Old-Version: 0.6.2
@ -161,6 +161,7 @@
;;; Code:
(require 'bytecomp) ;; for byte-compile-docstring-max-column
(require 'cl-lib)
(require 'help-mode) ;; for help-xref-info-regexp
(require 'thingatpt) ;; for handy thing-at-point-looking-at

2
lisp/emacs-lisp/cl-extra.el
View file

@ -1,6 +1,6 @@
;;; cl-extra.el --- Common Lisp features, part 2 -*- lexical-binding: t -*-
;; Copyright (C) 1993, 2000-2021 Free Software Foundation, Inc.
;; Copyright (C) 1993, 2000-2022 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Keywords: extensions

10
lisp/emacs-lisp/cl-generic.el
View file

@ -1,6 +1,6 @@
;;; cl-generic.el --- CLOS-style generic functions for Elisp -*- lexical-binding: t; -*-
;; Copyright (C) 2015-2021 Free Software Foundation, Inc.
;; Copyright (C) 2015-2022 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Version: 1.0
@ -286,7 +286,9 @@ DEFAULT-BODY, if present, is used as the body of a default method.
(progn
(defalias ',name
(cl-generic-define ',name ',args ',(nreverse options))
,(help-add-fundoc-usage doc args))
,(if (consp doc) ;An expression rather than a constant.
`(help-add-fundoc-usage ,doc ',args)
(help-add-fundoc-usage doc args)))
:autoload-end
,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method))
(nreverse methods)))
@ -604,7 +606,9 @@ The set of acceptable TYPEs (also called \"specializers\") is defined
(defun cl--generic-get-dispatcher (dispatch)
(with-memoization
(gethash dispatch cl--generic-dispatchers)
;; We need `copy-sequence` here because this `dispatch' object might be
;; modified by side-effect in `cl-generic-define-method' (bug#46722).
(gethash (copy-sequence dispatch) cl--generic-dispatchers)
;; (message "cl--generic-get-dispatcher (%S)" dispatch)
(let* ((dispatch-arg (car dispatch))
(generalizers (cdr dispatch))

2
lisp/emacs-lisp/cl-indent.el
View file

@ -1,6 +1,6 @@
;;; cl-indent.el --- Enhanced lisp-indent mode -*- lexical-binding:t -*-
;; Copyright (C) 1987, 2000-2021 Free Software Foundation, Inc.
;; Copyright (C) 1987, 2000-2022 Free Software Foundation, Inc.
;; Author: Richard Mlynarik <mly@eddie.mit.edu>
;; Created: July 1987

7
lisp/emacs-lisp/cl-lib.el
View file

@ -1,6 +1,6 @@
;;; cl-lib.el --- Common Lisp extensions for Emacs -*- lexical-binding: t -*-
;; Copyright (C) 1993, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1993, 2001-2022 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Version: 1.0
@ -560,4 +560,9 @@ of record objects."
(t
(advice-remove 'type-of #'cl--old-struct-type-of))))
(defun cl-constantly (value)
"Return a function that takes any number of arguments, but returns VALUE."
(lambda (&rest _)
value))
;;; cl-lib.el ends here

51
lisp/emacs-lisp/cl-macs.el
View file

@ -1,6 +1,6 @@
;;; cl-macs.el --- Common Lisp macros -*- lexical-binding: t -*-
;; Copyright (C) 1993, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1993, 2001-2022 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Old-Version: 2.02
@ -301,24 +301,31 @@ FORM is of the form (ARGS . BODY)."
(t ;; `simple-args' doesn't handle all the parsing that we need,
;; so we pass the rest to cl--do-arglist which will do
;; "manual" parsing.
(let ((slen (length simple-args)))
(when (memq '&optional simple-args)
(cl-decf slen))
(setq header
(let ((slen (length simple-args))
(usage-str
;; Macro expansion can take place in the middle of
;; apparently harmless computation, so it should not
;; touch the match-data.
(save-match-data
(cons (help-add-fundoc-usage
(if (stringp (car header)) (pop header))
;; Be careful with make-symbol and (back)quote,
;; see bug#12884.
(help--docstring-quote
(let ((print-gensym nil) (print-quoted t)
(print-escape-newlines t))
(format "%S" (cons 'fn (cl--make-usage-args
orig-args))))))
header)))
(help--docstring-quote
(let ((print-gensym nil) (print-quoted t)
(print-escape-newlines t))
(format "%S" (cons 'fn (cl--make-usage-args
orig-args))))))))
(when (memq '&optional simple-args)
(cl-decf slen))
(setq header
(cons
(if (eq :documentation (car-safe (car header)))
`(:documentation (help-add-fundoc-usage
,(cadr (pop header))
,usage-str))
(help-add-fundoc-usage
(if (stringp (car header)) (pop header))
;; Be careful with make-symbol and (back)quote,
;; see bug#12884.
usage-str))
header))
;; FIXME: we'd want to choose an arg name for the &rest param
;; and pass that as `expr' to cl--do-arglist, but that ends up
;; generating code with a redundant let-binding, so we instead
@ -2139,9 +2146,14 @@ Like `cl-flet' but the definitions can refer to previous ones.
;; setq the fresh new `ofargs' vars instead ;-)
(let ((shadowings
(mapcar (lambda (b) (if (consp b) (car b) b)) bindings)))
;; If `var' is shadowed, then it clearly can't be
;; tail-called any more.
(not (memq var shadowings)))))
(and
;; If `var' is shadowed, then it clearly can't be
;; tail-called any more.
(not (memq var shadowings))
;; If any of the new bindings is a dynamic
;; variable, the body is not in tail position.
(not (delq nil (mapcar #'macroexp--dynamic-variable-p
shadowings)))))))
`(,(car exp) ,bindings . ,(funcall opt-exps exps)))
((and `(condition-case ,err-var ,bodyform . ,handlers)
(guard (not (eq err-var var))))
@ -3052,7 +3064,7 @@ To see the documentation for a defined struct type, use
`(,predicate cl-x))))
(when pred-form
(push `(,defsym ,predicate (cl-x)
(declare (side-effect-free error-free))
(declare (side-effect-free error-free) (pure t))
,(if (eq (car pred-form) 'and)
(append pred-form '(t))
`(and ,pred-form t)))
@ -3369,6 +3381,7 @@ Of course, we really can't know that for sure, so it's just a heuristic."
(integer . integerp)
(keyword . keywordp)
(list . listp)
(natnum . natnump)
(number . numberp)
(null . null)
(real . numberp)

2
lisp/emacs-lisp/cl-print.el
View file

@ -1,6 +1,6 @@
;;; cl-print.el --- CL-style generic printing -*- lexical-binding: t; -*-
;; Copyright (C) 2017-2021 Free Software Foundation, Inc.
;; Copyright (C) 2017-2022 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords:

2
lisp/emacs-lisp/cl-seq.el
View file

@ -1,6 +1,6 @@
;;; cl-seq.el --- Common Lisp features, part 3 -*- lexical-binding: t -*-
;; Copyright (C) 1993, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1993, 2001-2022 Free Software Foundation, Inc.
;; Author: Dave Gillespie <daveg@synaptics.com>
;; Old-Version: 2.02

66
lisp/emacs-lisp/comp-cstr.el
View file

@ -1,6 +1,6 @@
;;; comp-cstr.el --- native compiler constraint library -*- lexical-binding: t -*-
;; Copyright (C) 2020-2021 Free Software Foundation, Inc.
;; Copyright (C) 2020-2022 Free Software Foundation, Inc.
;; Author: Andrea Corallo <akrl@sdf.com>
;; Keywords: lisp
@ -70,7 +70,7 @@
(irange &aux
(range (list irange))
(typeset ())))
(:copier comp-cstr-shallow-copy))
(:copier nil))
"Internal representation of a type/value constraint."
(typeset '(t) :type list
:documentation "List of possible types the mvar can assume.
@ -133,6 +133,14 @@ Integer values are handled in the `range' slot.")
:range (copy-tree (range cstr))
:neg (neg cstr))))
(defsubst comp-cstr-shallow-copy (dst src)
"Copy the content of SRC into DST."
(with-comp-cstr-accessors
(setf (range dst) (range src)
(valset dst) (valset src)
(typeset dst) (typeset src)
(neg dst) (neg src))))
(defsubst comp-cstr-empty-p (cstr)
"Return t if CSTR is equivalent to the nil type specifier or nil otherwise."
(with-comp-cstr-accessors
@ -438,10 +446,7 @@ Return them as multiple value."
ext-range)
ext-range)
(neg dst) nil)
(setf (typeset dst) (typeset old-dst)
(valset dst) (valset old-dst)
(range dst) (range old-dst)
(neg dst) (neg old-dst)))))
(comp-cstr-shallow-copy dst old-dst))))
(defmacro comp-cstr-set-range-for-arithm (dst src1 src2 &rest range-body)
;; Prevent some code duplication for `comp-cstr-add-2'
@ -581,10 +586,8 @@ DST is returned."
(when (range pos)
'(integer)))))
(typeset neg)))
(setf (typeset dst) (typeset pos)
(valset dst) (valset pos)
(range dst) (range pos)
(neg dst) nil)
(comp-cstr-shallow-copy dst pos)
(setf (neg dst) nil)
(cl-return-from comp-cstr-union-1-no-mem dst))
;; Verify disjoint condition between positive types and
@ -631,15 +634,9 @@ DST is returned."
(comp-range-negation (range neg))
(range pos))))))
(if (comp-cstr-empty-p neg)
(setf (typeset dst) (typeset pos)
(valset dst) (valset pos)
(range dst) (range pos)
(neg dst) nil)
(setf (typeset dst) (typeset neg)
(valset dst) (valset neg)
(range dst) (range neg)
(neg dst) (neg neg)))))
(comp-cstr-shallow-copy dst (if (comp-cstr-empty-p neg)
pos
neg))))
;; (not null) => t
(when (and (neg dst)
@ -663,10 +660,7 @@ DST is returned."
(mapcar #'comp-cstr-copy srcs)
(apply #'comp-cstr-union-1-no-mem range srcs)
mem-h))))
(setf (typeset dst) (typeset res)
(valset dst) (valset res)
(range dst) (range res)
(neg dst) (neg res))
(comp-cstr-shallow-copy dst res)
res)))
(cl-defun comp-cstr-intersection-homogeneous (dst &rest srcs)
@ -753,10 +747,8 @@ Non memoized version of `comp-cstr-intersection-no-mem'."
;; In case pos is not relevant return directly the content
;; of neg.
(when (equal (typeset pos) '(t))
(setf (typeset dst) (typeset neg)
(valset dst) (valset neg)
(range dst) (range neg)
(neg dst) t)
(comp-cstr-shallow-copy dst neg)
(setf (neg dst) t)
;; (not t) => nil
(when (and (null (valset dst))
@ -800,10 +792,8 @@ Non memoized version of `comp-cstr-intersection-no-mem'."
(cl-set-difference (valset pos) (valset neg)))
;; Return a non negated form.
(setf (typeset dst) (typeset pos)
(valset dst) (valset pos)
(range dst) (range pos)
(neg dst) nil)))
(comp-cstr-shallow-copy dst pos)
(setf (neg dst) nil)))
dst))))
@ -883,7 +873,7 @@ Non memoized version of `comp-cstr-intersection-no-mem'."
"Constraint OP1 being = OP2 setting the result into DST."
(with-comp-cstr-accessors
(cl-flet ((relax-cstr (cstr)
(setf cstr (comp-cstr-shallow-copy cstr))
(setf cstr (copy-sequence cstr))
;; If can be any float extend it to all integers.
(when (memq 'float (typeset cstr))
(setf (range cstr) '((- . +))))
@ -1008,10 +998,7 @@ DST is returned."
(mapcar #'comp-cstr-copy srcs)
(apply #'comp-cstr-intersection-no-mem srcs)
mem-h))))
(setf (typeset dst) (typeset res)
(valset dst) (valset res)
(range dst) (range res)
(neg dst) (neg res))
(comp-cstr-shallow-copy dst res)
res)))
(defun comp-cstr-intersection-no-hashcons (dst &rest srcs)
@ -1067,10 +1054,9 @@ DST is returned."
(valset dst) ()
(range dst) nil
(neg dst) nil))
(t (setf (typeset dst) (typeset src)
(valset dst) (valset src)
(range dst) (range src)
(neg dst) (not (neg src)))))
(t
(comp-cstr-shallow-copy dst src)
(setf (neg dst) (not (neg src)))))
dst))
(defun comp-cstr-value-negation (dst src)

25
lisp/emacs-lisp/comp.el
View file

@ -1,6 +1,6 @@
;;; comp.el --- compilation of Lisp code into native code -*- lexical-binding: t -*-
;; Copyright (C) 2019-2021 Free Software Foundation, Inc.
;; Copyright (C) 2019-2022 Free Software Foundation, Inc.
;; Author: Andrea Corallo <akrl@sdf.com>
;; Keywords: lisp
@ -1181,7 +1181,9 @@ clashes."
for i across orig-name
for byte = (format "%x" i)
do (aset str j (aref byte 0))
(aset str (1+ j) (aref byte 1))
(aset str (1+ j) (if (length> byte 1)
(aref byte 1)
?\_))
finally return str))
(human-readable (string-replace
"-" "_" orig-name))
@ -3084,13 +3086,6 @@ Forward propagate immediate involed in assignments." ; FIXME: Typo. Involved or
(`(setimm ,lval ,v)
(setf (comp-cstr-imm lval) v))))))
(defun comp-mvar-propagate (lval rval)
"Propagate into LVAL properties of RVAL."
(setf (comp-mvar-typeset lval) (comp-mvar-typeset rval)
(comp-mvar-valset lval) (comp-mvar-valset rval)
(comp-mvar-range lval) (comp-mvar-range rval)
(comp-mvar-neg lval) (comp-mvar-neg rval)))
(defun comp-function-foldable-p (f args)
"Given function F called with ARGS, return non-nil when optimizable."
(and (comp-function-pure-p f)
@ -3140,10 +3135,7 @@ Fold the call in case."
(when (comp-cstr-empty-p cstr)
;; Store it to be rewritten as non local exit.
(setf (comp-block-lap-non-ret-insn comp-block) insn))
(setf (comp-mvar-range lval) (comp-cstr-range cstr)
(comp-mvar-valset lval) (comp-cstr-valset cstr)
(comp-mvar-typeset lval) (comp-cstr-typeset cstr)
(comp-mvar-neg lval) (comp-cstr-neg cstr))))
(comp-cstr-shallow-copy lval cstr)))
(cl-case f
(+ (comp-cstr-add lval args))
(- (comp-cstr-sub lval args))
@ -3161,9 +3153,9 @@ Fold the call in case."
(let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt)))))
(comp-fwprop-call insn lval f args)))
(_
(comp-mvar-propagate lval rval))))
(comp-cstr-shallow-copy lval rval))))
(`(assume ,lval ,(and (pred comp-mvar-p) rval))
(comp-mvar-propagate lval rval))
(comp-cstr-shallow-copy lval rval))
(`(assume ,lval (,kind . ,operands))
(cl-case kind
(and
@ -4223,7 +4215,8 @@ variable 'NATIVE_DISABLED' is set, only byte compile."
(batch-native-compile)
(pcase byte-to-native-output-file
(`(,tempfile . ,target-file)
(rename-file tempfile target-file t))))))
(rename-file tempfile target-file t)))
(setq command-line-args-left (cdr command-line-args-left)))))
;;;###autoload
(defun native-compile-async (files &optional recursively load selector)

2
lisp/emacs-lisp/copyright.el
View file

@ -1,6 +1,6 @@
;;; copyright.el --- update the copyright notice in current buffer -*- lexical-binding: t -*-
;; Copyright (C) 1991-1995, 1998, 2001-2021 Free Software Foundation,
;; Copyright (C) 1991-1995, 1998, 2001-2022 Free Software Foundation,
;; Inc.
;; Author: Daniel Pfeiffer <occitan@esperanto.org>

2
lisp/emacs-lisp/crm.el
View file

@ -1,6 +1,6 @@
;;; crm.el --- read multiple strings with completion -*- lexical-binding: t; -*-
;; Copyright (C) 1985-1986, 1993-2021 Free Software Foundation, Inc.
;; Copyright (C) 1985-1986, 1993-2022 Free Software Foundation, Inc.
;; Author: Sen Nagata <sen@eccosys.com>
;; Keywords: completion, minibuffer, multiple elements

2
lisp/emacs-lisp/cursor-sensor.el
View file

@ -1,6 +1,6 @@
;;; cursor-sensor.el --- React to cursor movement -*- lexical-binding: t; -*-
;; Copyright (C) 2015-2021 Free Software Foundation, Inc.
;; Copyright (C) 2015-2022 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords:

2
lisp/emacs-lisp/debug.el
View file

@ -1,6 +1,6 @@
;;; debug.el --- debuggers and related commands for Emacs -*- lexical-binding: t -*-
;; Copyright (C) 1985-1986, 1994, 2001-2021 Free Software Foundation,
;; Copyright (C) 1985-1986, 1994, 2001-2022 Free Software Foundation,
;; Inc.
;; Maintainer: emacs-devel@gnu.org

2
lisp/emacs-lisp/derived.el
View file

@ -1,7 +1,7 @@
;;; derived.el --- allow inheritance of major modes -*- lexical-binding: t; -*-
;; (formerly mode-clone.el)
;; Copyright (C) 1993-1994, 1999, 2001-2021 Free Software Foundation,
;; Copyright (C) 1993-1994, 1999, 2001-2022 Free Software Foundation,
;; Inc.
;; Author: David Megginson (dmeggins@aix1.uottawa.ca)

2
lisp/emacs-lisp/disass.el
View file

@ -1,6 +1,6 @@
;;; disass.el --- disassembler for compiled Emacs Lisp code -*- lexical-binding:t -*-
;; Copyright (C) 1986, 1991, 2002-2021 Free Software Foundation, Inc.
;; Copyright (C) 1986, 1991, 2002-2022 Free Software Foundation, Inc.
;; Author: Doug Cutting <doug@csli.stanford.edu>
;; Jamie Zawinski <jwz@lucid.com>

6
lisp/emacs-lisp/easy-mmode.el
View file

@ -1,6 +1,6 @@
;;; easy-mmode.el --- easy definition for major and minor modes -*- lexical-binding: t; -*-
;; Copyright (C) 1997, 2000-2021 Free Software Foundation, Inc.
;; Copyright (C) 1997, 2000-2022 Free Software Foundation, Inc.
;; Author: Georges Brun-Cottan <Georges.Brun-Cottan@inria.fr>
;; Maintainer: Stefan Monnier <monnier@gnu.org>
@ -698,7 +698,7 @@ Valid keywords and arguments are:
"Define a constant M whose value is the result of `easy-mmode-define-keymap'.
The M, BS, and ARGS arguments are as per that function. DOC is
the constant's documentation."
(declare (indent 1))
(declare (doc-string 3) (indent 1))
`(defconst ,m
(easy-mmode-define-keymap ,bs nil (if (boundp ',m) ,m) ,(cons 'list args))
,doc))
@ -725,7 +725,7 @@ the constant's documentation."
(defmacro easy-mmode-defsyntax (st css doc &rest args)
"Define variable ST as a syntax-table.
CSS contains a list of syntax specifications of the form (CHAR . SYNTAX)."
(declare (indent 1))
(declare (doc-string 3) (indent 1))
`(progn
(autoload 'easy-mmode-define-syntax "easy-mmode")
(defconst ,st (easy-mmode-define-syntax ,css ,(cons 'list args)) ,doc)))

2
lisp/emacs-lisp/easymenu.el
View file

@ -1,6 +1,6 @@
;;; easymenu.el --- support the easymenu interface for defining a menu -*- lexical-binding:t -*-
;; Copyright (C) 1994, 1996, 1998-2021 Free Software Foundation, Inc.
;; Copyright (C) 1994, 1996, 1998-2022 Free Software Foundation, Inc.
;; Keywords: emulations
;; Author: Richard Stallman <rms@gnu.org>

4
lisp/emacs-lisp/edebug.el
View file

@ -1,6 +1,6 @@
;;; edebug.el --- a source-level debugger for Emacs Lisp -*- lexical-binding: t -*-
;; Copyright (C) 1988-1995, 1997, 1999-2021 Free Software Foundation,
;; Copyright (C) 1988-1995, 1997, 1999-2022 Free Software Foundation,
;; Inc.
;; Author: Daniel LaLiberte <liberte@holonexus.org>
@ -469,7 +469,7 @@ just FUNCTION is printed."
(funcall orig-fun nil)))
(defun edebug-eval-defun (edebug-it)
(declare (obsolete "use eval-defun or edebug--eval-defun instead" "28.1"))
(declare (obsolete "use `eval-defun' or `edebug--eval-defun' instead" "28.1"))
(interactive "P")
(if (advice-member-p #'edebug--eval-defun 'eval-defun)
(eval-defun edebug-it)

2
lisp/emacs-lisp/eieio-base.el
View file

@ -1,6 +1,6 @@
;;; eieio-base.el --- Base classes for EIEIO. -*- lexical-binding:t -*-
;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
;; Copyright (C) 2000-2022 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: OO, lisp

277
lisp/emacs-lisp/eieio-compat.el
View file

@ -1,277 +0,0 @@
;;; eieio-compat.el --- Compatibility with Older EIEIO versions -*- lexical-binding:t -*-
;; Copyright (C) 1995-1996, 1998-2021 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: OO, lisp
;; Package: eieio
;; 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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Backward compatibility definition of old EIEIO functions in
;; terms of newer equivalent.
;; The main elements are the old EIEIO `defmethod' and `defgeneric' which are
;; now implemented on top of cl-generic. The differences we have to
;; accommodate are:
;; - EIEIO's :static methods (turned into a new `eieio--static' specializer).
;; - EIEIO's support for `call-next-method' and `next-method-p' instead of
;; `cl-next-method-p' and `cl-call-next-method' (simple matter of renaming).
;; - Different errors are signaled.
;; - EIEIO's defgeneric does not reset the function.
;; - EIEIO's no-next-method and no-applicable-method can't be aliases of
;; cl-generic's namesakes since they have different calling conventions,
;; which means that packages that (defmethod no-next-method ..) don't work.
;; - EIEIO's `call-next-method' and `next-method-p' had dynamic scope whereas
;; cl-generic's `cl-next-method-p' and `cl-call-next-method' are lexically
;; scoped.
;;; Code:
(require 'eieio-core)
(require 'cl-generic)
(put 'eieio--defalias 'byte-hunk-handler
#'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler)
;;;###autoload
(defun eieio--defalias (name body)
"Like `defalias', but with less side-effects.
More specifically, it has no side-effects at all when the new function
definition is the same (`eq') as the old one."
(cl-assert (not (symbolp body)))
(while (and (fboundp name) (symbolp (symbol-function name)))
;; Follow aliases, so methods applied to obsolete aliases still work.
(setq name (symbol-function name)))
(unless (and (fboundp name)
(eq (symbol-function name) body))
(defalias name body)))
;;;###autoload
(defmacro defgeneric (method args &optional doc-string)
"Create a generic function METHOD.
DOC-STRING is the base documentation for this class. A generic
function has no body, as its purpose is to decide which method body
is appropriate to use. Uses `defmethod' to create methods, and calls
`defgeneric' for you. With this implementation the ARGS are
currently ignored. You can use `defgeneric' to apply specialized
top level documentation to a method."
(declare (doc-string 3) (obsolete cl-defgeneric "25.1")
(indent defun))
`(eieio--defalias ',method
(eieio--defgeneric-init-form
',method
,(if doc-string (help-add-fundoc-usage doc-string args)))))
;;;###autoload
(defmacro defmethod (method &rest args)
"Create a new METHOD through `defgeneric' with ARGS.
The optional second argument KEY is a specifier that
modifies how the method is called, including:
:before - Method will be called before the :primary
:primary - The default if not specified
:after - Method will be called after the :primary
:static - First arg could be an object or class
The next argument is the ARGLIST. The ARGLIST specifies the arguments
to the method as with `defun'. The first argument can have a type
specifier, such as:
((VARNAME CLASS) ARG2 ...)
where VARNAME is the name of the local variable for the method being
created. The CLASS is a class symbol for a class made with `defclass'.
A DOCSTRING comes after the ARGLIST, and is optional.
All the rest of the args are the BODY of the method. A method will
return the value of the last form in the BODY.
Summary:
(defmethod mymethod [:before | :primary | :after | :static]
((typearg class-name) arg2 &optional opt &rest rest)
\"doc-string\"
body)"
(declare (doc-string 3) (obsolete cl-defmethod "25.1")
(indent defun)
(debug
(&define ; this means we are defining something
[&name sexp] ;Allow (setf ...) additionally to symbols.
;; ^^ This is the methods symbol
[ &optional symbolp ] ; this is key :before etc
cl-generic-method-args ; arguments
[ &optional stringp ] ; documentation string
def-body ; part to be debugged
)))
(let* ((key (if (keywordp (car args)) (pop args)))
(params (car args))
(arg1 (car params))
(fargs (if (consp arg1)
(cons (car arg1) (cdr params))
params))
(class (if (consp arg1) (nth 1 arg1)))
(code `(lambda ,fargs ,@(cdr args))))
`(progn
;; Make sure there is a generic and the byte-compiler sees it.
(defgeneric ,method ,args)
(eieio--defmethod ',method ',key ',class #',code))))
(defun eieio--generic-static-symbol-specializers (tag &rest _)
(cl-assert (or (null tag) (eieio--class-p tag)))
(when (eieio--class-p tag)
(let ((superclasses (eieio--generic-subclass-specializers tag))
(specializers ()))
(dolist (superclass superclasses)
(push superclass specializers)
(push `(eieio--static ,(cadr superclass)) specializers))
(nreverse specializers))))
(cl-generic-define-generalizer eieio--generic-static-symbol-generalizer
;; Give it a slightly higher priority than `subclass' so that the
;; interleaved list comes before subclass's non-interleaved list.
61 (lambda (name &rest _) `(and (symbolp ,name) (cl--find-class ,name)))
#'eieio--generic-static-symbol-specializers)
(cl-generic-define-generalizer eieio--generic-static-object-generalizer
;; Give it a slightly higher priority than `class' so that the
;; interleaved list comes before the class's non-interleaved list.
51 #'cl--generic-struct-tag
(lambda (tag &rest _)
(and (symbolp tag) (setq tag (cl--find-class tag))
(eieio--class-p tag)
(let ((superclasses (eieio--class-precedence-list tag))
(specializers ()))
(dolist (superclass superclasses)
(setq superclass (eieio--class-name superclass))
(push superclass specializers)
(push `(eieio--static ,superclass) specializers))
(nreverse specializers)))))
(cl-defmethod cl-generic-generalizers ((_specializer (head eieio--static)))
(list eieio--generic-static-symbol-generalizer
eieio--generic-static-object-generalizer))
;;;###autoload
(defun eieio--defgeneric-init-form (method doc-string)
(if doc-string (put method 'function-documentation doc-string))
(if (memq method '(no-next-method no-applicable-method))
(symbol-function method)
(let ((generic (cl-generic-ensure-function method)))
(or (symbol-function (cl--generic-name generic))
(cl--generic-make-function generic)))))
;;;###autoload
(defun eieio--defmethod (method kind argclass code)
(setq kind (intern (downcase (symbol-name kind))))
(let* ((specializer (if (not (eq kind :static))
(or argclass t)
(setq kind nil)
`(eieio--static ,argclass)))
(uses-cnm (not (memq kind '(:before :after))))
(specializers `((arg ,specializer)))
(code
;; Backward compatibility for `no-next-method' and
;; `no-applicable-method', which have slightly different calling
;; convention than their cl-generic counterpart.
(pcase method
('no-next-method
(setq method 'cl-no-next-method)
(setq specializers `(generic method ,@specializers))
(lambda (_generic _method &rest args) (apply code args)))
('no-applicable-method
(setq method 'cl-no-applicable-method)
(setq specializers `(generic ,@specializers))
(lambda (generic arg &rest args)
(apply code arg (cl--generic-name generic) (cons arg args))))
(_ code))))
(cl-generic-define-method
method (unless (memq kind '(nil :primary)) (list kind))
specializers uses-cnm
(if uses-cnm
(let* ((docstring (documentation code 'raw))
(args (help-function-arglist code 'preserve-names))
(doc-only (if docstring
(let ((split (help-split-fundoc docstring nil)))
(if split (cdr split) docstring)))))
(lambda (cnm &rest args)
(:documentation
(help-add-fundoc-usage doc-only (cons 'cl-cnm args)))
(cl-letf (((symbol-function 'call-next-method) cnm)
((symbol-function 'next-method-p)
(lambda () (cl--generic-isnot-nnm-p cnm))))
(apply code args))))
code))
;; The old EIEIO code did not signal an error when there are methods
;; applicable but only of the before/after kind. So if we add a :before
;; or :after, make sure there's a matching dummy primary.
(when (and (memq kind '(:before :after))
;; FIXME: Use `cl-find-method'?
(not (cl-find-method method ()
(mapcar (lambda (arg)
(if (consp arg) (nth 1 arg) t))
specializers))))
(cl-generic-define-method method () specializers t
(lambda (cnm &rest args)
(if (cl--generic-isnot-nnm-p cnm)
(apply cnm args)))))
method))
;; Compatibility with code which tries to catch `no-method-definition' errors.
(push 'no-method-definition (get 'cl-no-applicable-method 'error-conditions))
(defun generic-p (fname) (not (null (cl--generic fname))))
(defun no-next-method (&rest args)
(declare (obsolete cl-no-next-method "25.1"))
(apply #'cl-no-next-method 'unknown nil args))
(defun no-applicable-method (object method &rest args)
(declare (obsolete cl-no-applicable-method "25.1"))
(apply #'cl-no-applicable-method method object args))
(define-obsolete-function-alias 'call-next-method 'cl-call-next-method "25.1")
(defun next-method-p ()
(declare (obsolete cl-next-method-p "25.1"))
;; EIEIO's `next-method-p' just returned nil when called in an
;; invalid context.
(message "next-method-p called outside of a primary or around method")
nil)
;;;###autoload
(defun eieio-defmethod (method args)
"Obsolete work part of an old version of the `defmethod' macro."
(declare (obsolete cl-defmethod "24.1"))
(eval `(defmethod ,method ,@args))
method)
;;;###autoload
(defun eieio-defgeneric (method doc-string)
"Obsolete work part of an old version of the `defgeneric' macro."
(declare (obsolete cl-defgeneric "24.1"))
(eval `(defgeneric ,method (x) ,@(if doc-string `(,doc-string))))
;; Return the method
'method)
;;;###autoload
(defun eieio-defclass (cname superclasses slots options)
(declare (obsolete eieio-defclass-internal "25.1"))
(eval `(defclass ,cname ,superclasses ,slots ,@options)))
;; Local Variables:
;; generated-autoload-file: "eieio-loaddefs.el"
;; End:
(provide 'eieio-compat)
;;; eieio-compat.el ends here

21
lisp/emacs-lisp/eieio-core.el
View file

@ -1,6 +1,6 @@
;;; eieio-core.el --- Core implementation for eieio -*- lexical-binding:t -*-
;; Copyright (C) 1995-1996, 1998-2021 Free Software Foundation, Inc.
;; Copyright (C) 1995-1996, 1998-2022 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 1.4
@ -450,7 +450,7 @@ See `defclass' for more information."
))
;; Now that everything has been loaded up, all our lists are backwards!
;; Fix that up now and then them into vectors.
;; Fix that up now and turn them into vectors.
(cl-callf (lambda (slots) (apply #'vector (nreverse slots)))
(eieio--class-slots newc))
(cl-callf nreverse (eieio--class-initarg-tuples newc))
@ -704,11 +704,15 @@ an error."
nil
;; Trim off object IDX junk added in for the object index.
(setq slot-idx (- slot-idx (eval-when-compile eieio--object-num-slots)))
(let ((st (cl--slot-descriptor-type (aref (eieio--class-slots class)
slot-idx))))
(if (not (eieio--perform-slot-validation st value))
(signal 'invalid-slot-type
(list (eieio--class-name class) slot st value))))))
(let* ((sd (aref (eieio--class-slots class)
slot-idx))
(st (cl--slot-descriptor-type sd)))
(cond
((not (eieio--perform-slot-validation st value))
(signal 'invalid-slot-type
(list (eieio--class-name class) slot st value)))
((alist-get :read-only (cl--slot-descriptor-props sd))
(signal 'eieio-read-only (list (eieio--class-name class) slot)))))))
(defun eieio--validate-class-slot-value (class slot-idx value slot)
"Make sure that for CLASS referencing SLOT-IDX, VALUE is valid.
@ -816,7 +820,7 @@ Fills in CLASS's SLOT with its default value."
(defun eieio-oset (obj slot value)
"Do the work for the macro `oset'.
Fills in OBJ's SLOT with VALUE."
(cl-check-type obj eieio-object)
(cl-check-type obj (or eieio-object cl-structure-object))
(cl-check-type slot symbol)
(let* ((class (eieio--object-class obj))
(c (eieio--slot-name-index class slot)))
@ -1068,6 +1072,7 @@ method invocation orders of the involved classes."
;;
(define-error 'invalid-slot-name "Invalid slot name")
(define-error 'invalid-slot-type "Invalid slot type")
(define-error 'eieio-read-only "Read-only slot")
(define-error 'unbound-slot "Unbound slot")
(define-error 'inconsistent-class-hierarchy "Inconsistent class hierarchy")

2
lisp/emacs-lisp/eieio-custom.el
View file

@ -1,6 +1,6 @@
;;; eieio-custom.el --- eieio object customization -*- lexical-binding:t -*-
;; Copyright (C) 1999-2001, 2005, 2007-2021 Free Software Foundation,
;; Copyright (C) 1999-2001, 2005, 2007-2022 Free Software Foundation,
;; Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>

2
lisp/emacs-lisp/eieio-datadebug.el
View file

@ -1,6 +1,6 @@
;;; eieio-datadebug.el --- EIEIO extensions to the data debugger. -*- lexical-binding:t -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
;; Copyright (C) 2007-2022 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: OO, lisp

3
lisp/emacs-lisp/eieio-opt.el
View file

@ -1,6 +1,6 @@
;;; eieio-opt.el --- eieio optional functions (debug, printing, speedbar) -*- lexical-binding: t; -*-
;; Copyright (C) 1996, 1998-2003, 2005, 2008-2021 Free Software
;; Copyright (C) 1996, 1998-2003, 2005, 2008-2022 Free Software
;; Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
@ -130,6 +130,7 @@ are not abstract."
;;;###autoload
(defun eieio-help-constructor (ctr)
"Describe CTR if it is a class constructor."
(declare (obsolete "use `describe-function' or `cl--describe-class'." "29.1"))
(when (class-p ctr)
(erase-buffer)
(let ((location (find-lisp-object-file-name ctr 'define-type))

2
lisp/emacs-lisp/eieio-speedbar.el
View file

@ -1,6 +1,6 @@
;;; eieio-speedbar.el --- Classes for managing speedbar displays. -*- lexical-binding:t -*-
;; Copyright (C) 1999-2002, 2005, 2007-2021 Free Software Foundation,
;; Copyright (C) 1999-2002, 2005, 2007-2022 Free Software Foundation,
;; Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>

7
lisp/emacs-lisp/eieio.el
View file

@ -1,7 +1,7 @@
;;; eieio.el --- Enhanced Implementation of Emacs Interpreted Objects -*- lexical-binding:t -*-
;;; or maybe Eric's Implementation of Emacs Interpreted Objects
;; Copyright (C) 1995-1996, 1998-2021 Free Software Foundation, Inc.
;; Copyright (C) 1995-1996, 1998-2022 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Version: 1.4
@ -994,11 +994,6 @@ of `eq'."
(error "EIEIO: `change-class' is unimplemented"))
(define-obsolete-function-alias 'change-class #'eieio-change-class "26.1")
;; Hook ourselves into help system for describing classes and methods.
;; FIXME: This is not actually needed any more since we can click on the
;; hyperlink from the constructor's docstring to see the type definition.
(add-hook 'help-fns-describe-function-functions #'eieio-help-constructor)
(provide 'eieio)
;;; eieio.el ends here

2
lisp/emacs-lisp/eldoc.el
View file

@ -1,6 +1,6 @@
;;; eldoc.el --- Show function arglist or variable docstring in echo area -*- lexical-binding:t; -*-
;; Copyright (C) 1996-2021 Free Software Foundation, Inc.
;; Copyright (C) 1996-2022 Free Software Foundation, Inc.
;; Author: Noah Friedman <friedman@splode.com>
;; Keywords: extensions

2
lisp/emacs-lisp/elint.el
View file

@ -1,6 +1,6 @@
;;; elint.el --- Lint Emacs Lisp -*- lexical-binding: t -*-
;; Copyright (C) 1997, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1997, 2001-2022 Free Software Foundation, Inc.
;; Author: Peter Liljenberg <petli@lysator.liu.se>
;; Created: May 1997

14
lisp/emacs-lisp/elp.el
View file

@ -1,6 +1,6 @@
;;; elp.el --- Emacs Lisp Profiler -*- lexical-binding: t -*-
;; Copyright (C) 1994-2021 Free Software Foundation, Inc.
;; Copyright (C) 1994-2022 Free Software Foundation, Inc.
;; Author: Barry A. Warsaw
;; Maintainer: emacs-devel@gnu.org
@ -298,10 +298,18 @@ For example, to instrument all ELP functions, do the following:
'intern
(all-completions prefix obarray 'elp-profilable-p))))
(defun elp-restore-package (prefix)
"Remove instrumentation from functions with names starting with PREFIX."
(interactive "SPrefix: ")
(elp-restore-list
(mapcar #'intern
(all-completions (symbol-name prefix)
obarray 'elp-profilable-p))))
(defun elp-restore-list (&optional list)
"Restore the original definitions for all functions in `elp-function-list'.
Use optional LIST if provided instead."
(interactive "PList of functions to restore: ") ;FIXME: Doesn't work!?
(interactive)
(mapcar #'elp-restore-function (or list elp-function-list)))
(defun elp-restore-all ()
@ -323,7 +331,7 @@ Use optional LIST if provided instead."
(defun elp-reset-list (&optional list)
"Reset the profiling information for all functions in `elp-function-list'.
Use optional LIST if provided instead."
(interactive "PList of functions to reset: ") ;FIXME: Doesn't work!?
(interactive)
(let ((list (or list elp-function-list)))
(mapcar 'elp-reset-function list)))

2
lisp/emacs-lisp/ert-x.el
View file

@ -1,6 +1,6 @@
;;; ert-x.el --- Staging area for experimental extensions to ERT -*- lexical-binding: t -*-
;; Copyright (C) 2008, 2010-2021 Free Software Foundation, Inc.
;; Copyright (C) 2008, 2010-2022 Free Software Foundation, Inc.
;; Author: Lennart Borgman (lennart O borgman A gmail O com)
;; Christian Ohler <ohler@gnu.org>

281
lisp/emacs-lisp/ert.el
View file

@ -1,6 +1,6 @@
;;; ert.el --- Emacs Lisp Regression Testing -*- lexical-binding: t -*-
;; Copyright (C) 2007-2008, 2010-2021 Free Software Foundation, Inc.
;; Copyright (C) 2007-2008, 2010-2022 Free Software Foundation, Inc.
;; Author: Christian Ohler <ohler@gnu.org>
;; Keywords: lisp, tools
@ -39,7 +39,7 @@
;; 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
;; (`assert' tries to do something similar when its second argument
;; (`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
@ -65,6 +65,8 @@
(require 'pp)
(require 'map)
(autoload 'xml-escape-string "xml.el")
;;; UI customization options.
(defgroup ert ()
@ -247,7 +249,6 @@ in batch mode, an error is signalled.
"%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")
@ -677,7 +678,6 @@ and is displayed in front of the value of MESSAGE-FORM."
,@body))
;;; Facilities for running a single test.
(defvar ert-debug-on-error nil
@ -950,7 +950,8 @@ t -- Selects UNIVERSE.
: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 that the symbol names, errors if none.
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.
@ -1012,52 +1013,47 @@ contained in UNIVERSE."
universe))))
((pred ert-test-p) (list selector))
((pred symbolp)
(cl-assert (ert-test-boundp selector))
(unless (ert-test-boundp selector)
(signal 'ert-test-unbound (list selector)))
(list (ert-get-test selector)))
(`(,operator . ,operands)
(cl-ecase operator
(member
(mapcar (lambda (purported-test)
(pcase-exhaustive purported-test
((pred symbolp)
(cl-assert (ert-test-boundp purported-test))
(ert-get-test purported-test))
((pred ert-test-p) purported-test)))
operands))
(eql
(cl-assert (eql (length operands) 1))
(ert-select-tests `(member ,@operands) universe))
(and
;; Do these definitions of AND, NOT and OR satisfy de
;; Morgan's laws? Should they?
(cl-case (length operands)
(0 (ert-select-tests 't universe))
(t (ert-select-tests `(and ,@(cdr operands))
(ert-select-tests (car operands)
universe)))))
(not
(cl-assert (eql (length operands) 1))
(let ((all-tests (ert-select-tests 't universe)))
(cl-set-difference all-tests
(ert-select-tests (car operands)
all-tests))))
(or
(cl-case (length operands)
(0 (ert-select-tests 'nil universe))
(t (cl-union (ert-select-tests (car operands) universe)
(ert-select-tests `(or ,@(cdr operands))
universe)))))
(tag
(cl-assert (eql (length operands) 1))
(let ((tag (car operands)))
(ert-select-tests `(satisfies
,(lambda (test)
(member tag (ert-test-tags test))))
universe)))
(satisfies
(cl-assert (eql (length operands) 1))
(cl-remove-if-not (car operands)
(ert-select-tests 't universe)))))))
(`(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."
@ -1437,7 +1433,9 @@ Returns the stats object."
(if (getenv "EMACS_TEST_VERBOSE")
(ert-reason-for-test-result result)
""))))
(message "%s" "")))))
(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
@ -1525,6 +1523,183 @@ the tests)."
(backtrace))
(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 "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n")
(insert (format "<testsuites name=\"%s\" tests=\"%s\" errors=\"%s\" failures=\"%s\" skipped=\"%s\" time=\"%s\">\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 " <testsuite id=\"0\" name=\"%s\" tests=\"%s\" errors=\"%s\" failures=\"%s\" skipped=\"%s\" time=\"%s\" timestamp=\"%s\">\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 " <properties>\n"
(format " <property name=\"selector\" value=\"%s\"/>\n"
(xml-escape-string
(format "%s" (ert--stats-selector stats)) 'noerror))
" </properties>\n"))
(cl-loop for test across (ert--stats-tests stats)
for result = (ert-test-most-recent-result test) do
(insert (format " <testcase name=\"%s\" status=\"%s\" time=\"%s\""
(xml-escape-string
(symbol-name (ert-test-name test)) 'noerror)
(ert-string-for-test-result
result
(ert-test-result-expected-p test result))
(ert-test-result-duration result)))
(if (and (ert-test-result-expected-p test result)
(not (ert-test-aborted-with-non-local-exit-p result))
(not (ert-test-skipped-p result))
(zerop (length (ert-test-result-messages result))))
(insert "/>\n")
(insert ">\n")
(cond
((ert-test-skipped-p result)
(insert (format " <skipped message=\"%s\" type=\"%s\">\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"
" </skipped>\n"))
((ert-test-aborted-with-non-local-exit-p result)
(insert (format " <error message=\"%s\" type=\"%s\">\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))
" </error>\n"))
((not (ert-test-result-type-p
result (ert-test-expected-result-type test)))
(insert (format " <failure message=\"%s\" type=\"%s\">\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"
" </failure>\n")))
(unless (zerop (length (ert-test-result-messages result)))
(insert " <system-out>\n"
(xml-escape-string
(ert-test-result-messages result) 'noerror)
" </system-out>\n"))
(insert " </testcase>\n")))
(insert " </testsuite>\n")
(insert "</testsuites>\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 " <testsuite id=\"%s\" name=\"%s\" tests=\"1\" errors=\"1\" failures=\"0\" skipped=\"0\" time=\"0\" timestamp=\"%s\">\n"
id test-report
(ert--format-time-iso8601 (current-time))))
(insert (format " <testcase name=\"Test report missing %s\" status=\"error\" time=\"0\">\n"
(file-name-nondirectory test-report)))
(insert (format " <error message=\"Test report missing %s\" type=\"error\">\n"
(file-name-nondirectory test-report)))
(when logfile-contents
(insert (xml-escape-string logfile-contents 'noerror)))
(insert " </error>\n"
" </testcase>\n"
" </testsuite>\n")
(cl-incf errors 1)
(cl-incf id 1)))
(insert-file-contents-literally test-report)
(when (looking-at-p
(regexp-quote "<?xml version=\"1.0\" encoding=\"utf-8\"?>"))
(delete-region (point) (line-beginning-position 2)))
(when (looking-at
"<testsuites name=\".+\" tests=\"\\(.+\\)\" errors=\"\\(.+\\)\" failures=\"\\(.+\\)\" skipped=\"\\(.+\\)\" time=\"\\(.+\\)\">")
(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 " <testsuite id=\"\\(0\\)\"")
(replace-match (number-to-string id) nil nil nil 1)
(cl-incf id 1))
(goto-char (point-max))
(beginning-of-line 0)
(when (looking-at-p "</testsuites>")
(delete-region (point) (line-beginning-position 2))))
(narrow-to-region (point-max) (point-max))))
(insert "</testsuites>\n")
(widen)
(goto-char (point-min))
(insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n")
(insert (format "<testsuites name=\"%s\" tests=\"%s\" errors=\"%s\" failures=\"%s\" skipped=\"%s\" time=\"%s\">\n"
(file-name-nondirectory report)
tests errors failures skipped time)))))
(defun ert-summarize-tests-batch-and-exit (&optional high)
"Summarize the results of testing.
@ -1540,6 +1715,8 @@ If HIGH is a natural number, the HIGH long lasting tests are summarized."
;; 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)
@ -1855,7 +2032,6 @@ Also sets `ert--results-progress-bar-button-begin'."
;; should test it again.)
"\n")))
(defvar ert-test-run-redisplay-interval-secs .1
"How many seconds ERT should wait between redisplays while running tests.
@ -2037,7 +2213,6 @@ STATS is the stats object; LISTENER is the results listener."
(goto-char (1- (point-max)))
buffer)))))
(defvar ert--selector-history nil
"List of recent test selectors read from terminal.")

2
lisp/emacs-lisp/ewoc.el
View file

@ -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-2021 Free Software Foundation, Inc.
;; Copyright (C) 1991-2022 Free Software Foundation, Inc.
;; Author: Per Cederqvist <ceder@lysator.liu.se>
;; Inge Wallin <inge@lysator.liu.se>

2
lisp/emacs-lisp/faceup.el
View file

@ -1,6 +1,6 @@
;;; faceup.el --- Markup language for faces and font-lock regression testing -*- lexical-binding: t -*-
;; Copyright (C) 2013-2021 Free Software Foundation, Inc.
;; Copyright (C) 2013-2022 Free Software Foundation, Inc.
;; Author: Anders Lindgren
;; Version: 0.0.6

2
lisp/emacs-lisp/find-func.el
View file

@ -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-2021 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1999, 2001-2022 Free Software Foundation, Inc.
;; Author: Jens Petersen <petersen@kurims.kyoto-u.ac.jp>
;; Keywords: emacs-lisp, functions, variables

2
lisp/emacs-lisp/float-sup.el
View file

@ -1,6 +1,6 @@
;;; float-sup.el --- define some constants useful for floating point numbers. -*- lexical-binding:t -*-
;; Copyright (C) 1985-1987, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1985-1987, 2001-2022 Free Software Foundation, Inc.
;; Maintainer: emacs-devel@gnu.org
;; Keywords: internal

33
lisp/emacs-lisp/generator.el
View file

@ -1,6 +1,6 @@
;;; generator.el --- generators -*- lexical-binding: t -*-
;; Copyright (C) 2015-2021 Free Software Foundation, Inc.
;; Copyright (C) 2015-2022 Free Software Foundation, Inc.
;; Author: Daniel Colascione <dancol@dancol.org>
;; Keywords: extensions, elisp
@ -143,8 +143,7 @@ the CPS state machinery."
(setf ,static-var ,dynamic-var)))))
(defmacro cps--with-dynamic-binding (dynamic-var static-var &rest body)
"Evaluate BODY such that generated atomic evaluations run with
DYNAMIC-VAR bound to STATIC-VAR."
"Run BODY's atomic evaluations run with DYNAMIC-VAR bound to STATIC-VAR."
(declare (indent 2))
`(cps--with-value-wrapper
(cps--make-dynamic-binding-wrapper ,dynamic-var ,static-var)
@ -291,22 +290,28 @@ DYNAMIC-VAR bound to STATIC-VAR."
(cps--transform-1 `(progn ,@rest)
next-state)))
;; Process `let' in a helper function that transforms it into a
;; let* with temporaries.
(`(,(or 'let 'let*) () . ,body)
(cps--transform-1 `(progn ,@body) next-state))
;; Transform multi-variable `let' into `let*':
;; (let ((v1 e1) ... (vN eN)) BODY)
;; -> (let* ((t1 e1) ... (tN-1 eN-1) (vN eN) (v1 t1) (vN-1 tN-1)) BODY)
(`(let ,bindings . ,body)
(let* ((bindings (cl-loop for binding in bindings
collect (if (symbolp binding)
(list binding nil)
binding)))
(temps (cl-loop for (var _value-form) in bindings
(butlast-bindings (butlast bindings))
(temps (cl-loop for (var _value-form) in butlast-bindings
collect (cps--add-binding var))))
(cps--transform-1
`(let* ,(append
(cl-loop for (_var value-form) in bindings
(cl-loop for (_var value-form) in butlast-bindings
for temp in temps
collect (list temp value-form))
(cl-loop for (var _binding) in bindings
(last bindings)
(cl-loop for (var _binding) in butlast-bindings
for temp in temps
collect (list var temp)))
,@body)
@ -315,9 +320,6 @@ DYNAMIC-VAR bound to STATIC-VAR."
;; Process `let*' binding: process one binding at a time. Flatten
;; lexical bindings.
(`(let* () . ,body)
(cps--transform-1 `(progn ,@body) next-state))
(`(let* (,binding . ,more-bindings) . ,body)
(let* ((var (if (symbolp binding) binding (car binding)))
(value-form (car (cdr-safe binding)))
@ -642,12 +644,11 @@ modified copy."
(iter-close iterator)))))
iterator))))
(defun iter-yield (value)
(defun iter-yield (_value)
"When used inside a generator, yield control to caller.
The caller of `iter-next' receives VALUE, and the next call to
`iter-next' resumes execution with the form immediately following this
`iter-yield' call."
(identity value)
(error "`iter-yield' used outside a generator"))
(defmacro iter-yield-from (value)
@ -689,8 +690,10 @@ of values. Callers can retrieve each value using `iter-next'."
(declare (indent defun)
(debug (&define lambda-list lambda-doc &rest sexp)))
(cl-assert lexical-binding)
`(lambda ,arglist
,(cps-generate-evaluator body)))
(pcase-let* ((`(,declarations . ,exps) (macroexp-parse-body body)))
`(lambda ,arglist
,@declarations
,(cps-generate-evaluator exps))))
(defmacro iter-make (&rest body)
"Return a new iterator."

2
lisp/emacs-lisp/generic.el
View file

@ -1,6 +1,6 @@
;;; generic.el --- defining simple major modes with comment and font-lock -*- lexical-binding: t; -*-
;;
;; Copyright (C) 1997, 1999, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1997, 1999, 2001-2022 Free Software Foundation, Inc.
;;
;; Author: Peter Breton <pbreton@cs.umb.edu>
;; Created: Fri Sep 27 1996

2
lisp/emacs-lisp/gv.el
View file

@ -1,6 +1,6 @@
;;; gv.el --- generalized variables -*- lexical-binding: t -*-
;; Copyright (C) 2012-2021 Free Software Foundation, Inc.
;; Copyright (C) 2012-2022 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: extensions

2
lisp/emacs-lisp/helper.el
View file

@ -1,6 +1,6 @@
;;; helper.el --- utility help package supporting help in electric modes -*- lexical-binding: t; -*-
;; Copyright (C) 1985, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1985, 2001-2022 Free Software Foundation, Inc.
;; Author: K. Shane Hartman
;; Maintainer: emacs-devel@gnu.org

2
lisp/emacs-lisp/hierarchy.el
View file

@ -1,6 +1,6 @@
;;; hierarchy.el --- Library to create and display hierarchical structures -*- lexical-binding: t; -*-
;; Copyright (C) 2020-2021 Free Software Foundation, Inc.
;; Copyright (C) 2020-2022 Free Software Foundation, Inc.
;; Author: Damien Cassou <damien@cassou.me>
;; Maintainer: emacs-devel@gnu.org

2
lisp/emacs-lisp/inline.el
View file

@ -1,6 +1,6 @@
;;; inline.el --- Define functions by their inliner -*- lexical-binding:t; -*-
;; Copyright (C) 2014-2021 Free Software Foundation, Inc.
;; Copyright (C) 2014-2022 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>

2
lisp/emacs-lisp/let-alist.el
View file

@ -1,6 +1,6 @@
;;; let-alist.el --- Easily let-bind values of an assoc-list by their names -*- lexical-binding: t; -*-
;; Copyright (C) 2014-2021 Free Software Foundation, Inc.
;; Copyright (C) 2014-2022 Free Software Foundation, Inc.
;; Author: Artur Malabarba <emacs@endlessparentheses.com>
;; Package-Requires: ((emacs "24.1"))

2
lisp/emacs-lisp/lisp-mnt.el
View file

@ -1,6 +1,6 @@
;;; lisp-mnt.el --- utility functions for Emacs Lisp maintainers -*- lexical-binding:t -*-
;; Copyright (C) 1992, 1994, 1997, 2000-2021 Free Software Foundation,
;; Copyright (C) 1992, 1994, 1997, 2000-2022 Free Software Foundation,
;; Inc.
;; Author: Eric S. Raymond <esr@snark.thyrsus.com>

2
lisp/emacs-lisp/lisp-mode.el
View file

@ -1,6 +1,6 @@
;;; lisp-mode.el --- Lisp mode, and its idiosyncratic commands -*- lexical-binding:t -*-
;; Copyright (C) 1985-1986, 1999-2021 Free Software Foundation, Inc.
;; Copyright (C) 1985-1986, 1999-2022 Free Software Foundation, Inc.
;; Maintainer: emacs-devel@gnu.org
;; Keywords: lisp, languages

2
lisp/emacs-lisp/lisp.el
View file

@ -1,6 +1,6 @@
;;; lisp.el --- Lisp editing commands for Emacs -*- lexical-binding:t -*-
;; Copyright (C) 1985-1986, 1994, 2000-2021 Free Software Foundation,
;; Copyright (C) 1985-1986, 1994, 2000-2022 Free Software Foundation,
;; Inc.
;; Maintainer: emacs-devel@gnu.org

75
lisp/emacs-lisp/macroexp.el
View file

@ -1,6 +1,6 @@
;;; macroexp.el --- Additional macro-expansion support -*- lexical-binding: t -*-
;;
;; Copyright (C) 2004-2021 Free Software Foundation, Inc.
;; Copyright (C) 2004-2022 Free Software Foundation, Inc.
;;
;; Author: Miles Bader <miles@gnu.org>
;; Keywords: lisp, compiler, macros
@ -209,9 +209,12 @@ Other uses risk returning non-nil value that point to the wrong file."
(defvar macroexp--warned (make-hash-table :test #'equal :weakness 'key))
(defun macroexp--warn-wrap (arg msg form category)
(let ((when-compiled (lambda ()
(when (byte-compile-warning-enabled-p category)
(byte-compile-warn-x arg "%s" msg)))))
(let ((when-compiled
(lambda ()
(when (if (consp category)
(apply #'byte-compile-warning-enabled-p category)
(byte-compile-warning-enabled-p category))
(byte-compile-warn-x arg "%s" msg)))))
`(progn
(macroexp--funcall-if-compiled ',when-compiled)
,form)))
@ -294,7 +297,7 @@ is executed without being compiled first."
fun obsolete
(if (symbolp (symbol-function fun))
"alias" "macro"))
new-form 'obsolete))
new-form (list 'obsolete fun)))
new-form)))
(defun macroexp--unfold-lambda (form &optional name)
@ -361,6 +364,16 @@ is executed without being compiled first."
`(let ,(nreverse bindings) . ,body)
(macroexp-progn body)))))
(defun macroexp--dynamic-variable-p (var)
"Whether the variable VAR is dynamically scoped.
Only valid during macro-expansion."
(defvar byte-compile-bound-variables)
(or (not lexical-binding)
(special-variable-p var)
(memq var macroexp--dynvars)
(and (boundp 'byte-compile-bound-variables)
(memq var byte-compile-bound-variables))))
(defun macroexp--expand-all (form)
"Expand all macros in FORM.
This is an internal version of `macroexpand-all'.
@ -388,29 +401,33 @@ Assumes the caller has bound `macroexpand-all-environment'."
(cddr form))
(cdr form))
form))
(`(,(or 'defvar 'defconst) . ,_) (macroexp--all-forms form 2))
(`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_)
(push name macroexp--dynvars)
(macroexp--all-forms form 2))
(`(function ,(and f `(lambda . ,_)))
(macroexp--cons 'function
(macroexp--cons (macroexp--all-forms f 2)
nil
(cdr form))
form))
(let ((macroexp--dynvars macroexp--dynvars))
(macroexp--cons 'function
(macroexp--cons (macroexp--all-forms f 2)
nil
(cdr form))
form)))
(`(,(or 'function 'quote) . ,_) form)
(`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body)
pcase--dontcare))
(macroexp--cons
fun
(macroexp--cons
(macroexp--all-clauses bindings 1)
(if (null body)
(macroexp-unprogn
(macroexp-warn-and-return
fun
(format "Empty %s body" fun)
nil nil 'compile-only))
(macroexp--all-forms body))
(cdr form))
form))
(let ((macroexp--dynvars macroexp--dynvars))
(macroexp--cons
fun
(macroexp--cons
(macroexp--all-clauses bindings 1)
(if (null body)
(macroexp-unprogn
(macroexp-warn-and-return
fun
(format "Empty %s body" fun)
nil nil 'compile-only))
(macroexp--all-forms body))
(cdr form))
form)))
(`(,(and fun `(lambda . ,_)) . ,args)
;; Embedded lambda in function position.
;; If the byte-optimizer is loaded, try to unfold this,
@ -495,6 +512,14 @@ Assumes the caller has bound `macroexpand-all-environment'."
If no macros are expanded, FORM is returned unchanged.
The second optional arg ENVIRONMENT specifies an environment of macro
definitions to shadow the loaded ones for use in file byte-compilation."
(let ((macroexpand-all-environment environment)
(macroexp--dynvars macroexp--dynvars))
(macroexp--expand-all form)))
;; This function is like `macroexpand-all' but for use with top-level
;; forms. It does not dynbind `macroexp--dynvars' because we want
;; top-level `defvar' declarations to be recorded in that variable.
(defun macroexpand--all-toplevel (form &optional environment)
(let ((macroexpand-all-environment environment))
(macroexp--expand-all form)))
@ -781,7 +806,7 @@ test of free variables in the following ways:
(let ((macroexp--pending-eager-loads
(cons load-file-name macroexp--pending-eager-loads)))
(if full-p
(macroexpand-all form)
(macroexpand--all-toplevel form)
(macroexpand form)))
(error
;; Hopefully this shouldn't happen thanks to the cycle detection,

2
lisp/emacs-lisp/map-ynp.el
View file

@ -1,6 +1,6 @@
;;; map-ynp.el --- general-purpose boolean question-asker -*- lexical-binding:t -*-
;; Copyright (C) 1991-1995, 2000-2021 Free Software Foundation, Inc.
;; Copyright (C) 1991-1995, 2000-2022 Free Software Foundation, Inc.
;; Author: Roland McGrath <roland@gnu.org>
;; Maintainer: emacs-devel@gnu.org

2
lisp/emacs-lisp/map.el
View file

@ -1,6 +1,6 @@
;;; map.el --- Map manipulation functions -*- lexical-binding: t; -*-
;; Copyright (C) 2015-2021 Free Software Foundation, Inc.
;; Copyright (C) 2015-2022 Free Software Foundation, Inc.
;; Author: Nicolas Petton <nicolas@petton.fr>
;; Maintainer: emacs-devel@gnu.org

2
lisp/emacs-lisp/memory-report.el
View file

@ -1,6 +1,6 @@
;;; memory-report.el --- Short function summaries -*- lexical-binding: t -*-
;; Copyright (C) 2020-2021 Free Software Foundation, Inc.
;; Copyright (C) 2020-2022 Free Software Foundation, Inc.
;; Keywords: lisp, help

449
lisp/emacs-lisp/multisession.el Normal file
View file

@ -0,0 +1,449 @@
;;; multisession.el --- Multisession storage for variables -*- lexical-binding: t; -*-
;; Copyright (C) 2021-2022 Free Software Foundation, Inc.
;; 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 <https://www.gnu.org/licenses/>.
;;; Commentary:
;;
;;; Code:
(require 'cl-lib)
(require 'eieio)
(require 'sqlite)
(require 'tabulated-list)
(defcustom multisession-storage 'files
"Storage method for multisession variables.
Valid methods are `sqlite' and `files'."
:type '(choice (const :tag "SQLite" sqlite)
(const :tag "Files" files))
:version "29.1"
:group 'files)
(defcustom multisession-directory (expand-file-name "multisession/"
user-emacs-directory)
"Directory to store multisession variables."
:type 'file
:version "29.1"
:group 'files)
;;;###autoload
(defmacro define-multisession-variable (name initial-value &optional doc
&rest args)
"Make NAME into a multisession variable initialized from INITIAL-VALUE.
DOC should be a doc string, and ARGS are keywords as applicable to
`make-multisession'."
(declare (indent defun))
(unless (plist-get args :package)
(setq args (nconc (list :package
(replace-regexp-in-string "-.*" ""
(symbol-name name)))
args)))
`(defvar ,name
(make-multisession :key ,(symbol-name name)
:initial-value ,initial-value
,@args)
,@(list doc)))
(defconst multisession--unbound (make-symbol "unbound"))
(cl-defstruct (multisession
(:constructor nil)
(:constructor multisession--create)
(:conc-name multisession--))
"A persistent variable that will live across Emacs invocations."
key
(initial-value nil)
package
(storage multisession-storage)
(synchronized nil)
(cached-value multisession--unbound)
(cached-sequence 0))
(cl-defun make-multisession (&key key initial-value package synchronized
storage)
"Create a multisession object."
(unless package
(error "No package for the multisession object"))
(unless key
(error "No key for the multisession object"))
(unless (stringp package)
(error "The package has to be a string"))
(unless (stringp key)
(error "The key has to be a string"))
(multisession--create
:key key
:synchronized synchronized
:initial-value initial-value
:package package
:storage (or storage multisession-storage)))
(defun multisession-value (object)
"Return the value of the multisession OBJECT."
(if (null user-init-file)
;; If we don't have storage, then just return the value from the
;; object.
(if (eq (multisession--cached-value object) multisession--unbound)
(multisession--initial-value object)
(multisession--cached-value object))
;; We have storage, so we update from storage.
(multisession-backend-value (multisession--storage object) object)))
(defun multisession--set-value (object value)
"Set the stored value of OBJECT to VALUE."
(if (null user-init-file)
;; We have no backend, so just store the value.
(setf (multisession--cached-value object) value)
;; We have a backend.
(multisession--backend-set-value (multisession--storage object)
object value)))
(defun multisession-delete (object)
"Delete OBJECT from the backend storage."
(multisession--backend-delete (multisession--storage object) object))
(gv-define-simple-setter multisession-value multisession--set-value)
;; SQLite Backend
(declare-function sqlite-execute "sqlite.c")
(declare-function sqlite-select "sqlite.c")
(declare-function sqlite-open "sqlite.c")
(declare-function sqlite-pragma "sqlite.c")
(declare-function sqlite-transaction "sqlite.c")
(declare-function sqlite-commit "sqlite.c")
(defvar multisession--db nil)
(defun multisession--ensure-db ()
(unless multisession--db
(let* ((file (expand-file-name "sqlite/multisession.sqlite"
multisession-directory))
(dir (file-name-directory file)))
(unless (file-exists-p dir)
(make-directory dir t))
(setq multisession--db (sqlite-open file)))
(with-sqlite-transaction multisession--db
;; Use a write-ahead-log (available since 2010), which makes
;; writes a lot faster.
(sqlite-pragma multisession--db "journal_mode = WAL")
(sqlite-pragma multisession--db "synchronous = NORMAL")
(unless (sqlite-select
multisession--db
"select name from sqlite_master where type = 'table' and name = 'multisession'")
;; Tidy up the database automatically.
(sqlite-pragma multisession--db "auto_vacuum = FULL")
;; Create the table.
(sqlite-execute
multisession--db
"create table multisession (package text not null, key text not null, sequence number not null default 1, value text not null)")
(sqlite-execute
multisession--db
"create unique index multisession_idx on multisession (package, key)")))))
(cl-defmethod multisession-backend-value ((_type (eql 'sqlite)) object)
(multisession--ensure-db)
(let ((id (list (multisession--package object)
(multisession--key object))))
(cond
;; We have no value yet; check the database.
((eq (multisession--cached-value object) multisession--unbound)
(let ((stored
(car
(sqlite-select
multisession--db
"select value, sequence from multisession where package = ? and key = ?"
id))))
(if stored
(let ((value (car (read-from-string (car stored)))))
(setf (multisession--cached-value object) value
(multisession--cached-sequence object) (cadr stored))
value)
;; Nothing; return the initial value.
(multisession--initial-value object))))
;; We have a value, but we want to update in case some other
;; Emacs instance has updated.
((multisession--synchronized object)
(let ((stored
(car
(sqlite-select
multisession--db
"select value, sequence from multisession where sequence > ? and package = ? and key = ?"
(cons (multisession--cached-sequence object) id)))))
(if stored
(let ((value (car (read-from-string (car stored)))))
(setf (multisession--cached-value object) value
(multisession--cached-sequence object) (cadr stored))
value)
;; Nothing, return the cached value.
(multisession--cached-value object))))
;; Just return the cached value.
(t
(multisession--cached-value object)))))
(cl-defmethod multisession--backend-set-value ((_type (eql 'sqlite))
object value)
(catch 'done
(let ((i 0))
(while (< i 10)
(condition-case nil
(throw 'done (multisession--set-value-sqlite object value))
(sqlite-locked-error
(setq i (1+ i))
(sleep-for (+ 0.1 (/ (float (random 10)) 10))))))
(signal 'sqlite-locked-error "Database is locked"))))
(defun multisession--set-value-sqlite (object value)
(multisession--ensure-db)
(with-sqlite-transaction multisession--db
(let ((id (list (multisession--package object)
(multisession--key object)))
(pvalue
(let ((print-length nil)
(print-circle t)
(print-level nil))
(prin1-to-string value))))
(condition-case nil
(ignore (read-from-string pvalue))
(error (error "Unable to store unreadable value: %s" pvalue)))
(sqlite-execute
multisession--db
"insert into multisession(package, key, sequence, value) values(?, ?, 1, ?) on conflict(package, key) do update set sequence = sequence + 1, value = ?"
(append id (list pvalue pvalue)))
(setf (multisession--cached-sequence object)
(caar (sqlite-select
multisession--db
"select sequence from multisession where package = ? and key = ?"
id)))
(setf (multisession--cached-value object) value))))
(cl-defmethod multisession--backend-values ((_type (eql 'sqlite)))
(multisession--ensure-db)
(sqlite-select
multisession--db
"select package, key, value from multisession order by package, key"))
(cl-defmethod multisession--backend-delete ((_type (eql 'sqlite)) object)
(sqlite-execute multisession--db
"delete from multisession where package = ? and key = ?"
(list (multisession--package object)
(multisession--key object))))
;; Files Backend
(defun multisession--encode-file-name (name)
(url-hexify-string name))
(defun multisession--read-file-value (file object)
(catch 'done
(let ((i 0)
last-error)
(while (< i 10)
(condition-case err
(throw 'done
(with-temp-buffer
(let* ((time (file-attribute-modification-time
(file-attributes file)))
(coding-system-for-read 'utf-8-emacs-unix))
(insert-file-contents file)
(let ((stored (read (current-buffer))))
(setf (multisession--cached-value object) stored
(multisession--cached-sequence object) time)
stored))))
;; Windows uses OS-level file locking that may preclude
;; reading the file in some circumstances. In addition,
;; rename-file is not an atomic operation on MS-Windows,
;; when the target file already exists, so there could be a
;; small race window when the file to read doesn't yet
;; exist. So when these problems happen, wait a bit and retry.
((permission-denied file-missing)
(setq i (1+ i)
last-error err)
(sleep-for (+ 0.1 (/ (float (random 10)) 10))))))
(signal (car last-error) (cdr last-error)))))
(defun multisession--object-file-name (object)
(expand-file-name
(concat "files/"
(multisession--encode-file-name (multisession--package object))
"/"
(multisession--encode-file-name (multisession--key object))
".value")
multisession-directory))
(cl-defmethod multisession-backend-value ((_type (eql 'files)) object)
(let ((file (multisession--object-file-name object)))
(cond
;; We have no value yet; see whether it's stored.
((eq (multisession--cached-value object) multisession--unbound)
(if (file-exists-p file)
(multisession--read-file-value file object)
;; Nope; return the initial value.
(multisession--initial-value object)))
;; We have a value, but we want to update in case some other
;; Emacs instance has updated.
((multisession--synchronized object)
(if (and (file-exists-p file)
(time-less-p (multisession--cached-sequence object)
(file-attribute-modification-time
(file-attributes file))))
(multisession--read-file-value file object)
;; Nothing, return the cached value.
(multisession--cached-value object)))
;; Just return the cached value.
(t
(multisession--cached-value object)))))
(cl-defmethod multisession--backend-set-value ((_type (eql 'files))
object value)
(let ((file (multisession--object-file-name object))
(time (current-time)))
;; Ensure that the directory exists.
(let ((dir (file-name-directory file)))
(unless (file-exists-p dir)
(make-directory dir t)))
(with-temp-buffer
(let ((print-length nil)
(print-circle t)
(print-level nil))
(prin1 value (current-buffer)))
(goto-char (point-min))
(condition-case nil
(read (current-buffer))
(error (error "Unable to store unreadable value: %s" (buffer-string))))
;; Write to a temp file in the same directory and rename to the
;; file for somewhat better atomicity.
(let ((coding-system-for-write 'utf-8-emacs-unix)
(create-lockfiles nil)
(temp (make-temp-name file))
(write-region-inhibit-fsync nil))
(write-region (point-min) (point-max) temp nil 'silent)
(set-file-times temp time)
(rename-file temp file t)))
(setf (multisession--cached-sequence object) time
(multisession--cached-value object) value)))
(cl-defmethod multisession--backend-values ((_type (eql 'files)))
(mapcar (lambda (file)
(let ((bits (file-name-split file)))
(list (url-unhex-string (car (last bits 2)))
(url-unhex-string
(file-name-sans-extension (car (last bits))))
(with-temp-buffer
(let ((coding-system-for-read 'utf-8-emacs-unix))
(insert-file-contents file)
(read (current-buffer)))))))
(directory-files-recursively
(expand-file-name "files" multisession-directory)
"\\.value\\'")))
(cl-defmethod multisession--backend-delete ((_type (eql 'files)) object)
(let ((file (multisession--object-file-name object)))
(when (file-exists-p file)
(delete-file file))))
;; Mode for editing.
(defvar-keymap multisession-edit-mode-map
:parent tabulated-list-mode-map
"d" #'multisession-delete-value
"e" #'multisession-edit-value)
(define-derived-mode multisession-edit-mode special-mode "Multisession"
"This mode lists all elements in the \"multisession\" database."
:interactive nil
(buffer-disable-undo)
(setq-local buffer-read-only t
truncate-lines t)
(setq tabulated-list-format
[("Package" 10)
("Key" 30)
("Value" 30)])
(setq-local revert-buffer-function #'multisession-edit-mode--revert))
;;;###autoload
(defun list-multisession-values (&optional choose-storage)
"List all values in the \"multisession\" database.
If CHOOSE-STORAGE (interactively, the prefix), query for the
storage method to list."
(interactive "P")
(let ((storage
(if choose-storage
(intern (completing-read "Storage method: " '(sqlite files) nil t))
multisession-storage)))
(pop-to-buffer (get-buffer-create (format "*Multisession %s*" storage)))
(multisession-edit-mode)
(setq-local multisession-storage storage)
(multisession-edit-mode--revert)
(goto-char (point-min))))
(defun multisession-edit-mode--revert (&rest _)
(let ((inhibit-read-only t)
(id (get-text-property (point) 'tabulated-list-id)))
(erase-buffer)
(tabulated-list-init-header)
(setq tabulated-list-entries
(mapcar (lambda (elem)
(list
(cons (car elem) (cadr elem))
(vector (car elem) (cadr elem)
(string-replace "\n" "\\n"
(format "%s" (caddr elem))))))
(multisession--backend-values multisession-storage)))
(tabulated-list-print t)
(goto-char (point-min))
(when id
(when-let ((match
(text-property-search-forward 'tabulated-list-id id t)))
(goto-char (prop-match-beginning match))))))
(defun multisession-delete-value (id)
"Delete the value at point."
(interactive (list (get-text-property (point) 'tabulated-list-id))
multisession-edit-mode)
(unless id
(error "No value on the current line"))
(unless (yes-or-no-p "Really delete this item? ")
(user-error "Not deleting"))
(multisession--backend-delete multisession-storage
(make-multisession :package (car id)
:key (cdr id)))
(let ((inhibit-read-only t))
(beginning-of-line)
(delete-region (point) (progn (forward-line 1) (point)))))
(defun multisession-edit-value (id)
"Edit the value at point."
(interactive (list (get-text-property (point) 'tabulated-list-id))
multisession-edit-mode)
(unless id
(error "No value on the current line"))
(let* ((object (make-multisession
:package (car id)
:key (cdr id)
:storage multisession-storage))
(value (multisession-value object)))
(setf (multisession-value object)
(car (read-from-string
(read-string "New value: " (prin1-to-string value))))))
(multisession-edit-mode--revert))
(provide 'multisession)
;;; multisession.el ends here

4
lisp/emacs-lisp/nadvice.el
View file

@ -1,6 +1,6 @@
;;; nadvice.el --- Light-weight advice primitives for Elisp functions -*- lexical-binding: t -*-
;; Copyright (C) 2012-2021 Free Software Foundation, Inc.
;; Copyright (C) 2012-2022 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: extensions, lisp, tools
@ -480,6 +480,8 @@ is defined as a macro, alias, command, ..."
(get symbol 'advice--pending))
(t (symbol-function symbol)))
function props)
;; FIXME: We could use a defmethod on `function-docstring' instead,
;; except when (or (not nf) (autoloadp nf))!
(put symbol 'function-documentation `(advice--make-docstring ',symbol))
(add-function :around (get symbol 'defalias-fset-function)
#'advice--defalias-fset))

2
lisp/emacs-lisp/package-x.el
View file

@ -1,6 +1,6 @@
;;; package-x.el --- Package extras -*- lexical-binding: t; -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
;; Copyright (C) 2007-2022 Free Software Foundation, Inc.
;; Author: Tom Tromey <tromey@redhat.com>
;; Created: 10 Mar 2007

89
lisp/emacs-lisp/package.el
View file

@ -1,6 +1,6 @@
;;; package.el --- Simple package system for Emacs -*- lexical-binding:t -*-
;; Copyright (C) 2007-2021 Free Software Foundation, Inc.
;; Copyright (C) 2007-2022 Free Software Foundation, Inc.
;; Author: Tom Tromey <tromey@redhat.com>
;; Daniel Hackney <dan@haxney.org>
@ -397,7 +397,13 @@ a sane initial value."
:type '(repeat symbol))
(defcustom package-native-compile nil
"Non-nil means to native compile packages on installation."
"Non-nil means to natively compile packages as part of their installation.
This controls ahead-of-time compilation of packages when they are
installed. If this option is nil, packages will be natively
compiled when they are loaded for the first time.
This option does not have any effect if Emacs was not built with
native compilation support."
:type '(boolean)
:risky t
:version "28.1")
@ -1181,13 +1187,17 @@ The return result is a `package-desc'."
info)
(while files
(with-temp-buffer
(insert-file-contents (pop files))
;; When we find the file with the data,
(when (setq info (ignore-errors (package-buffer-info)))
;; stop looping,
(setq files nil)
;; set the 'dir kind,
(setf (package-desc-kind info) 'dir))))
(let ((file (pop files)))
;; The file may be a link to a nonexistent file; e.g., a
;; lock file.
(when (file-exists-p file)
(insert-file-contents file)
;; When we find the file with the data,
(when (setq info (ignore-errors (package-buffer-info)))
;; stop looping,
(setq files nil)
;; set the 'dir kind,
(setf (package-desc-kind info) 'dir))))))
(unless info
(error "No .el files with package headers in `%s'" default-directory))
;; and return the info.
@ -2764,35 +2774,33 @@ either a full name or nil, and EMAIL is a valid email address."
;;;; Package menu mode.
(defvar package-menu-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map tabulated-list-mode-map)
(define-key map "\C-m" 'package-menu-describe-package)
(define-key map "u" 'package-menu-mark-unmark)
(define-key map "\177" 'package-menu-backup-unmark)
(define-key map "d" 'package-menu-mark-delete)
(define-key map "i" 'package-menu-mark-install)
(define-key map "U" 'package-menu-mark-upgrades)
(define-key map "r" 'revert-buffer)
(define-key map "~" 'package-menu-mark-obsolete-for-deletion)
(define-key map "w" 'package-browse-url)
(define-key map "x" 'package-menu-execute)
(define-key map "h" 'package-menu-quick-help)
(define-key map "H" #'package-menu-hide-package)
(define-key map "?" 'package-menu-describe-package)
(define-key map "(" #'package-menu-toggle-hiding)
(define-key map (kbd "/ /") 'package-menu-clear-filter)
(define-key map (kbd "/ a") 'package-menu-filter-by-archive)
(define-key map (kbd "/ d") 'package-menu-filter-by-description)
(define-key map (kbd "/ k") 'package-menu-filter-by-keyword)
(define-key map (kbd "/ N") 'package-menu-filter-by-name-or-description)
(define-key map (kbd "/ n") 'package-menu-filter-by-name)
(define-key map (kbd "/ s") 'package-menu-filter-by-status)
(define-key map (kbd "/ v") 'package-menu-filter-by-version)
(define-key map (kbd "/ m") 'package-menu-filter-marked)
(define-key map (kbd "/ u") 'package-menu-filter-upgradable)
map)
"Local keymap for `package-menu-mode' buffers.")
(defvar-keymap package-menu-mode-map
:doc "Local keymap for `package-menu-mode' buffers."
:parent tabulated-list-mode-map
"C-m" #'package-menu-describe-package
"u" #'package-menu-mark-unmark
"DEL" #'package-menu-backup-unmark
"d" #'package-menu-mark-delete
"i" #'package-menu-mark-install
"U" #'package-menu-mark-upgrades
"r" #'revert-buffer
"~" #'package-menu-mark-obsolete-for-deletion
"w" #'package-browse-url
"x" #'package-menu-execute
"h" #'package-menu-quick-help
"H" #'package-menu-hide-package
"?" #'package-menu-describe-package
"(" #'package-menu-toggle-hiding
"/ /" #'package-menu-clear-filter
"/ a" #'package-menu-filter-by-archive
"/ d" #'package-menu-filter-by-description
"/ k" #'package-menu-filter-by-keyword
"/ N" #'package-menu-filter-by-name-or-description
"/ n" #'package-menu-filter-by-name
"/ s" #'package-menu-filter-by-status
"/ v" #'package-menu-filter-by-version
"/ m" #'package-menu-filter-marked
"/ u" #'package-menu-filter-upgradable)
(easy-menu-define package-menu-mode-menu package-menu-mode-map
"Menu for `package-menu-mode'."
@ -4074,7 +4082,9 @@ The list is displayed in a buffer named `*Packages*'."
"Return the version number of the package in which this is used.
Assumes it is used from an Elisp file placed inside the top-level directory
of an installed ELPA package.
The return value is a string (or nil in case we can't find it)."
The return value is a string (or nil in case we can't find it).
It works in more cases if the call is in the file which contains
the `Version:' header."
;; In a sense, this is a lie, but it does just what we want: precompute
;; the version at compile time and hardcodes it into the .elc file!
(declare (pure t))
@ -4093,6 +4103,7 @@ The return value is a string (or nil in case we can't find it)."
(let* ((pkgdir (file-name-directory file))
(pkgname (file-name-nondirectory (directory-file-name pkgdir)))
(mainfile (expand-file-name (concat pkgname ".el") pkgdir)))
(unless (file-readable-p mainfile) (setq mainfile file))
(when (file-readable-p mainfile)
(require 'lisp-mnt)
(with-temp-buffer

2
lisp/emacs-lisp/pcase.el
View file

@ -1,6 +1,6 @@
;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t -*-
;; Copyright (C) 2010-2021 Free Software Foundation, Inc.
;; Copyright (C) 2010-2022 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: extensions

8
lisp/emacs-lisp/pp.el
View file

@ -1,6 +1,6 @@
;;; pp.el --- pretty printer for Emacs Lisp -*- lexical-binding: t -*-
;; Copyright (C) 1989, 1993, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1989, 1993, 2001-2022 Free Software Foundation, Inc.
;; Author: Randal Schwartz <merlyn@stonehenge.com>
;; Keywords: lisp
@ -24,6 +24,7 @@
;;; Code:
(require 'cl-lib)
(defvar font-lock-verbose)
(defgroup pp nil
@ -233,13 +234,14 @@ Use the `pp-max-width' variable to control the desired line length."
(cons (cond
((consp (cdr sexp))
(if (and (length= sexp 2)
(eq (car sexp) 'quote))
(memq (car sexp) '(quote function)))
(cond
((symbolp (cadr sexp))
(let ((print-quoted t))
(prin1 sexp (current-buffer))))
((consp (cadr sexp))
(insert "'")
(insert (if (eq (car sexp) 'quote)
"'" "#'"))
(pp--format-list (cadr sexp)
(set-marker (make-marker) (1- (point))))))
(pp--format-list sexp)))

2
lisp/emacs-lisp/radix-tree.el
View file

@ -1,6 +1,6 @@
;;; radix-tree.el --- A simple library of radix trees -*- lexical-binding: t; -*-
;; Copyright (C) 2016-2021 Free Software Foundation, Inc.
;; Copyright (C) 2016-2022 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords:

20
lisp/emacs-lisp/re-builder.el
View file

@ -1,6 +1,6 @@
;;; re-builder.el --- building Regexps with visual feedback -*- lexical-binding: t -*-
;; Copyright (C) 1999-2021 Free Software Foundation, Inc.
;; Copyright (C) 1999-2022 Free Software Foundation, Inc.
;; Author: Detlev Zundel <dzu@gnu.org>
;; Keywords: matching, lisp, tools
@ -274,8 +274,8 @@ Except for Lisp syntax this is the same as `reb-regexp'.")
emacs-lisp-mode "RE Builder Lisp"
"Major mode for interactively building symbolic Regular Expressions."
;; Pull in packages as needed
(cond ((memq reb-re-syntax '(sregex rx)) ; rx-to-string is autoloaded
(require 'rx))) ; require rx anyway
(when (eq reb-re-syntax 'rx) ; rx-to-string is autoloaded
(require 'rx)) ; require rx anyway
(reb-mode-common))
(defvar reb-subexp-mode-map
@ -307,8 +307,8 @@ Except for Lisp syntax this is the same as `reb-regexp'.")
(eq 'color (frame-parameter nil 'display-type)))
(defsubst reb-lisp-syntax-p ()
"Return non-nil if RE Builder uses a Lisp syntax."
(memq reb-re-syntax '(sregex rx)))
"Return non-nil if RE Builder uses `rx' syntax."
(eq reb-re-syntax 'rx))
(defmacro reb-target-binding (symbol)
"Return binding for SYMBOL in the RE Builder target buffer."
@ -483,11 +483,11 @@ Optional argument SYNTAX must be specified if called non-interactively."
(list (intern
(completing-read
(format-prompt "Select syntax" reb-re-syntax)
'(read string sregex rx)
'(read string rx)
nil t nil nil (symbol-name reb-re-syntax)
'reb-change-syntax-hist))))
(if (memq syntax '(read string sregex rx))
(if (memq syntax '(read string rx))
(let ((buffer (get-buffer reb-buffer)))
(setq reb-re-syntax syntax)
(when buffer
@ -606,9 +606,9 @@ optional fourth argument FORCE is non-nil."
(defun reb-cook-regexp (re)
"Return RE after processing it according to `reb-re-syntax'."
(cond ((memq reb-re-syntax '(sregex rx))
(rx-to-string (eval (car (read-from-string re)))))
(t re)))
(if (eq reb-re-syntax 'rx)
(rx-to-string (eval (car (read-from-string re))))
re))
(defun reb-update-regexp ()
"Update the regexp for the target buffer.

2
lisp/emacs-lisp/regexp-opt.el
View file

@ -1,6 +1,6 @@
;;; regexp-opt.el --- generate efficient regexps to match strings -*- lexical-binding: t -*-
;; Copyright (C) 1994-2021 Free Software Foundation, Inc.
;; Copyright (C) 1994-2022 Free Software Foundation, Inc.
;; Author: Simon Marshall <simon@gnu.org>
;; Maintainer: emacs-devel@gnu.org

2
lisp/emacs-lisp/regi.el
View file

@ -1,6 +1,6 @@
;;; regi.el --- REGular expression Interpreting engine -*- lexical-binding: t; -*-
;; Copyright (C) 1993, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1993, 2001-2022 Free Software Foundation, Inc.
;; Author: 1993 Barry A. Warsaw, Century Computing, Inc. <bwarsaw@cen.com>
;; Created: 24-Feb-1993

2
lisp/emacs-lisp/ring.el
View file

@ -1,6 +1,6 @@
;;; ring.el --- handle rings of items -*- lexical-binding: t; -*-
;; Copyright (C) 1992, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1992, 2001-2022 Free Software Foundation, Inc.
;; Maintainer: emacs-devel@gnu.org
;; Keywords: extensions

191
lisp/emacs-lisp/rmc.el
View file

@ -1,6 +1,6 @@
;;; rmc.el --- read from a multiple choice question -*- lexical-binding: t -*-
;; Copyright (C) 2016-2021 Free Software Foundation, Inc.
;; Copyright (C) 2016-2022 Free Software Foundation, Inc.
;; Maintainer: emacs-devel@gnu.org
@ -25,8 +25,101 @@
(require 'seq)
(defun rmc--add-key-description (elem)
(let* ((char (car elem))
(name (cadr elem))
(pos (seq-position name char))
(desc (key-description (char-to-string char)))
(graphical-terminal
(display-supports-face-attributes-p
'(:underline t) (window-frame)))
(altered-name
(cond
;; Not in the name string, or a special character.
((or (not pos)
(member desc '("ESC" "TAB" "RET" "DEL" "SPC")))
(format "%s %s"
(if graphical-terminal
(propertize desc 'face 'read-multiple-choice-face)
(propertize desc 'face 'help-key-binding))
name))
;; The prompt character is in the name, so highlight
;; it on graphical terminals.
(graphical-terminal
(setq name (copy-sequence name))
(put-text-property pos (1+ pos)
'face 'read-multiple-choice-face
name)
name)
;; And put it in [bracket] on non-graphical terminals.
(t
(concat
(substring name 0 pos)
"["
(upcase (substring name pos (1+ pos)))
"]"
(substring name (1+ pos)))))))
(cons char altered-name)))
(defun rmc--show-help (prompt help-string show-help choices altered-names)
(let* ((buf-name (if (stringp show-help)
show-help
"*Multiple Choice Help*"))
(buf (get-buffer-create buf-name)))
(if (stringp help-string)
(with-help-window buf
(with-current-buffer buf
(insert help-string)))
(with-help-window buf
(with-current-buffer buf
(erase-buffer)
(pop-to-buffer buf)
(insert prompt "\n\n")
(let* ((columns (/ (window-width) 25))
(fill-column 21)
(times 0)
(start (point)))
(dolist (elem choices)
(goto-char start)
(unless (zerop times)
(if (zerop (mod times columns))
;; Go to the next "line".
(goto-char (setq start (point-max)))
;; Add padding.
(while (not (eobp))
(end-of-line)
(insert (make-string (max (- (* (mod times columns)
(+ fill-column 4))
(current-column))
0)
?\s))
(forward-line 1))))
(setq times (1+ times))
(let ((text
(with-temp-buffer
(insert (format
"%c: %s\n"
(car elem)
(cdr (assq (car elem) altered-names))))
(fill-region (point-min) (point-max))
(when (nth 2 elem)
(let ((start (point)))
(insert (nth 2 elem))
(unless (bolp)
(insert "\n"))
(fill-region start (point-max))))
(buffer-string))))
(goto-char start)
(dolist (line (split-string text "\n"))
(end-of-line)
(if (bolp)
(insert line "\n")
(insert line))
(forward-line 1))))))))
buf))
;;;###autoload
(defun read-multiple-choice (prompt choices &optional help-string)
(defun read-multiple-choice (prompt choices &optional help-string show-help)
"Ask user to select an entry from CHOICES, promting with PROMPT.
This function allows to ask the user a multiple-choice question.
@ -42,6 +135,9 @@ the optional argument HELP-STRING. This argument is a string that
should contain a more detailed description of all of the possible
choices. `read-multiple-choice' will display that description in a
help buffer if the user requests that.
If optional argument SHOW-HELP is non-nil, show the help screen
immediately, before any user input. If SHOW-HELP is a string,
use it as the name of the help buffer.
This function translates user input into responses by consulting
the bindings in `query-replace-map'; see the documentation of
@ -67,45 +163,19 @@ Usage example:
\\='((?a \"always\")
(?s \"session only\")
(?n \"no\")))"
(let* ((altered-names nil)
(let* ((choices (if show-help choices (append choices '((?? "?")))))
(altered-names (mapcar #'rmc--add-key-description choices))
(full-prompt
(format
"%s (%s): "
prompt
(mapconcat
(lambda (elem)
(let* ((name (cadr elem))
(pos (seq-position name (car elem)))
(altered-name
(cond
;; Not in the name string.
((not pos)
(format "[%c] %s" (car elem) name))
;; The prompt character is in the name, so highlight
;; it on graphical terminals...
((display-supports-face-attributes-p
'(:underline t) (window-frame))
(setq name (copy-sequence name))
(put-text-property pos (1+ pos)
'face 'read-multiple-choice-face
name)
name)
;; And put it in [bracket] on non-graphical terminals.
(t
(concat
(substring name 0 pos)
"["
(upcase (substring name pos (1+ pos)))
"]"
(substring name (1+ pos)))))))
(push (cons (car elem) altered-name)
altered-names)
altered-name))
(append choices '((?? "?")))
", ")))
(mapconcat (lambda (e) (cdr e)) altered-names ", ")))
tchar buf wrong-char answer)
(save-window-excursion
(save-excursion
(if show-help
(setq buf (rmc--show-help prompt help-string show-help
choices altered-names)))
(while (not tchar)
(message "%s%s"
(if wrong-char
@ -161,57 +231,8 @@ Usage example:
tchar nil)
(when wrong-char
(ding))
(setq buf (get-buffer-create "*Multiple Choice Help*"))
(if (stringp help-string)
(with-help-window buf
(with-current-buffer buf
(insert help-string)))
(with-help-window buf
(with-current-buffer buf
(erase-buffer)
(pop-to-buffer buf)
(insert prompt "\n\n")
(let* ((columns (/ (window-width) 25))
(fill-column 21)
(times 0)
(start (point)))
(dolist (elem choices)
(goto-char start)
(unless (zerop times)
(if (zerop (mod times columns))
;; Go to the next "line".
(goto-char (setq start (point-max)))
;; Add padding.
(while (not (eobp))
(end-of-line)
(insert (make-string (max (- (* (mod times columns)
(+ fill-column 4))
(current-column))
0)
?\s))
(forward-line 1))))
(setq times (1+ times))
(let ((text
(with-temp-buffer
(insert (format
"%c: %s\n"
(car elem)
(cdr (assq (car elem) altered-names))))
(fill-region (point-min) (point-max))
(when (nth 2 elem)
(let ((start (point)))
(insert (nth 2 elem))
(unless (bolp)
(insert "\n"))
(fill-region start (point-max))))
(buffer-string))))
(goto-char start)
(dolist (line (split-string text "\n"))
(end-of-line)
(if (bolp)
(insert line "\n")
(insert line))
(forward-line 1))))))))))))
(setq buf (rmc--show-help prompt help-string show-help
choices altered-names))))))
(when (buffer-live-p buf)
(kill-buffer buf))
(assq tchar choices)))

2
lisp/emacs-lisp/rx.el
View file

@ -1,6 +1,6 @@
;;; rx.el --- S-exp notation for regexps --*- lexical-binding: t -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 2001-2022 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.

2
lisp/emacs-lisp/seq.el
View file

@ -1,6 +1,6 @@
;;; seq.el --- Sequence manipulation functions -*- lexical-binding: t -*-
;; Copyright (C) 2014-2021 Free Software Foundation, Inc.
;; Copyright (C) 2014-2022 Free Software Foundation, Inc.
;; Author: Nicolas Petton <nicolas@petton.fr>
;; Keywords: sequences

5
lisp/emacs-lisp/shadow.el
View file

@ -1,6 +1,6 @@
;;; shadow.el --- locate Emacs Lisp file shadowings -*- lexical-binding: t; -*-
;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1995, 2001-2022 Free Software Foundation, Inc.
;; Author: Terry Jones <terry@santafe.edu>
;; Keywords: lisp
@ -151,9 +151,6 @@ See the documentation for `list-load-path-shadows' for further information."
;; Return the list of shadowings.
shadows))
(define-obsolete-function-alias 'find-emacs-lisp-shadows
'load-path-shadows-find "23.3")
;; Return true if neither file exists, or if both exist and have identical
;; contents.
(defun load-path-shadows-same-file-or-nonexistent (f1 f2)

18
lisp/emacs-lisp/shortdoc.el
View file

@ -1,6 +1,6 @@
;;; shortdoc.el --- Short function summaries -*- lexical-binding: t -*-
;; Copyright (C) 2020-2021 Free Software Foundation, Inc.
;; Copyright (C) 2020-2022 Free Software Foundation, Inc.
;; Keywords: lisp, help
;; Package: emacs
@ -1232,7 +1232,7 @@ There can be any number of :example/:result elements."
(define-keymap
:no-eval (define-keymap "C-c C-c" #'quit-buffer))
(defvar-keymap
:no-eval (defvar-keymap my-keymap "C-c C-c" map #'quit-buffer))
:no-eval (defvar-keymap my-keymap "C-c C-c" #'quit-buffer))
"Setting keys"
(keymap-set
:no-eval (keymap-set map "C-c C-c" #'quit-buffer))
@ -1423,14 +1423,12 @@ Example:
(setq slist (cdr slist)))
(setcdr slist (cons elem (cdr slist))))))
(defvar shortdoc-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "n") 'shortdoc-next)
(define-key map (kbd "p") 'shortdoc-previous)
(define-key map (kbd "C-c C-n") 'shortdoc-next-section)
(define-key map (kbd "C-c C-p") 'shortdoc-previous-section)
map)
"Keymap for `shortdoc-mode'.")
(defvar-keymap shortdoc-mode-map
:doc "Keymap for `shortdoc-mode'."
"n" #'shortdoc-next
"p" #'shortdoc-previous
"C-c C-n" #'shortdoc-next-section
"C-c C-p" #'shortdoc-previous-section)
(define-derived-mode shortdoc-mode special-mode "shortdoc"
"Mode for shortdoc."

2
lisp/emacs-lisp/shorthands.el
View file

@ -1,6 +1,6 @@
;;; shorthands.el --- Read code considering Elisp shorthands -*- lexical-binding: t; -*-
;; Copyright (C) 2021 Free Software Foundation, Inc.
;; Copyright (C) 2021-2022 Free Software Foundation, Inc.
;; Author: João Távora <joaotavora@gmail.com>
;; Keywords: lisp

2
lisp/emacs-lisp/smie.el
View file

@ -1,6 +1,6 @@
;;; smie.el --- Simple Minded Indentation Engine -*- lexical-binding: t -*-
;; Copyright (C) 2010-2021 Free Software Foundation, Inc.
;; Copyright (C) 2010-2022 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: languages, lisp, internal, parsing, indentation

2
lisp/emacs-lisp/subr-x.el
View file

@ -1,6 +1,6 @@
;;; subr-x.el --- extra Lisp functions -*- lexical-binding:t -*-
;; Copyright (C) 2013-2021 Free Software Foundation, Inc.
;; Copyright (C) 2013-2022 Free Software Foundation, Inc.
;; Maintainer: emacs-devel@gnu.org
;; Keywords: convenience

2
lisp/emacs-lisp/syntax.el
View file

@ -1,6 +1,6 @@
;;; syntax.el --- helper functions to find syntactic context -*- lexical-binding: t -*-
;; Copyright (C) 2000-2021 Free Software Foundation, Inc.
;; Copyright (C) 2000-2022 Free Software Foundation, Inc.
;; Maintainer: emacs-devel@gnu.org
;; Keywords: internal

9
lisp/emacs-lisp/tabulated-list.el
View file

@ -1,6 +1,6 @@
;;; tabulated-list.el --- generic major mode for tabulated lists -*- lexical-binding: t -*-
;; Copyright (C) 2011-2021 Free Software Foundation, Inc.
;; Copyright (C) 2011-2022 Free Software Foundation, Inc.
;; Author: Chong Yidong <cyd@stupidchicken.com>
;; Keywords: extensions, lisp
@ -596,8 +596,7 @@ Return the column number after insertion."
(when not-last-col
(when (> pad-right 0) (insert (make-string pad-right ?\s)))
(insert (propertize
;; We need at least one space to align correctly.
(make-string (- width (min 1 width label-width)) ?\s)
(make-string (- width (min width label-width)) ?\s)
'display `(space :align-to ,next-x))))
(put-text-property opoint (point) 'tabulated-list-column-name name)
next-x)))
@ -684,6 +683,10 @@ With a numeric prefix argument N, sort the Nth column.
If the numeric prefix is -1, restore order the list was
originally displayed in."
(interactive "P")
(when (and n
(or (>= n (length tabulated-list-format))
(< n -1)))
(user-error "Invalid column number"))
(if (equal n -1)
;; Restore original order.
(progn

2
lisp/emacs-lisp/tcover-ses.el
View file

@ -1,6 +1,6 @@
;;; tcover-ses.el --- Example use of `testcover' to test "SES" -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
;; Copyright (C) 2002-2022 Free Software Foundation, Inc.
;; Author: Jonathan Yavner <jyavner@member.fsf.org>
;; Keywords: spreadsheet lisp utility

2
lisp/emacs-lisp/testcover.el
View file

@ -1,6 +1,6 @@
;;; testcover.el --- Visual code-coverage tool -*- lexical-binding:t -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
;; Copyright (C) 2002-2022 Free Software Foundation, Inc.
;; Author: Jonathan Yavner <jyavner@member.fsf.org>
;; Keywords: lisp utility

2
lisp/emacs-lisp/text-property-search.el
View file

@ -1,6 +1,6 @@
;;; text-property-search.el --- search for text properties -*- lexical-binding:t -*-
;; Copyright (C) 2018-2021 Free Software Foundation, Inc.
;; Copyright (C) 2018-2022 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: convenience

2
lisp/emacs-lisp/thunk.el
View file

@ -1,6 +1,6 @@
;;; thunk.el --- Lazy form evaluation -*- lexical-binding: t -*-
;; Copyright (C) 2015-2021 Free Software Foundation, Inc.
;; Copyright (C) 2015-2022 Free Software Foundation, Inc.
;; Author: Nicolas Petton <nicolas@petton.fr>
;; Keywords: sequences

2
lisp/emacs-lisp/timer-list.el
View file

@ -1,6 +1,6 @@
;;; timer-list.el --- list active timers in a buffer -*- lexical-binding:t -*-
;; Copyright (C) 2016-2021 Free Software Foundation, Inc.
;; Copyright (C) 2016-2022 Free Software Foundation, Inc.
;; Maintainer: emacs-devel@gnu.org
;; Package: emacs

18
lisp/emacs-lisp/timer.el
View file

@ -1,6 +1,6 @@
;;; timer.el --- run a function with args at some time in future -*- lexical-binding: t -*-
;; Copyright (C) 1996, 2001-2021 Free Software Foundation, Inc.
;; Copyright (C) 1996, 2001-2022 Free Software Foundation, Inc.
;; Maintainer: emacs-devel@gnu.org
;; Package: emacs
@ -314,7 +314,7 @@ This function is called, by name, directly by the C code."
(not (timer--idle-delay timer)))
(setf (timer--time timer)
(timer-next-integral-multiple-of-time
(current-time) (timer--repeat-delay timer))))
nil (timer--repeat-delay timer))))
;; Place it back on the timer-list before running
;; timer--function, so it can cancel-timer itself.
(timer-activate timer t cell)
@ -351,19 +351,27 @@ This function is called, by name, directly by the C code."
Repeat the action every REPEAT seconds, if REPEAT is non-nil.
REPEAT may be an integer or floating point number.
TIME should be one of:
- a string giving today's time like \"11:23pm\"
(the acceptable formats are HHMM, H:MM, HH:MM, HHam, HHAM,
HHpm, HHPM, HH:MMam, HH:MMAM, HH:MMpm, or HH:MMPM;
a period `.' can be used instead of a colon `:' to separate
the hour and minute parts);
- a string giving a relative time like \"90\" or \"2 hours 35 minutes\"
(the acceptable forms are a number of seconds without units
or some combination of values using units in `timer-duration-words');
- nil, meaning now;
- a number of seconds from now;
- a value from `encode-time';
- or t (with non-nil REPEAT) meaning the next integral
multiple of REPEAT.
- or t (with non-nil REPEAT) meaning the next integral multiple
of REPEAT. This is handy when you want the function to run at
a certain \"round\" number. For instance, (run-at-time t 60 ...)
will run at 11:04:00, 11:05:00, etc.
The action is to call FUNCTION with arguments ARGS.
@ -383,7 +391,7 @@ This function returns a timer object which you can use in
;; Special case: t means the next integral multiple of REPEAT.
(when (and (eq time t) repeat)
(setq time (timer-next-integral-multiple-of-time (current-time) repeat))
(setq time (timer-next-integral-multiple-of-time nil repeat))
(setf (timer--integral-multiple timer) t))
;; Handle numbers as relative times in seconds.

2
lisp/emacs-lisp/tq.el
View file

@ -1,6 +1,6 @@
;;; tq.el --- utility to maintain a transaction queue -*- lexical-binding:t -*-
;; Copyright (C) 1985-1987, 1992, 2001-2021 Free Software Foundation,
;; Copyright (C) 1985-1987, 1992, 2001-2022 Free Software Foundation,
;; Inc.
;; Author: Scott Draves <spot@cs.cmu.edu>

2
lisp/emacs-lisp/trace.el
View file

@ -1,6 +1,6 @@
;;; trace.el --- tracing facility for Emacs Lisp functions -*- lexical-binding: t -*-
;; Copyright (C) 1993, 1998, 2000-2021 Free Software Foundation, Inc.
;; Copyright (C) 1993, 1998, 2000-2022 Free Software Foundation, Inc.
;; Author: Hans Chalupsky <hans@cs.buffalo.edu>
;; Maintainer: emacs-devel@gnu.org

2
lisp/emacs-lisp/unsafep.el
View file

@ -1,6 +1,6 @@
;;; unsafep.el --- Determine whether a Lisp form is safe to evaluate -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
;; Copyright (C) 2002-2022 Free Software Foundation, Inc.
;; Author: Jonathan Yavner <jyavner@member.fsf.org>
;; Keywords: safety lisp utility

6
lisp/emacs-lisp/warnings.el
View file

@ -1,6 +1,6 @@
;;; warnings.el --- log and display warnings -*- lexical-binding:t -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
;; Copyright (C) 2002-2022 Free Software Foundation, Inc.
;; Maintainer: emacs-devel@gnu.org
;; Keywords: internal
@ -307,7 +307,9 @@ entirely by setting `warning-suppress-types' or
'type 'warning-suppress-log-warning
'warning-type type))
(funcall newline)
(when (and warning-fill-prefix (not (string-search "\n" message)))
(when (and warning-fill-prefix
(not (string-search "\n" message))
(not noninteractive))
(let ((fill-prefix warning-fill-prefix)
(fill-column warning-fill-column))
(fill-region start (point))))