[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
scratch/etags-regen 44f19c7 3/8: Merge branch 'master' into scratch/etag
|
From: |
Dmitry Gutov |
|
Subject: |
scratch/etags-regen 44f19c7 3/8: Merge branch 'master' into scratch/etags-regen |
|
Date: |
Sun, 7 Feb 2021 21:12:00 -0500 (EST) |
branch: scratch/etags-regen
commit 44f19c7f283e70727bb5d06bc9702d06538192d5
Merge: 1daad17 90bd6d8
Author: Dmitry Gutov <dgutov@yandex.ru>
Commit: Dmitry Gutov <dgutov@yandex.ru>
Merge branch 'master' into scratch/etags-regen
---
.gitignore | 1 -
doc/lispref/keymaps.texi | 5 +-
doc/lispref/markers.texi | 4 +-
doc/misc/message.texi | 6 +
doc/misc/tramp.texi | 8 +-
etc/NEWS | 36 +-
etc/NEWS.19 | 2 +
lisp/calc/calc-embed.el | 2 +
lisp/calc/calc-lang.el | 2 +-
lisp/calc/calc.el | 2 +-
lisp/calc/calccomp.el | 247 +++--
lisp/calendar/cal-bahai.el | 28 +-
lisp/calendar/cal-china.el | 45 +-
lisp/calendar/cal-coptic.el | 56 +-
lisp/calendar/cal-french.el | 76 +-
lisp/calendar/cal-hebrew.el | 68 +-
lisp/calendar/cal-html.el | 19 +-
lisp/calendar/cal-islam.el | 25 +-
lisp/calendar/cal-iso.el | 21 +-
lisp/calendar/cal-julian.el | 26 +-
lisp/calendar/cal-mayan.el | 10 +-
lisp/calendar/cal-menu.el | 4 +-
lisp/calendar/cal-move.el | 17 +-
lisp/calendar/cal-persia.el | 30 +-
lisp/calendar/cal-tex.el | 85 +-
lisp/calendar/cal-x.el | 2 +-
lisp/calendar/calendar.el | 57 +-
lisp/calendar/diary-lib.el | 4 +-
lisp/calendar/holidays.el | 15 +-
lisp/comint.el | 6 +-
lisp/cus-start.el | 2 +-
lisp/custom.el | 12 +-
lisp/dired-aux.el | 3 +-
lisp/dired-x.el | 2 +-
lisp/emacs-lisp/byte-opt.el | 1050 ++++++++++----------
lisp/emacs-lisp/bytecomp.el | 3 +-
lisp/emacs-lisp/checkdoc.el | 7 +-
lisp/emacs-lisp/package.el | 2 +-
lisp/emacs-lisp/subr-x.el | 22 +
lisp/emulation/cua-gmrk.el | 8 +-
lisp/facemenu.el | 11 +-
lisp/faces.el | 2 +-
lisp/font-lock.el | 2 +-
lisp/frame.el | 16 +-
lisp/gnus/message.el | 98 +-
lisp/gnus/nntp.el | 2 +-
lisp/help-fns.el | 3 +
lisp/ibuf-ext.el | 4 +-
lisp/image.el | 2 +-
lisp/isearch.el | 30 +-
lisp/mail/flow-fill.el | 2 +-
lisp/mail/footnote.el | 26 +-
lisp/mail/rmailedit.el | 9 +-
lisp/mh-e/mh-speed.el | 4 +-
lisp/net/tramp-sh.el | 8 +-
lisp/net/tramp.el | 21 +-
lisp/net/webjump.el | 7 +-
lisp/nxml/nxml-mode.el | 30 +-
lisp/progmodes/perl-mode.el | 11 +-
lisp/progmodes/project.el | 3 +
lisp/progmodes/sh-script.el | 4 +-
lisp/replace.el | 30 +-
lisp/simple.el | 9 +-
lisp/startup.el | 11 +-
lisp/textmodes/remember.el | 37 +-
lisp/thingatpt.el | 9 +
lisp/type-break.el | 4 +-
lisp/vc/vc.el | 42 +-
lisp/version.el | 6 +-
lisp/wid-edit.el | 19 +-
src/alloc.c | 6 +-
src/process.c | 2 +
src/window.c | 2 +-
test/Makefile.in | 2 +-
test/README | 4 +-
test/file-organization.org | 16 +-
test/infra/gitlab-ci.yml | 38 +-
.../emacs-lisp/bytecomp-resources/foo-inlinable.el | 6 +
.../nowarn-inline-after-defvar.el | 17 +
test/lisp/emacs-lisp/bytecomp-tests.el | 4 +
test/lisp/faces-tests.el | 8 +
test/lisp/net/tramp-tests.el | 22 +-
test/lisp/replace-tests.el | 13 +
test/lisp/thingatpt-tests.el | 44 +
test/lisp/wid-edit-tests.el | 11 +
85 files changed, 1601 insertions(+), 1076 deletions(-)
diff --git a/.gitignore b/.gitignore
index 7e3e434..dd4eab7 100644
--- a/.gitignore
+++ b/.gitignore
@@ -298,4 +298,3 @@ nt/emacs.rc
nt/emacsclient.rc
src/gdb.ini
/var/
-src/fingerprint.c
diff --git a/doc/lispref/keymaps.texi b/doc/lispref/keymaps.texi
index 37bab7e..55d179b 100644
--- a/doc/lispref/keymaps.texi
+++ b/doc/lispref/keymaps.texi
@@ -2852,9 +2852,8 @@ Here is how to insert an item called @samp{Work} in the
@samp{Signals}
menu of Shell mode, after the item @code{break}:
@example
-(define-key-after
- (lookup-key shell-mode-map [menu-bar signals])
- [work] '("Work" . work-command) 'break)
+(define-key-after shell-mode-map [menu-bar signals work]
+ '("Work" . work-command) 'break)
@end example
@end defun
diff --git a/doc/lispref/markers.texi b/doc/lispref/markers.texi
index cdd0938..b39373f 100644
--- a/doc/lispref/markers.texi
+++ b/doc/lispref/markers.texi
@@ -560,7 +560,9 @@ deactivate the mark. If the value is @w{@code{(only .
@var{oldval})}},
then @code{transient-mark-mode} is set to the value @var{oldval} after
any subsequent command that moves point and is not shift-translated
(@pxref{Key Sequence Input, shift-translation}), or after any other
-action that would normally deactivate the mark.
+action that would normally deactivate the mark. (Marking a region
+with the mouse will temporarily enable @code{transient-mark-mode} in
+this way.)
@end defopt
@defopt mark-even-if-inactive
diff --git a/doc/misc/message.texi b/doc/misc/message.texi
index f2680b4..be6c9a4 100644
--- a/doc/misc/message.texi
+++ b/doc/misc/message.texi
@@ -317,6 +317,12 @@ when forwarding a message.
In non-@code{nil}, only headers that match this regexp will be kept
when forwarding a message. This can also be a list of regexps.
+@item message-forward-included-mime-headers
+@vindex message-forward-included-mime-headers
+In non-@code{nil}, headers that match this regexp will be kept when
+forwarding a message as @acronym{MIME}, but @acronym{MML} isn't used.
+This can also be a list of regexps.
+
@item message-make-forward-subject-function
@vindex message-make-forward-subject-function
A list of functions that are called to generate a subject header for
diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi
index 2c4b792..e9ffd6a 100644
--- a/doc/misc/tramp.texi
+++ b/doc/misc/tramp.texi
@@ -2369,8 +2369,7 @@ that can identify such questions using
@lisp
@group
(defconst my-tramp-prompt-regexp
- (concat (regexp-opt '("Enter the birth date of your mother:") t)
- "\\s-*")
+ "Enter the birth date of your mother:\\s-*"
"Regular expression matching my login prompt question.")
@end group
@@ -2389,6 +2388,11 @@ that can identify such questions using
@end group
@end lisp
+The regular expressions used in @code{tramp-actions-before-shell} must
+match the end of the connection buffer. Due to performance reasons,
+this search starts at the end of the buffer, and it is limited to 256
+characters backwards.
+
@item Conflicting names for users and variables in @file{.profile}
diff --git a/etc/NEWS b/etc/NEWS
index d632283..357c75b 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -326,6 +326,10 @@ the buffer cycles the whole buffer between "only top-level
headings",
* Changes in Specialized Modes and Packages in Emacs 28.1
+** 'blink-cursor-mode' is now enabled by default regardless of the UI.
+It used to be enabled when Emacs is started in GUI mode but not when started
+in text mode. The cursor still only actually blinks in GUI frames.
+
** pcase
+++
*** The `pred` pattern can now take the form (pred (not FUN)).
@@ -352,6 +356,12 @@ When emacsclient connects, Emacs will (by default) output
a message
about how to exit the client frame. If 'server-client-instructions'
is set to nil, this message is inhibited.
+** Perl mode
+
+---
+*** New face 'perl-non-scalar-variable'.
+This is used to fontify non-scalar variables.
+
** Python mode
*** 'python-shell-interpreter' now defaults to python3 on systems with python3.
@@ -711,9 +721,11 @@ not.
---
*** Respect 'message-forward-ignored-headers' more.
Previously, this variable would not be consulted if
-'message-forward-show-mml' was nil. It's now always used, except if
-'message-forward-show-mml' is 'best', and we're forwarding an
-encrypted/signed message.
+'message-forward-show-mml' was nil and forwarding as MIME.
+
++++
+*** New user option 'message-forward-included-mime-headers'.
+This is used when forwarding messages as MIME, but not using MML.
+++
*** Message now supports the OpenPGP header.
@@ -1544,9 +1556,22 @@ buttons in it.
This function takes a string and returns a string propertized in a way
that makes it a valid button.
+** subr-x
++++
+*** A number of new string manipulation functions have been added.
+'string-clean-whitespace', 'string-fill', 'string-limit',
+'string-lines', 'string-pad' and 'string-chop-newline'.
+
+*** New macro `named-let` that provides Scheme's "named let" looping construct
** Miscellaneous
+---
+*** New user option 'remember-diary-regexp'.
+
+---
+*** New user option 'remember-text-format-function'.
+
*** New function 'buffer-line-statistics'.
This function returns some statistics about the line lengths in a buffer.
@@ -1578,11 +1603,6 @@ length to a number).
This can be set to nil to inhibit hiding passwords in ".authinfo" files.
+++
-*** A number of new string manipulation functions have been added.
-'string-clean-whitespace', 'string-fill', 'string-limit',
-'string-lines', 'string-pad' and 'string-chop-newline'.
-
-+++
*** New variable 'current-minibuffer-command'.
This is like 'this-command', but it is bound recursively when entering
the minibuffer.
diff --git a/etc/NEWS.19 b/etc/NEWS.19
index 43235e0..f2cef62 100644
--- a/etc/NEWS.19
+++ b/etc/NEWS.19
@@ -2824,6 +2824,8 @@ the text of the region according to the new value.
the fill-column has been exceeded; the function can determine on its
own whether filling (or justification) is necessary.
+**** New helper function 'indent-line-to'
+
** Processes
*** process-tty-name is a new function that returns the name of the
diff --git a/lisp/calc/calc-embed.el b/lisp/calc/calc-embed.el
index ea79bfa..fda0b4b 100644
--- a/lisp/calc/calc-embed.el
+++ b/lisp/calc/calc-embed.el
@@ -651,6 +651,8 @@ The command \\[yank] can retrieve it from there."
(defvar calc-embed-prev-modes)
(defun calc-embedded-set-modes (gmodes modes local-modes &optional temp)
+ (defvar the-language)
+ (defvar the-display-just)
(let ((the-language (calc-embedded-language))
(the-display-just (calc-embedded-justify))
(v gmodes)
diff --git a/lisp/calc/calc-lang.el b/lisp/calc/calc-lang.el
index b4b2d4c..0117f44 100644
--- a/lisp/calc/calc-lang.el
+++ b/lisp/calc/calc-lang.el
@@ -2181,7 +2181,7 @@ order to Calc's."
v math-read-big-baseline))
;; Small radical sign.
- ((and (= other-char ?V)
+ ((and (memq other-char '(?V ?√))
(= (math-read-big-char (1+ math-rb-h1) (1- v)) ?\_))
(setq h (1+ math-rb-h1))
(math-read-big-emptyp math-rb-h1 math-rb-v1 h (1- v) nil t)
diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el
index d684c7b..ec09abb 100644
--- a/lisp/calc/calc.el
+++ b/lisp/calc/calc.el
@@ -2144,7 +2144,7 @@ the United States."
(let ((w (split-window nil (/ (* (window-width) 2) 3) t)))
(set-window-buffer w calc-trail-buffer)
(and calc-make-windows-dedicated
- (set-window-dedicated-p nil t))))
+ (set-window-dedicated-p w t))))
(calc-wrapper
(setq overlay-arrow-string calc-trail-overlay
overlay-arrow-position calc-trail-pointer)
diff --git a/lisp/calc/calccomp.el b/lisp/calc/calccomp.el
index 07e70ca..5f38ee7 100644
--- a/lisp/calc/calccomp.el
+++ b/lisp/calc/calccomp.el
@@ -138,19 +138,19 @@
(math-format-number (nth 2 aa))))))
(if (= calc-number-radix 10)
c
- (list 'horiz "(" c
- (list 'subscr ")"
- (int-to-string calc-number-radix)))))
+ (list 'subscr (math--comp-round-bracket c)
+ (int-to-string calc-number-radix))))
(math-format-number a)))
(if (not (eq calc-language 'big))
(math-format-number a prec)
(if (memq (car-safe a) '(cplx polar))
(if (math-zerop (nth 2 a))
(math-compose-expr (nth 1 a) prec)
- (list 'horiz "("
- (math-compose-expr (nth 1 a) 0)
- (if (eq (car a) 'cplx) ", " "; ")
- (math-compose-expr (nth 2 a) 0) ")"))
+ (math--comp-round-bracket
+ (list 'horiz
+ (math-compose-expr (nth 1 a) 0)
+ (if (eq (car a) 'cplx) ", " "; ")
+ (math-compose-expr (nth 2 a) 0))))
(if (or (= calc-number-radix 10)
(not (Math-realp a))
(and calc-group-digits
@@ -340,12 +340,13 @@
(funcall spfn a prec)
(math-compose-var a)))))
((eq (car a) 'intv)
- (list 'horiz
- (if (memq (nth 1 a) '(0 1)) "(" "[")
- (math-compose-expr (nth 2 a) 0)
- " .. "
- (math-compose-expr (nth 3 a) 0)
- (if (memq (nth 1 a) '(0 2)) ")" "]")))
+ (math--comp-bracket
+ (if (memq (nth 1 a) '(0 1)) ?\( ?\[)
+ (if (memq (nth 1 a) '(0 2)) ?\) ?\])
+ (list 'horiz
+ (math-compose-expr (nth 2 a) 0)
+ " .. "
+ (math-compose-expr (nth 3 a) 0))))
((eq (car a) 'date)
(if (eq (car calc-date-format) 'X)
(math-format-date a)
@@ -377,7 +378,7 @@
(and (eq (car-safe (nth 1 a)) 'cplx)
(math-negp (nth 1 (nth 1 a)))
(eq (nth 2 (nth 1 a)) 0)))
- (list 'horiz "(" (math-compose-expr (nth 1 a) 0) ")")
+ (math--comp-round-bracket (math-compose-expr (nth 1 a) 0))
(math-compose-expr (nth 1 a) 201))
(let ((calc-language 'flat)
(calc-number-radix 10)
@@ -444,7 +445,7 @@
(if (> prec (nth 2 a))
(if (setq spfn (get calc-language 'math-big-parens))
(list 'horiz (car spfn) c (cdr spfn))
- (list 'horiz "(" c ")"))
+ (math--comp-round-bracket c))
c)))
((and (eq (car a) 'calcFunc-choriz)
(not (eq calc-language 'unform))
@@ -612,7 +613,7 @@
(list 'horiz "{left ( "
(math-compose-expr a -1)
" right )}")))
- (list 'horiz "(" (math-compose-expr a 0) ")"))))
+ (math--comp-round-bracket (math-compose-expr a 0)))))
((and (memq calc-language '(tex latex))
(memq (car a) '(/ calcFunc-choose calcFunc-evalto))
(>= prec 0))
@@ -638,7 +639,7 @@
(rhs (math-compose-expr (nth 2 a) (nth 3 op) (eq (nth 1
op) '/))))
(and (equal (car op) "^")
(eq (math-comp-first-char lhs) ?-)
- (setq lhs (list 'horiz "(" lhs ")")))
+ (setq lhs (math--comp-round-bracket lhs)))
(and (memq calc-language '(tex latex))
(or (equal (car op) "^") (equal (car op) "_"))
(not (and (stringp rhs) (= (length rhs) 1)))
@@ -721,7 +722,7 @@
(list 'horiz "{left ( "
(math-compose-expr a -1)
" right )}")))
- (list 'horiz "(" (math-compose-expr a 0) ")"))))
+ (math--comp-round-bracket (math-compose-expr a 0)))))
(t
(let ((lhs (math-compose-expr (nth 1 a) (nth 2 op))))
(list 'horiz
@@ -759,7 +760,7 @@
(list 'horiz "{left ( "
(math-compose-expr a -1)
" right )}")))
- (list 'horiz "(" (math-compose-expr a 0) ")"))))
+ (math--comp-round-bracket (math-compose-expr a 0)))))
(t
(let ((rhs (math-compose-expr (nth 1 a) (nth 3 op))))
(list 'horiz
@@ -966,6 +967,69 @@
(and (memq (car a) '(^ calcFunc-subscr))
(math-tex-expr-is-flat (nth 1 a)))))
+;; FIXME: maybe try box drawing chars if big bracket chars are unavailable,
+;; like ┌ ┐n
+;; │a + b│ ┌ a + b ┐n
+;; │-----│ or │ ----- │ ?
+;; │ c │ └ c ┘
+;; └ ┘
+;; They are more common than the chars below, but look a bit square.
+;; Rounded corners exist but are less commonly available.
+
+(defconst math--big-bracket-alist
+ '((?\( . (?⎛ ?⎝ ?⎜))
+ (?\) . (?⎞ ?⎠ ?⎟))
+ (?\[ . (?⎡ ?⎣ ?⎢))
+ (?\] . (?⎤ ?⎦ ?⎥))
+ (?\{ . (?⎧ ?⎩ ?⎪ ?⎨))
+ (?\} . (?⎫ ?⎭ ?⎪ ?⎬)))
+ "Alist mapping bracket chars to (UPPER LOWER EXTENSION MIDPIECE).
+Not all brackets have midpieces.")
+
+(defun math--big-bracket (bracket-char height baseline)
+ "Composition for BRACKET-CHAR of HEIGHT with BASELINE."
+ (if (<= height 1)
+ (char-to-string bracket-char)
+ (let ((pieces (cdr (assq bracket-char math--big-bracket-alist))))
+ (if (memq nil (mapcar #'char-displayable-p pieces))
+ (char-to-string bracket-char)
+ (let* ((upper (nth 0 pieces))
+ (lower (nth 1 pieces))
+ (extension (nth 2 pieces))
+ (midpiece (nth 3 pieces)))
+ (cons 'vleft ; alignment doesn't matter; width is 1 char
+ (cons baseline
+ (mapcar
+ #'char-to-string
+ (append
+ (list upper)
+ (if midpiece
+ (let ((lower-ext (/ (- height 3) 2)))
+ (append
+ (make-list (- height 3 lower-ext) extension)
+ (list midpiece)
+ (make-list lower-ext extension)))
+ (make-list (- height 2) extension))
+ (list lower))))))))))
+
+(defun math--comp-bracket (left-bracket right-bracket comp)
+ "Put the composition COMP inside LEFT-BRACKET and RIGHT-BRACKET."
+ (if (eq calc-language 'big)
+ (let ((height (math-comp-height comp))
+ (baseline (1- (math-comp-ascent comp))))
+ (list 'horiz
+ (math--big-bracket left-bracket height baseline)
+ comp
+ (math--big-bracket right-bracket height baseline)))
+ (list 'horiz
+ (char-to-string left-bracket)
+ comp
+ (char-to-string right-bracket))))
+
+(defun math--comp-round-bracket (comp)
+ "Put the composition COMP inside plain brackets."
+ (math--comp-bracket ?\( ?\) comp))
+
(put 'calcFunc-log 'math-compose-big #'math-compose-log)
(defun math-compose-log (a _prec)
(and (= (length a) 3)
@@ -973,18 +1037,14 @@
(list 'subscr "log"
(let ((calc-language 'flat))
(math-compose-expr (nth 2 a) 1000)))
- "("
- (math-compose-expr (nth 1 a) 1000)
- ")")))
+ (math--comp-round-bracket (math-compose-expr (nth 1 a) 1000)))))
(put 'calcFunc-log10 'math-compose-big #'math-compose-log10)
(defun math-compose-log10 (a _prec)
(and (= (length a) 2)
(list 'horiz
- (list 'subscr "log" "10")
- "("
- (math-compose-expr (nth 1 a) 1000)
- ")")))
+ (list 'subscr "log" "10")
+ (math--comp-round-bracket (math-compose-expr (nth 1 a) 1000)))))
(put 'calcFunc-deriv 'math-compose-big #'math-compose-deriv)
(put 'calcFunc-tderiv 'math-compose-big #'math-compose-deriv)
@@ -1027,12 +1087,9 @@
(defun math-compose-choose (a _prec)
(let ((a1 (math-compose-expr (nth 1 a) 0))
(a2 (math-compose-expr (nth 2 a) 0)))
- (list 'horiz
- "("
- (list 'vcent
- (math-comp-height a1)
- a1 " " a2)
- ")")))
+ (math--comp-round-bracket (list 'vcent
+ (+ (math-comp-height a1))
+ a1 " " a2))))
(put 'calcFunc-integ 'math-compose-big #'math-compose-integ)
(defun math-compose-integ (a prec)
@@ -1052,9 +1109,12 @@
"d%s"
(nth 1 (nth 2 a)))))
(nth 1 a)) 185))
- (calc-language 'flat)
- (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
- (high (and (nth 4 a) (math-compose-expr (nth 4 a) 0)))
+ (low (and (nth 3 a)
+ (let ((calc-language 'flat))
+ (math-compose-expr (nth 3 a) 0))))
+ (high (and (nth 4 a)
+ (let ((calc-language 'flat))
+ (math-compose-expr (nth 4 a) 0))))
;; Check if we have Unicode integral top/bottom parts.
(fancy (and (char-displayable-p ?⌠)
(char-displayable-p ?⌡)))
@@ -1066,40 +1126,47 @@
((char-displayable-p ?│) "│ ")
;; U+007C VERTICAL LINE
(t "| "))))
- (list 'horiz
- (if parens "(" "")
- (append (list 'vcent (if fancy
- (if high 2 1)
- (if high 3 2)))
- (and high (list (if fancy
- (list 'horiz high " ")
- (list 'horiz " " high))))
- (if fancy
- (list "⌠ " fancy-stem "⌡ ")
- '(" /"
- " | "
- " | "
- " | "
- "/ "))
- (and low (list (if fancy
- (list 'horiz low " ")
- (list 'horiz low " ")))))
- expr
- (if over
- ""
- (list 'horiz " d" var))
- (if parens ")" "")))))
+ (let ((comp
+ (list 'horiz
+ (append (list 'vcent (if fancy
+ (if high 2 1)
+ (if high 3 2)))
+ (and high (list (if fancy
+ (list 'horiz high " ")
+ (list 'horiz " " high))))
+ (if fancy
+ (list "⌠ " fancy-stem "⌡ ")
+ '(" /"
+ " | "
+ " | "
+ " | "
+ "/ "))
+ (and low (list (if fancy
+ (list 'horiz low " ")
+ (list 'horiz low " ")))))
+ expr
+ (if over
+ ""
+ (list 'horiz " d" var)))))
+ (if parens
+ (math--comp-round-bracket comp)
+ comp)))))
(put 'calcFunc-sum 'math-compose-big #'math-compose-sum)
(defun math-compose-sum (a prec)
(and (memq (length a) '(3 5 6))
(let* ((expr (math-compose-expr (nth 1 a) 185))
- (calc-language 'flat)
- (var (math-compose-expr (nth 2 a) 0))
- (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
- (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0))))
- (list 'horiz
- (if (memq prec '(180 201)) "(" "")
+ (var
+ (let ((calc-language 'flat))
+ (math-compose-expr (nth 2 a) 0)))
+ (low (and (nth 3 a)
+ (let ((calc-language 'flat))
+ (math-compose-expr (nth 3 a) 0))))
+ (high (and (nth 4 a)
+ (let ((calc-language 'flat))
+ (math-compose-vector (nthcdr 4 a) ", " 0))))
+ (comp
+ (list 'horiz
(append (list 'vcent (if high 3 2))
(and high (list high))
'("---- "
@@ -1112,32 +1179,42 @@
(list var)))
(if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod))
" " "")
- expr
- (if (memq prec '(180 201)) ")" "")))))
+ expr)))
+ (if (memq prec '(180 201))
+ (math--comp-round-bracket comp)
+ comp))))
(put 'calcFunc-prod 'math-compose-big #'math-compose-prod)
(defun math-compose-prod (a prec)
(and (memq (length a) '(3 5 6))
(let* ((expr (math-compose-expr (nth 1 a) 198))
- (calc-language 'flat)
- (var (math-compose-expr (nth 2 a) 0))
- (low (and (nth 3 a) (math-compose-expr (nth 3 a) 0)))
- (high (and (nth 4 a) (math-compose-vector (nthcdr 4 a) ", " 0))))
- (list 'horiz
- (if (memq prec '(196 201)) "(" "")
- (append (list 'vcent (if high 3 2))
- (and high (list high))
- '("----- "
- " | | "
- " | | "
- " | | ")
- (if low
- (list (list 'horiz var " = " low))
- (list var)))
- (if (memq (car-safe (nth 1 a)) '(calcFunc-sum calcFunc-prod))
- " " "")
- expr
- (if (memq prec '(196 201)) ")" "")))))
+ (var
+ (let ((calc-language 'flat))
+ (math-compose-expr (nth 2 a) 0)))
+ (low (and (nth 3 a)
+ (let ((calc-language 'flat))
+ (math-compose-expr (nth 3 a) 0))))
+ (high (and (nth 4 a)
+ (let ((calc-language 'flat))
+ (math-compose-vector (nthcdr 4 a) ", " 0))))
+ (comp
+ (list 'horiz
+ (append (list 'vcent (if high 3 2))
+ (and high (list high))
+ '("----- "
+ " | | "
+ " | | "
+ " | | ")
+ (if low
+ (list (list 'horiz var " = " low))
+ (list var)))
+ (if (memq (car-safe (nth 1 a))
+ '(calcFunc-sum calcFunc-prod))
+ " " "")
+ expr)))
+ (if (memq prec '(196 201))
+ (math--comp-round-bracket comp)
+ comp))))
;; The variables math-svo-c, math-svo-wid and math-svo-off are local
;; to math-stack-value-offset in calc.el, but are used by
diff --git a/lisp/calendar/cal-bahai.el b/lisp/calendar/cal-bahai.el
index 22e4cdb..c2e4205 100644
--- a/lisp/calendar/cal-bahai.el
+++ b/lisp/calendar/cal-bahai.el
@@ -1,4 +1,4 @@
-;;; cal-bahai.el --- calendar functions for the Bahá’í calendar.
+;;; cal-bahai.el --- calendar functions for the Bahá’í calendar. -*-
lexical-binding: t; -*-
;; Copyright (C) 2001-2021 Free Software Foundation, Inc.
@@ -124,9 +124,10 @@ Defaults to today's date if DATE is not given."
(y (calendar-extract-year bahai-date)))
(if (< y 1)
"" ; pre-Bahai
- (let* ((m (calendar-extract-month bahai-date))
- (d (calendar-extract-day bahai-date))
- (monthname (if (and (= m 19)
+ (let ((m (calendar-extract-month bahai-date))
+ (d (calendar-extract-day bahai-date)))
+ (calendar-dlet*
+ ((monthname (if (and (= m 19)
(<= d 0))
"Ayyám-i-Há"
(aref calendar-bahai-month-name-array (1- m))))
@@ -137,8 +138,8 @@ Defaults to today's date if DATE is not given."
(year (number-to-string y))
(month (number-to-string m))
dayname)
- ;; Can't call calendar-date-string because of monthname oddity.
- (mapconcat 'eval calendar-date-display-form "")))))
+ ;; Can't call calendar-date-string because of monthname oddity.
+ (mapconcat #'eval calendar-date-display-form ""))))))
;;;###cal-autoload
(defun calendar-bahai-print-date ()
@@ -153,13 +154,12 @@ Defaults to today's date if DATE is not given."
"Interactively read the arguments for a Bahá’í date command.
Reads a year, month and day."
(let* ((today (calendar-current-date))
- (year (calendar-read
- "Bahá’í calendar year (not 0): "
+ (year (calendar-read-sexp
+ "Bahá’í calendar year (not 0)"
(lambda (x) (not (zerop x)))
- (number-to-string
- (calendar-extract-year
- (calendar-bahai-from-absolute
- (calendar-absolute-from-gregorian today))))))
+ (calendar-extract-year
+ (calendar-bahai-from-absolute
+ (calendar-absolute-from-gregorian today)))))
(completion-ignore-case t)
(month (cdr (assoc
(completing-read
@@ -169,8 +169,8 @@ Reads a year, month and day."
nil t)
(calendar-make-alist calendar-bahai-month-name-array
1))))
- (day (calendar-read "Bahá’í calendar day (1-19): "
- (lambda (x) (and (< 0 x) (<= x 19))))))
+ (day (calendar-read-sexp "Bahá’í calendar day (1-19)"
+ (lambda (x) (and (< 0 x) (<= x 19))))))
(list (list month day year))))
;;;###cal-autoload
diff --git a/lisp/calendar/cal-china.el b/lisp/calendar/cal-china.el
index 7e5d0c4..9a28984 100644
--- a/lisp/calendar/cal-china.el
+++ b/lisp/calendar/cal-china.el
@@ -1,4 +1,4 @@
-;;; cal-china.el --- calendar functions for the Chinese calendar
+;;; cal-china.el --- calendar functions for the Chinese calendar -*-
lexical-binding: t; -*-
;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc.
@@ -185,7 +185,9 @@ N congruent to 1 gives the first name, N congruent to 2
gives the second name,
(defun calendar-chinese-zodiac-sign-on-or-after (d)
"Absolute date of first new Zodiac sign on or after absolute date D.
The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees."
- (let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d)))
+ (with-suppressed-warnings ((lexical year))
+ (defvar year))
+ (let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d)))
(calendar-time-zone (eval calendar-chinese-time-zone)) ; uses year
(calendar-daylight-time-offset
calendar-chinese-daylight-time-offset)
@@ -207,6 +209,8 @@ The Zodiac signs begin when the sun's longitude is a
multiple of 30 degrees."
(defun calendar-chinese-new-moon-on-or-after (d)
"Absolute date of first new moon on or after absolute date D."
+ (with-suppressed-warnings ((lexical year))
+ (defvar year))
(let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d)))
(calendar-time-zone (eval calendar-chinese-time-zone))
(calendar-daylight-time-offset
@@ -602,14 +606,14 @@ Echo Chinese date unless NOECHO is non-nil."
(interactive
(let* ((c (calendar-chinese-from-absolute
(calendar-absolute-from-gregorian (calendar-current-date))))
- (cycle (calendar-read
- "Chinese calendar cycle number (>44): "
+ (cycle (calendar-read-sexp
+ "Chinese calendar cycle number (>44)"
(lambda (x) (> x 44))
- (number-to-string (car c))))
- (year (calendar-read
- "Year in Chinese cycle (1..60): "
+ (car c)))
+ (year (calendar-read-sexp
+ "Year in Chinese cycle (1..60)"
(lambda (x) (and (<= 1 x) (<= x 60)))
- (number-to-string (cadr c))))
+ (cadr c)))
(month-list (calendar-chinese-months-to-alist
(calendar-chinese-months cycle year)))
(month (cdr (assoc
@@ -624,9 +628,11 @@ Echo Chinese date unless NOECHO is non-nil."
(list cycle year month 1))))))
30
29))
- (day (calendar-read
- (format "Chinese calendar day (1-%d): " last)
- (lambda (x) (and (<= 1 x) (<= x last))))))
+ (day (calendar-read-sexp
+ "Chinese calendar day (1-%d)"
+ (lambda (x) (and (<= 1 x) (<= x last)))
+ nil
+ last)))
(list (list cycle year month day))))
(calendar-goto-date (calendar-gregorian-from-absolute
(calendar-chinese-to-absolute date)))
@@ -663,17 +669,17 @@ Echo Chinese date unless NOECHO is non-nil."
["正月" "二月" "三月" "四月" "五月" "六月"
"七月" "八月" "九月" "十月" "冬月" "臘月"])
-;;; NOTE: In the diary the cycle and year of a Chinese date is
-;;; combined using this formula: (+ (* cycle 100) year).
+;; NOTE: In the diary the cycle and year of a Chinese date is
+;; combined using this formula: (+ (* cycle 100) year).
;;;
-;;; These two functions convert to and back from this representation.
-(defun calendar-chinese-from-absolute-for-diary (date)
- (pcase-let ((`(,c ,y ,m ,d) (calendar-chinese-from-absolute date)))
+;; These two functions convert to and back from this representation.
+(defun calendar-chinese-from-absolute-for-diary (thedate)
+ (pcase-let ((`(,c ,y ,m ,d) (calendar-chinese-from-absolute thedate)))
;; Note: For leap months M is a float.
(list (floor m) d (+ (* c 100) y))))
-(defun calendar-chinese-to-absolute-for-diary (date &optional prefer-leap)
- (pcase-let* ((`(,m ,d ,y) date)
+(defun calendar-chinese-to-absolute-for-diary (thedate &optional prefer-leap)
+ (pcase-let* ((`(,m ,d ,y) thedate)
(cycle (floor y 100))
(year (mod y 100))
(months (calendar-chinese-months cycle year))
@@ -691,7 +697,8 @@ Echo Chinese date unless NOECHO is non-nil."
(unless (zerop month)
(calendar-mark-1 month day year
#'calendar-chinese-from-absolute-for-diary
- (lambda (date) (calendar-chinese-to-absolute-for-diary
date t))
+ (lambda (thedate)
+ (calendar-chinese-to-absolute-for-diary thedate t))
color)))
;;;###cal-autoload
diff --git a/lisp/calendar/cal-coptic.el b/lisp/calendar/cal-coptic.el
index 3461f32..346585e 100644
--- a/lisp/calendar/cal-coptic.el
+++ b/lisp/calendar/cal-coptic.el
@@ -1,4 +1,4 @@
-;;; cal-coptic.el --- calendar functions for the Coptic/Ethiopic calendars
+;;; cal-coptic.el --- calendar functions for the Coptic/Ethiopic calendars
-*- lexical-binding: t; -*-
;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc.
@@ -116,12 +116,13 @@ Defaults to today's date if DATE is not given."
(m (calendar-extract-month coptic-date)))
(if (< y 1)
""
- (let ((monthname (aref calendar-coptic-month-name-array (1- m)))
- (day (number-to-string (calendar-extract-day coptic-date)))
- (dayname nil)
- (month (number-to-string m))
- (year (number-to-string y)))
- (mapconcat 'eval calendar-date-display-form "")))))
+ (calendar-dlet*
+ ((monthname (aref calendar-coptic-month-name-array (1- m)))
+ (day (number-to-string (calendar-extract-day coptic-date)))
+ (dayname nil)
+ (month (number-to-string m))
+ (year (number-to-string y)))
+ (mapconcat #'eval calendar-date-display-form "")))))
;;;###cal-autoload
(defun calendar-coptic-print-date ()
@@ -136,13 +137,13 @@ Defaults to today's date if DATE is not given."
"Interactively read the arguments for a Coptic date command.
Reads a year, month, and day."
(let* ((today (calendar-current-date))
- (year (calendar-read
- (format "%s calendar year (>0): " calendar-coptic-name)
+ (year (calendar-read-sexp
+ "%s calendar year (>0)"
(lambda (x) (> x 0))
- (number-to-string
- (calendar-extract-year
- (calendar-coptic-from-absolute
- (calendar-absolute-from-gregorian today))))))
+ (calendar-extract-year
+ (calendar-coptic-from-absolute
+ (calendar-absolute-from-gregorian today)))
+ calendar-coptic-name))
(completion-ignore-case t)
(month (cdr (assoc-string
(completing-read
@@ -151,11 +152,14 @@ Reads a year, month, and day."
(append calendar-coptic-month-name-array nil))
nil t)
(calendar-make-alist calendar-coptic-month-name-array
- 1) t)))
+ 1)
+ t)))
(last (calendar-coptic-last-day-of-month month year))
- (day (calendar-read
- (format "%s calendar day (1-%d): " calendar-coptic-name last)
- (lambda (x) (and (< 0 x) (<= x last))))))
+ (day (calendar-read-sexp
+ "%s calendar day (1-%d)"
+ (lambda (x) (and (< 0 x) (<= x last)))
+ nil
+ calendar-coptic-name last)))
(list (list month day year))))
;;;###cal-autoload
@@ -194,30 +198,30 @@ Echo Coptic date unless NOECHO is t."
(defconst calendar-ethiopic-name "Ethiopic"
"Used in some message strings.")
-(defun calendar-ethiopic-to-absolute (date)
+(defun calendar-ethiopic-to-absolute (thedate)
"Compute absolute date from Ethiopic date DATE.
The absolute date is the number of days elapsed since the (imaginary)
Gregorian date Sunday, December 31, 1 BC."
(let ((calendar-coptic-epoch calendar-ethiopic-epoch))
- (calendar-coptic-to-absolute date)))
+ (calendar-coptic-to-absolute thedate)))
-(defun calendar-ethiopic-from-absolute (date)
+(defun calendar-ethiopic-from-absolute (thedate)
"Compute the Ethiopic equivalent for absolute date DATE.
The result is a list of the form (MONTH DAY YEAR).
The absolute date is the number of days elapsed since the imaginary
Gregorian date Sunday, December 31, 1 BC."
(let ((calendar-coptic-epoch calendar-ethiopic-epoch))
- (calendar-coptic-from-absolute date)))
+ (calendar-coptic-from-absolute thedate)))
;;;###cal-autoload
-(defun calendar-ethiopic-date-string (&optional date)
+(defun calendar-ethiopic-date-string (&optional thedate)
"String of Ethiopic date of Gregorian DATE.
Returns the empty string if DATE is pre-Ethiopic calendar.
Defaults to today's date if DATE is not given."
(let ((calendar-coptic-epoch calendar-ethiopic-epoch)
(calendar-coptic-name calendar-ethiopic-name)
(calendar-coptic-month-name-array calendar-ethiopic-month-name-array))
- (calendar-coptic-date-string date)))
+ (calendar-coptic-date-string thedate)))
;;;###cal-autoload
(defun calendar-ethiopic-print-date ()
@@ -229,8 +233,8 @@ Defaults to today's date if DATE is not given."
(call-interactively 'calendar-coptic-print-date)))
;;;###cal-autoload
-(defun calendar-ethiopic-goto-date (date &optional noecho)
- "Move cursor to Ethiopic date DATE.
+(defun calendar-ethiopic-goto-date (thedate &optional noecho)
+ "Move cursor to Ethiopic date THEDATE.
Echo Ethiopic date unless NOECHO is t."
(interactive
(let ((calendar-coptic-epoch calendar-ethiopic-epoch)
@@ -238,7 +242,7 @@ Echo Ethiopic date unless NOECHO is t."
(calendar-coptic-month-name-array calendar-ethiopic-month-name-array))
(calendar-coptic-read-date)))
(calendar-goto-date (calendar-gregorian-from-absolute
- (calendar-ethiopic-to-absolute date)))
+ (calendar-ethiopic-to-absolute thedate)))
(or noecho (calendar-ethiopic-print-date)))
;; To be called from diary-list-sexp-entries, where DATE is bound.
diff --git a/lisp/calendar/cal-french.el b/lisp/calendar/cal-french.el
index e759b5d..639bae7 100644
--- a/lisp/calendar/cal-french.el
+++ b/lisp/calendar/cal-french.el
@@ -1,4 +1,4 @@
-;;; cal-french.el --- calendar functions for the French Revolutionary calendar
+;;; cal-french.el --- calendar functions for the French Revolutionary calendar
-*- lexical-binding: t; -*-
;; Copyright (C) 1988-1989, 1992, 1994-1995, 1997, 2001-2021 Free
;; Software Foundation, Inc.
@@ -35,54 +35,45 @@
(defconst calendar-french-epoch (calendar-absolute-from-gregorian '(9 22 1792))
"Absolute date of start of French Revolutionary calendar = Sept 22, 1792.")
-(defconst calendar-french-month-name-array
- ["Vende'miaire" "Brumaire" "Frimaire" "Nivo^se" "Pluvio^se" "Vento^se"
- "Germinal" "Flore'al" "Prairial" "Messidor" "Thermidor" "Fructidor"]
- "Array of month names in the French calendar.")
+(define-obsolete-variable-alias 'calendar-french-multibyte-month-name-array
+ 'calendar-french-month-name-array "28.1")
-(defconst calendar-french-multibyte-month-name-array
+(defconst calendar-french-month-name-array
["Vendémiaire" "Brumaire" "Frimaire" "Nivôse" "Pluviôse" "Ventôse"
"Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"]
- "Array of multibyte month names in the French calendar.")
+ "Array of month names in the French calendar.")
(defconst calendar-french-day-name-array
["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi"
"Octidi" "Nonidi" "Decadi"]
"Array of day names in the French calendar.")
-(defconst calendar-french-special-days-array
- ["de la Vertu" "du Ge'nie" "du Travail" "de la Raison" "des Re'compenses"
- "de la Re'volution"]
- "Array of special day names in the French calendar.")
+(define-obsolete-variable-alias 'calendar-french-multibyte-special-days-array
+ 'calendar-french-special-days-array "28.1")
-(defconst calendar-french-multibyte-special-days-array
+(defconst calendar-french-special-days-array
["de la Vertu" "du Génie" "du Travail" "de la Raison" "des Récompenses"
"de la Révolution"]
- "Array of multibyte special day names in the French calendar.")
+ "Array of special day names in the French calendar.")
(defun calendar-french-accents-p ()
- "Return non-nil if diacritical marks are available."
- (and (or window-system
- (terminal-coding-system))
- (or enable-multibyte-characters
- (and (char-table-p standard-display-table)
- (equal (aref standard-display-table 161) [161])))))
+ (declare (obsolete nil "28.1"))
+ t)
(defun calendar-french-month-name-array ()
"Return the array of month names, depending on whether accents are
available."
- (if (calendar-french-accents-p)
- calendar-french-multibyte-month-name-array
- calendar-french-month-name-array))
+ (declare (obsolete "use the variable of the same name instead" "28.1"))
+ calendar-french-month-name-array)
(defun calendar-french-day-name-array ()
"Return the array of day names."
+ (declare (obsolete "use the variable of the same name instead" "28.1"))
calendar-french-day-name-array)
(defun calendar-french-special-days-array ()
"Return the special day names, depending on whether accents are available."
- (if (calendar-french-accents-p)
- calendar-french-multibyte-special-days-array
- calendar-french-special-days-array))
+ (declare (obsolete "use the variable of the same name instead" "28.1"))
+ calendar-french-special-days-array)
(defun calendar-french-leap-year-p (year)
"True if YEAR is a leap year on the French Revolutionary calendar.
@@ -171,17 +162,13 @@ Defaults to today's date if DATE is not given."
(d (calendar-extract-day french-date)))
(cond
((< y 1) "")
- ((= m 13) (format (if (calendar-french-accents-p)
- "Jour %s de l'Année %d de la Révolution"
- "Jour %s de l'Anne'e %d de la Re'volution")
- (aref (calendar-french-special-days-array) (1- d))
+ ((= m 13) (format "Jour %s de l'Année %d de la Révolution"
+ (aref calendar-french-special-days-array (1- d))
y))
(t (format
- (if (calendar-french-accents-p)
- "%d %s an %d de la Révolution"
- "%d %s an %d de la Re'volution")
+ "%d %s an %d de la Révolution"
d
- (aref (calendar-french-month-name-array) (1- m))
+ (aref calendar-french-month-name-array (1- m))
y)))))
;;;###cal-autoload
@@ -198,19 +185,16 @@ Defaults to today's date if DATE is not given."
"Move cursor to French Revolutionary date DATE.
Echo French Revolutionary date unless NOECHO is non-nil."
(interactive
- (let* ((months (calendar-french-month-name-array))
- (special-days (calendar-french-special-days-array))
+ (let* ((months calendar-french-month-name-array)
+ (special-days calendar-french-special-days-array)
(year (progn
- (calendar-read
- (if (calendar-french-accents-p)
- "Année de la Révolution (>0): "
- "Anne'e de la Re'volution (>0): ")
+ (calendar-read-sexp
+ "Année de la Révolution (>0)"
(lambda (x) (> x 0))
- (number-to-string
- (calendar-extract-year
- (calendar-french-from-absolute
- (calendar-absolute-from-gregorian
- (calendar-current-date))))))))
+ (calendar-extract-year
+ (calendar-french-from-absolute
+ (calendar-absolute-from-gregorian
+ (calendar-current-date)))))))
(month-list
(mapcar 'list
(append months
@@ -234,8 +218,8 @@ Echo French Revolutionary date unless NOECHO is non-nil."
(calendar-make-alist month-list 1 'car) t)))
(day (if (> month 12)
(- month 12)
- (calendar-read
- "Jour (1-30): "
+ (calendar-read-sexp
+ "Jour (1-30)"
(lambda (x) (and (<= 1 x) (<= x 30))))))
(month (if (> month 12) 13 month)))
(list (list month day year))))
diff --git a/lisp/calendar/cal-hebrew.el b/lisp/calendar/cal-hebrew.el
index bcc80f0..50b4fc3 100644
--- a/lisp/calendar/cal-hebrew.el
+++ b/lisp/calendar/cal-hebrew.el
@@ -1,4 +1,4 @@
-;;; cal-hebrew.el --- calendar functions for the Hebrew calendar
+;;; cal-hebrew.el --- calendar functions for the Hebrew calendar -*-
lexical-binding: t; -*-
;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc.
@@ -225,13 +225,12 @@ Driven by the variable `calendar-date-display-form'."
"Interactively read the arguments for a Hebrew date command.
Reads a year, month, and day."
(let* ((today (calendar-current-date))
- (year (calendar-read
- "Hebrew calendar year (>3760): "
+ (year (calendar-read-sexp
+ "Hebrew calendar year (>3760)"
(lambda (x) (> x 3760))
- (number-to-string
- (calendar-extract-year
- (calendar-hebrew-from-absolute
- (calendar-absolute-from-gregorian today))))))
+ (calendar-extract-year
+ (calendar-hebrew-from-absolute
+ (calendar-absolute-from-gregorian today)))))
(month-array (if (calendar-hebrew-leap-year-p year)
calendar-hebrew-month-name-array-leap-year
calendar-hebrew-month-name-array-common-year))
@@ -258,10 +257,11 @@ Reads a year, month, and day."
(last (calendar-hebrew-last-day-of-month month year))
(first (if (and (= year 3761) (= month 10))
18 1))
- (day (calendar-read
- (format "Hebrew calendar day (%d-%d): "
- first last)
- (lambda (x) (and (<= first x) (<= x last))))))
+ (day (calendar-read-sexp
+ "Hebrew calendar day (%d-%d)"
+ (lambda (x) (and (<= first x) (<= x last)))
+ nil
+ first last)))
(list (list month day year))))
;;;###cal-autoload
@@ -399,19 +399,20 @@ is non-nil."
(list m (calendar-last-day-of-month m y) y))))))
(abs-h (calendar-hebrew-to-absolute (list 9 25 h-y)))
(ord ["first" "second" "third" "fourth" "fifth" "sixth"
- "seventh" "eighth"])
- han)
+ "seventh" "eighth"]))
(holiday-filter-visible-calendar
(if (or all calendar-hebrew-all-holidays-flag)
(append
(list
(list (calendar-gregorian-from-absolute (1- abs-h))
"Erev Hanukkah"))
- (dotimes (i 8 (nreverse han))
- (push (list
- (calendar-gregorian-from-absolute (+ abs-h i))
- (format "Hanukkah (%s day)" (aref ord i)))
- han)))
+ (let (han)
+ (dotimes (i 8)
+ (push (list
+ (calendar-gregorian-from-absolute (+ abs-h i))
+ (format "Hanukkah (%s day)" (aref ord i)))
+ han))
+ (nreverse han)))
(list (list (calendar-gregorian-from-absolute abs-h) "Hanukkah")))))))
;;;###holiday-autoload
@@ -681,10 +682,10 @@ from the cursor position."
(if (equal (current-buffer) (get-buffer calendar-buffer))
(calendar-cursor-to-date t)
(let* ((today (calendar-current-date))
- (year (calendar-read
- "Year of death (>0): "
+ (year (calendar-read-sexp
+ "Year of death (>0)"
(lambda (x) (> x 0))
- (number-to-string (calendar-extract-year today))))
+ (calendar-extract-year today)))
(month-array calendar-month-name-array)
(completion-ignore-case t)
(month (cdr (assoc-string
@@ -694,20 +695,23 @@ from the cursor position."
nil t)
(calendar-make-alist month-array 1) t)))
(last (calendar-last-day-of-month month year))
- (day (calendar-read
- (format "Day of death (1-%d): " last)
- (lambda (x) (and (< 0 x) (<= x last))))))
+ (day (calendar-read-sexp
+ "Day of death (1-%d)"
+ (lambda (x) (and (< 0 x) (<= x last)))
+ nil
+ last)))
(list month day year))))
(death-year (calendar-extract-year death-date))
- (start-year (calendar-read
- (format "Starting year of Yahrzeit table (>%d): "
- death-year)
+ (start-year (calendar-read-sexp
+ "Starting year of Yahrzeit table (>%d)"
(lambda (x) (> x death-year))
- (number-to-string (1+ death-year))))
- (end-year (calendar-read
- (format "Ending year of Yahrzeit table (>=%d): "
- start-year)
- (lambda (x) (>= x start-year)))))
+ (1+ death-year)
+ death-year))
+ (end-year (calendar-read-sexp
+ "Ending year of Yahrzeit table (>=%d)"
+ (lambda (x) (>= x start-year))
+ nil
+ start-year)))
(list death-date start-year end-year)))
(message "Computing Yahrzeits...")
(let* ((h-date (calendar-hebrew-from-absolute
diff --git a/lisp/calendar/cal-html.el b/lisp/calendar/cal-html.el
index 3d7cc93..e5810c3 100644
--- a/lisp/calendar/cal-html.el
+++ b/lisp/calendar/cal-html.el
@@ -1,4 +1,4 @@
-;;; cal-html.el --- functions for printing HTML calendars
+;;; cal-html.el --- functions for printing HTML calendars -*-
lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@@ -250,7 +250,7 @@ Contains links to previous and next month and year, and
current minical."
calendar-week-start-day))
7))
(monthpage-name (cal-html-monthpage-name month year))
- date)
+ ) ;; date
;; Start writing table.
(insert (cal-html-comment "MINICAL")
(cal-html-b-table "class=minical border=1 align=center"))
@@ -276,7 +276,7 @@ Contains links to previous and next month and year, and
current minical."
(insert cal-html-e-tablerow-string
cal-html-b-tablerow-string)))
;; End empty slots (for some browsers like konqueror).
- (dotimes (i end-blank-days)
+ (dotimes (_ end-blank-days)
(insert
cal-html-b-tabledata-string
cal-html-e-tabledata-string)))
@@ -431,12 +431,11 @@ holidays in HOLIDAY-LIST."
;;; User commands.
;;;###cal-autoload
-(defun cal-html-cursor-month (month year dir &optional event)
+(defun cal-html-cursor-month (month year dir &optional _event)
"Write an HTML calendar file for numeric MONTH of four-digit YEAR.
The output directory DIR is created if necessary. Interactively,
-MONTH and YEAR are taken from the calendar cursor position, or from
-the position specified by EVENT. Note that any existing output files
-are overwritten."
+MONTH and YEAR are taken from the calendar cursor position.
+Note that any existing output files are overwritten."
(interactive (let* ((event last-nonmenu-event)
(date (calendar-cursor-to-date t event))
(month (calendar-extract-month date))
@@ -446,11 +445,11 @@ are overwritten."
(cal-html-one-month month year dir))
;;;###cal-autoload
-(defun cal-html-cursor-year (year dir &optional event)
+(defun cal-html-cursor-year (year dir &optional _event)
"Write HTML calendar files (index and monthly pages) for four-digit YEAR.
The output directory DIR is created if necessary. Interactively,
-YEAR is taken from the calendar cursor position, or from the position
-specified by EVENT. Note that any existing output files are overwritten."
+YEAR is taken from the calendar cursor position.
+Note that any existing output files are overwritten."
(interactive (let* ((event last-nonmenu-event)
(year (calendar-extract-year
(calendar-cursor-to-date t event))))
diff --git a/lisp/calendar/cal-islam.el b/lisp/calendar/cal-islam.el
index d256310..45c6ffa 100644
--- a/lisp/calendar/cal-islam.el
+++ b/lisp/calendar/cal-islam.el
@@ -1,4 +1,4 @@
-;;; cal-islam.el --- calendar functions for the Islamic calendar
+;;; cal-islam.el --- calendar functions for the Islamic calendar -*-
lexical-binding: t; -*-
;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc.
@@ -67,8 +67,8 @@
"Absolute date of Islamic DATE.
The absolute date is the number of days elapsed since the (imaginary)
Gregorian date Sunday, December 31, 1 BC."
- (let* ((month (calendar-extract-month date))
- (day (calendar-extract-day date))
+ (let* (;;(month (calendar-extract-month date))
+ ;;(day (calendar-extract-day date))
(year (calendar-extract-year date))
(y (% year 30))
(leap-years-in-cycle (cond ((< y 3) 0)
@@ -143,13 +143,12 @@ Driven by the variable `calendar-date-display-form'."
"Interactively read the arguments for an Islamic date command.
Reads a year, month, and day."
(let* ((today (calendar-current-date))
- (year (calendar-read
- "Islamic calendar year (>0): "
+ (year (calendar-read-sexp
+ "Islamic calendar year (>0)"
(lambda (x) (> x 0))
- (number-to-string
- (calendar-extract-year
- (calendar-islamic-from-absolute
- (calendar-absolute-from-gregorian today))))))
+ (calendar-extract-year
+ (calendar-islamic-from-absolute
+ (calendar-absolute-from-gregorian today)))))
(month-array calendar-islamic-month-name-array)
(completion-ignore-case t)
(month (cdr (assoc-string
@@ -159,9 +158,11 @@ Reads a year, month, and day."
nil t)
(calendar-make-alist month-array 1) t)))
(last (calendar-islamic-last-day-of-month month year))
- (day (calendar-read
- (format "Islamic calendar day (1-%d): " last)
- (lambda (x) (and (< 0 x) (<= x last))))))
+ (day (calendar-read-sexp
+ "Islamic calendar day (1-%d)"
+ (lambda (x) (and (< 0 x) (<= x last)))
+ nil
+ last)))
(list (list month day year))))
;;;###cal-autoload
diff --git a/lisp/calendar/cal-iso.el b/lisp/calendar/cal-iso.el
index 956433e..90f57c2 100644
--- a/lisp/calendar/cal-iso.el
+++ b/lisp/calendar/cal-iso.el
@@ -1,4 +1,4 @@
-;;; cal-iso.el --- calendar functions for the ISO calendar
+;;; cal-iso.el --- calendar functions for the ISO calendar -*-
lexical-binding: t; -*-
;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc.
@@ -92,22 +92,23 @@ date Sunday, December 31, 1 BC."
"Interactively read the arguments for an ISO date command.
Reads a year and week, and if DAYFLAG is non-nil a day (otherwise
taken to be 1)."
- (let* ((year (calendar-read
- "ISO calendar year (>0): "
+ (let* ((year (calendar-read-sexp
+ "ISO calendar year (>0)"
(lambda (x) (> x 0))
- (number-to-string (calendar-extract-year
- (calendar-current-date)))))
+ (calendar-extract-year (calendar-current-date))))
(no-weeks (calendar-extract-month
(calendar-iso-from-absolute
(1-
(calendar-dayname-on-or-before
1 (calendar-absolute-from-gregorian
(list 1 4 (1+ year))))))))
- (week (calendar-read
- (format "ISO calendar week (1-%d): " no-weeks)
- (lambda (x) (and (> x 0) (<= x no-weeks)))))
- (day (if dayflag (calendar-read
- "ISO day (1-7): "
+ (week (calendar-read-sexp
+ "ISO calendar week (1-%d)"
+ (lambda (x) (and (> x 0) (<= x no-weeks)))
+ nil
+ no-weeks))
+ (day (if dayflag (calendar-read-sexp
+ "ISO day (1-7)"
(lambda (x) (and (<= 1 x) (<= x 7))))
1)))
(list (list week day year))))
diff --git a/lisp/calendar/cal-julian.el b/lisp/calendar/cal-julian.el
index 235b4d0..47880a4 100644
--- a/lisp/calendar/cal-julian.el
+++ b/lisp/calendar/cal-julian.el
@@ -95,14 +95,13 @@ Driven by the variable `calendar-date-display-form'."
"Move cursor to Julian DATE; echo Julian date unless NOECHO is non-nil."
(interactive
(let* ((today (calendar-current-date))
- (year (calendar-read
- "Julian calendar year (>0): "
+ (year (calendar-read-sexp
+ "Julian calendar year (>0)"
(lambda (x) (> x 0))
- (number-to-string
- (calendar-extract-year
- (calendar-julian-from-absolute
- (calendar-absolute-from-gregorian
- today))))))
+ (calendar-extract-year
+ (calendar-julian-from-absolute
+ (calendar-absolute-from-gregorian
+ today)))))
(month-array calendar-month-name-array)
(completion-ignore-case t)
(month (cdr (assoc-string
@@ -115,12 +114,13 @@ Driven by the variable `calendar-date-display-form'."
(if (and (zerop (% year 4)) (= month 2))
29
(aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month))))
- (day (calendar-read
- (format "Julian calendar day (%d-%d): "
- (if (and (= year 1) (= month 1)) 3 1) last)
+ (day (calendar-read-sexp
+ "Julian calendar day (%d-%d)"
(lambda (x)
(and (< (if (and (= year 1) (= month 1)) 2 0) x)
- (<= x last))))))
+ (<= x last)))
+ nil
+ (if (and (= year 1) (= month 1)) 3 1) last)))
(list (list month day year))))
(calendar-goto-date (calendar-gregorian-from-absolute
(calendar-julian-to-absolute date)))
@@ -173,8 +173,8 @@ Defaults to today's date if DATE is not given."
(defun calendar-astro-goto-day-number (daynumber &optional noecho)
"Move cursor to astronomical (Julian) DAYNUMBER.
Echo astronomical (Julian) day number unless NOECHO is non-nil."
- (interactive (list (calendar-read
- "Astronomical (Julian) day number (>1721425): "
+ (interactive (list (calendar-read-sexp
+ "Astronomical (Julian) day number (>1721425)"
(lambda (x) (> x 1721425)))))
(calendar-goto-date
(calendar-gregorian-from-absolute
diff --git a/lisp/calendar/cal-mayan.el b/lisp/calendar/cal-mayan.el
index 8d894eb..9a22192 100644
--- a/lisp/calendar/cal-mayan.el
+++ b/lisp/calendar/cal-mayan.el
@@ -1,4 +1,4 @@
-;;; cal-mayan.el --- calendar functions for the Mayan calendars
+;;; cal-mayan.el --- calendar functions for the Mayan calendars -*-
lexical-binding: t; -*-
;; Copyright (C) 1992-1993, 1995, 1997, 2001-2021 Free Software
;; Foundation, Inc.
@@ -135,8 +135,8 @@ but some use 1137140. Using 1232041 gives you Spinden's
correlation; using
(defun calendar-mayan-read-haab-date ()
"Prompt for a Mayan haab date."
(let* ((completion-ignore-case t)
- (haab-day (calendar-read
- "Haab kin (0-19): "
+ (haab-day (calendar-read-sexp
+ "Haab kin (0-19)"
(lambda (x) (and (>= x 0) (< x 20)))))
(haab-month-list (append calendar-mayan-haab-month-name-array
(and (< haab-day 5) '("Uayeb"))))
@@ -151,8 +151,8 @@ but some use 1137140. Using 1232041 gives you Spinden's
correlation; using
(defun calendar-mayan-read-tzolkin-date ()
"Prompt for a Mayan tzolkin date."
(let* ((completion-ignore-case t)
- (tzolkin-count (calendar-read
- "Tzolkin kin (1-13): "
+ (tzolkin-count (calendar-read-sexp
+ "Tzolkin kin (1-13)"
(lambda (x) (and (> x 0) (< x 14)))))
(tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil))
(tzolkin-name (cdr
diff --git a/lisp/calendar/cal-menu.el b/lisp/calendar/cal-menu.el
index a30c681..497f332 100644
--- a/lisp/calendar/cal-menu.el
+++ b/lisp/calendar/cal-menu.el
@@ -1,4 +1,4 @@
-;;; cal-menu.el --- calendar functions for menu bar and popup menu support
+;;; cal-menu.el --- calendar functions for menu bar and popup menu support
-*- lexical-binding: t; -*-
;; Copyright (C) 1994-1995, 2001-2021 Free Software Foundation, Inc.
@@ -183,6 +183,8 @@ Signals an error if popups are unavailable."
;; Autoloaded in diary-lib.
(declare-function calendar-check-holidays "holidays" (date))
+(defvar diary-list-include-blanks)
+
(defun calendar-mouse-view-diary-entries (&optional date diary event)
"Pop up menu of diary entries for mouse-selected date.
Use optional DATE and alternative file DIARY. EVENT is the event
diff --git a/lisp/calendar/cal-move.el b/lisp/calendar/cal-move.el
index 710ce37..9294362 100644
--- a/lisp/calendar/cal-move.el
+++ b/lisp/calendar/cal-move.el
@@ -1,4 +1,4 @@
-;;; cal-move.el --- calendar functions for movement in the calendar
+;;; cal-move.el --- calendar functions for movement in the calendar -*-
lexical-binding: t; -*-
;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc.
@@ -386,15 +386,16 @@ Moves forward if ARG is negative."
"Move cursor to YEAR, DAY number; echo DAY/YEAR unless NOECHO is non-nil.
Negative DAY counts backward from end of year."
(interactive
- (let* ((year (calendar-read
- "Year (>0): "
+ (let* ((year (calendar-read-sexp
+ "Year (>0)"
(lambda (x) (> x 0))
- (number-to-string (calendar-extract-year
- (calendar-current-date)))))
+ (calendar-extract-year (calendar-current-date))))
(last (if (calendar-leap-year-p year) 366 365))
- (day (calendar-read
- (format "Day number (+/- 1-%d): " last)
- (lambda (x) (and (<= 1 (abs x)) (<= (abs x) last))))))
+ (day (calendar-read-sexp
+ "Day number (+/- 1-%d)"
+ (lambda (x) (and (<= 1 (abs x)) (<= (abs x) last)))
+ nil
+ last)))
(list year day)))
(calendar-goto-date
(calendar-gregorian-from-absolute
diff --git a/lisp/calendar/cal-persia.el b/lisp/calendar/cal-persia.el
index a9c99fe..ca37d80 100644
--- a/lisp/calendar/cal-persia.el
+++ b/lisp/calendar/cal-persia.el
@@ -1,4 +1,4 @@
-;;; cal-persia.el --- calendar functions for the Persian calendar
+;;; cal-persia.el --- calendar functions for the Persian calendar -*-
lexical-binding: t; -*-
;; Copyright (C) 1996-1997, 2001-2021 Free Software Foundation, Inc.
@@ -139,13 +139,14 @@ Gregorian date Sunday, December 31, 1 BC."
(calendar-absolute-from-gregorian
(or date (calendar-current-date)))))
(y (calendar-extract-year persian-date))
- (m (calendar-extract-month persian-date))
- (monthname (aref calendar-persian-month-name-array (1- m)))
+ (m (calendar-extract-month persian-date)))
+ (calendar-dlet*
+ ((monthname (aref calendar-persian-month-name-array (1- m)))
(day (number-to-string (calendar-extract-day persian-date)))
(year (number-to-string y))
(month (number-to-string m))
dayname)
- (mapconcat 'eval calendar-date-display-form "")))
+ (mapconcat #'eval calendar-date-display-form ""))))
;;;###cal-autoload
(defun calendar-persian-print-date ()
@@ -157,14 +158,13 @@ Gregorian date Sunday, December 31, 1 BC."
(defun calendar-persian-read-date ()
"Interactively read the arguments for a Persian date command.
Reads a year, month, and day."
- (let* ((year (calendar-read
- "Persian calendar year (not 0): "
+ (let* ((year (calendar-read-sexp
+ "Persian calendar year (not 0)"
(lambda (x) (not (zerop x)))
- (number-to-string
- (calendar-extract-year
- (calendar-persian-from-absolute
- (calendar-absolute-from-gregorian
- (calendar-current-date)))))))
+ (calendar-extract-year
+ (calendar-persian-from-absolute
+ (calendar-absolute-from-gregorian
+ (calendar-current-date))))))
(completion-ignore-case t)
(month (cdr (assoc
(completing-read
@@ -175,9 +175,11 @@ Reads a year, month, and day."
(calendar-make-alist calendar-persian-month-name-array
1))))
(last (calendar-persian-last-day-of-month month year))
- (day (calendar-read
- (format "Persian calendar day (1-%d): " last)
- (lambda (x) (and (< 0 x) (<= x last))))))
+ (day (calendar-read-sexp
+ "Persian calendar day (1-%d)"
+ (lambda (x) (and (< 0 x) (<= x last)))
+ nil
+ last)))
(list (list month day year))))
;;;###cal-autoload
diff --git a/lisp/calendar/cal-tex.el b/lisp/calendar/cal-tex.el
index 9df9f4c..f593201 100644
--- a/lisp/calendar/cal-tex.el
+++ b/lisp/calendar/cal-tex.el
@@ -1,4 +1,4 @@
-;;; cal-tex.el --- calendar functions for printing calendars with LaTeX
+;;; cal-tex.el --- calendar functions for printing calendars with LaTeX -*-
lexical-binding: t; -*-
;; Copyright (C) 1995, 2001-2021 Free Software Foundation, Inc.
@@ -248,6 +248,8 @@ This definition is the heart of the calendar!")
(autoload 'diary-list-entries "diary-lib")
+(defvar diary-list-include-blanks)
+
(defun cal-tex-list-diary-entries (d1 d2)
"Generate a list of all diary-entries from absolute date D1 to D2."
(let (diary-list-include-blanks)
@@ -591,6 +593,8 @@ indicates a buffer position to use instead of point."
LaTeX commands are inserted for the days of the MONTH in YEAR.
Diary entries on DIARY-LIST are included. Holidays on HOLIDAYS
are included. Each day is formatted using format DAY-FORMAT."
+ (with-suppressed-warnings ((lexical date))
+ (defvar date)) ;For `cal-tex-daily-string'.
(let ((blank-days ; at start of month
(mod
(- (calendar-day-of-week (list month 1 year))
@@ -605,7 +609,7 @@ are included. Each day is formatted using format
DAY-FORMAT."
(insert (format day-format (cal-tex-month-name month) j))
(cal-tex-arg (cal-tex-latexify-list diary-list date))
(cal-tex-arg (cal-tex-latexify-list holidays date))
- (cal-tex-arg (eval cal-tex-daily-string))
+ (cal-tex-arg (eval cal-tex-daily-string t))
(cal-tex-arg)
(cal-tex-comment))
(when (and (zerop (mod (+ j blank-days) 7))
@@ -885,13 +889,15 @@ argument EVENT specifies a different buffer position."
(interactive (list (prefix-numeric-value current-prefix-arg)
last-nonmenu-event))
(or n (setq n 1))
+ (with-suppressed-warnings ((lexical date))
+ (defvar date)) ;For `cal-tex-daily-string'.
(let* ((date (calendar-gregorian-from-absolute
(calendar-dayname-on-or-before
1
(calendar-absolute-from-gregorian
(calendar-cursor-to-date t event)))))
(month (calendar-extract-month date))
- (year (calendar-extract-year date))
+ ;; (year (calendar-extract-year date))
(day (calendar-extract-day date))
(d1 (calendar-absolute-from-gregorian date))
(d2 (+ (* 7 n) d1))
@@ -932,7 +938,7 @@ argument EVENT specifies a different buffer position."
(insert ": ")
(cal-tex-large-bf s))
(cal-tex-hfill)
- (insert " " (eval cal-tex-daily-string))
+ (insert " " (eval cal-tex-daily-string t))
(cal-tex-e-parbox)
(cal-tex-nl)
(cal-tex-noindent)
@@ -951,7 +957,8 @@ argument EVENT specifies a different buffer position."
(cal-tex-e-parbox "2cm")
(cal-tex-nl)
(setq month (calendar-extract-month date)
- year (calendar-extract-year date)))
+ ;; year (calendar-extract-year date)
+ ))
(cal-tex-e-parbox)
(unless (= i (1- n))
(run-hooks 'cal-tex-week-hook)
@@ -961,13 +968,16 @@ argument EVENT specifies a different buffer position."
;; TODO respect cal-tex-daily-start,end?
;; Using different numbers of hours will probably break some layouts.
-(defun cal-tex-week-hours (date holidays height)
- "Insert hourly entries for DATE with HOLIDAYS, with line height HEIGHT.
+(defun cal-tex-week-hours (thedate holidays height)
+ "Insert hourly entries for THEDATE with HOLIDAYS, with line height HEIGHT.
Uses the 24-hour clock if `cal-tex-24' is non-nil. Note that the hours
shown are hard-coded to 8-12, 13-17."
- (let ((month (calendar-extract-month date))
+ (with-suppressed-warnings ((lexical date))
+ (defvar date)) ;For `cal-tex-daily-string'.
+ (let ((date thedate)
+ (month (calendar-extract-month date))
(day (calendar-extract-day date))
- (year (calendar-extract-year date))
+ ;; (year (calendar-extract-year date))
morning afternoon s)
(cal-tex-comment "begin cal-tex-week-hours")
(cal-tex-cmd "\\ \\\\[-.2cm]")
@@ -983,7 +993,7 @@ shown are hard-coded to 8-12, 13-17."
(insert ": ")
(cal-tex-large-bf s))
(cal-tex-hfill)
- (insert " " (eval cal-tex-daily-string))
+ (insert " " (eval cal-tex-daily-string t))
(cal-tex-e-parbox)
(cal-tex-nl "-.3cm")
(cal-tex-rule "0pt" "6.8in" ".2mm")
@@ -1088,14 +1098,16 @@ shown are hard-coded to 8-12, 13-17."
(defun cal-tex-weekly-common (n event &optional filofax)
"Common code for weekly calendars."
(or n (setq n 1))
+ (with-suppressed-warnings ((lexical date))
+ (defvar date)) ;For `cal-tex-daily-string'.
(let* ((date (calendar-gregorian-from-absolute
(calendar-dayname-on-or-before
1
(calendar-absolute-from-gregorian
(calendar-cursor-to-date t event)))))
- (month (calendar-extract-month date))
- (year (calendar-extract-year date))
- (day (calendar-extract-day date))
+ ;; (month (calendar-extract-month date))
+ ;; (year (calendar-extract-year date))
+ ;; (day (calendar-extract-day date))
(d1 (calendar-absolute-from-gregorian date))
(d2 (+ (* 7 n) d1))
(holidays (if cal-tex-holidays
@@ -1161,7 +1173,7 @@ shown are hard-coded to 8-12, 13-17."
(cal-tex-arg (number-to-string (calendar-extract-day date)))
(cal-tex-arg (cal-tex-latexify-list diary-list date))
(cal-tex-arg (cal-tex-latexify-list holidays date))
- (cal-tex-arg (eval cal-tex-daily-string))
+ (cal-tex-arg (eval cal-tex-daily-string t))
(insert "%\n")
(setq date (cal-tex-incr-date date)))
(insert "\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n")
@@ -1258,14 +1270,16 @@ Optional EVENT indicates a buffer position to use
instead of point."
(interactive (list (prefix-numeric-value current-prefix-arg)
last-nonmenu-event))
(or n (setq n 1))
+ (with-suppressed-warnings ((lexical date))
+ (defvar date)) ;For `cal-tex-daily-string'.
(let* ((date (calendar-gregorian-from-absolute
(calendar-dayname-on-or-before
calendar-week-start-day
(calendar-absolute-from-gregorian
(calendar-cursor-to-date t event)))))
- (month (calendar-extract-month date))
- (year (calendar-extract-year date))
- (day (calendar-extract-day date))
+ ;; (month (calendar-extract-month date))
+ ;; (year (calendar-extract-year date))
+ ;; (day (calendar-extract-day date))
(d1 (calendar-absolute-from-gregorian date))
(d2 (+ (* 7 n) d1))
(holidays (if cal-tex-holidays
@@ -1311,7 +1325,7 @@ Optional EVENT indicates a buffer position to use instead
of point."
(cal-tex-arg (number-to-string (calendar-extract-day date)))
(cal-tex-arg (cal-tex-latexify-list diary-list date))
(cal-tex-arg (cal-tex-latexify-list holidays date))
- (cal-tex-arg (eval cal-tex-daily-string))
+ (cal-tex-arg (eval cal-tex-daily-string t))
(insert "%\n")
(setq date (cal-tex-incr-date date)))
(unless (= i (1- n))
@@ -1342,14 +1356,16 @@ Optional EVENT indicates a buffer position to use
instead of point."
(interactive (list (prefix-numeric-value current-prefix-arg)
last-nonmenu-event))
(or n (setq n 1))
+ (with-suppressed-warnings ((lexical date))
+ (defvar date)) ;For `cal-tex-daily-string'.
(let* ((date (calendar-gregorian-from-absolute
(calendar-dayname-on-or-before
1
(calendar-absolute-from-gregorian
(calendar-cursor-to-date t event)))))
- (month (calendar-extract-month date))
- (year (calendar-extract-year date))
- (day (calendar-extract-day date))
+ ;; (month (calendar-extract-month date))
+ ;; (year (calendar-extract-year date))
+ ;; (day (calendar-extract-day date))
(d1 (calendar-absolute-from-gregorian date))
(d2 (+ (* 7 n) d1))
(holidays (if cal-tex-holidays
@@ -1383,11 +1399,11 @@ Optional EVENT indicates a buffer position to use
instead of point."
"\\leftday")))
(cal-tex-arg (cal-tex-latexify-list diary-list date))
(cal-tex-arg (cal-tex-latexify-list holidays date "\\\\" t))
- (cal-tex-arg (eval cal-tex-daily-string))
+ (cal-tex-arg (eval cal-tex-daily-string t))
(insert "%\n")
- (if cal-tex-rules
- (insert "\\linesfill\n")
- (insert "\\vfill\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n"))
+ (insert (if cal-tex-rules
+ "\\linesfill\n"
+ "\\vfill\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n"))
(cal-tex-newpage)
(setq date (cal-tex-incr-date date)))
(insert "%\n")
@@ -1397,11 +1413,11 @@ Optional EVENT indicates a buffer position to use
instead of point."
(insert "\\weekend")
(cal-tex-arg (cal-tex-latexify-list diary-list date))
(cal-tex-arg (cal-tex-latexify-list holidays date "\\\\" t))
- (cal-tex-arg (eval cal-tex-daily-string))
+ (cal-tex-arg (eval cal-tex-daily-string t))
(insert "%\n")
- (if cal-tex-rules
- (insert "\\linesfill\n")
- (insert "\\vfill"))
+ (insert (if cal-tex-rules
+ "\\linesfill\n"
+ "\\vfill"))
(setq date (cal-tex-incr-date date)))
(or cal-tex-rules
(insert "\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n"))
@@ -1442,12 +1458,15 @@ a buffer position to use instead of point."
(cal-tex-end-document)
(run-hooks 'cal-tex-hook)))
-(defun cal-tex-daily-page (date)
- "Make a calendar page for Gregorian DATE on 8.5 by 11 paper.
+(defun cal-tex-daily-page (thedate)
+ "Make a calendar page for Gregorian THEDATE on 8.5 by 11 paper.
Uses the 24-hour clock if `cal-tex-24' is non-nil. Produces
hourly sections for the period specified by `cal-tex-daily-start'
and `cal-tex-daily-end'."
- (let ((month-name (cal-tex-month-name (calendar-extract-month date)))
+ (with-suppressed-warnings ((lexical date))
+ (defvar date)) ;For `cal-tex-daily-string'.
+ (let ((date thedate)
+ (month-name (cal-tex-month-name (calendar-extract-month date)))
(i (1- cal-tex-daily-start))
hour)
(cal-tex-banner "cal-tex-daily-page")
@@ -1459,7 +1478,7 @@ and `cal-tex-daily-end'."
(cal-tex-bf month-name )
(cal-tex-e-parbox)
(cal-tex-hspace "1cm")
- (cal-tex-scriptsize (eval cal-tex-daily-string))
+ (cal-tex-scriptsize (eval cal-tex-daily-string t))
(cal-tex-hspace "3.5cm")
(cal-tex-e-makebox)
(cal-tex-hfill)
diff --git a/lisp/calendar/cal-x.el b/lisp/calendar/cal-x.el
index 1c19a60..ca303ce 100644
--- a/lisp/calendar/cal-x.el
+++ b/lisp/calendar/cal-x.el
@@ -1,4 +1,4 @@
-;;; cal-x.el --- calendar windows in dedicated frames
+;;; cal-x.el --- calendar windows in dedicated frames -*- lexical-binding: t;
-*-
;; Copyright (C) 1994-1995, 2001-2021 Free Software Foundation, Inc.
diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el
index 21cea21..3f9fe1c 100644
--- a/lisp/calendar/calendar.el
+++ b/lisp/calendar/calendar.el
@@ -112,6 +112,8 @@
;;; Code:
+(eval-when-compile (require 'subr-x))
+
(load "cal-loaddefs" nil t)
;; Calendar has historically relied heavily on dynamic scoping.
@@ -1459,7 +1461,7 @@ Optional integers MON and YR are used instead of today's
date."
Inserts STRING so that it ends at INDENT. STRING is either a
literal string, or a sexp to evaluate to return such. Truncates
STRING to length TRUNCATE, and ensures a trailing space."
- (if (not (ignore-errors (stringp (setq string (eval string)))))
+ (if (not (ignore-errors (stringp (setq string (eval string t)))))
(calendar-move-to-column indent)
(if (> (string-width string) truncate)
(setq string (truncate-string-to-width string truncate)))
@@ -1526,7 +1528,7 @@ first INDENT characters on the line."
(format (format "%%%dd" calendar-day-digit-width) day)
'mouse-face 'highlight
'help-echo (calendar-dlet* ((day day) (month month) (year year))
- (eval calendar-date-echo-text))
+ (eval calendar-date-echo-text t))
;; 'date property prevents intermonth text confusing re-searches.
;; (Tried intangible, it did not really work.)
'date t)
@@ -2054,23 +2056,40 @@ With argument ARG, jump to mark, pop it, and put point
at end of ring."
(error "%s not available in the calendar"
(global-key-binding (this-command-keys))))
+(defun calendar-read-sexp (prompt predicate &optional default &rest args)
+ "Return an object read from the minibuffer.
+Passes PROMPT, DEFAULT, and ARGS to `format-prompt' to build
+the actual prompt. PREDICATE is called with a single value (the object
+the user entered) and it should return non-nil if that value is a valid choice.
+DEFAULT is the default value to use."
+ (unless (stringp default) (setq default (format "%S" default)))
+ (named-let query ()
+ ;; The call to `read-from-minibuffer' is copied from `read-minibuffer',
+ ;; except it's changed to use the DEFAULT arg instead of INITIAL-CONTENTS.
+ (let ((value (read-from-minibuffer
+ (apply #'format-prompt prompt default args)
+ nil minibuffer-local-map t 'minibuffer-history default)))
+ (if (funcall predicate value)
+ value
+ (query)))))
+
(defun calendar-read (prompt acceptable &optional initial-contents)
"Return an object read from the minibuffer.
Prompt with the string PROMPT and use the function ACCEPTABLE to decide
if entered item is acceptable. If non-nil, optional third arg
INITIAL-CONTENTS is a string to insert in the minibuffer before reading."
+ (declare (obsolete calendar-read-sexp "28.1"))
(let ((value (read-minibuffer prompt initial-contents)))
(while (not (funcall acceptable value))
(setq value (read-minibuffer prompt initial-contents)))
value))
-
(defun calendar-customized-p (symbol)
"Return non-nil if SYMBOL has been customized."
(and (default-boundp symbol)
(let ((standard (get symbol 'standard-value)))
(and standard
- (not (equal (eval (car standard)) (default-value symbol)))))))
+ (not (equal (eval (car standard) t) (default-value symbol)))))))
(defun calendar-abbrev-construct (full &optional maxlen)
"From sequence FULL, return a vector of abbreviations.
@@ -2284,32 +2303,38 @@ arguments SEQUENCES."
(append (list sequence) sequences))
(reverse alist)))
-(defun calendar-read-date (&optional noday)
+(defun calendar-read-date (&optional noday default-date)
"Prompt for Gregorian date. Return a list (month day year).
If optional NODAY is t, does not ask for day, but just returns
\(month 1 year); if NODAY is any other non-nil value the value
returned is (month year)."
- (let* ((year (calendar-read
- "Year (>0): "
- (lambda (x) (> x 0))
- (number-to-string (calendar-extract-year
- (calendar-current-date)))))
+ (unless default-date (setq default-date (calendar-current-date)))
+ (let* ((defyear (calendar-extract-year default-date))
+ (year (calendar-read-sexp "Year (>0)"
+ (lambda (x) (> x 0))
+ defyear))
(month-array calendar-month-name-array)
+ (defmon (aref month-array (1- (calendar-extract-month default-date))))
(completion-ignore-case t)
(month (cdr (assoc-string
- (completing-read
- "Month name: "
- (mapcar #'list (append month-array nil))
- nil t)
+ (completing-read
+ (format-prompt "Month name" defmon)
+ (append month-array nil)
+ nil t nil nil defmon)
(calendar-make-alist month-array 1) t)))
+ (defday (calendar-extract-day default-date))
(last (calendar-last-day-of-month month year)))
(if noday
(if (eq noday t)
(list month 1 year)
(list month year))
(list month
- (calendar-read (format "Day (1-%d): " last)
- (lambda (x) (and (< 0 x) (<= x last))))
+ (calendar-read-sexp "Day (1-%d)"
+ (lambda (x) (and (< 0 x) (<= x last)))
+ ;; Don't offer today's day as default
+ ;; if it's not valid for the chosen
+ ;; month/year.
+ (if (<= defday last) defday) last)
year))))
(defun calendar-interval (mon1 yr1 mon2 yr2)
diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el
index aad7016..4efa366 100644
--- a/lisp/calendar/diary-lib.el
+++ b/lisp/calendar/diary-lib.el
@@ -2221,8 +2221,8 @@ Prefix argument ARG makes the entry nonmarking."
(diary-make-entry
(format "%s(diary-cyclic %d %s)"
diary-sexp-entry-symbol
- (calendar-read "Repeat every how many days: "
- (lambda (x) (> x 0)))
+ (calendar-read-sexp "Repeat every how many days"
+ (lambda (x) (> x 0)))
(calendar-date-string (calendar-cursor-to-date t) nil t))
arg)))
diff --git a/lisp/calendar/holidays.el b/lisp/calendar/holidays.el
index 932993b..4bc17de 100644
--- a/lisp/calendar/holidays.el
+++ b/lisp/calendar/holidays.el
@@ -423,16 +423,15 @@ of a holiday list.
The optional LABEL is used to label the buffer created."
(interactive
- (let* ((start-year (calendar-read
- "Starting year of holidays (>0): "
+ (let* ((start-year (calendar-read-sexp
+ "Starting year of holidays (>0)"
(lambda (x) (> x 0))
- (number-to-string (calendar-extract-year
- (calendar-current-date)))))
- (end-year (calendar-read
- (format "Ending year (inclusive) of holidays (>=%s): "
- start-year)
+ (calendar-extract-year (calendar-current-date))))
+ (end-year (calendar-read-sexp
+ "Ending year (inclusive) of holidays (>=%s)"
(lambda (x) (>= x start-year))
- (number-to-string start-year)))
+ start-year
+ start-year))
(completion-ignore-case t)
(lists
(list
diff --git a/lisp/comint.el b/lisp/comint.el
index 53153af..e52d67d 100644
--- a/lisp/comint.el
+++ b/lisp/comint.el
@@ -3863,7 +3863,11 @@ REGEXP-GROUP is the regular expression group in REGEXP
to use."
(push (buffer-substring-no-properties
(match-beginning regexp-group)
(match-end regexp-group))
- results))
+ results)
+ (when (zerop (length (match-string 0)))
+ ;; If the regexp can be empty (for instance, "^.*$"), we
+ ;; don't advance, so ensure forward progress.
+ (forward-line 1)))
(nreverse results))))
;; Converting process modes to use comint mode
diff --git a/lisp/cus-start.el b/lisp/cus-start.el
index 0293d34..27fdb72 100644
--- a/lisp/cus-start.el
+++ b/lisp/cus-start.el
@@ -880,7 +880,7 @@ since it could result in memory overflow and make Emacs
crash."
;; Don't re-add to custom-delayed-init-variables post-startup.
(unless after-init-time
;; Note this is the _only_ initialize property we handle.
- (if (eq (cadr (memq :initialize rest)) 'custom-initialize-delay)
+ (if (eq (cadr (memq :initialize rest)) #'custom-initialize-delay)
;; These vars are defined early and should hence be initialized
;; early, even if this file happens to be loaded late. so add them
;; to the end of custom-delayed-init-variables. Otherwise,
diff --git a/lisp/custom.el b/lisp/custom.el
index 58ecd04..5e354c4 100644
--- a/lisp/custom.el
+++ b/lisp/custom.el
@@ -125,17 +125,7 @@ This is used in files that are preloaded (or for autoloaded
variables), so that the initialization is done in the run-time
context rather than the build-time context. This also has the
side-effect that the (delayed) initialization is performed with
-the :set function.
-
-For variables in preloaded files, you can simply use this
-function for the :initialize property. For autoloaded variables,
-you will also need to add an autoload stanza calling this
-function, and another one setting the standard-value property.
-Or you can wrap the defcustom in a progn, to force the autoloader
-to include all of it." ; see eg vc-sccs-search-project-dir
- ;; No longer true:
- ;; "See `send-mail-function' in sendmail.el for an example."
-
+the :set function."
;; Defvar it so as to mark it special, etc (bug#25770).
(internal--define-uninitialized-variable symbol)
diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el
index 5a96742..f860743 100644
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -1168,7 +1168,8 @@ ARGS are command switches passed to PROGRAM.")
("\\.tar\\.bz2\\'" . "tar -cf - %i | bzip2 -c9 > %o")
("\\.tar\\.xz\\'" . "tar -cf - %i | xz -c9 > %o")
("\\.tar\\.zst\\'" . "tar -cf - %i | zstd -19 -o %o")
- ("\\.zip\\'" . "zip %o -r --filesync %i"))
+ ("\\.zip\\'" . "zip %o -r --filesync %i")
+ ("\\.pax\\'" . "pax -wf %o %i"))
"Control the compression shell command for `dired-do-compress-to'.
Each element is (REGEXP . CMD), where REGEXP is the name of the
diff --git a/lisp/dired-x.el b/lisp/dired-x.el
index aebffe3..5a52ecc 100644
--- a/lisp/dired-x.el
+++ b/lisp/dired-x.el
@@ -1483,7 +1483,7 @@ a prefix argument, when it offers the filename near point
as a default."
;;; Internal functions.
;; Fixme: This should probably use `thing-at-point'. -- fx
-(define-obsolete-function-alias 'dired-file-name-at-point
+(define-obsolete-function-alias 'dired-filename-at-point
#'dired-x-guess-file-name-at-point "28.1")
(defun dired-x-guess-file-name-at-point ()
"Return the filename closest to point, expanded.
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index f29f85b..66a117f 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -284,8 +284,10 @@
;; If `fn' is from the same file, it has already
;; been preprocessed!
`(function ,fn)
- (byte-compile-preprocess
- (byte-compile--reify-function fn)))))
+ ;; Try and process it "in its original environment".
+ (let ((byte-compile-bound-variables nil))
+ (byte-compile-preprocess
+ (byte-compile--reify-function fn))))))
(if (eq (car-safe newfn) 'function)
(byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form)))
;; This can happen because of macroexp-warn-and-return &co.
@@ -1561,467 +1563,548 @@ If FOR-EFFECT is non-nil, the return value is assumed
to be of no importance."
;; You may notice that sequences like "dup varset discard" are
;; optimized but sequences like "dup varset TAG1: discard" are not.
;; You may be tempted to change this; resist that temptation.
- (cond ;;
- ;; <side-effect-free> pop --> <deleted>
- ;; ...including:
- ;; const-X pop --> <deleted>
- ;; varref-X pop --> <deleted>
- ;; dup pop --> <deleted>
- ;;
- ((and (eq 'byte-discard (car lap1))
- (memq (car lap0) side-effect-free))
- (setq keep-going t)
- (setq tmp (aref byte-stack+-info (symbol-value (car lap0))))
- (setq rest (cdr rest))
- (cond ((= tmp 1)
- (byte-compile-log-lap
- " %s discard\t-->\t<deleted>" lap0)
- (setq lap (delq lap0 (delq lap1 lap))))
- ((= tmp 0)
- (byte-compile-log-lap
- " %s discard\t-->\t<deleted> discard" lap0)
- (setq lap (delq lap0 lap)))
- ((= tmp -1)
- (byte-compile-log-lap
- " %s discard\t-->\tdiscard discard" lap0)
- (setcar lap0 'byte-discard)
- (setcdr lap0 0))
- ((error "Optimizer error: too much on the stack"))))
- ;;
- ;; goto*-X X: --> X:
- ;;
- ((and (memq (car lap0) byte-goto-ops)
- (eq (cdr lap0) lap1))
- (cond ((eq (car lap0) 'byte-goto)
- (setq lap (delq lap0 lap))
- (setq tmp "<deleted>"))
- ((memq (car lap0) byte-goto-always-pop-ops)
- (setcar lap0 (setq tmp 'byte-discard))
- (setcdr lap0 0))
- ((error "Depth conflict at tag %d" (nth 2 lap0))))
- (and (memq byte-optimize-log '(t byte))
- (byte-compile-log " (goto %s) %s:\t-->\t%s %s:"
- (nth 1 lap1) (nth 1 lap1)
- tmp (nth 1 lap1)))
- (setq keep-going t))
- ;;
- ;; varset-X varref-X --> dup varset-X
- ;; varbind-X varref-X --> dup varbind-X
- ;; const/dup varset-X varref-X --> const/dup varset-X const/dup
- ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup
- ;; The latter two can enable other optimizations.
- ;;
- ;; For lexical variables, we could do the same
- ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2
- ;; but this is a very minor gain, since dup is stack-ref-0,
- ;; i.e. it's only better if X>5, and even then it comes
- ;; at the cost of an extra stack slot. Let's not bother.
- ((and (eq 'byte-varref (car lap2))
- (eq (cdr lap1) (cdr lap2))
- (memq (car lap1) '(byte-varset byte-varbind)))
- (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars))
- (not (eq (car lap0) 'byte-constant)))
- nil
- (setq keep-going t)
- (if (memq (car lap0) '(byte-constant byte-dup))
- (progn
- (setq tmp (if (or (not tmp)
- (macroexp--const-symbol-p
- (car (cdr lap0))))
- (cdr lap0)
- (byte-compile-get-constant t)))
- (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s"
- lap0 lap1 lap2 lap0 lap1
- (cons (car lap0) tmp))
- (setcar lap2 (car lap0))
- (setcdr lap2 tmp))
- (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1)
- (setcar lap2 (car lap1))
- (setcar lap1 'byte-dup)
- (setcdr lap1 0)
- ;; The stack depth gets locally increased, so we will
- ;; increase maxdepth in case depth = maxdepth here.
- ;; This can cause the third argument to byte-code to
- ;; be larger than necessary.
- (setq add-depth 1))))
- ;;
- ;; dup varset-X discard --> varset-X
- ;; dup varbind-X discard --> varbind-X
- ;; dup stack-set-X discard --> stack-set-X-1
- ;; (the varbind variant can emerge from other optimizations)
- ;;
- ((and (eq 'byte-dup (car lap0))
- (eq 'byte-discard (car lap2))
- (memq (car lap1) '(byte-varset byte-varbind
- byte-stack-set)))
- (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1)
- (setq keep-going t
- rest (cdr rest))
- (if (eq 'byte-stack-set (car lap1)) (cl-decf (cdr lap1)))
- (setq lap (delq lap0 (delq lap2 lap))))
- ;;
- ;; not goto-X-if-nil --> goto-X-if-non-nil
- ;; not goto-X-if-non-nil --> goto-X-if-nil
- ;;
- ;; it is wrong to do the same thing for the -else-pop variants.
- ;;
- ((and (eq 'byte-not (car lap0))
- (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil)))
- (byte-compile-log-lap " not %s\t-->\t%s"
- lap1
- (cons
- (if (eq (car lap1) 'byte-goto-if-nil)
- 'byte-goto-if-not-nil
- 'byte-goto-if-nil)
- (cdr lap1)))
- (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil)
- 'byte-goto-if-not-nil
- 'byte-goto-if-nil))
- (setq lap (delq lap0 lap))
- (setq keep-going t))
- ;;
- ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X:
- ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X:
- ;;
- ;; it is wrong to do the same thing for the -else-pop variants.
- ;;
- ((and (memq (car lap0)
- '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX
- (eq 'byte-goto (car lap1)) ; gotoY
- (eq (cdr lap0) lap2)) ; TAG X
- (let ((inverse (if (eq 'byte-goto-if-nil (car lap0))
- 'byte-goto-if-not-nil 'byte-goto-if-nil)))
- (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:"
- lap0 lap1 lap2
- (cons inverse (cdr lap1)) lap2)
- (setq lap (delq lap0 lap))
- (setcar lap1 inverse)
- (setq keep-going t)))
- ;;
- ;; const goto-if-* --> whatever
- ;;
- ((and (eq 'byte-constant (car lap0))
- (memq (car lap1) byte-conditional-ops)
- ;; If the `byte-constant's cdr is not a cons cell, it has
- ;; to be an index into the constant pool); even though
- ;; it'll be a constant, that constant is not known yet
- ;; (it's typically a free variable of a closure, so will
- ;; only be known when the closure will be built at
- ;; run-time).
- (consp (cdr lap0)))
- (cond ((if (memq (car lap1) '(byte-goto-if-nil
- byte-goto-if-nil-else-pop))
- (car (cdr lap0))
- (not (car (cdr lap0))))
- (byte-compile-log-lap " %s %s\t-->\t<deleted>"
- lap0 lap1)
- (setq rest (cdr rest)
- lap (delq lap0 (delq lap1 lap))))
- (t
- (byte-compile-log-lap " %s %s\t-->\t%s"
- lap0 lap1
- (cons 'byte-goto (cdr lap1)))
- (when (memq (car lap1) byte-goto-always-pop-ops)
- (setq lap (delq lap0 lap)))
- (setcar lap1 'byte-goto)))
- (setq keep-going t))
- ;;
- ;; varref-X varref-X --> varref-X dup
- ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup
- ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup
- ;; We don't optimize the const-X variations on this here,
- ;; because that would inhibit some goto optimizations; we
- ;; optimize the const-X case after all other optimizations.
- ;;
- ((and (memq (car lap0) '(byte-varref byte-stack-ref))
- (progn
- (setq tmp (cdr rest))
- (setq tmp2 0)
- (while (eq (car (car tmp)) 'byte-dup)
- (setq tmp2 (1+ tmp2))
- (setq tmp (cdr tmp)))
- t)
- (eq (if (eq 'byte-stack-ref (car lap0))
- (+ tmp2 1 (cdr lap0))
- (cdr lap0))
- (cdr (car tmp)))
- (eq (car lap0) (car (car tmp))))
- (if (memq byte-optimize-log '(t byte))
- (let ((str ""))
- (setq tmp2 (cdr rest))
- (while (not (eq tmp tmp2))
- (setq tmp2 (cdr tmp2)
- str (concat str " dup")))
- (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup"
- lap0 str lap0 lap0 str)))
- (setq keep-going t)
- (setcar (car tmp) 'byte-dup)
- (setcdr (car tmp) 0)
- (setq rest tmp))
- ;;
- ;; TAG1: TAG2: --> TAG1: <deleted>
- ;; (and other references to TAG2 are replaced with TAG1)
- ;;
- ((and (eq (car lap0) 'TAG)
- (eq (car lap1) 'TAG))
- (and (memq byte-optimize-log '(t byte))
- (byte-compile-log " adjacent tags %d and %d merged"
- (nth 1 lap1) (nth 1 lap0)))
- (setq tmp3 lap)
- (while (setq tmp2 (rassq lap0 tmp3))
- (setcdr tmp2 lap1)
- (setq tmp3 (cdr (memq tmp2 tmp3))))
- (setq lap (delq lap0 lap)
- keep-going t)
- ;; replace references to tag in jump tables, if any
- (dolist (table byte-compile-jump-tables)
- (maphash #'(lambda (value tag)
- (when (equal tag lap0)
- (puthash value lap1 table)))
- table)))
- ;;
- ;; unused-TAG: --> <deleted>
- ;;
- ((and (eq 'TAG (car lap0))
- (not (rassq lap0 lap))
- ;; make sure this tag isn't used in a jump-table
- (cl-loop for table in byte-compile-jump-tables
- when (member lap0 (hash-table-values table))
- return nil finally return t))
- (and (memq byte-optimize-log '(t byte))
- (byte-compile-log " unused tag %d removed" (nth 1 lap0)))
- (setq lap (delq lap0 lap)
- keep-going t))
- ;;
- ;; goto ... --> goto <delete until TAG or end>
- ;; return ... --> return <delete until TAG or end>
- ;; (unless a jump-table is being used, where deleting may affect
- ;; other valid case bodies)
- ;;
- ((and (memq (car lap0) '(byte-goto byte-return))
- (not (memq (car lap1) '(TAG nil)))
- ;; FIXME: Instead of deferring simply when jump-tables are
- ;; being used, keep a list of tags used for switch tags and
- ;; use them instead (see `byte-compile-inline-lapcode').
- (not byte-compile-jump-tables))
- (setq tmp rest)
- (let ((i 0)
- (opt-p (memq byte-optimize-log '(t lap)))
- str deleted)
- (while (and (setq tmp (cdr tmp))
- (not (eq 'TAG (car (car tmp)))))
- (if opt-p (setq deleted (cons (car tmp) deleted)
- str (concat str " %s")
- i (1+ i))))
- (if opt-p
- (let ((tagstr
- (if (eq 'TAG (car (car tmp)))
- (format "%d:" (car (cdr (car tmp))))
- (or (car tmp) ""))))
- (if (< i 6)
- (apply 'byte-compile-log-lap-1
- (concat " %s" str
- " %s\t-->\t%s <deleted> %s")
- lap0
- (nconc (nreverse deleted)
- (list tagstr lap0 tagstr)))
- (byte-compile-log-lap
- " %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s"
- lap0 i (if (= i 1) "" "s")
- tagstr lap0 tagstr))))
- (rplacd rest tmp))
- (setq keep-going t))
- ;;
- ;; <safe-op> unbind --> unbind <safe-op>
- ;; (this may enable other optimizations.)
- ;;
- ((and (eq 'byte-unbind (car lap1))
- (memq (car lap0) byte-after-unbind-ops))
- (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0)
- (setcar rest lap1)
- (setcar (cdr rest) lap0)
- (setq keep-going t))
- ;;
- ;; varbind-X unbind-N --> discard unbind-(N-1)
- ;; save-excursion unbind-N --> unbind-(N-1)
- ;; save-restriction unbind-N --> unbind-(N-1)
- ;;
- ((and (eq 'byte-unbind (car lap1))
- (memq (car lap0) '(byte-varbind byte-save-excursion
- byte-save-restriction))
- (< 0 (cdr lap1)))
- (if (zerop (setcdr lap1 (1- (cdr lap1))))
- (delq lap1 rest))
- (if (eq (car lap0) 'byte-varbind)
- (setcar rest (cons 'byte-discard 0))
+ (cond
+ ;; <side-effect-free> pop --> <deleted>
+ ;; ...including:
+ ;; const-X pop --> <deleted>
+ ;; varref-X pop --> <deleted>
+ ;; dup pop --> <deleted>
+ ;;
+ ((and (eq 'byte-discard (car lap1))
+ (memq (car lap0) side-effect-free))
+ (setq keep-going t)
+ (setq tmp (aref byte-stack+-info (symbol-value (car lap0))))
+ (setq rest (cdr rest))
+ (cond ((= tmp 1)
+ (byte-compile-log-lap
+ " %s discard\t-->\t<deleted>" lap0)
+ (setq lap (delq lap0 (delq lap1 lap))))
+ ((= tmp 0)
+ (byte-compile-log-lap
+ " %s discard\t-->\t<deleted> discard" lap0)
(setq lap (delq lap0 lap)))
- (byte-compile-log-lap " %s %s\t-->\t%s %s"
- lap0 (cons (car lap1) (1+ (cdr lap1)))
- (if (eq (car lap0) 'byte-varbind)
- (car rest)
- (car (cdr rest)))
- (if (and (/= 0 (cdr lap1))
- (eq (car lap0) 'byte-varbind))
- (car (cdr rest))
- ""))
- (setq keep-going t))
- ;;
- ;; goto*-X ... X: goto-Y --> goto*-Y
- ;; goto-X ... X: return --> return
- ;;
- ((and (memq (car lap0) byte-goto-ops)
- (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap))))
- '(byte-goto byte-return)))
- (cond ((and (not (eq tmp lap0))
- (or (eq (car lap0) 'byte-goto)
- (eq (car tmp) 'byte-goto)))
- (byte-compile-log-lap " %s [%s]\t-->\t%s"
- (car lap0) tmp tmp)
- (if (eq (car tmp) 'byte-return)
- (setcar lap0 'byte-return))
- (setcdr lap0 (cdr tmp))
- (setq keep-going t))))
- ;;
- ;; goto-*-else-pop X ... X: goto-if-* --> whatever
- ;; goto-*-else-pop X ... X: discard --> whatever
- ;;
- ((and (memq (car lap0) '(byte-goto-if-nil-else-pop
- byte-goto-if-not-nil-else-pop))
- (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap)))))
- (eval-when-compile
- (cons 'byte-discard byte-conditional-ops)))
- (not (eq lap0 (car tmp))))
- (setq tmp2 (car tmp))
- (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop
- byte-goto-if-nil)
- (byte-goto-if-not-nil-else-pop
- byte-goto-if-not-nil))))
- (if (memq (car tmp2) tmp3)
- (progn (setcar lap0 (car tmp2))
- (setcdr lap0 (cdr tmp2))
- (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s"
- (car lap0) tmp2 lap0))
- ;; Get rid of the -else-pop's and jump one step further.
+ ((= tmp -1)
+ (byte-compile-log-lap
+ " %s discard\t-->\tdiscard discard" lap0)
+ (setcar lap0 'byte-discard)
+ (setcdr lap0 0))
+ ((error "Optimizer error: too much on the stack"))))
+ ;;
+ ;; goto*-X X: --> X:
+ ;;
+ ((and (memq (car lap0) byte-goto-ops)
+ (eq (cdr lap0) lap1))
+ (cond ((eq (car lap0) 'byte-goto)
+ (setq lap (delq lap0 lap))
+ (setq tmp "<deleted>"))
+ ((memq (car lap0) byte-goto-always-pop-ops)
+ (setcar lap0 (setq tmp 'byte-discard))
+ (setcdr lap0 0))
+ ((error "Depth conflict at tag %d" (nth 2 lap0))))
+ (and (memq byte-optimize-log '(t byte))
+ (byte-compile-log " (goto %s) %s:\t-->\t%s %s:"
+ (nth 1 lap1) (nth 1 lap1)
+ tmp (nth 1 lap1)))
+ (setq keep-going t))
+ ;;
+ ;; varset-X varref-X --> dup varset-X
+ ;; varbind-X varref-X --> dup varbind-X
+ ;; const/dup varset-X varref-X --> const/dup varset-X const/dup
+ ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup
+ ;; The latter two can enable other optimizations.
+ ;;
+ ;; For lexical variables, we could do the same
+ ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2
+ ;; but this is a very minor gain, since dup is stack-ref-0,
+ ;; i.e. it's only better if X>5, and even then it comes
+ ;; at the cost of an extra stack slot. Let's not bother.
+ ((and (eq 'byte-varref (car lap2))
+ (eq (cdr lap1) (cdr lap2))
+ (memq (car lap1) '(byte-varset byte-varbind)))
+ (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars))
+ (not (eq (car lap0) 'byte-constant)))
+ nil
+ (setq keep-going t)
+ (if (memq (car lap0) '(byte-constant byte-dup))
+ (progn
+ (setq tmp (if (or (not tmp)
+ (macroexp--const-symbol-p
+ (car (cdr lap0))))
+ (cdr lap0)
+ (byte-compile-get-constant t)))
+ (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s"
+ lap0 lap1 lap2 lap0 lap1
+ (cons (car lap0) tmp))
+ (setcar lap2 (car lap0))
+ (setcdr lap2 tmp))
+ (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1)
+ (setcar lap2 (car lap1))
+ (setcar lap1 'byte-dup)
+ (setcdr lap1 0)
+ ;; The stack depth gets locally increased, so we will
+ ;; increase maxdepth in case depth = maxdepth here.
+ ;; This can cause the third argument to byte-code to
+ ;; be larger than necessary.
+ (setq add-depth 1))))
+ ;;
+ ;; dup varset-X discard --> varset-X
+ ;; dup varbind-X discard --> varbind-X
+ ;; dup stack-set-X discard --> stack-set-X-1
+ ;; (the varbind variant can emerge from other optimizations)
+ ;;
+ ((and (eq 'byte-dup (car lap0))
+ (eq 'byte-discard (car lap2))
+ (memq (car lap1) '(byte-varset byte-varbind
+ byte-stack-set)))
+ (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1)
+ (setq keep-going t
+ rest (cdr rest))
+ (if (eq 'byte-stack-set (car lap1)) (cl-decf (cdr lap1)))
+ (setq lap (delq lap0 (delq lap2 lap))))
+ ;;
+ ;; not goto-X-if-nil --> goto-X-if-non-nil
+ ;; not goto-X-if-non-nil --> goto-X-if-nil
+ ;;
+ ;; it is wrong to do the same thing for the -else-pop variants.
+ ;;
+ ((and (eq 'byte-not (car lap0))
+ (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil)))
+ (byte-compile-log-lap " not %s\t-->\t%s"
+ lap1
+ (cons
+ (if (eq (car lap1) 'byte-goto-if-nil)
+ 'byte-goto-if-not-nil
+ 'byte-goto-if-nil)
+ (cdr lap1)))
+ (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil)
+ 'byte-goto-if-not-nil
+ 'byte-goto-if-nil))
+ (setq lap (delq lap0 lap))
+ (setq keep-going t))
+ ;;
+ ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X:
+ ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X:
+ ;;
+ ;; it is wrong to do the same thing for the -else-pop variants.
+ ;;
+ ((and (memq (car lap0)
+ '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX
+ (eq 'byte-goto (car lap1)) ; gotoY
+ (eq (cdr lap0) lap2)) ; TAG X
+ (let ((inverse (if (eq 'byte-goto-if-nil (car lap0))
+ 'byte-goto-if-not-nil 'byte-goto-if-nil)))
+ (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:"
+ lap0 lap1 lap2
+ (cons inverse (cdr lap1)) lap2)
+ (setq lap (delq lap0 lap))
+ (setcar lap1 inverse)
+ (setq keep-going t)))
+ ;;
+ ;; const goto-if-* --> whatever
+ ;;
+ ((and (eq 'byte-constant (car lap0))
+ (memq (car lap1) byte-conditional-ops)
+ ;; If the `byte-constant's cdr is not a cons cell, it has
+ ;; to be an index into the constant pool); even though
+ ;; it'll be a constant, that constant is not known yet
+ ;; (it's typically a free variable of a closure, so will
+ ;; only be known when the closure will be built at
+ ;; run-time).
+ (consp (cdr lap0)))
+ (cond ((if (memq (car lap1) '(byte-goto-if-nil
+ byte-goto-if-nil-else-pop))
+ (car (cdr lap0))
+ (not (car (cdr lap0))))
+ (byte-compile-log-lap " %s %s\t-->\t<deleted>"
+ lap0 lap1)
+ (setq rest (cdr rest)
+ lap (delq lap0 (delq lap1 lap))))
+ (t
+ (byte-compile-log-lap " %s %s\t-->\t%s"
+ lap0 lap1
+ (cons 'byte-goto (cdr lap1)))
+ (when (memq (car lap1) byte-goto-always-pop-ops)
+ (setq lap (delq lap0 lap)))
+ (setcar lap1 'byte-goto)))
+ (setq keep-going t))
+ ;;
+ ;; varref-X varref-X --> varref-X dup
+ ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup
+ ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup
+ ;; We don't optimize the const-X variations on this here,
+ ;; because that would inhibit some goto optimizations; we
+ ;; optimize the const-X case after all other optimizations.
+ ;;
+ ((and (memq (car lap0) '(byte-varref byte-stack-ref))
+ (progn
+ (setq tmp (cdr rest))
+ (setq tmp2 0)
+ (while (eq (car (car tmp)) 'byte-dup)
+ (setq tmp2 (1+ tmp2))
+ (setq tmp (cdr tmp)))
+ t)
+ (eq (if (eq 'byte-stack-ref (car lap0))
+ (+ tmp2 1 (cdr lap0))
+ (cdr lap0))
+ (cdr (car tmp)))
+ (eq (car lap0) (car (car tmp))))
+ (if (memq byte-optimize-log '(t byte))
+ (let ((str ""))
+ (setq tmp2 (cdr rest))
+ (while (not (eq tmp tmp2))
+ (setq tmp2 (cdr tmp2)
+ str (concat str " dup")))
+ (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup"
+ lap0 str lap0 lap0 str)))
+ (setq keep-going t)
+ (setcar (car tmp) 'byte-dup)
+ (setcdr (car tmp) 0)
+ (setq rest tmp))
+ ;;
+ ;; TAG1: TAG2: --> TAG1: <deleted>
+ ;; (and other references to TAG2 are replaced with TAG1)
+ ;;
+ ((and (eq (car lap0) 'TAG)
+ (eq (car lap1) 'TAG))
+ (and (memq byte-optimize-log '(t byte))
+ (byte-compile-log " adjacent tags %d and %d merged"
+ (nth 1 lap1) (nth 1 lap0)))
+ (setq tmp3 lap)
+ (while (setq tmp2 (rassq lap0 tmp3))
+ (setcdr tmp2 lap1)
+ (setq tmp3 (cdr (memq tmp2 tmp3))))
+ (setq lap (delq lap0 lap)
+ keep-going t)
+ ;; replace references to tag in jump tables, if any
+ (dolist (table byte-compile-jump-tables)
+ (maphash #'(lambda (value tag)
+ (when (equal tag lap0)
+ (puthash value lap1 table)))
+ table)))
+ ;;
+ ;; unused-TAG: --> <deleted>
+ ;;
+ ((and (eq 'TAG (car lap0))
+ (not (rassq lap0 lap))
+ ;; make sure this tag isn't used in a jump-table
+ (cl-loop for table in byte-compile-jump-tables
+ when (member lap0 (hash-table-values table))
+ return nil finally return t))
+ (and (memq byte-optimize-log '(t byte))
+ (byte-compile-log " unused tag %d removed" (nth 1 lap0)))
+ (setq lap (delq lap0 lap)
+ keep-going t))
+ ;;
+ ;; goto ... --> goto <delete until TAG or end>
+ ;; return ... --> return <delete until TAG or end>
+ ;; (unless a jump-table is being used, where deleting may affect
+ ;; other valid case bodies)
+ ;;
+ ((and (memq (car lap0) '(byte-goto byte-return))
+ (not (memq (car lap1) '(TAG nil)))
+ ;; FIXME: Instead of deferring simply when jump-tables are
+ ;; being used, keep a list of tags used for switch tags and
+ ;; use them instead (see `byte-compile-inline-lapcode').
+ (not byte-compile-jump-tables))
+ (setq tmp rest)
+ (let ((i 0)
+ (opt-p (memq byte-optimize-log '(t lap)))
+ str deleted)
+ (while (and (setq tmp (cdr tmp))
+ (not (eq 'TAG (car (car tmp)))))
+ (if opt-p (setq deleted (cons (car tmp) deleted)
+ str (concat str " %s")
+ i (1+ i))))
+ (if opt-p
+ (let ((tagstr
+ (if (eq 'TAG (car (car tmp)))
+ (format "%d:" (car (cdr (car tmp))))
+ (or (car tmp) ""))))
+ (if (< i 6)
+ (apply 'byte-compile-log-lap-1
+ (concat " %s" str
+ " %s\t-->\t%s <deleted> %s")
+ lap0
+ (nconc (nreverse deleted)
+ (list tagstr lap0 tagstr)))
+ (byte-compile-log-lap
+ " %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s"
+ lap0 i (if (= i 1) "" "s")
+ tagstr lap0 tagstr))))
+ (rplacd rest tmp))
+ (setq keep-going t))
+ ;;
+ ;; <safe-op> unbind --> unbind <safe-op>
+ ;; (this may enable other optimizations.)
+ ;;
+ ((and (eq 'byte-unbind (car lap1))
+ (memq (car lap0) byte-after-unbind-ops))
+ (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0)
+ (setcar rest lap1)
+ (setcar (cdr rest) lap0)
+ (setq keep-going t))
+ ;;
+ ;; varbind-X unbind-N --> discard unbind-(N-1)
+ ;; save-excursion unbind-N --> unbind-(N-1)
+ ;; save-restriction unbind-N --> unbind-(N-1)
+ ;;
+ ((and (eq 'byte-unbind (car lap1))
+ (memq (car lap0) '(byte-varbind byte-save-excursion
+ byte-save-restriction))
+ (< 0 (cdr lap1)))
+ (if (zerop (setcdr lap1 (1- (cdr lap1))))
+ (delq lap1 rest))
+ (if (eq (car lap0) 'byte-varbind)
+ (setcar rest (cons 'byte-discard 0))
+ (setq lap (delq lap0 lap)))
+ (byte-compile-log-lap " %s %s\t-->\t%s %s"
+ lap0 (cons (car lap1) (1+ (cdr lap1)))
+ (if (eq (car lap0) 'byte-varbind)
+ (car rest)
+ (car (cdr rest)))
+ (if (and (/= 0 (cdr lap1))
+ (eq (car lap0) 'byte-varbind))
+ (car (cdr rest))
+ ""))
+ (setq keep-going t))
+ ;;
+ ;; goto*-X ... X: goto-Y --> goto*-Y
+ ;; goto-X ... X: return --> return
+ ;;
+ ((and (memq (car lap0) byte-goto-ops)
+ (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap))))
+ '(byte-goto byte-return)))
+ (cond ((and (not (eq tmp lap0))
+ (or (eq (car lap0) 'byte-goto)
+ (eq (car tmp) 'byte-goto)))
+ (byte-compile-log-lap " %s [%s]\t-->\t%s"
+ (car lap0) tmp tmp)
+ (if (eq (car tmp) 'byte-return)
+ (setcar lap0 'byte-return))
+ (setcdr lap0 (cdr tmp))
+ (setq keep-going t))))
+ ;;
+ ;; goto-*-else-pop X ... X: goto-if-* --> whatever
+ ;; goto-*-else-pop X ... X: discard --> whatever
+ ;;
+ ((and (memq (car lap0) '(byte-goto-if-nil-else-pop
+ byte-goto-if-not-nil-else-pop))
+ (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap)))))
+ (eval-when-compile
+ (cons 'byte-discard byte-conditional-ops)))
+ (not (eq lap0 (car tmp))))
+ (setq tmp2 (car tmp))
+ (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop
+ byte-goto-if-nil)
+ (byte-goto-if-not-nil-else-pop
+ byte-goto-if-not-nil))))
+ (if (memq (car tmp2) tmp3)
+ (progn (setcar lap0 (car tmp2))
+ (setcdr lap0 (cdr tmp2))
+ (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s"
+ (car lap0) tmp2 lap0))
+ ;; Get rid of the -else-pop's and jump one step further.
+ (or (eq 'TAG (car (nth 1 tmp)))
+ (setcdr tmp (cons (byte-compile-make-tag)
+ (cdr tmp))))
+ (byte-compile-log-lap " %s [%s]\t-->\t%s <skip>"
+ (car lap0) tmp2 (nth 1 tmp3))
+ (setcar lap0 (nth 1 tmp3))
+ (setcdr lap0 (nth 1 tmp)))
+ (setq keep-going t))
+ ;;
+ ;; const goto-X ... X: goto-if-* --> whatever
+ ;; const goto-X ... X: discard --> whatever
+ ;;
+ ((and (eq (car lap0) 'byte-constant)
+ (eq (car lap1) 'byte-goto)
+ (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap)))))
+ (eval-when-compile
+ (cons 'byte-discard byte-conditional-ops)))
+ (not (eq lap1 (car tmp))))
+ (setq tmp2 (car tmp))
+ (cond ((when (consp (cdr lap0))
+ (memq (car tmp2)
+ (if (null (car (cdr lap0)))
+ '(byte-goto-if-nil byte-goto-if-nil-else-pop)
+ '(byte-goto-if-not-nil
+ byte-goto-if-not-nil-else-pop))))
+ (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s"
+ lap0 tmp2 lap0 tmp2)
+ (setcar lap1 (car tmp2))
+ (setcdr lap1 (cdr tmp2))
+ ;; Let next step fix the (const,goto-if*) sequence.
+ (setq rest (cons nil rest))
+ (setq keep-going t))
+ ((or (consp (cdr lap0))
+ (eq (car tmp2) 'byte-discard))
+ ;; Jump one step further
+ (byte-compile-log-lap
+ " %s goto [%s]\t-->\t<deleted> goto <skip>"
+ lap0 tmp2)
(or (eq 'TAG (car (nth 1 tmp)))
(setcdr tmp (cons (byte-compile-make-tag)
(cdr tmp))))
- (byte-compile-log-lap " %s [%s]\t-->\t%s <skip>"
- (car lap0) tmp2 (nth 1 tmp3))
- (setcar lap0 (nth 1 tmp3))
- (setcdr lap0 (nth 1 tmp)))
- (setq keep-going t))
- ;;
- ;; const goto-X ... X: goto-if-* --> whatever
- ;; const goto-X ... X: discard --> whatever
- ;;
- ((and (eq (car lap0) 'byte-constant)
- (eq (car lap1) 'byte-goto)
- (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap)))))
- (eval-when-compile
- (cons 'byte-discard byte-conditional-ops)))
- (not (eq lap1 (car tmp))))
- (setq tmp2 (car tmp))
- (cond ((when (consp (cdr lap0))
- (memq (car tmp2)
- (if (null (car (cdr lap0)))
- '(byte-goto-if-nil byte-goto-if-nil-else-pop)
- '(byte-goto-if-not-nil
- byte-goto-if-not-nil-else-pop))))
- (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s"
- lap0 tmp2 lap0 tmp2)
- (setcar lap1 (car tmp2))
- (setcdr lap1 (cdr tmp2))
- ;; Let next step fix the (const,goto-if*) sequence.
- (setq rest (cons nil rest))
- (setq keep-going t))
- ((or (consp (cdr lap0))
- (eq (car tmp2) 'byte-discard))
- ;; Jump one step further
- (byte-compile-log-lap
- " %s goto [%s]\t-->\t<deleted> goto <skip>"
- lap0 tmp2)
- (or (eq 'TAG (car (nth 1 tmp)))
- (setcdr tmp (cons (byte-compile-make-tag)
- (cdr tmp))))
- (setcdr lap1 (car (cdr tmp)))
- (setq lap (delq lap0 lap))
- (setq keep-going t))))
- ;;
- ;; X: varref-Y ... varset-Y goto-X -->
- ;; X: varref-Y Z: ... dup varset-Y goto-Z
- ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.)
- ;; (This is so usual for while loops that it is worth handling).
- ;;
- ;; Here again, we could do it for stack-ref/stack-set, but
- ;; that's replacing a stack-ref-Y with a stack-ref-0, which
- ;; is a very minor improvement (if any), at the cost of
- ;; more stack use and more byte-code. Let's not do it.
- ;;
- ((and (eq (car lap1) 'byte-varset)
- (eq (car lap2) 'byte-goto)
- (not (memq (cdr lap2) rest)) ;Backwards jump
- (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap)))))
- 'byte-varref)
- (eq (cdr (car tmp)) (cdr lap1))
- (not (memq (car (cdr lap1)) byte-boolean-vars)))
- ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp))
- (let ((newtag (byte-compile-make-tag)))
- (byte-compile-log-lap
- " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s"
- (nth 1 (cdr lap2)) (car tmp)
- lap1 lap2
- (nth 1 (cdr lap2)) (car tmp)
- (nth 1 newtag) 'byte-dup lap1
- (cons 'byte-goto newtag)
- )
- (setcdr rest (cons (cons 'byte-dup 0) (cdr rest)))
- (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp))))
- (setq add-depth 1)
- (setq keep-going t))
- ;;
- ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y:
- ;; (This can pull the loop test to the end of the loop)
- ;;
- ((and (eq (car lap0) 'byte-goto)
- (eq (car lap1) 'TAG)
- (eq lap1
- (cdr (car (setq tmp (cdr (memq (cdr lap0) lap))))))
- (memq (car (car tmp))
- '(byte-goto byte-goto-if-nil byte-goto-if-not-nil
- byte-goto-if-nil-else-pop)))
-;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional"
-;; lap0 lap1 (cdr lap0) (car tmp))
- (let ((newtag (byte-compile-make-tag)))
- (byte-compile-log-lap
- "%s %s: ... %s: %s\t-->\t%s ... %s:"
- lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp)
- (cons (cdr (assq (car (car tmp))
- '((byte-goto-if-nil . byte-goto-if-not-nil)
- (byte-goto-if-not-nil . byte-goto-if-nil)
- (byte-goto-if-nil-else-pop .
- byte-goto-if-not-nil-else-pop)
- (byte-goto-if-not-nil-else-pop .
- byte-goto-if-nil-else-pop))))
- newtag)
-
- (nth 1 newtag)
- )
- (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp)))
- (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop)
- ;; We can handle this case but not the -if-not-nil case,
- ;; because we won't know which non-nil constant to push.
- (setcdr rest (cons (cons 'byte-constant
- (byte-compile-get-constant nil))
- (cdr rest))))
- (setcar lap0 (nth 1 (memq (car (car tmp))
- '(byte-goto-if-nil-else-pop
- byte-goto-if-not-nil
- byte-goto-if-nil
- byte-goto-if-not-nil
- byte-goto byte-goto))))
- )
- (setq keep-going t))
- )
+ (setcdr lap1 (car (cdr tmp)))
+ (setq lap (delq lap0 lap))
+ (setq keep-going t))))
+ ;;
+ ;; X: varref-Y ... varset-Y goto-X -->
+ ;; X: varref-Y Z: ... dup varset-Y goto-Z
+ ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.)
+ ;; (This is so usual for while loops that it is worth handling).
+ ;;
+ ;; Here again, we could do it for stack-ref/stack-set, but
+ ;; that's replacing a stack-ref-Y with a stack-ref-0, which
+ ;; is a very minor improvement (if any), at the cost of
+ ;; more stack use and more byte-code. Let's not do it.
+ ;;
+ ((and (eq (car lap1) 'byte-varset)
+ (eq (car lap2) 'byte-goto)
+ (not (memq (cdr lap2) rest)) ;Backwards jump
+ (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap)))))
+ 'byte-varref)
+ (eq (cdr (car tmp)) (cdr lap1))
+ (not (memq (car (cdr lap1)) byte-boolean-vars)))
+ ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp))
+ (let ((newtag (byte-compile-make-tag)))
+ (byte-compile-log-lap
+ " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s"
+ (nth 1 (cdr lap2)) (car tmp)
+ lap1 lap2
+ (nth 1 (cdr lap2)) (car tmp)
+ (nth 1 newtag) 'byte-dup lap1
+ (cons 'byte-goto newtag)
+ )
+ (setcdr rest (cons (cons 'byte-dup 0) (cdr rest)))
+ (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp))))
+ (setq add-depth 1)
+ (setq keep-going t))
+ ;;
+ ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y:
+ ;; (This can pull the loop test to the end of the loop)
+ ;;
+ ((and (eq (car lap0) 'byte-goto)
+ (eq (car lap1) 'TAG)
+ (eq lap1
+ (cdr (car (setq tmp (cdr (memq (cdr lap0) lap))))))
+ (memq (car (car tmp))
+ '(byte-goto byte-goto-if-nil byte-goto-if-not-nil
+ byte-goto-if-nil-else-pop)))
+ ;; (byte-compile-log-lap " %s %s, %s %s --> moved
conditional"
+ ;; lap0 lap1 (cdr lap0) (car tmp))
+ (let ((newtag (byte-compile-make-tag)))
+ (byte-compile-log-lap
+ "%s %s: ... %s: %s\t-->\t%s ... %s:"
+ lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp)
+ (cons (cdr (assq (car (car tmp))
+ '((byte-goto-if-nil . byte-goto-if-not-nil)
+ (byte-goto-if-not-nil . byte-goto-if-nil)
+ (byte-goto-if-nil-else-pop .
+
byte-goto-if-not-nil-else-pop)
+ (byte-goto-if-not-nil-else-pop .
+
byte-goto-if-nil-else-pop))))
+ newtag)
+
+ (nth 1 newtag)
+ )
+ (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp)))
+ (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop)
+ ;; We can handle this case but not the -if-not-nil case,
+ ;; because we won't know which non-nil constant to push.
+ (setcdr rest (cons (cons 'byte-constant
+ (byte-compile-get-constant nil))
+ (cdr rest))))
+ (setcar lap0 (nth 1 (memq (car (car tmp))
+ '(byte-goto-if-nil-else-pop
+ byte-goto-if-not-nil
+ byte-goto-if-nil
+ byte-goto-if-not-nil
+ byte-goto byte-goto))))
+ )
+ (setq keep-going t))
+
+ ;;
+ ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos
+ ;; stack-set-M [discard/discardN ...] --> discardN
+ ;;
+ ((and (eq (car lap0) 'byte-stack-set)
+ (memq (car lap1) '(byte-discard byte-discardN))
+ (progn
+ ;; See if enough discard operations follow to expose or
+ ;; destroy the value stored by the stack-set.
+ (setq tmp (cdr rest))
+ (setq tmp2 (1- (cdr lap0)))
+ (setq tmp3 0)
+ (while (memq (car (car tmp)) '(byte-discard byte-discardN))
+ (setq tmp3
+ (+ tmp3 (if (eq (car (car tmp)) 'byte-discard)
+ 1
+ (cdr (car tmp)))))
+ (setq tmp (cdr tmp)))
+ (>= tmp3 tmp2)))
+ ;; Do the optimization.
+ (setq lap (delq lap0 lap))
+ (setcar lap1
+ (if (= tmp2 tmp3)
+ ;; The value stored is the new TOS, so pop one more
+ ;; value (to get rid of the old value) using the
+ ;; TOS-preserving discard operator.
+ 'byte-discardN-preserve-tos
+ ;; Otherwise, the value stored is lost, so just use a
+ ;; normal discard.
+ 'byte-discardN))
+ (setcdr lap1 (1+ tmp3))
+ (setcdr (cdr rest) tmp)
+ (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s"
+ lap0 lap1))
+
+ ;;
+ ;; discardN-preserve-tos return --> return
+ ;; dup return --> return
+ ;; stack-set-N return --> return ; where N is TOS-1
+ ;;
+ ((and (eq (car lap1) 'byte-return)
+ (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup))
+ (and (eq (car lap0) 'byte-stack-set)
+ (= (cdr lap0) 1))))
+ (setq keep-going t)
+ ;; The byte-code interpreter will pop the stack for us, so
+ ;; we can just leave stuff on it.
+ (setq lap (delq lap0 lap))
+ (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1))
+
+ ;;
+ ;; goto-X ... X: discard ==> discard goto-Y ... X: discard Y:
+ ;;
+ ((and (eq (car lap0) 'byte-goto)
+ (setq tmp (cdr (memq (cdr lap0) lap)))
+ (memq (caar tmp) '(byte-discard byte-discardN
+ byte-discardN-preserve-tos)))
+ (byte-compile-log-lap
+ " goto-X .. X: \t-->\t%s goto-X.. X: %s Y:"
+ (car tmp) (car tmp))
+ (setq keep-going t)
+ (let* ((newtag (byte-compile-make-tag))
+ ;; Make a copy, since we sometimes modify insts in-place!
+ (newdiscard (cons (caar tmp) (cdar tmp)))
+ (newjmp (cons (car lap0) newtag)))
+ (push newtag (cdr tmp)) ;Push new tag after the discard.
+ (setcar rest newdiscard)
+ (push newjmp (cdr rest))))
+
+ ;;
+ ;; const discardN-preserve-tos ==> discardN const
+ ;;
+ ((and (eq (car lap0) 'byte-constant)
+ (eq (car lap1) 'byte-discardN-preserve-tos))
+ (setq keep-going t)
+ (let ((newdiscard (cons 'byte-discardN (cdr lap1))))
+ (byte-compile-log-lap
+ " %s %s\t-->\t%s %s" lap0 lap1 newdiscard lap0)
+ (setf (car rest) newdiscard)
+ (setf (cadr rest) lap0)))
+ )
(setq rest (cdr rest)))
)
;; Cleanup stage:
@@ -2085,41 +2168,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to
be of no importance."
(setcdr lap1 (+ (cdr lap1) (cdr lap0))))
;;
- ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos
- ;; stack-set-M [discard/discardN ...] --> discardN
- ;;
- ((and (eq (car lap0) 'byte-stack-set)
- (memq (car lap1) '(byte-discard byte-discardN))
- (progn
- ;; See if enough discard operations follow to expose or
- ;; destroy the value stored by the stack-set.
- (setq tmp (cdr rest))
- (setq tmp2 (1- (cdr lap0)))
- (setq tmp3 0)
- (while (memq (car (car tmp)) '(byte-discard byte-discardN))
- (setq tmp3
- (+ tmp3 (if (eq (car (car tmp)) 'byte-discard)
- 1
- (cdr (car tmp)))))
- (setq tmp (cdr tmp)))
- (>= tmp3 tmp2)))
- ;; Do the optimization.
- (setq lap (delq lap0 lap))
- (setcar lap1
- (if (= tmp2 tmp3)
- ;; The value stored is the new TOS, so pop one more
- ;; value (to get rid of the old value) using the
- ;; TOS-preserving discard operator.
- 'byte-discardN-preserve-tos
- ;; Otherwise, the value stored is lost, so just use a
- ;; normal discard.
- 'byte-discardN))
- (setcdr lap1 (1+ tmp3))
- (setcdr (cdr rest) tmp)
- (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s"
- lap0 lap1))
-
- ;;
;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y -->
;; discardN-(X+Y)
;;
@@ -2146,20 +2194,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to
be of no importance."
(setq lap (delq lap0 lap))
(setcdr lap1 (+ (cdr lap0) (cdr lap1)))
(byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (car rest)))
-
- ;;
- ;; discardN-preserve-tos return --> return
- ;; dup return --> return
- ;; stack-set-N return --> return ; where N is TOS-1
- ;;
- ((and (eq (car lap1) 'byte-return)
- (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup))
- (and (eq (car lap0) 'byte-stack-set)
- (= (cdr lap0) 1))))
- ;; The byte-code interpreter will pop the stack for us, so
- ;; we can just leave stuff on it.
- (setq lap (delq lap0 lap))
- (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1))
)
(setq rest (cdr rest)))
(setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth)))
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 360da6b..9429d6a 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -2505,7 +2505,8 @@ list that represents a doc string reference.
(when (memq sym byte-compile-lexical-variables)
(setq byte-compile-lexical-variables
(delq sym byte-compile-lexical-variables))
- (byte-compile-warn "Variable `%S' declared after its first use" sym))
+ (when (byte-compile-warning-enabled-p 'lexical sym)
+ (byte-compile-warn "Variable `%S' declared after its first use" sym)))
(push sym byte-compile-bound-variables)
(push sym byte-compile--seen-defvars))
diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el
index 2e204ff..76638ec 100644
--- a/lisp/emacs-lisp/checkdoc.el
+++ b/lisp/emacs-lisp/checkdoc.el
@@ -241,7 +241,12 @@ system. Possible values are:
defun - Spell-check when style checking a single defun.
buffer - Spell-check when style checking the whole buffer.
interactive - Spell-check during any interactive check.
- t - Always spell-check."
+ t - Always spell-check.
+
+There is a list of Lisp-specific words which checkdoc will
+install into Ispell on the fly, but only if Ispell is not already
+running. Use `ispell-kill-ispell' to make checkdoc restart it
+with these words enabled."
:type '(choice (const nil)
(const defun)
(const buffer)
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index 453e86c..90b7b88 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -3260,9 +3260,9 @@ To unhide a package, type
`\\[customize-variable] RET package-hidden-regexps'.
Type \\[package-menu-toggle-hiding] to toggle package hiding."
+ (declare (interactive-only "change `package-hidden-regexps' instead."))
(interactive)
(package--ensure-package-menu-mode)
- (declare (interactive-only "change `package-hidden-regexps' instead."))
(let* ((name (when (derived-mode-p 'package-menu-mode)
(concat "\\`" (regexp-quote (symbol-name (package-desc-name
(tabulated-list-get-id))))
diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el
index b90227d..a451445 100644
--- a/lisp/emacs-lisp/subr-x.el
+++ b/lisp/emacs-lisp/subr-x.el
@@ -389,6 +389,28 @@ it makes no sense to convert it to a string using
(set-buffer source-buffer)
(replace-buffer-contents tmp-buffer max-secs max-costs)))))))))
+(defmacro named-let (name bindings &rest body)
+ "Looping construct taken from Scheme.
+Like `let', bind variables in BINDINGS and then evaluate BODY,
+but with the twist that BODY can evaluate itself recursively by
+calling NAME, where the arguments passed to NAME are used
+as the new values of the bound variables in the recursive invocation."
+ (declare (indent 2) (debug (symbolp (&rest (symbolp form)) body)))
+ (require 'cl-lib)
+ (let ((fargs (mapcar (lambda (b) (if (consp b) (car b) b)) bindings))
+ (aargs (mapcar (lambda (b) (if (consp b) (cadr b))) bindings)))
+ ;; According to the Scheme semantics of named let, `name' is not in scope
+ ;; while evaluating the expressions in `bindings', and for this reason, the
+ ;; "initial" function call below needs to be outside of the `cl-labels'.
+ ;; When the "self-tco" eliminates all recursive calls, the `cl-labels'
+ ;; expands to a lambda which the byte-compiler then combines with the
+ ;; funcall to make a `let' so we end up with a plain `while' loop and no
+ ;; remaining `lambda' at all.
+ `(funcall
+ (cl-labels ((,name ,fargs . ,body)) #',name)
+ . ,aargs)))
+
+
(provide 'subr-x)
;;; subr-x.el ends here
diff --git a/lisp/emulation/cua-gmrk.el b/lisp/emulation/cua-gmrk.el
index 195bba1..6f6b9fc 100644
--- a/lisp/emulation/cua-gmrk.el
+++ b/lisp/emulation/cua-gmrk.el
@@ -87,9 +87,11 @@
(defun cua-toggle-global-mark (stay)
"Set or cancel the global marker.
-When the global marker is set, CUA cut and copy commands will automatically
-insert the deleted or copied text before the global marker, even when the
-global marker is in another buffer.
+When the global marker is set, CUA cut and copy commands will
+automatically insert the inserted, deleted or copied text before
+the global marker, even when the global marker is in another
+buffer.
+
If the global marker isn't set, set the global marker at point in the current
buffer. Otherwise jump to the global marker position and cancel it.
With prefix argument, don't jump to global mark when canceling it."
diff --git a/lisp/facemenu.el b/lisp/facemenu.el
index 2609397..dc5f8f4 100644
--- a/lisp/facemenu.el
+++ b/lisp/facemenu.el
@@ -606,9 +606,14 @@ color. The function should accept a single argument, the
color name."
(defun list-colors-print (list &optional callback)
(let ((callback-fn
- (if callback
- `(lambda (button)
- (funcall ,callback (button-get button 'color-name))))))
+ ;; Expect CALLBACK to be a function, but allow it to be a form that
+ ;; evaluates to a function, for backward-compatibility. (Bug#45831)
+ (cond ((functionp callback)
+ (lambda (button)
+ (funcall callback (button-get button 'color-name))))
+ (callback
+ `(lambda (button)
+ (funcall ,callback (button-get button 'color-name)))))))
(dolist (color list)
(if (consp color)
(if (cdr color)
diff --git a/lisp/faces.el b/lisp/faces.el
index 4e98338..d654b1f 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -2199,7 +2199,7 @@ the above example."
(not (funcall pred type)))
;; Strip off last hyphen and what follows, then try again
(setq type
- (if (setq hyphend (string-match-p "[-_][^-_]+$" type))
+ (if (setq hyphend (string-match-p "[-_.][^-_.]+$" type))
(substring type 0 hyphend)
nil))))
type)
diff --git a/lisp/font-lock.el b/lisp/font-lock.el
index a51434c..a9fc69d 100644
--- a/lisp/font-lock.el
+++ b/lisp/font-lock.el
@@ -1104,8 +1104,8 @@ Called with two arguments BEG and END.")
"Reinitialize the font-lock machinery and (re-)fontify the buffer.
This functions is a convenience functions when developing font
locking for a mode, and is not meant to be called from lisp functions."
- (interactive)
(declare (interactive-only t))
+ (interactive)
;; Make font-lock recalculate all the mode-specific data.
(setq font-lock-major-mode nil)
;; Make the syntax machinery discard all information.
diff --git a/lisp/frame.el b/lisp/frame.el
index e2d7f21..06aab26 100644
--- a/lisp/frame.el
+++ b/lisp/frame.el
@@ -2552,13 +2552,15 @@ Use 0 or negative value to blink forever."
This starts the timer `blink-cursor-timer', which makes the cursor blink
if appropriate. It also arranges to cancel that timer when the next
command starts, by installing a pre-command hook."
- (when (null blink-cursor-timer)
+ (cond
+ ((null blink-cursor-mode) (blink-cursor-mode -1))
+ ((null blink-cursor-timer)
;; Set up the timer first, so that if this signals an error,
;; blink-cursor-end is not added to pre-command-hook.
(setq blink-cursor-blinks-done 1)
(blink-cursor--start-timer)
(add-hook 'pre-command-hook #'blink-cursor-end)
- (internal-show-cursor nil nil)))
+ (internal-show-cursor nil nil))))
(defun blink-cursor-timer-function ()
"Timer function of timer `blink-cursor-timer'."
@@ -2615,7 +2617,7 @@ stopped by `blink-cursor-suspend'. Internally calls
`blink-cursor--should-blink' and returns its result."
(let ((should-blink (blink-cursor--should-blink)))
(when (and should-blink (not blink-cursor-idle-timer))
- (remove-hook 'post-command-hook 'blink-cursor-check)
+ (remove-hook 'post-command-hook #'blink-cursor-check)
(blink-cursor--start-idle-timer))
should-blink))
@@ -2637,16 +2639,16 @@ This command is effective only on graphical frames. On
text-only
terminals, cursor blinking is controlled by the terminal."
:init-value (not (or noninteractive
no-blinking-cursor
- (eq system-type 'ms-dos)
- (not (display-blink-cursor-p))))
- :initialize 'custom-initialize-delay
+ (eq system-type 'ms-dos)))
+ :initialize #'custom-initialize-delay
:group 'cursor
:global t
(blink-cursor-suspend)
(remove-hook 'after-delete-frame-functions #'blink-cursor--rescan-frames)
(remove-function after-focus-change-function #'blink-cursor--rescan-frames)
(when blink-cursor-mode
- (add-function :after after-focus-change-function
#'blink-cursor--rescan-frames)
+ (add-function :after after-focus-change-function
+ #'blink-cursor--rescan-frames)
(add-hook 'after-delete-frame-functions #'blink-cursor--rescan-frames)
(blink-cursor-check)))
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index 50e0218..1409a43 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -47,7 +47,7 @@
(require 'rfc2047)
(require 'puny)
(require 'rmc) ; read-multiple-choice
-(eval-when-compile (require 'subr-x))
+(require 'subr-x)
(autoload 'mailclient-send-it "mailclient")
@@ -620,8 +620,8 @@ Done before generating the new subject of a forward."
(defcustom message-forward-ignored-headers
"^Content-Transfer-Encoding:\\|^X-Gnus"
"All headers that match this regexp will be deleted when forwarding a
message.
-This variable is not consulted when forwarding encrypted messages
-and `message-forward-show-mml' is `best'.
+Also see `message-forward-included-headers' -- both variables are applied.
+In addition, see `message-forward-included-mime-headers'.
This may also be a list of regexps."
:version "21.1"
@@ -637,7 +637,14 @@ This may also be a list of regexps."
'("^From:" "^Subject:" "^Date:" "^To:" "^Cc:")
"If non-nil, delete non-matching headers when forwarding a message.
Only headers that match this regexp will be included. This
-variable should be a regexp or a list of regexps."
+variable should be a regexp or a list of regexps.
+
+Also see `message-forward-ignored-headers' -- both variables are applied.
+In addition, see `message-forward-included-mime-headers'.
+
+When forwarding messages as MIME, but when
+`message-forward-show-mml' results in MML not being used,
+`message-forward-included-mime-headers' take precedence."
:version "27.1"
:group 'message-forwarding
:type '(repeat :value-to-internal (lambda (widget value)
@@ -647,6 +654,24 @@ variable should be a regexp or a list of regexps."
(widget-editable-list-match widget value)))
regexp))
+(defcustom message-forward-included-mime-headers
+ '("^Content-Type:" "^MIME-Version:")
+ "When forwarding as MIME, but not using MML, don't delete these headers.
+Also see `message-forward-ignored-headers' and
+`message-forward-ignored-headers'.
+
+When forwarding messages as MIME, but when
+`message-forward-show-mml' results in MML not being used,
+`message-forward-included-mime-headers' take precedence."
+ :version "28.1"
+ :group 'message-forwarding
+ :type '(repeat :value-to-internal (lambda (widget value)
+ (custom-split-regexp-maybe value))
+ :match (lambda (widget value)
+ (or (stringp value)
+ (widget-editable-list-match widget value)))
+ regexp))
+
(defcustom message-ignored-cited-headers "."
"Delete these headers from the messages you yank."
:group 'message-insertion
@@ -3057,22 +3082,23 @@ See also `message-forbidden-properties'."
(defun message--syntax-propertize (beg end)
"Syntax-propertize certain message text specially."
- (let ((citation-regexp (concat "^" message-cite-prefix-regexp ".*$"))
- (smiley-regexp (regexp-opt message-smileys)))
- (goto-char beg)
- (while (search-forward-regexp citation-regexp
- end 'noerror)
- (let ((start (match-beginning 0))
- (end (match-end 0)))
- (add-text-properties start (1+ start)
- `(syntax-table ,(string-to-syntax "<")))
- (add-text-properties end (min (1+ end) (point-max))
- `(syntax-table ,(string-to-syntax ">")))))
- (goto-char beg)
- (while (search-forward-regexp smiley-regexp
- end 'noerror)
- (add-text-properties (match-beginning 0) (match-end 0)
- `(syntax-table ,(string-to-syntax "."))))))
+ (with-syntax-table message-mode-syntax-table
+ (let ((citation-regexp (concat "^" message-cite-prefix-regexp ".*$"))
+ (smiley-regexp (regexp-opt message-smileys)))
+ (goto-char beg)
+ (while (search-forward-regexp citation-regexp
+ end 'noerror)
+ (let ((start (match-beginning 0))
+ (end (match-end 0)))
+ (add-text-properties start (1+ start)
+ `(syntax-table ,(string-to-syntax "<")))
+ (add-text-properties end (min (1+ end) (point-max))
+ `(syntax-table ,(string-to-syntax ">")))))
+ (goto-char beg)
+ (while (search-forward-regexp smiley-regexp
+ end 'noerror)
+ (add-text-properties (match-beginning 0) (match-end 0)
+ `(syntax-table ,(string-to-syntax ".")))))))
;;;###autoload
(define-derived-mode message-mode text-mode "Message"
@@ -7616,14 +7642,28 @@ Optional DIGEST will use digest to forward."
"-------------------- End of forwarded message --------------------\n")
(message-remove-ignored-headers b e)))
-(defun message-remove-ignored-headers (b e)
+(defun message-remove-ignored-headers (b e &optional preserve-mime)
(when (or message-forward-ignored-headers
message-forward-included-headers)
+ (let ((saved-headers nil))
(save-restriction
(narrow-to-region b e)
(goto-char b)
(narrow-to-region (point)
(or (search-forward "\n\n" nil t) (point)))
+ ;; When forwarding as MIME, preserve some MIME headers.
+ (when preserve-mime
+ (let ((headers (buffer-string)))
+ (with-temp-buffer
+ (insert headers)
+ (message-remove-header
+ (if (listp message-forward-included-mime-headers)
+ (mapconcat
+ #'identity (cons "^$" message-forward-included-mime-headers)
+ "\\|")
+ message-forward-included-mime-headers)
+ t nil t)
+ (setq saved-headers (string-lines (buffer-string) t)))))
(when message-forward-ignored-headers
(let ((ignored (if (stringp message-forward-ignored-headers)
(list message-forward-ignored-headers)
@@ -7636,10 +7676,14 @@ Optional DIGEST will use digest to forward."
(mapconcat #'identity (cons "^$" message-forward-included-headers)
"\\|")
message-forward-included-headers)
- t nil t)))))
+ t nil t))
+ ;; Insert the MIME headers, if any.
+ (goto-char (point-max))
+ (forward-line -1)
+ (dolist (header saved-headers)
+ (insert header "\n"))))))
-(defun message-forward-make-body-mime (forward-buffer &optional beg end
- remove-headers)
+(defun message-forward-make-body-mime (forward-buffer &optional beg end)
(let ((b (point)))
(insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n")
(save-restriction
@@ -7649,8 +7693,7 @@ Optional DIGEST will use digest to forward."
(goto-char (point-min))
(when (looking-at "From ")
(replace-match "X-From-Line: "))
- (when remove-headers
- (message-remove-ignored-headers (point-min) (point-max)))
+ (message-remove-ignored-headers (point-min) (point-max) t)
(goto-char (point-max)))
(insert "<#/part>\n")
;; Consider there is no illegible text.
@@ -7789,8 +7832,7 @@ is for the internal use."
(message-signed-or-encrypted-p)
(error t))))))
(message-forward-make-body-mml forward-buffer)
- (message-forward-make-body-mime
- forward-buffer nil nil (not (eq message-forward-show-mml 'best))))
+ (message-forward-make-body-mime forward-buffer))
(message-forward-make-body-plain forward-buffer)))
(message-position-point))
diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el
index 7e10e15..c2bb960 100644
--- a/lisp/gnus/nntp.el
+++ b/lisp/gnus/nntp.el
@@ -1209,7 +1209,7 @@ If SEND-IF-FORCE, only send authinfo to the server if the
(read-passwd (format "NNTP (%s@%s) password: "
user nntp-address)))))))
(if (not result)
- (signal 'nntp-authinfo-rejected "Password rejected")
+ (error "Password rejected")
result))))))
;;; Internal functions.
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index d559221..da90519 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -1653,6 +1653,9 @@ in `describe-keymap'. See also `Searching the Active
Keymaps'."
(get-char-property (point) 'local-map)
(current-local-map)))))
+(defvar keymap-name-history nil
+ "History for input to `describe-keymap'.")
+
;;;###autoload
(defun describe-keymap (keymap)
"Describe key bindings in KEYMAP.
diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el
index ed5c9c0..44574ab 100644
--- a/lisp/ibuf-ext.el
+++ b/lisp/ibuf-ext.el
@@ -1497,10 +1497,10 @@ Ordering is lexicographic."
(string-lessp
;; FIXME: For now just compare the file name and the process name
;; (if it exists). Is there a better way to do this?
- (or (buffer-file-name (car a))
+ (or (with-current-buffer (car a) (ibuffer-buffer-file-name))
(let ((pr-a (get-buffer-process (car a))))
(and (processp pr-a) (process-name pr-a))))
- (or (buffer-file-name (car b))
+ (or (with-current-buffer (car b) (ibuffer-buffer-file-name))
(let ((pr-b (get-buffer-process (car b))))
(and (processp pr-b) (process-name pr-b))))))
diff --git a/lisp/image.el b/lisp/image.el
index 8140355..6955a90 100644
--- a/lisp/image.el
+++ b/lisp/image.el
@@ -264,9 +264,9 @@ compatibility with versions of Emacs that lack the variable
;; Used to be in image-type-header-regexps, but now not used anywhere
;; (since 2009-08-28).
(defun image-jpeg-p (data)
- (declare (obsolete "It is unused inside Emacs and will be removed." "27.1"))
"Value is non-nil if DATA, a string, consists of JFIF image data.
We accept the tag Exif because that is the same format."
+ (declare (obsolete "It is unused inside Emacs and will be removed." "27.1"))
(setq data (ignore-errors (string-to-unibyte data)))
(when (and data (string-match-p "\\`\xff\xd8" data))
(catch 'jfif
diff --git a/lisp/isearch.el b/lisp/isearch.el
index c6f7fe7..a866785 100644
--- a/lisp/isearch.el
+++ b/lisp/isearch.el
@@ -3757,23 +3757,27 @@ since they have special meaning in a regexp."
(overlay-put isearch-overlay 'priority 1001)
(overlay-put isearch-overlay 'face isearch-face)))
- (when (and search-highlight-submatches
- isearch-regexp)
+ (when (and search-highlight-submatches isearch-regexp)
(mapc 'delete-overlay isearch-submatches-overlays)
(setq isearch-submatches-overlays nil)
- (let ((submatch-data (cddr (butlast match-data)))
+ ;; 'cddr' removes whole expression match from match-data
+ (let ((submatch-data (cddr match-data))
(group 0)
- ov face)
+ b e ov face)
(while submatch-data
- (setq group (1+ group))
- (setq ov (make-overlay (pop submatch-data) (pop submatch-data))
- face (intern-soft (format "isearch-group-%d" group)))
- ;; Recycle faces from beginning.
- (unless (facep face)
- (setq group 1 face 'isearch-group-1))
- (overlay-put ov 'face face)
- (overlay-put ov 'priority 1002)
- (push ov isearch-submatches-overlays)))))
+ (setq b (pop submatch-data)
+ e (pop submatch-data))
+ (when (and (integer-or-marker-p b)
+ (integer-or-marker-p e))
+ (setq ov (make-overlay b e)
+ group (1+ group)
+ face (intern-soft (format "isearch-group-%d" group)))
+ ;; Recycle faces from beginning
+ (unless (facep face)
+ (setq group 1 face 'isearch-group-1))
+ (overlay-put ov 'face face)
+ (overlay-put ov 'priority 1002)
+ (push ov isearch-submatches-overlays))))))
(defun isearch-dehighlight ()
(when isearch-overlay
diff --git a/lisp/mail/flow-fill.el b/lisp/mail/flow-fill.el
index e93ba54..0fab1b2 100644
--- a/lisp/mail/flow-fill.el
+++ b/lisp/mail/flow-fill.el
@@ -174,8 +174,8 @@ lines."
(defvar fill-flowed-encode-tests)
(defun fill-flowed-test ()
- (interactive "")
(declare (obsolete nil "27.1"))
+ (interactive "")
(user-error (concat "This function is obsolete. Please see "
"test/lisp/mail/flow-fill-tests.el "
"in the Emacs source tree")))
diff --git a/lisp/mail/footnote.el b/lisp/mail/footnote.el
index ea109ee..995ae5f 100644
--- a/lisp/mail/footnote.el
+++ b/lisp/mail/footnote.el
@@ -910,7 +910,31 @@ play around with the following keys:
(unless (assoc bullet-regexp filladapt-token-table)
(setq filladapt-token-table
(append filladapt-token-table
- (list (list bullet-regexp 'bullet)))))))))
+ (list (list bullet-regexp 'bullet)))))))
+ (footnote--regenerate-alist)))
+
+(defun footnote--regenerate-alist ()
+ (save-excursion
+ (goto-char (point-min))
+ (when (re-search-forward footnote-section-tag-regexp nil t)
+ (setq footnote--markers-alist
+ (cl-loop
+ with start-of-footnotes = (match-beginning 0)
+ with regexp = (footnote--current-regexp)
+ for (note text) in
+ (cl-loop for pos = (re-search-forward regexp nil t)
+ while pos
+ collect (list (match-string 1)
+ (copy-marker (match-beginning 0) t)))
+ do (goto-char (point-min))
+ collect (cl-list*
+ (string-to-number note)
+ text
+ (cl-loop
+ for pos = (re-search-forward regexp start-of-footnotes
t)
+ while pos
+ when (equal note (match-string 1))
+ collect (copy-marker (match-beginning 0) t))))))))
(provide 'footnote)
diff --git a/lisp/mail/rmailedit.el b/lisp/mail/rmailedit.el
index 2680ed7..c3b351d 100644
--- a/lisp/mail/rmailedit.el
+++ b/lisp/mail/rmailedit.el
@@ -145,8 +145,9 @@ This function runs the hooks `text-mode-hook' and
`rmail-edit-mode-hook'.
(declare-function rmail-summary-enable "rmailsum" ())
(declare-function rmail-summary-update-line "rmailsum" (n))
-(defun rmail-cease-edit ()
- "Finish editing message; switch back to Rmail proper."
+(defun rmail-cease-edit (&optional abort)
+ "Finish editing message; switch back to Rmail proper.
+If ABORT, this is the result of aborting an edit."
(interactive)
(if (rmail-summary-exists)
(with-current-buffer rmail-summary-buffer
@@ -271,6 +272,8 @@ This function runs the hooks `text-mode-hook' and
`rmail-edit-mode-hook'.
;; No match for rmail-mime-charset-pattern, but there was some
;; other Content-Type. We should not insert another. (Bug#4624)
(content-type)
+ ;; Don't insert anything if aborting.
+ (abort)
((null old-coding)
;; If there was no charset= spec, insert one.
(backward-char 1)
@@ -352,7 +355,7 @@ This function runs the hooks `text-mode-hook' and
`rmail-edit-mode-hook'.
(widen)
(delete-region (point-min) (point-max))
(insert rmail-old-text)
- (rmail-cease-edit)
+ (rmail-cease-edit t)
(rmail-highlight-headers))
(defun rmail-edit-headers-alist (&optional widen markers)
diff --git a/lisp/mh-e/mh-speed.el b/lisp/mh-e/mh-speed.el
index 35d5884..00b9680 100644
--- a/lisp/mh-e/mh-speed.el
+++ b/lisp/mh-e/mh-speed.el
@@ -128,8 +128,8 @@ With non-nil FORCE, the update is always carried out."
(defun mh-speed-toggle (&rest ignored)
"Toggle the display of child folders in the speedbar.
The optional arguments from speedbar are IGNORED."
- (interactive)
(declare (ignore args))
+ (interactive)
(beginning-of-line)
(let ((parent (get-text-property (point) 'mh-folder))
(kids-p (get-text-property (point) 'mh-children-p))
@@ -167,8 +167,8 @@ The optional arguments from speedbar are IGNORED."
(defun mh-speed-view (&rest ignored)
"Visits the selected folder just as if you had used
\\<mh-folder-mode-map>\\[mh-visit-folder].
The optional arguments from speedbar are IGNORED."
- (interactive)
(declare (ignore args))
+ (interactive)
(let* ((folder (get-text-property (mh-line-beginning-position) 'mh-folder))
(range (and (stringp folder)
(mh-read-range "Scan" folder t nil nil
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index e8ee372..618a9fb 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -2608,12 +2608,11 @@ The method used must be an out-of-band method."
(defun tramp-sh-handle-insert-directory
(filename switches &optional wildcard full-directory-p)
"Like `insert-directory' for Tramp files."
- (setq filename (expand-file-name filename))
(unless switches (setq switches ""))
;; Check, whether directory is accessible.
(unless wildcard
(access-file filename "Reading directory"))
- (with-parsed-tramp-file-name filename nil
+ (with-parsed-tramp-file-name (expand-file-name filename) nil
(if (and (featurep 'ls-lisp)
(not (symbol-value 'ls-lisp-use-insert-directory-program)))
(tramp-handle-insert-directory
@@ -4306,11 +4305,14 @@ file exists and nonzero exit status otherwise."
;; ensure they have the correct values when the shell starts, not
;; just processes run within the shell. (Which processes include
;; our initial probes to ensure the remote shell is usable.)
+ ;; For the time being, we assume that all shells interpret -i as
+ ;; interactive shell. Must be the last argument, because (for
+ ;; example) bash expects long options first.
(tramp-send-command
vec (format
(concat
"exec env TERM='%s' INSIDE_EMACS='%s,tramp:%s' "
- "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s")
+ "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s -i")
tramp-terminal-type
(or (getenv "INSIDE_EMACS") emacs-version) tramp-version
(or (getenv-internal "ENV" tramp-remote-process-environment) "")
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index 2816c58..7b34a74 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -1990,6 +1990,8 @@ the resulting error message."
(tramp-dissect-file-name default-directory) 0 fmt-string arguments)
(apply #'message fmt-string arguments)))
+(put #'tramp-test-message 'tramp-suppress-trace t)
+
;; This function provides traces in case of errors not triggered by
;; Tramp functions.
(defun tramp-signal-hook-function (error-symbol data)
@@ -3801,15 +3803,20 @@ It does not support `:stderr'."
(get-buffer-create buffer)
;; BUFFER can be nil. We use a temporary buffer.
(generate-new-buffer tramp-temp-buffer-name)))
- ;; We use as environment the difference to toplevel
- ;; `process-environment'.
(env (mapcar
(lambda (elt)
- (unless
- (member
- elt (default-toplevel-value 'process-environment))
- (when (string-match-p "=" elt) elt)))
- process-environment))
+ (when (string-match-p "=" elt) elt))
+ tramp-remote-process-environment))
+ ;; We use as environment the difference to toplevel
+ ;; `process-environment'.
+ (env (dolist (elt process-environment env)
+ (when
+ (and
+ (string-match-p "=" elt)
+ (not
+ (member
+ elt (default-toplevel-value
'process-environment))))
+ (setq env (cons elt env)))))
(env (setenv-internal
env "INSIDE_EMACS"
(concat (or (getenv "INSIDE_EMACS") emacs-version)
diff --git a/lisp/net/webjump.el b/lisp/net/webjump.el
index 9bcf1d3..e5941ae 100644
--- a/lisp/net/webjump.el
+++ b/lisp/net/webjump.el
@@ -2,9 +2,10 @@
;; Copyright (C) 1996-1997, 2001-2021 Free Software Foundation, Inc.
-;; Author: Neil W. Van Dyke <nwv@acm.org>
-;; Created: 09-Aug-1996
-;; Keywords: comm www
+;; Author: Neil W. Van Dyke <nwv@acm.org>
+;; Maintainer: emacs-devel@gnu.org
+;; Created: 09-Aug-1996
+;; Keywords: comm www
;; This file is part of GNU Emacs.
diff --git a/lisp/nxml/nxml-mode.el b/lisp/nxml/nxml-mode.el
index 5bc3049..0602943 100644
--- a/lisp/nxml/nxml-mode.el
+++ b/lisp/nxml/nxml-mode.el
@@ -54,26 +54,30 @@
"Non-nil means display glyph following character reference.
The glyph is displayed in face `nxml-glyph'."
:group 'nxml
- :type 'boolean)
+ :type 'boolean
+ :safe #'booleanp)
(defcustom nxml-sexp-element-flag t
"Non-nil means sexp commands treat an element as a single expression."
:version "27.1" ; nil -> t
:group 'nxml
- :type 'boolean)
+ :type 'boolean
+ :safe #'booleanp)
(defcustom nxml-slash-auto-complete-flag nil
"Non-nil means typing a slash automatically completes the end-tag.
This is used by `nxml-electric-slash'."
:group 'nxml
- :type 'boolean)
+ :type 'boolean
+ :safe #'booleanp)
(defcustom nxml-child-indent 2
"Indentation for the children of an element relative to the start-tag.
This only applies when the line or lines containing the start-tag contains
nothing else other than that start-tag."
:group 'nxml
- :type 'integer)
+ :type 'integer
+ :safe #'integerp)
(defcustom nxml-attribute-indent 4
"Indentation for the attributes of an element relative to the start-tag.
@@ -81,12 +85,14 @@ This only applies when the first attribute of a tag starts
a line.
In other cases, the first attribute on one line is indented the same
as the first attribute on the previous line."
:group 'nxml
- :type 'integer)
+ :type 'integer
+ :safe #'integerp)
(defcustom nxml-bind-meta-tab-to-complete-flag t
"Non-nil means to use nXML completion in \\[completion-at-point]."
:group 'nxml
- :type 'boolean)
+ :type 'boolean
+ :safe #'booleanp)
(defcustom nxml-prefer-utf-16-to-utf-8-flag nil
"Non-nil means prefer UTF-16 to UTF-8 when saving a buffer.
@@ -94,7 +100,8 @@ This is used only when a buffer does not contain an encoding
declaration
and when its current `buffer-file-coding-system' specifies neither UTF-16
nor UTF-8."
:group 'nxml
- :type 'boolean)
+ :type 'boolean
+ :safe #'booleanp)
(defcustom nxml-prefer-utf-16-little-to-big-endian-flag (eq system-type
'windows-nt)
@@ -103,7 +110,8 @@ This is used only for saving a buffer; when reading the
byte-order is
auto-detected. It may be relevant both when there is no encoding declaration
and when the encoding declaration specifies `UTF-16'."
:group 'nxml
- :type 'boolean)
+ :type 'boolean
+ :safe #'booleanp)
(defcustom nxml-default-buffer-file-coding-system nil
"Default value for `buffer-file-coding-system' for a buffer for a new file.
@@ -112,13 +120,15 @@ A value of nil means use the default value of
A buffer's `buffer-file-coding-system' affects what
\\[nxml-insert-xml-declaration] inserts."
:group 'nxml
- :type 'coding-system)
+ :type 'coding-system
+ :safe #'coding-system-p)
(defcustom nxml-auto-insert-xml-declaration-flag nil
"Non-nil means automatically insert an XML declaration in a new file.
The XML declaration is inserted using `nxml-insert-xml-declaration'."
:group 'nxml
- :type 'boolean)
+ :type 'boolean
+ :safe #'booleanp)
(defface nxml-delimited-data
'((t (:inherit font-lock-doc-face)))
diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el
index 2a2a497..d047dd5 100644
--- a/lisp/progmodes/perl-mode.el
+++ b/lisp/progmodes/perl-mode.el
@@ -95,6 +95,12 @@
:prefix "perl-"
:group 'languages)
+(defface perl-non-scalar-variable
+ '((t :inherit font-lock-variable-name-face :underline t))
+ "Face used for non-scalar variables."
+ :version "28.1"
+ :group 'perl)
+
(defvar perl-mode-abbrev-table nil
"Abbrev table in use in perl-mode buffers.")
(define-abbrev-table 'perl-mode-abbrev-table ())
@@ -187,11 +193,12 @@
;;
;; Fontify function, variable and file name references.
("&\\(\\sw+\\(::\\sw+\\)*\\)" 1 font-lock-function-name-face)
- ;; Additionally underline non-scalar variables. Maybe this is a bad idea.
+ ;; Additionally fontify non-scalar variables. `perl-non-scalar-variable'
+ ;; will underline them by default.
;;'("[$@%*][#{]?\\(\\sw+\\)" 1 font-lock-variable-name-face)
("[$*]{?\\(\\sw+\\(::\\sw+\\)*\\)" 1 font-lock-variable-name-face)
("\\([@%]\\|\\$#\\)\\(\\sw+\\(::\\sw+\\)*\\)"
- (2 (cons font-lock-variable-name-face '(underline))))
+ (2 'perl-non-scalar-variable))
("<\\(\\sw+\\)>" 1 font-lock-constant-face)
;;
;; Fontify keywords with/and labels as we do in `c++-font-lock-keywords'.
diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el
index 06966f3..768cd58 100644
--- a/lisp/progmodes/project.el
+++ b/lisp/progmodes/project.el
@@ -928,6 +928,7 @@ if one already exists."
;;;###autoload
(defun project-async-shell-command ()
"Run `async-shell-command' in the current project's root directory."
+ (declare (interactive-only async-shell-command))
(interactive)
(let ((default-directory (project-root (project-current t))))
(call-interactively #'async-shell-command)))
@@ -935,6 +936,7 @@ if one already exists."
;;;###autoload
(defun project-shell-command ()
"Run `shell-command' in the current project's root directory."
+ (declare (interactive-only shell-command))
(interactive)
(let ((default-directory (project-root (project-current t))))
(call-interactively #'shell-command)))
@@ -972,6 +974,7 @@ loop using the command \\[fileloop-continue]."
;;;###autoload
(defun project-compile ()
"Run `compile' in the project root."
+ (declare (interactive-only compile))
(interactive)
(let ((default-directory (project-root (project-current t))))
(call-interactively #'compile)))
diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el
index a417de3..cc045a1 100644
--- a/lisp/progmodes/sh-script.el
+++ b/lisp/progmodes/sh-script.el
@@ -1556,7 +1556,7 @@ with your script for an edit-interpret-debug cycle."
(sh-set-shell
(cond ((save-excursion
(goto-char (point-min))
- (looking-at "#![ \t]?\\([^ \t\n]*/bin/env[ \t]\\)?\\([^
\t\n]+\\)"))
+ (looking-at auto-mode-interpreter-regexp))
(match-string 2))
((not buffer-file-name) sh-shell-file)
;; Checks that use `buffer-file-name' follow.
@@ -2927,8 +2927,8 @@ option followed by a colon `:' if the option accepts an
argument."
(put 'sh-assignment 'delete-selection t)
(defun sh-assignment (arg)
"Remember preceding identifier for future completion and do self-insert."
- (interactive "p")
(declare (obsolete nil "27.1"))
+ (interactive "p")
(self-insert-command arg)
(sh--assignment-collect))
diff --git a/lisp/replace.el b/lisp/replace.el
index 8f8cbfa..db5b340 100644
--- a/lisp/replace.el
+++ b/lisp/replace.el
@@ -2425,23 +2425,27 @@ It is called with three arguments, as if it were
(overlay-put replace-overlay 'priority 1001) ;higher than lazy overlays
(overlay-put replace-overlay 'face 'query-replace)))
- (when (and query-replace-highlight-submatches
- regexp-flag)
+ (when (and query-replace-highlight-submatches regexp-flag)
(mapc 'delete-overlay replace-submatches-overlays)
(setq replace-submatches-overlays nil)
- (let ((submatch-data (cddr (butlast (match-data t))))
+ ;; 'cddr' removes whole expression match from match-data
+ (let ((submatch-data (cddr (match-data t)))
(group 0)
- ov face)
+ b e ov face)
(while submatch-data
- (setq group (1+ group))
- (setq ov (make-overlay (pop submatch-data) (pop submatch-data))
- face (intern-soft (format "isearch-group-%d" group)))
- ;; Recycle faces from beginning.
- (unless (facep face)
- (setq group 1 face 'isearch-group-1))
- (overlay-put ov 'face face)
- (overlay-put ov 'priority 1002)
- (push ov replace-submatches-overlays))))
+ (setq b (pop submatch-data)
+ e (pop submatch-data))
+ (when (and (integer-or-marker-p b)
+ (integer-or-marker-p e))
+ (setq ov (make-overlay b e)
+ group (1+ group)
+ face (intern-soft (format "isearch-group-%d" group)))
+ ;; Recycle faces from beginning
+ (unless (facep face)
+ (setq group 1 face 'isearch-group-1))
+ (overlay-put ov 'face face)
+ (overlay-put ov 'priority 1002)
+ (push ov replace-submatches-overlays)))))
(if query-replace-lazy-highlight
(let ((isearch-string search-string)
diff --git a/lisp/simple.el b/lisp/simple.el
index 37c0885..2c6e391 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -7338,10 +7338,7 @@ even beep.)"
;; of the kill before killing.
(let ((opoint (point))
(kill-whole-line (and kill-whole-line (bolp)))
- (orig-y (cdr (nth 2 (posn-at-point))))
- ;; FIXME: This tolerance should be zero! It isn't due to a
- ;; bug in posn-at-point, see bug#45837.
- (tol (/ (line-pixel-height) 2)))
+ (orig-vlnum (cdr (nth 6 (posn-at-point)))))
(if arg
(vertical-motion (prefix-numeric-value arg))
(end-of-visual-line 1)
@@ -7352,8 +7349,8 @@ even beep.)"
;; end-of-visual-line didn't overshoot due to complications
;; like display or overlay strings, intangible text, etc.:
;; otherwise, we don't want to kill a character that's
- ;; unrelated to the place where the visual line wrapped.
- (and (< (abs (- (cdr (nth 2 (posn-at-point))) orig-y)) tol)
+ ;; unrelated to the place where the visual line wraps.
+ (and (= (cdr (nth 6 (posn-at-point))) orig-vlnum)
;; Make sure we delete the character where the line wraps
;; under visual-line-mode, be it whitespace or a
;; character whose category set allows to wrap at it.
diff --git a/lisp/startup.el b/lisp/startup.el
index 552802a..7011fbf 100644
--- a/lisp/startup.el
+++ b/lisp/startup.el
@@ -1172,6 +1172,7 @@ please check its value")
;; are dependencies between them.
(nreverse custom-delayed-init-variables))
(mapc #'custom-reevaluate-setting custom-delayed-init-variables)
+ (setq custom-delayed-init-variables nil)
;; Warn for invalid user name.
(when init-file-user
@@ -1301,12 +1302,6 @@ please check its value")
(startup--setup-quote-display)
(setq internal--text-quoting-flag t))
- ;; Re-evaluate again the predefined variables whose initial value
- ;; depends on the runtime context, in case some of them depend on
- ;; the window-system features. Example: blink-cursor-mode.
- (mapc #'custom-reevaluate-setting custom-delayed-init-variables)
- (setq custom-delayed-init-variables nil)
-
(normal-erase-is-backspace-setup-frame)
;; Register default TTY colors for the case the terminal hasn't a
@@ -1487,13 +1482,13 @@ to reading the init file), or afterwards when the user
first
opens a graphical frame.
This can set the values of `menu-bar-mode', `tool-bar-mode',
-`tab-bar-mode', and `no-blinking-cursor', as well as the `cursor' face.
+`tab-bar-mode', and `blink-cursor-mode', as well as the `cursor' face.
Changed settings will be marked as \"CHANGED outside of Customize\"."
(let ((no-vals '("no" "off" "false" "0"))
(settings '(("menuBar" "MenuBar" menu-bar-mode nil)
("toolBar" "ToolBar" tool-bar-mode nil)
("scrollBar" "ScrollBar" scroll-bar-mode nil)
- ("cursorBlink" "CursorBlink" no-blinking-cursor t))))
+ ("cursorBlink" "CursorBlink" blink-cursor-mode nil))))
(dolist (x settings)
(if (member (x-get-resource (nth 0 x) (nth 1 x)) no-vals)
(set (nth 2 x) (nth 3 x)))))
diff --git a/lisp/textmodes/remember.el b/lisp/textmodes/remember.el
index 98d3a38..811a265 100644
--- a/lisp/textmodes/remember.el
+++ b/lisp/textmodes/remember.el
@@ -159,7 +159,8 @@
;; ;; This should be before other entries that may return t
;; (add-to-list 'remember-handler-functions 'remember-diary-extract-entries)
;;
-;; This module recognizes entries of the form
+;; This module recognizes entries of the form (defined by
+;; `remember-diary-regexp')
;;
;; DIARY: ....
;;
@@ -410,13 +411,24 @@ The default emulates `current-time-string' for backward
compatibility."
:group 'remember
:version "27.1")
+(defcustom remember-text-format-function nil
+ "The function to format the remembered text.
+The function receives the remembered text as argument and should
+return the text to be remembered."
+ :type 'function
+ :group 'remember
+ :version "28.1")
+
(defun remember-append-to-file ()
"Remember, with description DESC, the given TEXT."
(let* ((text (buffer-string))
(desc (remember-buffer-desc))
- (remember-text (concat "\n" remember-leader-text
- (format-time-string remember-time-format)
- " (" desc ")\n\n" text
+ (remember-text (concat "\n"
+ (if remember-text-format-function
+ (funcall remember-text-format-function
text)
+ (concat remember-leader-text
+ (format-time-string
remember-time-format)
+ " (" desc ")\n\n" text))
(save-excursion (goto-char (point-max))
(if (bolp) nil "\n"))))
(buf (find-buffer-visiting remember-data-file)))
@@ -532,17 +544,28 @@ If this is nil, then `diary-file' will be used instead."
(autoload 'diary-make-entry "diary-lib")
+(defcustom remember-diary-regexp "^DIARY:\\s-*\\(.+\\)"
+ "Regexp to extract diary entries."
+ :type 'regexp
+ :version "28.1")
+
+(defvar diary-file)
+
;;;###autoload
(defun remember-diary-extract-entries ()
- "Extract diary entries from the region."
+ "Extract diary entries from the region based on `remember-diary-regexp'."
(save-excursion
(goto-char (point-min))
(let (list)
- (while (re-search-forward "^DIARY:\\s-*\\(.+\\)" nil t)
+ (while (re-search-forward remember-diary-regexp nil t)
(push (remember-diary-convert-entry (match-string 1)) list))
(when list
(diary-make-entry (mapconcat 'identity list "\n")
- nil remember-diary-file))
+ nil remember-diary-file)
+ (when remember-save-after-remembering
+ (with-current-buffer (find-buffer-visiting (or remember-diary-file
+ diary-file))
+ (save-buffer))))
nil))) ;; Continue processing
;;; Internal Functions:
diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el
index d3ba941..67d4092 100644
--- a/lisp/thingatpt.el
+++ b/lisp/thingatpt.el
@@ -218,6 +218,15 @@ The bounds of THING are determined by
`bounds-of-thing-at-point'."
(put 'sexp 'beginning-op 'thing-at-point--beginning-of-sexp)
+;; Symbols
+
+(put 'symbol 'beginning-op 'thing-at-point--beginning-of-symbol)
+
+(defun thing-at-point--beginning-of-symbol ()
+ "Move point to the beginning of the current symbol."
+ (and (re-search-backward "\\(\\sw\\|\\s_\\)+")
+ (skip-syntax-backward "w_")))
+
;; Lists
(put 'list 'bounds-of-thing-at-point 'thing-at-point-bounds-of-list-at-point)
diff --git a/lisp/type-break.el b/lisp/type-break.el
index 84c240c..a6d5cd0 100644
--- a/lisp/type-break.el
+++ b/lisp/type-break.el
@@ -487,7 +487,7 @@ Return nil if the file is missing or if the time is not a
Lisp time value."
(goto-char (point-min))
(read (current-buffer)))
(end-of-file
- (error "End of file in `%s'" file))))))))
+ (warn "End of file in `%s'" file))))))))
(defun type-break-get-previous-count ()
"Get previous keystroke count from `type-break-file-name'.
@@ -505,7 +505,7 @@ integer."
(forward-line 1)
(read (current-buffer)))
(end-of-file
- (error "End of file in `%s'" file)))))))
+ (warn "End of file in `%s'" file)))))))
file
0)))
diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el
index 6c96d8c..bc9f112 100644
--- a/lisp/vc/vc.el
+++ b/lisp/vc/vc.el
@@ -2392,6 +2392,7 @@ If it contains `file', show short logs for files.
Not all VC backends support short logs!")
(defvar log-view-vc-fileset)
+(defvar log-view-message-re)
(defun vc-print-log-setup-buttons (working-revision is-start-revision limit
pl-return)
"Insert at the end of the current buffer buttons to show more log entries.
@@ -2401,21 +2402,32 @@ Does nothing if IS-START-REVISION is non-nil, or if
LIMIT is nil,
or if PL-RETURN is `limit-unsupported'."
(when (and limit (not (eq 'limit-unsupported pl-return))
(not is-start-revision))
- (goto-char (point-max))
- (insert "\n")
- (insert-text-button "Show 2X entries"
- 'action (lambda (&rest _ignore)
- (vc-print-log-internal
- log-view-vc-backend log-view-vc-fileset
- working-revision nil (* 2 limit)))
- 'help-echo "Show the log again, and double the number
of log entries shown")
- (insert " ")
- (insert-text-button "Show unlimited entries"
- 'action (lambda (&rest _ignore)
- (vc-print-log-internal
- log-view-vc-backend log-view-vc-fileset
- working-revision nil nil))
- 'help-echo "Show the log again, including all
entries")))
+ (let ((entries 0))
+ (goto-char (point-min))
+ (while (re-search-forward log-view-message-re nil t)
+ (cl-incf entries))
+ ;; If we got fewer entries than we asked for, then displaying
+ ;; the "more" buttons isn't useful.
+ (when (>= entries limit)
+ (goto-char (point-max))
+ (insert "\n")
+ (insert-text-button
+ "Show 2X entries"
+ 'action (lambda (&rest _ignore)
+ (vc-print-log-internal
+ log-view-vc-backend log-view-vc-fileset
+ working-revision nil (* 2 limit)))
+ 'help-echo
+ "Show the log again, and double the number of log entries shown")
+ (insert " ")
+ (insert-text-button
+ "Show unlimited entries"
+ 'action (lambda (&rest _ignore)
+ (vc-print-log-internal
+ log-view-vc-backend log-view-vc-fileset
+ working-revision nil nil))
+ 'help-echo "Show the log again, including all entries")
+ (insert "\n")))))
(defun vc-print-log-internal (backend files working-revision
&optional is-start-revision limit type)
diff --git a/lisp/version.el b/lisp/version.el
index fcfc2f8..3a3093f 100644
--- a/lisp/version.el
+++ b/lisp/version.el
@@ -29,14 +29,12 @@
(defconst emacs-major-version
(progn (string-match "^[0-9]+" emacs-version)
(string-to-number (match-string 0 emacs-version)))
- "Major version number of this version of Emacs.
-This variable first existed in version 19.23.")
+ "Major version number of this version of Emacs.")
(defconst emacs-minor-version
(progn (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version)
(string-to-number (match-string 1 emacs-version)))
- "Minor version number of this version of Emacs.
-This variable first existed in version 19.23.")
+ "Minor version number of this version of Emacs.")
(defconst emacs-build-system (system-name)
"Name of the system on which Emacs was built, or nil if not available.")
diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el
index 7dda04e..68a0d3d 100644
--- a/lisp/wid-edit.el
+++ b/lisp/wid-edit.el
@@ -4026,17 +4026,19 @@ is inline."
;;; The `color' Widget.
-;; Fixme: match
(define-widget 'color 'editable-field
"Choose a color name (with sample)."
:format "%{%t%}: %v (%{sample%})\n"
:value-create 'widget-color-value-create
- :size 10
+ :size (1+ (apply #'max 13 ; Longest RGB hex string.
+ (mapcar #'length (defined-colors))))
:tag "Color"
:value "black"
:completions (or facemenu-color-alist (defined-colors))
:sample-face-get 'widget-color-sample-face-get
:notify 'widget-color-notify
+ :match #'widget-color-match
+ :validate #'widget-color-validate
:action 'widget-color-action)
(defun widget-color-value-create (widget)
@@ -4085,6 +4087,19 @@ is inline."
(overlay-put (widget-get widget :sample-overlay)
'face (widget-apply widget :sample-face-get))
(widget-default-notify widget child event))
+
+(defun widget-color-match (_widget value)
+ "Non-nil if VALUE is a defined color or a RGB hex string."
+ (and (stringp value)
+ (or (color-defined-p value)
+ (string-match-p "^#\\(?:[[:xdigit:]]\\{3\\}\\)\\{1,4\\}$" value))))
+
+(defun widget-color-validate (widget)
+ "Check that WIDGET's value is a valid color."
+ (let ((value (widget-value widget)))
+ (unless (widget-color-match widget value)
+ (widget-put widget :error (format "Invalid color: %S" value))
+ widget)))
;;; The Help Echo
diff --git a/src/alloc.c b/src/alloc.c
index c0a55e6..b86ed4e 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -6101,11 +6101,13 @@ garbage_collect (void)
gc_in_progress = 0;
- unblock_input ();
-
consing_until_gc = gc_threshold
= consing_threshold (gc_cons_threshold, Vgc_cons_percentage, 0);
+ /* Unblock *after* re-setting `consing_until_gc` in case `unblock_input`
+ signals an error (see bug#43389). */
+ unblock_input ();
+
if (garbage_collection_messages && NILP (Vmemory_full))
{
if (message_p || minibuf_level > 0)
diff --git a/src/process.c b/src/process.c
index 09f8790..5710598 100644
--- a/src/process.c
+++ b/src/process.c
@@ -7179,6 +7179,8 @@ child_signal_init (void)
exits. */
eassert (0 <= fds[0]);
eassert (0 <= fds[1]);
+ if (fcntl (fds[0], F_SETFL, O_NONBLOCK) != 0)
+ emacs_perror ("fcntl");
add_read_fd (fds[0], child_signal_read, NULL);
fd_callback_info[fds[0]].flags &= ~KEYBOARD_FD;
child_signal_read_fd = fds[0];
diff --git a/src/window.c b/src/window.c
index e025e0b..eb16e2a 100644
--- a/src/window.c
+++ b/src/window.c
@@ -2260,7 +2260,7 @@ return value is a list of elements of the form (PARAMETER
. VALUE). */)
Lisp_Object
window_parameter (struct window *w, Lisp_Object parameter)
{
- Lisp_Object result = Fassq (parameter, w->window_parameters);
+ Lisp_Object result = assq_no_quit (parameter, w->window_parameters);
return CDR_SAFE (result);
}
diff --git a/test/Makefile.in b/test/Makefile.in
index 4ca43c8..c5e86df 100644
--- a/test/Makefile.in
+++ b/test/Makefile.in
@@ -247,7 +247,7 @@ endef
$(foreach test,${TESTS},$(eval $(call test_template,${test})))
## Get the tests for only a specific directory.
-SUBDIRS = $(sort $(shell find lisp src -type d ! -path "*resources*" -print))
+SUBDIRS = $(sort $(shell find lib-src lisp src -type d ! -path "*resources*"
-print))
define subdir_template
.PHONY: check-$(subst /,-,$(1))
diff --git a/test/README b/test/README
index 58f5f38..5f3c10a 100644
--- a/test/README
+++ b/test/README
@@ -60,7 +60,9 @@
https://www.gnu.org/software/emacs/manual/html_node/ert/Test-Selectors.html
You could use predefined selectors of the Makefile. "make <filename>
SELECTOR='$(SELECTOR_DEFAULT)'" runs all tests for <filename>.el
-except the tests tagged as expensive or unstable.
+except the tests tagged as expensive or unstable. Other predefined
+selectors are $(SELECTOR_EXPENSIVE) (run all tests except unstable
+ones) and $(SELECTOR_ALL) (run all tests).
If your test file contains the tests "test-foo", "test2-foo" and
"test-foo-remote", and you want to run only the former two tests, you
diff --git a/test/file-organization.org b/test/file-organization.org
index efc3545..7cf5b88 100644
--- a/test/file-organization.org
+++ b/test/file-organization.org
@@ -17,13 +17,15 @@ Sub-directories are in many cases themed after packages
(~gnus~, ~org~,
~calc~), related functionality (~net~, ~emacs-lisp~, ~progmodes~) or status
(~obsolete~).
-C source is stored in the ~src~ directory, which is flat.
+C source is stored in the ~src~ directory, which is flat. Source for
+utility programs is stored in the ~lib-src~ directory.
** Test Files
Automated tests should be stored in the ~test/lisp~ directory for
-tests of functionality implemented in Lisp, and in the ~test/src~
-directory for functionality implemented in C. Tests should reflect
+tests of functionality implemented in Lisp, in the ~test/src~
+directory for functionality implemented in C, and in the
+~test/lib-src~ directory for utility programs. Tests should reflect
the directory structure of the source tree; so tests for files in the
~lisp/emacs-lisp~ source directory should reside in the
~test/lisp/emacs-lisp~ directory.
@@ -36,10 +38,10 @@ files of any name which are themselves placed in a
directory named
after the feature with ~-tests~ appended, such as
~/test/lisp/emacs-lisp/eieio-tests~
-Similarly, features implemented in C should reside in ~/test/src~ and
-be named after the C file with ~-tests.el~ added to the base-name of
-the tested source file. Thus, tests for ~src/fileio.c~ should be in
-~test/src/fileio-tests.el~.
+Similarly, tests of features implemented in C should reside in
+~/test/src~ or in ~test/lib-src~ and be named after the C file with
+~-tests.el~ added to the base-name of the tested source file. Thus,
+tests for ~src/fileio.c~ should be in ~test/src/fileio-tests.el~.
There are also some test materials that cannot be run automatically
(i.e. via ert). These should be placed in ~/test/manual~; they are
diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml
index 3214f01..2f71d12 100644
--- a/test/infra/gitlab-ci.yml
+++ b/test/infra/gitlab-ci.yml
@@ -49,6 +49,8 @@ variables:
# DOCKER_TLS_CERTDIR: "/certs"
# Put the configuration for each run in a separate directory to avoid
conflicts
DOCKER_CONFIG: "/.docker-config-${CI_COMMIT_SHA}"
+ # We don't use ${CI_COMMIT_SHA} to be able to do one bootstrap across
multiple builds
+ BUILD_TAG: ${CI_COMMIT_REF_SLUG}
default:
image: docker:19.03.12
@@ -96,17 +98,43 @@ default:
# - "**/*.log"
# using the variables for each job
script:
- - docker pull ${CI_REGISTRY_IMAGE}:${target}-${CI_COMMIT_SHA}
+ - docker pull ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG}
# TODO: with make -j4 several of the tests were failing, for example
shadowfile-tests, but passed without it
- - docker run -i --rm -e EMACS_EMBA_CI=${EMACS_EMBA_CI}
${CI_REGISTRY_IMAGE}:${target}-${CI_COMMIT_SHA} make ${make_params}
+ - 'export PWD=$(pwd)'
+ - 'docker run -i --rm -e EMACS_EMBA_CI=${EMACS_EMBA_CI} --volumes-from
$(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):ro
${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} /bin/bash -c "git fetch ${PWD} HEAD
&& echo checking out these updated files && git diff --name-only FETCH_HEAD &&
( git diff --name-only FETCH_HEAD | xargs git checkout -f FETCH_HEAD ) && make
-j4 && make ${make_params}"'
.build-template:
+ rules:
+ - if: '$CI_PIPELINE_SOURCE == "web"'
+ when: always
+ - changes:
+ - "**/Makefile.in"
+ - .gitlab-ci.yml
+ - aclocal.m4
+ - autogen.sh
+ - configure.ac
+ - lib/*.{h,c}
+ - lisp/emacs-lisp/*.el
+ - src/*.{h,c}
+ - test/infra/*
+ - changes:
+ # gfilemonitor, kqueue
+ - src/gfilenotify.c
+ - src/kqueue.c
+ # MS Windows
+ - "**/w32*"
+ # GNUstep
+ - lisp/term/ns-win.el
+ - src/ns*.{h,m}
+ - src/macfont.{h,m}
+ when: never
script:
- - docker build --pull --target ${target} -t
${CI_REGISTRY_IMAGE}:${target}-${CI_COMMIT_SHA} -f test/infra/Dockerfile.emba .
- - docker push ${CI_REGISTRY_IMAGE}:${target}-${CI_COMMIT_SHA}
+ - docker build --pull --target ${target} -t
${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} -f test/infra/Dockerfile.emba .
+ - docker push ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG}
.gnustep-template:
rules:
+ - if: '$CI_PIPELINE_SOURCE == "web"'
- if: '$CI_PIPELINE_SOURCE == "schedule"'
changes:
- "**/Makefile.in"
@@ -120,6 +148,7 @@ default:
.filenotify-gio-template:
rules:
+ - if: '$CI_PIPELINE_SOURCE == "web"'
- if: '$CI_PIPELINE_SOURCE == "schedule"'
changes:
- "**/Makefile.in"
@@ -208,6 +237,7 @@ test-all-inotify:
extends: [.job-template]
rules:
# note there's no "changes" section, so this always runs on a schedule
+ - if: '$CI_PIPELINE_SOURCE == "web"'
- if: '$CI_PIPELINE_SOURCE == "schedule"'
variables:
target: emacs-inotify
diff --git a/test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el
b/test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el
new file mode 100644
index 0000000..4748157
--- /dev/null
+++ b/test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el
@@ -0,0 +1,6 @@
+;; -*- lexical-binding: t; -*-
+
+(defsubst foo-inlineable (foo-var)
+ (+ foo-var 2))
+
+(provide 'foo-inlinable)
diff --git
a/test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el
b/test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el
new file mode 100644
index 0000000..5582b2a
--- /dev/null
+++ b/test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el
@@ -0,0 +1,17 @@
+;; -*- lexical-binding: t; -*-
+
+;; In this test, we try and make sure that inlined functions's code isn't
+;; mistakenly re-interpreted in the caller's context: we import an
+;; inlinable function from another file where `foo-var' is a normal
+;; lexical variable, and then call(inline) it in a function where
+;; `foo-var' is a dynamically-scoped variable.
+
+(require 'foo-inlinable
+ (expand-file-name "foo-inlinable.el"
+ (file-name-directory
+ (or byte-compile-current-file load-file-name))))
+
+(defvar foo-var)
+
+(defun foo-fun ()
+ (+ (foo-inlineable 5) 1))
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el
b/test/lisp/emacs-lisp/bytecomp-tests.el
index 263736a..980b402 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -713,6 +713,10 @@ Subtests signal errors if something goes wrong."
"warn-wide-docstring-multiline.el"
"defvar.*foo.*wider than.*characters")
+(bytecomp--define-warning-file-test
+ "nowarn-inline-after-defvar.el"
+ "Lexical argument shadows" 'reverse)
+
;;;; Macro expansion.
diff --git a/test/lisp/faces-tests.el b/test/lisp/faces-tests.el
index 6e77259..c0db9c9 100644
--- a/test/lisp/faces-tests.el
+++ b/test/lisp/faces-tests.el
@@ -217,5 +217,13 @@
))
)
+(ert-deftest test-tty-find-type ()
+ (let ((pred (lambda (string)
+ (locate-library (concat "term/" string ".el")))))
+ (should (tty-find-type pred "cygwin"))
+ (should (tty-find-type pred "cygwin-foo"))
+ (should (equal (tty-find-type pred "xterm") "xterm"))
+ (should (equal (tty-find-type pred "screen.xterm") "screen"))))
+
(provide 'faces-tests)
;;; faces-tests.el ends here
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index ef0968a..5deee65 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -2272,8 +2272,8 @@ This checks also `file-name-as-directory',
`file-name-directory',
(delete-file tmp-name)
(should-not (file-exists-p tmp-name))
- ;; Trashing files doesn't work for crypted remote files.
- (unless (tramp--test-crypt-p)
+ ;; Trashing files doesn't work on MS Windows, and for crypted remote
files.
+ (unless (or (tramp--test-windows-nt-p) (tramp--test-crypt-p))
(let ((trash-directory (tramp--test-make-temp-name 'local quoted))
(delete-by-moving-to-trash t))
(make-directory trash-directory)
@@ -2786,9 +2786,9 @@ This tests also `file-directory-p' and
`file-accessible-directory-p'."
(should-not (file-directory-p tmp-name1))
;; Trashing directories works only since Emacs 27.1. It doesn't
- ;; work for crypted remote directories and for ange-ftp.
- (when (and (not (tramp--test-crypt-p)) (not (tramp--test-ftp-p))
- (tramp--test-emacs27-p))
+ ;; work on MS Windows, for crypted remote directories and for ange-ftp.
+ (when (and (not (tramp--test-windows-nt-p)) (not (tramp--test-crypt-p))
+ (not (tramp--test-ftp-p)) (tramp--test-emacs27-p))
(let ((trash-directory (tramp--test-make-temp-name 'local quoted))
(delete-by-moving-to-trash t))
(make-directory trash-directory)
@@ -6349,6 +6349,7 @@ process sentinels. They shall not disturb each other."
(tramp--test-sh-p)))
(skip-unless (not (tramp--test-crypt-p)))
(skip-unless (not (tramp--test-docker-p)))
+ (skip-unless (not (tramp--test-windows-nt-p)))
(with-timeout
(tramp--test-asynchronous-requests-timeout (tramp--test-timeout-handler))
@@ -6358,12 +6359,11 @@ process sentinels. They shall not disturb each other."
(shell-file-name (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh"))
;; It doesn't work on w32 systems.
(watchdog
- (unless (tramp--test-windows-nt-p)
- (start-process-shell-command
- "*watchdog*" nil
- (format
- "sleep %d; kill -USR1 %d"
- tramp--test-asynchronous-requests-timeout (emacs-pid)))))
+ (start-process-shell-command
+ "*watchdog*" nil
+ (format
+ "sleep %d; kill -USR1 %d"
+ tramp--test-asynchronous-requests-timeout (emacs-pid))))
(tmp-name (tramp--test-make-temp-name))
(default-directory tmp-name)
;; Do not cache Tramp properties.
diff --git a/test/lisp/replace-tests.el b/test/lisp/replace-tests.el
index 8c2682a..2db570c 100644
--- a/test/lisp/replace-tests.el
+++ b/test/lisp/replace-tests.el
@@ -587,5 +587,18 @@ bound to HIGHLIGHT-LOCUS."
(get-text-property (point) 'occur-target))
(should (funcall check-overlays has-overlay)))))))
+(ert-deftest replace-regexp-bug45973 ()
+ "Test for https://debbugs.gnu.org/45973 ."
+ (let ((before "1RB 1LC 1RC 1RB 1RD 0LE 1LA 1LD 1RH 0LA")
+ (after "1LB 1RC 1LC 1LB 1LD 0RE 1RA 1RD 1LH 0RA"))
+ (with-temp-buffer
+ (insert before)
+ (goto-char (point-min))
+ (replace-regexp
+ "\\(\\(L\\)\\|\\(R\\)\\)"
+ '(replace-eval-replacement
+ replace-quote
+ (if (match-string 2) "R" "L")))
+ (should (equal (buffer-string) after)))))
;;; replace-tests.el ends here
diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el
index c43c81a..62a27f0 100644
--- a/test/lisp/thingatpt-tests.el
+++ b/test/lisp/thingatpt-tests.el
@@ -146,4 +146,48 @@ position to retrieve THING.")
(should (thing-at-point-looking-at "2abcd"))
(should (equal (match-data) m2)))))
+(ert-deftest test-symbol-thing-1 ()
+ (with-temp-buffer
+ (insert "foo bar zot")
+ (goto-char 4)
+ (should (eq (symbol-at-point) 'foo))
+ (forward-char 1)
+ (should (eq (symbol-at-point) 'bar))
+ (forward-char 1)
+ (should (eq (symbol-at-point) 'bar))
+ (forward-char 1)
+ (should (eq (symbol-at-point) 'bar))
+ (forward-char 1)
+ (should (eq (symbol-at-point) 'bar))
+ (forward-char 1)
+ (should (eq (symbol-at-point) 'zot))))
+
+(ert-deftest test-symbol-thing-2 ()
+ (with-temp-buffer
+ (insert " bar ")
+ (goto-char (point-max))
+ (should (eq (symbol-at-point) nil))
+ (forward-char -1)
+ (should (eq (symbol-at-point) 'bar))))
+
+(ert-deftest test-symbol-thing-2 ()
+ (with-temp-buffer
+ (insert " bar ")
+ (goto-char (point-max))
+ (should (eq (symbol-at-point) nil))
+ (forward-char -1)
+ (should (eq (symbol-at-point) 'bar))))
+
+(ert-deftest test-symbol-thing-3 ()
+ (with-temp-buffer
+ (insert "bar")
+ (goto-char 2)
+ (should (eq (symbol-at-point) 'bar))))
+
+(ert-deftest test-symbol-thing-3 ()
+ (with-temp-buffer
+ (insert "`[[`(")
+ (goto-char 2)
+ (should (eq (symbol-at-point) nil))))
+
;;; thingatpt.el ends here
diff --git a/test/lisp/wid-edit-tests.el b/test/lisp/wid-edit-tests.el
index 17fdfef..f843649 100644
--- a/test/lisp/wid-edit-tests.el
+++ b/test/lisp/wid-edit-tests.el
@@ -322,4 +322,15 @@ return nil, even with a non-nil bubblep argument."
(widget-backward 1)
(should (string= "Second" (widget-value (widget-at))))))
+(ert-deftest widget-test-color-match ()
+ "Test that the :match function for the color widget works."
+ (let ((widget (widget-convert 'color)))
+ (should (widget-apply widget :match "red"))
+ (should (widget-apply widget :match "#fa3"))
+ (should (widget-apply widget :match "#ff0000"))
+ (should (widget-apply widget :match "#111222333"))
+ (should (widget-apply widget :match "#111122223333"))
+ (should-not (widget-apply widget :match "someundefinedcolorihope"))
+ (should-not (widget-apply widget :match "#11223"))))
+
;;; wid-edit-tests.el ends here
- scratch/etags-regen updated (153a549 -> f4a1d47), Dmitry Gutov, 2021/02/07
- scratch/etags-regen 8d00e2f 1/8: Merge branch 'master' into scratch/etags-regen, Dmitry Gutov, 2021/02/07
- scratch/etags-regen 1daad17 2/8: Merge branch 'master' into scratch/etags-regen, Dmitry Gutov, 2021/02/07
- scratch/etags-regen 44f19c7 3/8: Merge branch 'master' into scratch/etags-regen,
Dmitry Gutov <=
- scratch/etags-regen 25b2915 7/8: Introduce project-files-filtered and use it, Dmitry Gutov, 2021/02/07
- scratch/etags-regen f4a1d47 8/8: Brute force refresh implementation, Dmitry Gutov, 2021/02/07
- scratch/etags-regen 3098e47 4/8: Merge branch 'master' into scratch/etags-regen, Dmitry Gutov, 2021/02/07
- scratch/etags-regen 4f7b533 6/8: etags-regen--all-files: Extract to a separate function, Dmitry Gutov, 2021/02/07
- scratch/etags-regen f520e5d 5/8: Merge branch 'master' into scratch/etags-regen, Dmitry Gutov, 2021/02/07