aboutsummaryrefslogtreecommitdiffstats
path: root/lisp
diff options
context:
space:
mode:
authorKenichi Handa2012-11-23 23:36:24 +0900
committerKenichi Handa2012-11-23 23:36:24 +0900
commit2aaec2d9be5cec44ea3b59cba476fd3e091f2fc9 (patch)
tree3711b97807201b7eeaa066003b1c3a4ce929e5bb /lisp
parente1d276cbf9e18f13101328f56bed1a1c0a66e63a (diff)
parente7d0e5ee247a155a268ffbf80bedbe25e15b5032 (diff)
downloademacs-2aaec2d9be5cec44ea3b59cba476fd3e091f2fc9.tar.gz
emacs-2aaec2d9be5cec44ea3b59cba476fd3e091f2fc9.zip
Diffstat (limited to 'lisp')
-rw-r--r--lisp/ChangeLog167
-rw-r--r--lisp/allout.el7
-rw-r--r--lisp/calc/README13
-rw-r--r--lisp/calc/calc-forms.el13
-rw-r--r--lisp/calc/calc.el88
-rw-r--r--lisp/calendar/time-date.el13
-rw-r--r--lisp/cedet/ChangeLog13
-rw-r--r--lisp/cedet/semantic/fw.el14
-rw-r--r--lisp/color.el9
-rw-r--r--lisp/emacs-lisp/byte-run.el10
-rw-r--r--lisp/emacs-lisp/bytecomp.el4
-rw-r--r--lisp/emacs-lisp/edebug.el15
-rw-r--r--lisp/emacs-lisp/ert-x.el47
-rw-r--r--lisp/emacs-lisp/ert.el804
-rw-r--r--lisp/emacs-lisp/nadvice.el50
-rw-r--r--lisp/emacs-lisp/trace.el206
-rw-r--r--lisp/erc/ChangeLog13
-rw-r--r--lisp/erc/erc-backend.el156
-rw-r--r--lisp/erc/erc-capab.el1
-rw-r--r--lisp/erc/erc-dcc.el68
-rw-r--r--lisp/erc/erc-ezbounce.el1
-rw-r--r--lisp/erc/erc-join.el1
-rw-r--r--lisp/erc/erc-log.el7
-rw-r--r--lisp/erc/erc-match.el1
-rw-r--r--lisp/erc/erc-netsplit.el7
-rw-r--r--lisp/erc/erc-networks.el14
-rw-r--r--lisp/erc/erc-notify.el4
-rw-r--r--lisp/erc/erc-pcomplete.el1
-rw-r--r--lisp/erc/erc-services.el2
-rw-r--r--lisp/erc/erc-speedbar.el1
-rw-r--r--lisp/erc/erc-track.el26
-rw-r--r--lisp/erc/erc.el99
-rw-r--r--lisp/eshell/em-cmpl.el8
-rw-r--r--lisp/faces.el47
-rw-r--r--lisp/files.el4
-rw-r--r--lisp/find-cmd.el15
-rw-r--r--lisp/gnus/ChangeLog5
-rw-r--r--lisp/gnus/message.el13
-rw-r--r--lisp/json.el1
-rw-r--r--lisp/net/tramp-sh.el16
-rw-r--r--lisp/net/tramp.el2
-rw-r--r--lisp/pcomplete.el3
-rw-r--r--lisp/play/gamegrid.el2
-rw-r--r--lisp/profiler.el54
-rw-r--r--lisp/progmodes/python.el77
-rw-r--r--lisp/progmodes/sql.el19
-rw-r--r--lisp/ps-bdf.el19
-rw-r--r--lisp/simple.el3
-rw-r--r--lisp/subr.el148
-rw-r--r--lisp/term/w32-win.el4
-rw-r--r--lisp/textmodes/table.el2
-rw-r--r--lisp/uniquify.el29
-rw-r--r--lisp/vc/diff-mode.el28
-rw-r--r--lisp/window.el7
54 files changed, 1441 insertions, 940 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index ca65e431964..09f42233f96 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,166 @@
12012-11-23 Chong Yidong <cyd@gnu.org>
2
3 * find-cmd.el (find-constituents): Add executable, ipath,
4 readable, samefile, writable, daystart, regextype (Bug#12856).
5
62012-11-23 Stefan Monnier <monnier@iro.umontreal.ca>
7
8 * emacs-lisp/ert.el, emacs-lisp/ert-x.el: Use cl-lib and lexical-binding.
9
102012-11-22 Paul Eggert <eggert@cs.ucla.edu>
11
12 * calc/calc.el (calc-gregorian-switch): Move to after calc-refresh
13 definition. This fixes a bootstrap failure.
14 (calc-gregorian-switch): In menu, put dates before regions.
15 This is easier to follow, lines up better in the menu, and lets us
16 coalesce regions that switch at the same time. Give country
17 names, not "Vatican", as that's better for non-expert users.
18 Use names that are stable between the date of switch and now, e.g.,
19 Bohemia and Moravia (which existed then and now) and not
20 Czechoslovakia (which didn't exist then and doesn't exist now).
21 What is now the U.S. mostly did not switch at the same time as
22 Britain, so omit the U.S. Correct spelling of "Britain".
23 Catholic Switzerland was too much of a mess, so omit it.
24
252012-11-22 Jay Belanger <jay.p.belanger@gmail.com>
26
27 * calc/calc.el (calc-gregorian-switch): Refresh the Calc buffer
28 after the variable is changed.
29
302012-11-21 Daniel Colascione <dancol@dancol.org>
31
32 * progmodes/sql.el (sql-mode-font-lock-object-name): Support IF NOT EXISTS
33 in SQL declarations for font-lock.
34 (sql-imenu-generic-expression): Teach imenu about IF NOT EXISTS.
35
362012-11-21 Glenn Morris <rgm@gnu.org>
37
38 * faces.el (face-underline-p, face-inverse-video-p, face-bold-p)
39 (face-italic-p): Add optional argument "inherit".
40
41 * faces.el (set-face-inverse-video, set-face-bold, set-face-italic):
42 Remove -p suffix from names, for consistency with other set-face-*.
43 (set-face-inverse-video): Fix interactive spec.
44 * play/gamegrid.el (gamegrid-make-mono-tty-face):
45 * textmodes/table.el (table--update-cell-face):
46 Use set-face-inverse-video rather than now obsolete alias.
47
482012-11-21 Eli Zaretskii <eliz@gnu.org>
49
50 * simple.el (line-move): Don't call line-move-partial if
51 scroll-conservatively is in effect. (Bug#12927)
52
532012-11-21 Stefan Monnier <monnier@iro.umontreal.ca>
54
55 * eshell/em-cmpl.el (eshell-pcomplete): Refine fix for bug#12838:
56 Fallback on completion-at-point rather than
57 pcomplete-expand-and-complete, and only if pcomplete actually failed.
58 (eshell-cmpl-initialize): Setup completion-at-point.
59
60 * pcomplete.el (pcomplete--entries): Obey pcomplete-ignore-case.
61
62 * emacs-lisp/ert.el (ert--expand-should-1): Adapt to cl-lib.
63
642012-11-21 Michael Albinus <michael.albinus@gmx.de>
65
66 * net/tramp-sh.el (tramp-do-copy-or-rename-file): If both files
67 are remote, check out-of-band property for both.
68
692012-11-21 Stefan Monnier <monnier@iro.umontreal.ca>
70
71 * window.el (switch-to-buffer): Re-add the warning that was lost in the
72 code rewrite.
73
742012-11-21 Paul Eggert <eggert@cs.ucla.edu>
75
76 More minor time fixes.
77 * calendar/time-date.el: Commentary fix.
78 * net/tramp-sh.el (tramp-do-file-attributes-with-ls): Undo last change;
79 too much other code depends on (0 0) time stamps.
80 * net/tramp.el (tramp-time-less-p, tramp-time-subtract):
81 Add a couple of FIXME comments.
82
83 Minor cleanup for times as lists of four integers.
84 * files.el (dir-locals-directory-cache):
85 * ps-bdf.el (bdf-file-mod-time, bdf-read-font-info):
86 Doc fixes.
87 * net/tramp-sh.el (tramp-do-file-attributes-with-ls):
88 * ps-bdf.el (bdf-file-newer-than-time):
89 Process four-integers time stamps, not two. Doc fixes.
90
912012-11-20 Stefan Monnier <monnier@iro.umontreal.ca>
92
93 * uniquify.el (uniquify-managed): Use defvar-local.
94 (rename-buffer, create-file-buffer): Advise with advice-add.
95 (uniquify-unload-function): Unadvise accordingly.
96
97 * emacs-lisp/trace.el: Rewrite, use nadvice and lexical-binding.
98 (trace-buffer): Don't purecopy.
99 (trace-entry-message, trace-exit-message): Add `context' arg.
100 (trace--timer): New var.
101 (trace-make-advice): Adjust for use in nadvice.
102 Add `context' argument. Delay `display-buffer' via a timer.
103 (trace-function-internal): Use advice-add.
104 (trace--read-args): New function.
105 (trace-function-foreground, trace-function-background): Use it.
106 (trace-function): Rename to trace-function-foreground and redefine as
107 an alias to that new name.
108 (untrace-function, untrace-all): Adjust to the use of nadvice.
109
110 * emacs-lisp/bytecomp.el (byte-compile): Fix handling of closures.
111
112 * emacs-lisp/byte-run.el (defun-declarations-alist): Fix last change.
113
114 * subr.el (called-interactively-p-functions): New var.
115 (internal--called-interactively-p--get-frame): New macro.
116 (called-interactively-p, interactive-p): Rewrite in Lisp.
117 * emacs-lisp/nadvice.el (advice--called-interactively-skip): New fun.
118 (called-interactively-p-functions): Use it.
119 * emacs-lisp/edebug.el (edebug--called-interactively-skip): New fun.
120 (called-interactively-p-functions): Use it.
121 * allout.el (allout-called-interactively-p): Don't assume
122 called-interactively-p is a subr.
123
1242012-11-20 Glenn Morris <rgm@gnu.org>
125
126 * profiler.el (profiler-report-mode-map): Add a menu.
127 No need to bind `q' because we derive from special-mode.
128 (profiler-report-find-entry): Handle calls from the menu-bar.
129
1302012-11-19 Stefan Monnier <monnier@iro.umontreal.ca>
131
132 * emacs-lisp/byte-run.el (defun-declarations-alist):
133 Allow a compiler-macro to be a lambda expression.
134
135 * progmodes/python.el: Use cl-lib. Move var declarations outside of
136 eval-when-compile.
137 (python-syntax-context): Add compiler-macro.
138 (python-font-lock-keywords): Simplify with De Morgan.
139
140 * vc/diff-mode.el (diff-hunk): Don't make useless timers.
141
142 * files.el (load-file): Require match in minibuffer selection, as was
143 the case in Emacs-20 before we changed the spec to allow .elc files
144 (bug#12935).
145
146 * json.el: Don't require cl since we don't use it.
147 * color.el: Don't require cl.
148 (color-complement): `caddr' -> `nth 2'.
149
150 * calendar/time-date.el (time-to-seconds): De-obsolete.
151
1522012-11-19 Jay Belanger <jay.p.belanger@gmail.com>
153
154 * calc/calc-forms.el (math-leap-year-p): Fix formula for negative
155 year numbers.
156 (math-date-to-julian-dt): Adjust the initial approximation for the
157 year to deal with the new definition of the DATE.
158
1592012-11-19 Daniel Colascione <dancol@dancol.org>
160
161 * term/w32-win.el (cygwin-convert-path-from-windows):
162 Accomodate rename of cygwin_convert_path* to cygwin_convert_file_name*.
163
12012-11-18 Chong Yidong <cyd@gnu.org> 1642012-11-18 Chong Yidong <cyd@gnu.org>
2 165
3 * filecache.el (file-cache--read-list): New function. 166 * filecache.el (file-cache--read-list): New function.
@@ -47,8 +210,10 @@
47 210
482012-11-17 Paul Eggert <eggert@cs.ucla.edu> 2112012-11-17 Paul Eggert <eggert@cs.ucla.edu>
49 212
213 Calc by default uses the Gregorian calendar for all dates (Bug#12633).
214 It also uses January 1, 1 AD as its day number 1.
50 * calc/calc-forms.el (math-julian-date-beginning) 215 * calc/calc-forms.el (math-julian-date-beginning)
51 (math-julian-date-beginning-int): Implement [new date numbering]. 216 (math-julian-date-beginning-int): Implement this.
52 217
532012-11-17 Juanma Barranquero <lekktu@gmail.com> 2182012-11-17 Juanma Barranquero <lekktu@gmail.com>
54 219
diff --git a/lisp/allout.el b/lisp/allout.el
index 04de853ebe0..e93aefd12cc 100644
--- a/lisp/allout.el
+++ b/lisp/allout.el
@@ -1657,10 +1657,9 @@ and the place for the cursor after the decryption is done."
1657(defmacro allout-called-interactively-p () 1657(defmacro allout-called-interactively-p ()
1658 "A version of `called-interactively-p' independent of Emacs version." 1658 "A version of `called-interactively-p' independent of Emacs version."
1659 ;; ... to ease maintenance of allout without betraying deprecation. 1659 ;; ... to ease maintenance of allout without betraying deprecation.
1660 (if (equal (subr-arity (symbol-function 'called-interactively-p)) 1660 (if (ignore-errors (called-interactively-p 'interactive) t)
1661 '(0 . 0)) 1661 '(called-interactively-p 'interactive)
1662 '(called-interactively-p) 1662 '(called-interactively-p)))
1663 '(called-interactively-p 'interactive)))
1664;;;_ = allout-inhibit-aberrance-doublecheck nil 1663;;;_ = allout-inhibit-aberrance-doublecheck nil
1665;; In some exceptional moments, disparate topic depths need to be allowed 1664;; In some exceptional moments, disparate topic depths need to be allowed
1666;; momentarily, eg when one topic is being yanked into another and they're 1665;; momentarily, eg when one topic is being yanked into another and they're
diff --git a/lisp/calc/README b/lisp/calc/README
index 25d1a5e9b58..638b482a60a 100644
--- a/lisp/calc/README
+++ b/lisp/calc/README
@@ -70,11 +70,18 @@ opinions.
70Summary of changes to "Calc" 70Summary of changes to "Calc"
71------- -- ------- -- ---- 71------- -- ------- -- ----
72 72
73Emacs 24.4
74
75* The date forms use the Gregorian calendar for all dates.
76 (Previously they were a combination of Julian and Gregorian
77 dates.) This can be configured with the customizable variable
78 `calc-gregorian-switch'.
79
73Emacs 24.3 80Emacs 24.3
74 81
75Algebraic simplification mode is now the default. 82* Algebraic simplification mode is now the default.
76To restrict to the limited simplifications given by the former 83 To restrict to the limited simplifications given by the former
77default simplification mode, use `m I'. 84 default simplification mode, use `m I'.
78 85
79Emacs 24.1 86Emacs 24.1
80 87
diff --git a/lisp/calc/calc-forms.el b/lisp/calc/calc-forms.el
index 709250f9ba9..98b22550f75 100644
--- a/lisp/calc/calc-forms.el
+++ b/lisp/calc/calc-forms.el
@@ -371,9 +371,10 @@
371;;; These versions are rewritten to use arbitrary-size integers. 371;;; These versions are rewritten to use arbitrary-size integers.
372 372
373;;; A numerical date is the number of days since midnight on 373;;; A numerical date is the number of days since midnight on
374;;; the morning of December 31, 1 B.C. Emacs's calendar refers to such 374;;; the morning of December 31, 1 B.C. (Gregorian) or January 2, 1 A.D. (Julian).
375;;; a date as an absolute date, some function names also use that 375;;; Emacs's calendar refers to such a date as an absolute date, some Calc function
376;;; terminology. If the date is a non-integer, it represents a specific date and time. 376;;; names also use that terminology. If the date is a non-integer, it represents
377;;; a specific date and time.
377;;; A "dt" is a list of the form, (year month day), corresponding to 378;;; A "dt" is a list of the form, (year month day), corresponding to
378;;; an integer code, or (year month day hour minute second), corresponding 379;;; an integer code, or (year month day hour minute second), corresponding
379;;; to a non-integer code. 380;;; to a non-integer code.
@@ -408,8 +409,8 @@ DATE is the number of days since December 31, -1 in the Gregorian calendar."
408 (let* ((month 1) 409 (let* ((month 1)
409 day 410 day
410 (year (math-quotient (math-add date (if (Math-lessp date 711859) 411 (year (math-quotient (math-add date (if (Math-lessp date 711859)
411 365 ; for speed, we take 412 367 ; for speed, we take
412 -108)) ; >1950 as a special case 413 -106)) ; >1950 as a special case
413 (if (math-negp date) 366 365))) 414 (if (math-negp date) 366 365)))
414 ; this result may be an overestimate 415 ; this result may be an overestimate
415 temp) 416 temp)
@@ -494,6 +495,8 @@ Gregorian calendar."
494 (if (math-negp year) 495 (if (math-negp year)
495 (= (math-imod (math-neg year) 4) 1) 496 (= (math-imod (math-neg year) 4) 1)
496 (= (math-imod year 4) 0)) 497 (= (math-imod year 4) 0))
498 (if (math-negp year)
499 (setq year (math-sub -1 year)))
497 (setq year (math-imod year 400)) 500 (setq year (math-imod year 400))
498 (or (and (= (% year 4) 0) (/= (% year 100) 0)) 501 (or (and (= (% year 4) 0) (/= (% year 100) 0))
499 (= year 0)))) 502 (= year 0))))
diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el
index aeca45ebf26..58eabf9bcec 100644
--- a/lisp/calc/calc.el
+++ b/lisp/calc/calc.el
@@ -466,50 +466,6 @@ to be identified as that note."
466 466
467(defvar math-format-date-cache) ; calc-forms.el 467(defvar math-format-date-cache) ; calc-forms.el
468 468
469;; Dates that are built-in options for `calc-gregorian-switch' should be
470;; (YEAR MONTH DAY math-date-from-gregorian-dt(YEAR MONTH DAY)) for speed.
471(defcustom calc-gregorian-switch nil
472 "The first day the Gregorian calendar is used by Calc's date forms.
473This is `nil' (the default) if the Gregorian calendar is the only one used.
474Otherwise, it should be a list `(YEAR MONTH DAY)' when Calc begins to use
475the Gregorian calendar; Calc will use the Julian calendar for earlier dates.
476The dates in which different regions of the world began to use the
477Gregorian calendar vary quite a bit, even within a single country.
478If you want Calc's date forms to switch between the Julian and
479Gregorian calendar, you can specify the date or choose from several
480common choices. Some of these choices should be taken with a grain
481of salt; for example different parts of France changed calendars at
482different times, and Sweden's change to the Gregorian calendar was
483complicated. Also, the boundaries of the countries were different at
484the times of the calendar changes than they are now.
485The Vatican decided that the Gregorian calendar should take effect
486on 15 October 1582 (Gregorian), and many Catholic countries made
487the change then. Great Britian and its colonies had the Gregorian
488calendar take effect on 14 September 1752 (Gregorian); this includes
489the United States."
490 :group 'calc
491 :version "24.4"
492 :type '(choice (const :tag "Always use the Gregorian calendar" nil)
493 (const :tag "Great Britian and the US (1752 9 14)" (1752 9 14 639797))
494 (const :tag "Vatican (1582 10 15)" (1582 10 15 577736))
495 (const :tag "Czechoslovakia (1584 1 17)" (1584 1 17 578195))
496 (const :tag "Denmark (1700 3 1)" (1700 3 1 620607))
497 (const :tag "France (1582 12 20)" (1582 12 20 577802))
498 (const :tag "Hungary (1587 11 1)" (1587 11 1 579579))
499 (const :tag "Luxemburg (1582 12 25)" (1582 12 25 577807))
500 (const :tag "Romania (1919 4 14)" (1919 4 14 700638))
501 (const :tag "Russia (1918 2 14)" (1918 2 14 700214))
502 (const :tag "Sweden (1753 3 1)" (1753 3 1 639965))
503 (const :tag "Switzerland (Catholic) (1584 1 22)" (1584 1 22 578200))
504 (const :tag "Switzerland (Protestant) (1701 1 12)" (1701 1 12 620924))
505 (list :tag "(YEAR MONTH DAY)"
506 (integer :tag "Year")
507 (integer :tag "Month (integer)")
508 (integer :tag "Day")))
509 :set (lambda (symbol value)
510 (set-default symbol value)
511 (setq math-format-date-cache nil)))
512
513(defface calc-nonselected-face 469(defface calc-nonselected-face
514 '((t :inherit shadow 470 '((t :inherit shadow
515 :slant italic)) 471 :slant italic))
@@ -2066,6 +2022,50 @@ See calc-keypad for details."
2066 (calc-refresh align))) 2022 (calc-refresh align)))
2067 (setq calc-refresh-count (1+ calc-refresh-count))) 2023 (setq calc-refresh-count (1+ calc-refresh-count)))
2068 2024
2025;; Dates that are built-in options for `calc-gregorian-switch' should be
2026;; (YEAR MONTH DAY math-date-from-gregorian-dt(YEAR MONTH DAY)) for speed.
2027(defcustom calc-gregorian-switch nil
2028 "The first day the Gregorian calendar is used by Calc's date forms.
2029This is `nil' (the default) if the Gregorian calendar is the only one used.
2030Otherwise, it should be a list `(YEAR MONTH DAY)' when Calc begins to use
2031the Gregorian calendar; Calc will use the Julian calendar for earlier dates.
2032The dates in which different regions of the world began to use the
2033Gregorian calendar vary quite a bit, even within a single country.
2034If you want Calc's date forms to switch between the Julian and
2035Gregorian calendar, you can specify the date or choose from several
2036common choices. Some of these choices should be taken with a grain
2037of salt; for example different parts of France changed calendars at
2038different times, and Sweden's change to the Gregorian calendar was
2039complicated. Also, the boundaries of the countries were different at
2040the times of the calendar changes than they are now.
2041The Vatican decided that the Gregorian calendar should take effect
2042on 15 October 1582 (Gregorian), and many Catholic countries made
2043the change then. Great Britain and its colonies had the Gregorian
2044calendar take effect on 14 September 1752 (Gregorian); this includes
2045the United States."
2046 :group 'calc
2047 :version "24.4"
2048 :type '(choice (const :tag "Always use the Gregorian calendar" nil)
2049 (const :tag "1582-10-15 - Italy, Poland, Portugal, Spain" (1582 10 15 577736))
2050 (const :tag "1582-12-20 - France" (1582 12 20 577802))
2051 (const :tag "1582-12-25 - Luxemburg" (1582 12 25 577807))
2052 (const :tag "1584-01-17 - Bohemia and Moravia" (1584 1 17 578195))
2053 (const :tag "1587-11-01 - Hungary" (1587 11 1 579579))
2054 (const :tag "1700-03-01 - Denmark" (1700 3 1 620607))
2055 (const :tag "1701-01-12 - Protestant Switzerland" (1701 1 12 620924))
2056 (const :tag "1752-09-14 - Great Britain and dominions" (1752 9 14 639797))
2057 (const :tag "1753-03-01 - Sweden" (1753 3 1 639965))
2058 (const :tag "1918-02-14 - Russia" (1918 2 14 700214))
2059 (const :tag "1919-04-14 - Romania" (1919 4 14 700638))
2060 (list :tag "(YEAR MONTH DAY)"
2061 (integer :tag "Year")
2062 (integer :tag "Month (integer)")
2063 (integer :tag "Day")))
2064 :set (lambda (symbol value)
2065 (set-default symbol value)
2066 (setq math-format-date-cache nil)
2067 (calc-refresh)))
2068
2069;;;; The Calc Trail buffer. 2069;;;; The Calc Trail buffer.
2070 2070
2071(defun calc-check-trail-aligned () 2071(defun calc-check-trail-aligned ()
diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el
index 38b766084c9..9cac659d848 100644
--- a/lisp/calendar/time-date.el
+++ b/lisp/calendar/time-date.el
@@ -30,11 +30,10 @@
30;; value equal to HIGH * 2^16 + LOW + USEC * 10^-6 + PSEC * 10^-12 30;; value equal to HIGH * 2^16 + LOW + USEC * 10^-6 + PSEC * 10^-12
31;; seconds, where missing components are treated as zero. HIGH can be 31;; seconds, where missing components are treated as zero. HIGH can be
32;; negative, either because the value is a time difference, or because 32;; negative, either because the value is a time difference, or because
33;; the machine supports negative time stamps that fall before the 33;; the machine supports negative time stamps that fall before the epoch.
34;; epoch. The macro `with-decoded-time-value' and the 34;; The macro `with-decoded-time-value' and the function
35;; function `encode-time-value' make it easier to deal with these 35;; `encode-time-value' make it easier to deal with these formats.
36;; three formats. See `time-subtract' for an example of how to use 36;; See `time-subtract' for an example of how to use them.
37;; them.
38 37
39;;; Code: 38;;; Code:
40 39
@@ -134,9 +133,7 @@ If DATE lacks timezone information, GMT is assumed."
134;;;###autoload(if (or (featurep 'emacs) 133;;;###autoload(if (or (featurep 'emacs)
135;;;###autoload (and (fboundp 'float-time) 134;;;###autoload (and (fboundp 'float-time)
136;;;###autoload (subrp (symbol-function 'float-time)))) 135;;;###autoload (subrp (symbol-function 'float-time))))
137;;;###autoload (progn 136;;;###autoload (defalias 'time-to-seconds 'float-time)
138;;;###autoload (defalias 'time-to-seconds 'float-time)
139;;;###autoload (make-obsolete 'time-to-seconds 'float-time "21.1"))
140;;;###autoload (autoload 'time-to-seconds "time-date")) 137;;;###autoload (autoload 'time-to-seconds "time-date"))
141 138
142(eval-when-compile 139(eval-when-compile
diff --git a/lisp/cedet/ChangeLog b/lisp/cedet/ChangeLog
index a01ce4c30a3..cdfb357b646 100644
--- a/lisp/cedet/ChangeLog
+++ b/lisp/cedet/ChangeLog
@@ -1,12 +1,17 @@
12012-11-19 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 * semantic/fw.el (semantic-make-local-hook, semantic-mode-line-update):
4 Simplify via CSE.
5
12012-11-16 David Engster <deng@randomsample.de> 62012-11-16 David Engster <deng@randomsample.de>
2 7
3 * semantic/symref/list.el (semantic-symref-symbol): Use 8 * semantic/symref/list.el (semantic-symref-symbol):
4 `semantic-complete-read-tag-project' instead of 9 Use `semantic-complete-read-tag-project' instead of
5 `semantic-complete-read-tag-buffer-deep', since the latter is not 10 `semantic-complete-read-tag-buffer-deep', since the latter is not
6 working correctly. 11 working correctly.
7 12
8 * semantic/symref.el (semantic-symref-result-get-tags): Use 13 * semantic/symref.el (semantic-symref-result-get-tags):
9 `find-buffer-visiting' to follow symbolic links. 14 Use `find-buffer-visiting' to follow symbolic links.
10 15
11 * semantic/fw.el (semantic-find-file-noselect): Always set 16 * semantic/fw.el (semantic-find-file-noselect): Always set
12 `enable-local-variables' to `:safe' when loading files. 17 `enable-local-variables' to `:safe' when loading files.
diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el
index 14ffc808c44..6dd85309967 100644
--- a/lisp/cedet/semantic/fw.el
+++ b/lisp/cedet/semantic/fw.el
@@ -122,15 +122,13 @@
122 ) 122 )
123 123
124 124
125 (if (and (not (featurep 'xemacs)) 125 (defalias 'semantic-make-local-hook
126 (>= emacs-major-version 21)) 126 (if (and (not (featurep 'xemacs))
127 (defalias 'semantic-make-local-hook 'identity) 127 (>= emacs-major-version 21))
128 (defalias 'semantic-make-local-hook 'make-local-hook) 128 #'identity #'make-local-hook))
129 )
130 129
131 (if (featurep 'xemacs) 130 (defalias 'semantic-mode-line-update
132 (defalias 'semantic-mode-line-update 'redraw-modeline) 131 (if (featurep 'xemacs) #'redraw-modeline #'force-mode-line-update))
133 (defalias 'semantic-mode-line-update 'force-mode-line-update))
134 132
135 ;; Since Emacs 22 major mode functions should use `run-mode-hooks' to 133 ;; Since Emacs 22 major mode functions should use `run-mode-hooks' to
136 ;; run major mode hooks. 134 ;; run major mode hooks.
diff --git a/lisp/color.el b/lisp/color.el
index b915beacb0a..e1563ea474c 100644
--- a/lisp/color.el
+++ b/lisp/color.el
@@ -33,9 +33,6 @@
33 33
34;;; Code: 34;;; Code:
35 35
36(eval-when-compile
37 (require 'cl))
38
39;; Emacs < 23.3 36;; Emacs < 23.3
40(eval-and-compile 37(eval-and-compile
41 (unless (boundp 'float-pi) 38 (unless (boundp 'float-pi)
@@ -69,9 +66,9 @@ RED, GREEN, and BLUE should be numbers between 0.0 and 1.0, inclusive."
69COLOR-NAME should be a string naming a color (e.g. \"white\"), or 66COLOR-NAME should be a string naming a color (e.g. \"white\"), or
70a string specifying a color's RGB components (e.g. \"#ff12ec\")." 67a string specifying a color's RGB components (e.g. \"#ff12ec\")."
71 (let ((color (color-name-to-rgb color-name))) 68 (let ((color (color-name-to-rgb color-name)))
72 (list (- 1.0 (car color)) 69 (list (- 1.0 (nth 0 color))
73 (- 1.0 (cadr color)) 70 (- 1.0 (nth 1 color))
74 (- 1.0 (caddr color))))) 71 (- 1.0 (nth 2 color)))))
75 72
76(defun color-gradient (start stop step-number) 73(defun color-gradient (start stop step-number)
77 "Return a list with STEP-NUMBER colors from START to STOP. 74 "Return a list with STEP-NUMBER colors from START to STOP.
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index 462b4a25154..b4582a41d6c 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -81,8 +81,14 @@ The return value of this function is not used."
81 #'(lambda (f _args new-name when) 81 #'(lambda (f _args new-name when)
82 `(make-obsolete ',f ',new-name ,when))) 82 `(make-obsolete ',f ',new-name ,when)))
83 (list 'compiler-macro 83 (list 'compiler-macro
84 #'(lambda (f _args compiler-function) 84 #'(lambda (f args compiler-function)
85 `(put ',f 'compiler-macro #',compiler-function))) 85 ;; FIXME: Make it possible to just reuse `args'.
86 `(eval-and-compile
87 (put ',f 'compiler-macro
88 ,(if (eq (car-safe compiler-function) 'lambda)
89 `(lambda ,(append (cadr compiler-function) args)
90 ,@(cddr compiler-function))
91 `#',compiler-function)))))
86 (list 'doc-string 92 (list 'doc-string
87 #'(lambda (f _args pos) 93 #'(lambda (f _args pos)
88 (list 'put (list 'quote f) ''doc-string-elt (list 'quote pos)))) 94 (list 'put (list 'quote f) ''doc-string-elt (list 'quote pos))))
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index a325e0f3e44..60036c86dc0 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -2509,8 +2509,8 @@ If FORM is a lambda or a macro, byte-compile it as a function."
2509 (when (symbolp form) 2509 (when (symbolp form)
2510 (unless (memq (car-safe fun) '(closure lambda)) 2510 (unless (memq (car-safe fun) '(closure lambda))
2511 (error "Don't know how to compile %S" fun)) 2511 (error "Don't know how to compile %S" fun))
2512 (setq fun (byte-compile--reify-function fun)) 2512 (setq lexical-binding (eq (car fun) 'closure))
2513 (setq lexical-binding (eq (car fun) 'closure))) 2513 (setq fun (byte-compile--reify-function fun)))
2514 (unless (eq (car-safe fun) 'lambda) 2514 (unless (eq (car-safe fun) 'lambda)
2515 (error "Don't know how to compile %S" fun)) 2515 (error "Don't know how to compile %S" fun))
2516 ;; Expand macros. 2516 ;; Expand macros.
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index 483ed64de20..12311711fe0 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -4268,6 +4268,21 @@ With prefix argument, make it a temporary breakpoint."
4268 4268
4269;;; Finalize Loading 4269;;; Finalize Loading
4270 4270
4271;; When edebugging a function, some of the sub-expressions are
4272;; wrapped in (edebug-enter (lambda () ..)), so we need to teach
4273;; called-interactively-p that calls within the inner lambda should refer to
4274;; the outside function.
4275(add-hook 'called-interactively-p-functions
4276 #'edebug--called-interactively-skip)
4277(defun edebug--called-interactively-skip (i frame1 frame2)
4278 (when (and (eq (car-safe (nth 1 frame1)) 'lambda)
4279 (eq (nth 1 (nth 1 frame1)) '())
4280 (eq (nth 1 frame2) 'edebug-enter))
4281 ;; `edebug-enter' calls itself on its first invocation.
4282 (if (eq (nth 1 (internal--called-interactively-p--get-frame i))
4283 'edebug-enter)
4284 2 1)))
4285
4271;; Finally, hook edebug into the rest of Emacs. 4286;; Finally, hook edebug into the rest of Emacs.
4272;; There are probably some other things that could go here. 4287;; There are probably some other things that could go here.
4273 4288
diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el
index c3b8e5e10d4..60d74774e87 100644
--- a/lisp/emacs-lisp/ert-x.el
+++ b/lisp/emacs-lisp/ert-x.el
@@ -1,4 +1,4 @@
1;;; ert-x.el --- Staging area for experimental extensions to ERT 1;;; ert-x.el --- Staging area for experimental extensions to ERT -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 2008, 2010-2012 Free Software Foundation, Inc. 3;; Copyright (C) 2008, 2010-2012 Free Software Foundation, Inc.
4 4
@@ -28,8 +28,7 @@
28 28
29;;; Code: 29;;; Code:
30 30
31(eval-when-compile 31(eval-when-compile (require 'cl-lib))
32 (require 'cl))
33(require 'ert) 32(require 'ert)
34 33
35 34
@@ -90,8 +89,8 @@ ERT--THUNK with that buffer as current."
90 (kill-buffer ert--buffer) 89 (kill-buffer ert--buffer)
91 (remhash ert--buffer ert--test-buffers)))) 90 (remhash ert--buffer ert--test-buffers))))
92 91
93(defmacro* ert-with-test-buffer ((&key ((:name name-form))) 92(cl-defmacro ert-with-test-buffer ((&key ((:name name-form)))
94 &body body) 93 &body body)
95 "Create a test buffer and run BODY in that buffer. 94 "Create a test buffer and run BODY in that buffer.
96 95
97To be used in ERT tests. If BODY finishes successfully, the test 96To be used in ERT tests. If BODY finishes successfully, the test
@@ -116,10 +115,10 @@ the name of the test and the result of NAME-FORM."
116 "Kill all test buffers that are still live." 115 "Kill all test buffers that are still live."
117 (interactive) 116 (interactive)
118 (let ((count 0)) 117 (let ((count 0))
119 (maphash (lambda (buffer dummy) 118 (maphash (lambda (buffer _dummy)
120 (when (or (not (buffer-live-p buffer)) 119 (when (or (not (buffer-live-p buffer))
121 (kill-buffer buffer)) 120 (kill-buffer buffer))
122 (incf count))) 121 (cl-incf count)))
123 ert--test-buffers) 122 ert--test-buffers)
124 (message "%s out of %s test buffers killed" 123 (message "%s out of %s test buffers killed"
125 count (hash-table-count ert--test-buffers))) 124 count (hash-table-count ert--test-buffers)))
@@ -149,9 +148,9 @@ the rest are arguments to the command.
149 148
150NOTE: Since the command is not called by `call-interactively' 149NOTE: Since the command is not called by `call-interactively'
151test for `called-interactively' in the command will fail." 150test for `called-interactively' in the command will fail."
152 (assert (listp command) t) 151 (cl-assert (listp command) t)
153 (assert (commandp (car command)) t) 152 (cl-assert (commandp (car command)) t)
154 (assert (not unread-command-events) t) 153 (cl-assert (not unread-command-events) t)
155 (let (return-value) 154 (let (return-value)
156 ;; For the order of things here see command_loop_1 in keyboard.c. 155 ;; For the order of things here see command_loop_1 in keyboard.c.
157 ;; 156 ;;
@@ -175,7 +174,7 @@ test for `called-interactively' in the command will fail."
175 (when (boundp 'last-repeatable-command) 174 (when (boundp 'last-repeatable-command)
176 (setq last-repeatable-command real-last-command)) 175 (setq last-repeatable-command real-last-command))
177 (when (and deactivate-mark transient-mark-mode) (deactivate-mark)) 176 (when (and deactivate-mark transient-mark-mode) (deactivate-mark))
178 (assert (not unread-command-events) t) 177 (cl-assert (not unread-command-events) t)
179 return-value)) 178 return-value))
180 179
181(defun ert-run-idle-timers () 180(defun ert-run-idle-timers ()
@@ -198,7 +197,7 @@ rather than the entire match."
198 (with-temp-buffer 197 (with-temp-buffer
199 (insert s) 198 (insert s)
200 (dolist (x regexps) 199 (dolist (x regexps)
201 (destructuring-bind (regexp subexp) (if (listp x) x `(,x nil)) 200 (cl-destructuring-bind (regexp subexp) (if (listp x) x `(,x nil))
202 (goto-char (point-min)) 201 (goto-char (point-min))
203 (while (re-search-forward regexp nil t) 202 (while (re-search-forward regexp nil t)
204 (replace-match "" t t nil subexp)))) 203 (replace-match "" t t nil subexp))))
@@ -224,15 +223,15 @@ would return the string \"foo bar baz quux\" where the substring
224None of the ARGS are modified, but the return value may share 223None of the ARGS are modified, but the return value may share
225structure with the plists in ARGS." 224structure with the plists in ARGS."
226 (with-temp-buffer 225 (with-temp-buffer
227 (loop with current-plist = nil 226 (cl-loop with current-plist = nil
228 for x in args do 227 for x in args do
229 (etypecase x 228 (cl-etypecase x
230 (string (let ((begin (point))) 229 (string (let ((begin (point)))
231 (insert x) 230 (insert x)
232 (set-text-properties begin (point) current-plist))) 231 (set-text-properties begin (point) current-plist)))
233 (list (unless (zerop (mod (length x) 2)) 232 (list (unless (zerop (mod (length x) 2))
234 (error "Odd number of args in plist: %S" x)) 233 (error "Odd number of args in plist: %S" x))
235 (setq current-plist x)))) 234 (setq current-plist x))))
236 (buffer-string))) 235 (buffer-string)))
237 236
238 237
@@ -245,8 +244,8 @@ buffer, and renames the original buffer back to BUFFER-NAME.
245 244
246This is useful if THUNK has undesirable side-effects on an Emacs 245This is useful if THUNK has undesirable side-effects on an Emacs
247buffer with a fixed name such as *Messages*." 246buffer with a fixed name such as *Messages*."
248 (lexical-let ((new-buffer-name (generate-new-buffer-name 247 (let ((new-buffer-name (generate-new-buffer-name
249 (format "%s orig buffer" buffer-name)))) 248 (format "%s orig buffer" buffer-name))))
250 (with-current-buffer (get-buffer-create buffer-name) 249 (with-current-buffer (get-buffer-create buffer-name)
251 (rename-buffer new-buffer-name)) 250 (rename-buffer new-buffer-name))
252 (unwind-protect 251 (unwind-protect
@@ -258,7 +257,7 @@ buffer with a fixed name such as *Messages*."
258 (with-current-buffer new-buffer-name 257 (with-current-buffer new-buffer-name
259 (rename-buffer buffer-name))))) 258 (rename-buffer buffer-name)))))
260 259
261(defmacro* ert-with-buffer-renamed ((buffer-name-form) &body body) 260(cl-defmacro ert-with-buffer-renamed ((buffer-name-form) &body body)
262 "Protect the buffer named BUFFER-NAME from side-effects and run BODY. 261 "Protect the buffer named BUFFER-NAME from side-effects and run BODY.
263 262
264See `ert-call-with-buffer-renamed' for details." 263See `ert-call-with-buffer-renamed' for details."
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index ff00be7a237..ab6dcb58143 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -1,4 +1,4 @@
1;;; ert.el --- Emacs Lisp Regression Testing 1;;; ert.el --- Emacs Lisp Regression Testing -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 2007-2008, 2010-2012 Free Software Foundation, Inc. 3;; Copyright (C) 2007-2008, 2010-2012 Free Software Foundation, Inc.
4 4
@@ -54,8 +54,7 @@
54 54
55;;; Code: 55;;; Code:
56 56
57(eval-when-compile 57(eval-when-compile (require 'cl-lib))
58 (require 'cl))
59(require 'button) 58(require 'button)
60(require 'debug) 59(require 'debug)
61(require 'easymenu) 60(require 'easymenu)
@@ -105,33 +104,33 @@
105 "A reimplementation of `remove-if-not'. 104 "A reimplementation of `remove-if-not'.
106 105
107ERT-PRED is a predicate, ERT-LIST is the input list." 106ERT-PRED is a predicate, ERT-LIST is the input list."
108 (loop for ert-x in ert-list 107 (cl-loop for ert-x in ert-list
109 if (funcall ert-pred ert-x) 108 if (funcall ert-pred ert-x)
110 collect ert-x)) 109 collect ert-x))
111 110
112(defun ert--intersection (a b) 111(defun ert--intersection (a b)
113 "A reimplementation of `intersection'. Intersect the sets A and B. 112 "A reimplementation of `intersection'. Intersect the sets A and B.
114 113
115Elements are compared using `eql'." 114Elements are compared using `eql'."
116 (loop for x in a 115 (cl-loop for x in a
117 if (memql x b) 116 if (memql x b)
118 collect x)) 117 collect x))
119 118
120(defun ert--set-difference (a b) 119(defun ert--set-difference (a b)
121 "A reimplementation of `set-difference'. Subtract the set B from the set A. 120 "A reimplementation of `set-difference'. Subtract the set B from the set A.
122 121
123Elements are compared using `eql'." 122Elements are compared using `eql'."
124 (loop for x in a 123 (cl-loop for x in a
125 unless (memql x b) 124 unless (memql x b)
126 collect x)) 125 collect x))
127 126
128(defun ert--set-difference-eq (a b) 127(defun ert--set-difference-eq (a b)
129 "A reimplementation of `set-difference'. Subtract the set B from the set A. 128 "A reimplementation of `set-difference'. Subtract the set B from the set A.
130 129
131Elements are compared using `eq'." 130Elements are compared using `eq'."
132 (loop for x in a 131 (cl-loop for x in a
133 unless (memq x b) 132 unless (memq x b)
134 collect x)) 133 collect x))
135 134
136(defun ert--union (a b) 135(defun ert--union (a b)
137 "A reimplementation of `union'. Compute the union of the sets A and B. 136 "A reimplementation of `union'. Compute the union of the sets A and B.
@@ -149,7 +148,7 @@ Elements are compared using `eql'."
149 (make-symbol (format "%s%s" 148 (make-symbol (format "%s%s"
150 prefix 149 prefix
151 (prog1 ert--gensym-counter 150 (prog1 ert--gensym-counter
152 (incf ert--gensym-counter)))))) 151 (cl-incf ert--gensym-counter))))))
153 152
154(defun ert--coerce-to-vector (x) 153(defun ert--coerce-to-vector (x)
155 "Coerce X to a vector." 154 "Coerce X to a vector."
@@ -158,19 +157,19 @@ Elements are compared using `eql'."
158 x 157 x
159 (vconcat x))) 158 (vconcat x)))
160 159
161(defun* ert--remove* (x list &key key test) 160(cl-defun ert--remove* (x list &key key test)
162 "Does not support all the keywords of remove*." 161 "Does not support all the keywords of remove*."
163 (unless key (setq key #'identity)) 162 (unless key (setq key #'identity))
164 (unless test (setq test #'eql)) 163 (unless test (setq test #'eql))
165 (loop for y in list 164 (cl-loop for y in list
166 unless (funcall test x (funcall key y)) 165 unless (funcall test x (funcall key y))
167 collect y)) 166 collect y))
168 167
169(defun ert--string-position (c s) 168(defun ert--string-position (c s)
170 "Return the position of the first occurrence of C in S, or nil if none." 169 "Return the position of the first occurrence of C in S, or nil if none."
171 (loop for i from 0 170 (cl-loop for i from 0
172 for x across s 171 for x across s
173 when (eql x c) return i)) 172 when (eql x c) return i))
174 173
175(defun ert--mismatch (a b) 174(defun ert--mismatch (a b)
176 "Return index of first element that differs between A and B. 175 "Return index of first element that differs between A and B.
@@ -184,29 +183,30 @@ Like `mismatch'. Uses `equal' for comparison."
184 (t 183 (t
185 (let ((la (length a)) 184 (let ((la (length a))
186 (lb (length b))) 185 (lb (length b)))
187 (assert (arrayp a) t) 186 (cl-assert (arrayp a) t)
188 (assert (arrayp b) t) 187 (cl-assert (arrayp b) t)
189 (assert (<= la lb) t) 188 (cl-assert (<= la lb) t)
190 (loop for i below la 189 (cl-loop for i below la
191 when (not (equal (aref a i) (aref b i))) return i 190 when (not (equal (aref a i) (aref b i))) return i
192 finally (return (if (/= la lb) 191 finally (cl-return (if (/= la lb)
193 la 192 la
194 (assert (equal a b) t) 193 (cl-assert (equal a b) t)
195 nil))))))) 194 nil)))))))
196 195
197(defun ert--subseq (seq start &optional end) 196(defun ert--subseq (seq start &optional end)
198 "Return a subsequence of SEQ from START to END." 197 "Return a subsequence of SEQ from START to END."
199 (when (char-table-p seq) (error "Not supported")) 198 (when (char-table-p seq) (error "Not supported"))
200 (let ((vector (substring (ert--coerce-to-vector seq) start end))) 199 (let ((vector (substring (ert--coerce-to-vector seq) start end)))
201 (etypecase seq 200 (cl-etypecase seq
202 (vector vector) 201 (vector vector)
203 (string (concat vector)) 202 (string (concat vector))
204 (list (append vector nil)) 203 (list (append vector nil))
205 (bool-vector (loop with result = (make-bool-vector (length vector) nil) 204 (bool-vector (cl-loop with result
206 for i below (length vector) do 205 = (make-bool-vector (length vector) nil)
207 (setf (aref result i) (aref vector i)) 206 for i below (length vector) do
208 finally (return result))) 207 (setf (aref result i) (aref vector i))
209 (char-table (assert nil))))) 208 finally (cl-return result)))
209 (char-table (cl-assert nil)))))
210 210
211(defun ert-equal-including-properties (a b) 211(defun ert-equal-including-properties (a b)
212 "Return t if A and B have similar structure and contents. 212 "Return t if A and B have similar structure and contents.
@@ -225,10 +225,10 @@ Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'."
225;;; Defining and locating tests. 225;;; Defining and locating tests.
226 226
227;; The data structure that represents a test case. 227;; The data structure that represents a test case.
228(defstruct ert-test 228(cl-defstruct ert-test
229 (name nil) 229 (name nil)
230 (documentation nil) 230 (documentation nil)
231 (body (assert nil)) 231 (body (cl-assert nil))
232 (most-recent-result nil) 232 (most-recent-result nil)
233 (expected-result-type ':passed) 233 (expected-result-type ':passed)
234 (tags '())) 234 (tags '()))
@@ -273,7 +273,7 @@ Returns a two-element list containing the keys-and-values plist
273and the body." 273and the body."
274 (let ((extracted-key-accu '()) 274 (let ((extracted-key-accu '())
275 (remaining keys-and-body)) 275 (remaining keys-and-body))
276 (while (and (consp remaining) (keywordp (first remaining))) 276 (while (keywordp (car-safe remaining))
277 (let ((keyword (pop remaining))) 277 (let ((keyword (pop remaining)))
278 (unless (consp remaining) 278 (unless (consp remaining)
279 (error "Value expected after keyword %S in %S" 279 (error "Value expected after keyword %S in %S"
@@ -283,13 +283,13 @@ and the body."
283 keys-and-body)) 283 keys-and-body))
284 (push (cons keyword (pop remaining)) extracted-key-accu))) 284 (push (cons keyword (pop remaining)) extracted-key-accu)))
285 (setq extracted-key-accu (nreverse extracted-key-accu)) 285 (setq extracted-key-accu (nreverse extracted-key-accu))
286 (list (loop for (key . value) in extracted-key-accu 286 (list (cl-loop for (key . value) in extracted-key-accu
287 collect key 287 collect key
288 collect value) 288 collect value)
289 remaining))) 289 remaining)))
290 290
291;;;###autoload 291;;;###autoload
292(defmacro* ert-deftest (name () &body docstring-keys-and-body) 292(cl-defmacro ert-deftest (name () &body docstring-keys-and-body)
293 "Define NAME (a symbol) as a test. 293 "Define NAME (a symbol) as a test.
294 294
295BODY is evaluated as a `progn' when the test is run. It should 295BODY is evaluated as a `progn' when the test is run. It should
@@ -313,12 +313,13 @@ description of valid values for RESULT-TYPE.
313 (indent 2)) 313 (indent 2))
314 (let ((documentation nil) 314 (let ((documentation nil)
315 (documentation-supplied-p nil)) 315 (documentation-supplied-p nil))
316 (when (stringp (first docstring-keys-and-body)) 316 (when (stringp (car docstring-keys-and-body))
317 (setq documentation (pop docstring-keys-and-body) 317 (setq documentation (pop docstring-keys-and-body)
318 documentation-supplied-p t)) 318 documentation-supplied-p t))
319 (destructuring-bind ((&key (expected-result nil expected-result-supplied-p) 319 (cl-destructuring-bind
320 (tags nil tags-supplied-p)) 320 ((&key (expected-result nil expected-result-supplied-p)
321 body) 321 (tags nil tags-supplied-p))
322 body)
322 (ert--parse-keys-and-body docstring-keys-and-body) 323 (ert--parse-keys-and-body docstring-keys-and-body)
323 `(progn 324 `(progn
324 (ert-set-test ',name 325 (ert-set-test ',name
@@ -388,16 +389,11 @@ DATA is displayed to the user and should state the reason of the failure."
388(defun ert--expand-should-1 (whole form inner-expander) 389(defun ert--expand-should-1 (whole form inner-expander)
389 "Helper function for the `should' macro and its variants." 390 "Helper function for the `should' macro and its variants."
390 (let ((form 391 (let ((form
391 ;; If `cl-macroexpand' isn't bound, the code that we're 392 (macroexpand form (cond
392 ;; compiling doesn't depend on cl and thus doesn't need an 393 ((boundp 'macroexpand-all-environment)
393 ;; environment arg for `macroexpand'. 394 macroexpand-all-environment)
394 (if (fboundp 'cl-macroexpand) 395 ((boundp 'cl-macro-environment)
395 ;; Suppress warning about run-time call to cl function: we 396 cl-macro-environment)))))
396 ;; only call it if it's fboundp.
397 (with-no-warnings
398 (cl-macroexpand form (and (boundp 'cl-macro-environment)
399 cl-macro-environment)))
400 (macroexpand form))))
401 (cond 397 (cond
402 ((or (atom form) (ert--special-operator-p (car form))) 398 ((or (atom form) (ert--special-operator-p (car form)))
403 (let ((value (ert--gensym "value-"))) 399 (let ((value (ert--gensym "value-")))
@@ -410,10 +406,10 @@ DATA is displayed to the user and should state the reason of the failure."
410 (t 406 (t
411 (let ((fn-name (car form)) 407 (let ((fn-name (car form))
412 (arg-forms (cdr form))) 408 (arg-forms (cdr form)))
413 (assert (or (symbolp fn-name) 409 (cl-assert (or (symbolp fn-name)
414 (and (consp fn-name) 410 (and (consp fn-name)
415 (eql (car fn-name) 'lambda) 411 (eql (car fn-name) 'lambda)
416 (listp (cdr fn-name))))) 412 (listp (cdr fn-name)))))
417 (let ((fn (ert--gensym "fn-")) 413 (let ((fn (ert--gensym "fn-"))
418 (args (ert--gensym "args-")) 414 (args (ert--gensym "args-"))
419 (value (ert--gensym "value-")) 415 (value (ert--gensym "value-"))
@@ -451,35 +447,34 @@ should return code that calls INNER-FORM and performs the checks
451and error signaling specific to the particular variant of 447and error signaling specific to the particular variant of
452`should'. The code that INNER-EXPANDER returns must not call 448`should'. The code that INNER-EXPANDER returns must not call
453FORM-DESCRIPTION-FORM before it has called INNER-FORM." 449FORM-DESCRIPTION-FORM before it has called INNER-FORM."
454 (lexical-let ((inner-expander inner-expander)) 450 (ert--expand-should-1
455 (ert--expand-should-1 451 whole form
456 whole form 452 (lambda (inner-form form-description-form value-var)
457 (lambda (inner-form form-description-form value-var) 453 (let ((form-description (ert--gensym "form-description-")))
458 (let ((form-description (ert--gensym "form-description-"))) 454 `(let (,form-description)
459 `(let (,form-description) 455 ,(funcall inner-expander
460 ,(funcall inner-expander 456 `(unwind-protect
461 `(unwind-protect 457 ,inner-form
462 ,inner-form 458 (setq ,form-description ,form-description-form)
463 (setq ,form-description ,form-description-form) 459 (ert--signal-should-execution ,form-description))
464 (ert--signal-should-execution ,form-description)) 460 `,form-description
465 `,form-description 461 value-var))))))
466 value-var))))))) 462
467 463(cl-defmacro should (form)
468(defmacro* should (form)
469 "Evaluate FORM. If it returns nil, abort the current test as failed. 464 "Evaluate FORM. If it returns nil, abort the current test as failed.
470 465
471Returns the value of FORM." 466Returns the value of FORM."
472 (ert--expand-should `(should ,form) form 467 (ert--expand-should `(should ,form) form
473 (lambda (inner-form form-description-form value-var) 468 (lambda (inner-form form-description-form _value-var)
474 `(unless ,inner-form 469 `(unless ,inner-form
475 (ert-fail ,form-description-form))))) 470 (ert-fail ,form-description-form)))))
476 471
477(defmacro* should-not (form) 472(cl-defmacro should-not (form)
478 "Evaluate FORM. If it returns non-nil, abort the current test as failed. 473 "Evaluate FORM. If it returns non-nil, abort the current test as failed.
479 474
480Returns nil." 475Returns nil."
481 (ert--expand-should `(should-not ,form) form 476 (ert--expand-should `(should-not ,form) form
482 (lambda (inner-form form-description-form value-var) 477 (lambda (inner-form form-description-form _value-var)
483 `(unless (not ,inner-form) 478 `(unless (not ,inner-form)
484 (ert-fail ,form-description-form))))) 479 (ert-fail ,form-description-form)))))
485 480
@@ -490,10 +485,10 @@ Returns nil."
490Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES, 485Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES,
491and aborts the current test as failed if it doesn't." 486and aborts the current test as failed if it doesn't."
492 (let ((signaled-conditions (get (car condition) 'error-conditions)) 487 (let ((signaled-conditions (get (car condition) 'error-conditions))
493 (handled-conditions (etypecase type 488 (handled-conditions (cl-etypecase type
494 (list type) 489 (list type)
495 (symbol (list type))))) 490 (symbol (list type)))))
496 (assert signaled-conditions) 491 (cl-assert signaled-conditions)
497 (unless (ert--intersection signaled-conditions handled-conditions) 492 (unless (ert--intersection signaled-conditions handled-conditions)
498 (ert-fail (append 493 (ert-fail (append
499 (funcall form-description-fn) 494 (funcall form-description-fn)
@@ -512,7 +507,7 @@ and aborts the current test as failed if it doesn't."
512 507
513;; FIXME: The expansion will evaluate the keyword args (if any) in 508;; FIXME: The expansion will evaluate the keyword args (if any) in
514;; nonstandard order. 509;; nonstandard order.
515(defmacro* should-error (form &rest keys &key type exclude-subtypes) 510(cl-defmacro should-error (form &rest keys &key type exclude-subtypes)
516 "Evaluate FORM and check that it signals an error. 511 "Evaluate FORM and check that it signals an error.
517 512
518The error signaled needs to match TYPE. TYPE should be a list 513The error signaled needs to match TYPE. TYPE should be a list
@@ -560,19 +555,19 @@ failed."
560 555
561(defun ert--proper-list-p (x) 556(defun ert--proper-list-p (x)
562 "Return non-nil if X is a proper list, nil otherwise." 557 "Return non-nil if X is a proper list, nil otherwise."
563 (loop 558 (cl-loop
564 for firstp = t then nil 559 for firstp = t then nil
565 for fast = x then (cddr fast) 560 for fast = x then (cddr fast)
566 for slow = x then (cdr slow) do 561 for slow = x then (cdr slow) do
567 (when (null fast) (return t)) 562 (when (null fast) (cl-return t))
568 (when (not (consp fast)) (return nil)) 563 (when (not (consp fast)) (cl-return nil))
569 (when (null (cdr fast)) (return t)) 564 (when (null (cdr fast)) (cl-return t))
570 (when (not (consp (cdr fast))) (return nil)) 565 (when (not (consp (cdr fast))) (cl-return nil))
571 (when (and (not firstp) (eq fast slow)) (return nil)))) 566 (when (and (not firstp) (eq fast slow)) (cl-return nil))))
572 567
573(defun ert--explain-format-atom (x) 568(defun ert--explain-format-atom (x)
574 "Format the atom X for `ert--explain-equal'." 569 "Format the atom X for `ert--explain-equal'."
575 (typecase x 570 (cl-typecase x
576 (fixnum (list x (format "#x%x" x) (format "?%c" x))) 571 (fixnum (list x (format "#x%x" x) (format "?%c" x)))
577 (t x))) 572 (t x)))
578 573
@@ -581,7 +576,7 @@ failed."
581Returns nil if they are." 576Returns nil if they are."
582 (if (not (equal (type-of a) (type-of b))) 577 (if (not (equal (type-of a) (type-of b)))
583 `(different-types ,a ,b) 578 `(different-types ,a ,b)
584 (etypecase a 579 (cl-etypecase a
585 (cons 580 (cons
586 (let ((a-proper-p (ert--proper-list-p a)) 581 (let ((a-proper-p (ert--proper-list-p a))
587 (b-proper-p (ert--proper-list-p b))) 582 (b-proper-p (ert--proper-list-p b)))
@@ -593,19 +588,19 @@ Returns nil if they are."
593 ,a ,b 588 ,a ,b
594 first-mismatch-at 589 first-mismatch-at
595 ,(ert--mismatch a b)) 590 ,(ert--mismatch a b))
596 (loop for i from 0 591 (cl-loop for i from 0
597 for ai in a 592 for ai in a
598 for bi in b 593 for bi in b
599 for xi = (ert--explain-equal-rec ai bi) 594 for xi = (ert--explain-equal-rec ai bi)
600 do (when xi (return `(list-elt ,i ,xi))) 595 do (when xi (cl-return `(list-elt ,i ,xi)))
601 finally (assert (equal a b) t))) 596 finally (cl-assert (equal a b) t)))
602 (let ((car-x (ert--explain-equal-rec (car a) (car b)))) 597 (let ((car-x (ert--explain-equal-rec (car a) (car b))))
603 (if car-x 598 (if car-x
604 `(car ,car-x) 599 `(car ,car-x)
605 (let ((cdr-x (ert--explain-equal-rec (cdr a) (cdr b)))) 600 (let ((cdr-x (ert--explain-equal-rec (cdr a) (cdr b))))
606 (if cdr-x 601 (if cdr-x
607 `(cdr ,cdr-x) 602 `(cdr ,cdr-x)
608 (assert (equal a b) t) 603 (cl-assert (equal a b) t)
609 nil)))))))) 604 nil))))))))
610 (array (if (not (equal (length a) (length b))) 605 (array (if (not (equal (length a) (length b)))
611 `(arrays-of-different-length ,(length a) ,(length b) 606 `(arrays-of-different-length ,(length a) ,(length b)
@@ -613,12 +608,12 @@ Returns nil if they are."
613 ,@(unless (char-table-p a) 608 ,@(unless (char-table-p a)
614 `(first-mismatch-at 609 `(first-mismatch-at
615 ,(ert--mismatch a b)))) 610 ,(ert--mismatch a b))))
616 (loop for i from 0 611 (cl-loop for i from 0
617 for ai across a 612 for ai across a
618 for bi across b 613 for bi across b
619 for xi = (ert--explain-equal-rec ai bi) 614 for xi = (ert--explain-equal-rec ai bi)
620 do (when xi (return `(array-elt ,i ,xi))) 615 do (when xi (cl-return `(array-elt ,i ,xi)))
621 finally (assert (equal a b) t)))) 616 finally (cl-assert (equal a b) t))))
622 (atom (if (not (equal a b)) 617 (atom (if (not (equal a b))
623 (if (and (symbolp a) (symbolp b) (string= a b)) 618 (if (and (symbolp a) (symbolp b) (string= a b))
624 `(different-symbols-with-the-same-name ,a ,b) 619 `(different-symbols-with-the-same-name ,a ,b)
@@ -637,10 +632,10 @@ Returns nil if they are."
637 632
638(defun ert--significant-plist-keys (plist) 633(defun ert--significant-plist-keys (plist)
639 "Return the keys of PLIST that have non-null values, in order." 634 "Return the keys of PLIST that have non-null values, in order."
640 (assert (zerop (mod (length plist) 2)) t) 635 (cl-assert (zerop (mod (length plist) 2)) t)
641 (loop for (key value . rest) on plist by #'cddr 636 (cl-loop for (key value . rest) on plist by #'cddr
642 unless (or (null value) (memq key accu)) collect key into accu 637 unless (or (null value) (memq key accu)) collect key into accu
643 finally (return accu))) 638 finally (cl-return accu)))
644 639
645(defun ert--plist-difference-explanation (a b) 640(defun ert--plist-difference-explanation (a b)
646 "Return a programmer-readable explanation of why A and B are different plists. 641 "Return a programmer-readable explanation of why A and B are different plists.
@@ -648,8 +643,8 @@ Returns nil if they are."
648Returns nil if they are equivalent, i.e., have the same value for 643Returns nil if they are equivalent, i.e., have the same value for
649each key, where absent values are treated as nil. The order of 644each key, where absent values are treated as nil. The order of
650key/value pairs in each list does not matter." 645key/value pairs in each list does not matter."
651 (assert (zerop (mod (length a) 2)) t) 646 (cl-assert (zerop (mod (length a) 2)) t)
652 (assert (zerop (mod (length b) 2)) t) 647 (cl-assert (zerop (mod (length b) 2)) t)
653 ;; Normalizing the plists would be another way to do this but it 648 ;; Normalizing the plists would be another way to do this but it
654 ;; requires a total ordering on all lisp objects (since any object 649 ;; requires a total ordering on all lisp objects (since any object
655 ;; is valid as a text property key). Perhaps defining such an 650 ;; is valid as a text property key). Perhaps defining such an
@@ -659,21 +654,21 @@ key/value pairs in each list does not matter."
659 (keys-b (ert--significant-plist-keys b)) 654 (keys-b (ert--significant-plist-keys b))
660 (keys-in-a-not-in-b (ert--set-difference-eq keys-a keys-b)) 655 (keys-in-a-not-in-b (ert--set-difference-eq keys-a keys-b))
661 (keys-in-b-not-in-a (ert--set-difference-eq keys-b keys-a))) 656 (keys-in-b-not-in-a (ert--set-difference-eq keys-b keys-a)))
662 (flet ((explain-with-key (key) 657 (cl-flet ((explain-with-key (key)
663 (let ((value-a (plist-get a key)) 658 (let ((value-a (plist-get a key))
664 (value-b (plist-get b key))) 659 (value-b (plist-get b key)))
665 (assert (not (equal value-a value-b)) t) 660 (cl-assert (not (equal value-a value-b)) t)
666 `(different-properties-for-key 661 `(different-properties-for-key
667 ,key ,(ert--explain-equal-including-properties value-a 662 ,key ,(ert--explain-equal-including-properties value-a
668 value-b))))) 663 value-b)))))
669 (cond (keys-in-a-not-in-b 664 (cond (keys-in-a-not-in-b
670 (explain-with-key (first keys-in-a-not-in-b))) 665 (explain-with-key (car keys-in-a-not-in-b)))
671 (keys-in-b-not-in-a 666 (keys-in-b-not-in-a
672 (explain-with-key (first keys-in-b-not-in-a))) 667 (explain-with-key (car keys-in-b-not-in-a)))
673 (t 668 (t
674 (loop for key in keys-a 669 (cl-loop for key in keys-a
675 when (not (equal (plist-get a key) (plist-get b key))) 670 when (not (equal (plist-get a key) (plist-get b key)))
676 return (explain-with-key key))))))) 671 return (explain-with-key key)))))))
677 672
678(defun ert--abbreviate-string (s len suffixp) 673(defun ert--abbreviate-string (s len suffixp)
679 "Shorten string S to at most LEN chars. 674 "Shorten string S to at most LEN chars.
@@ -697,29 +692,30 @@ Returns a programmer-readable explanation of why A and B are not
697`ert-equal-including-properties', or nil if they are." 692`ert-equal-including-properties', or nil if they are."
698 (if (not (equal a b)) 693 (if (not (equal a b))
699 (ert--explain-equal a b) 694 (ert--explain-equal a b)
700 (assert (stringp a) t) 695 (cl-assert (stringp a) t)
701 (assert (stringp b) t) 696 (cl-assert (stringp b) t)
702 (assert (eql (length a) (length b)) t) 697 (cl-assert (eql (length a) (length b)) t)
703 (loop for i from 0 to (length a) 698 (cl-loop for i from 0 to (length a)
704 for props-a = (text-properties-at i a) 699 for props-a = (text-properties-at i a)
705 for props-b = (text-properties-at i b) 700 for props-b = (text-properties-at i b)
706 for difference = (ert--plist-difference-explanation props-a props-b) 701 for difference = (ert--plist-difference-explanation
707 do (when difference 702 props-a props-b)
708 (return `(char ,i ,(substring-no-properties a i (1+ i)) 703 do (when difference
709 ,difference 704 (cl-return `(char ,i ,(substring-no-properties a i (1+ i))
710 context-before 705 ,difference
711 ,(ert--abbreviate-string 706 context-before
712 (substring-no-properties a 0 i) 707 ,(ert--abbreviate-string
713 10 t) 708 (substring-no-properties a 0 i)
714 context-after 709 10 t)
715 ,(ert--abbreviate-string 710 context-after
716 (substring-no-properties a (1+ i)) 711 ,(ert--abbreviate-string
717 10 nil)))) 712 (substring-no-properties a (1+ i))
718 ;; TODO(ohler): Get `equal-including-properties' fixed in 713 10 nil))))
719 ;; Emacs, delete `ert-equal-including-properties', and 714 ;; TODO(ohler): Get `equal-including-properties' fixed in
720 ;; re-enable this assertion. 715 ;; Emacs, delete `ert-equal-including-properties', and
721 ;;finally (assert (equal-including-properties a b) t) 716 ;; re-enable this assertion.
722 ))) 717 ;;finally (cl-assert (equal-including-properties a b) t)
718 )))
723(put 'ert-equal-including-properties 719(put 'ert-equal-including-properties
724 'ert-explainer 720 'ert-explainer
725 'ert--explain-equal-including-properties) 721 'ert--explain-equal-including-properties)
@@ -734,8 +730,8 @@ Returns a programmer-readable explanation of why A and B are not
734 730
735Bound dynamically. This is a list of (PREFIX . MESSAGE) pairs.") 731Bound dynamically. This is a list of (PREFIX . MESSAGE) pairs.")
736 732
737(defmacro* ert-info ((message-form &key ((:prefix prefix-form) "Info: ")) 733(cl-defmacro ert-info ((message-form &key ((:prefix prefix-form) "Info: "))
738 &body body) 734 &body body)
739 "Evaluate MESSAGE-FORM and BODY, and report the message if BODY fails. 735 "Evaluate MESSAGE-FORM and BODY, and report the message if BODY fails.
740 736
741To be used within ERT tests. MESSAGE-FORM should evaluate to a 737To be used within ERT tests. MESSAGE-FORM should evaluate to a
@@ -755,18 +751,19 @@ and is displayed in front of the value of MESSAGE-FORM."
755 "Non-nil means enter debugger when a test fails or terminates with an error.") 751 "Non-nil means enter debugger when a test fails or terminates with an error.")
756 752
757;; The data structures that represent the result of running a test. 753;; The data structures that represent the result of running a test.
758(defstruct ert-test-result 754(cl-defstruct ert-test-result
759 (messages nil) 755 (messages nil)
760 (should-forms nil) 756 (should-forms nil)
761 ) 757 )
762(defstruct (ert-test-passed (:include ert-test-result))) 758(cl-defstruct (ert-test-passed (:include ert-test-result)))
763(defstruct (ert-test-result-with-condition (:include ert-test-result)) 759(cl-defstruct (ert-test-result-with-condition (:include ert-test-result))
764 (condition (assert nil)) 760 (condition (cl-assert nil))
765 (backtrace (assert nil)) 761 (backtrace (cl-assert nil))
766 (infos (assert nil))) 762 (infos (cl-assert nil)))
767(defstruct (ert-test-quit (:include ert-test-result-with-condition))) 763(cl-defstruct (ert-test-quit (:include ert-test-result-with-condition)))
768(defstruct (ert-test-failed (:include ert-test-result-with-condition))) 764(cl-defstruct (ert-test-failed (:include ert-test-result-with-condition)))
769(defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result))) 765(cl-defstruct (ert-test-aborted-with-non-local-exit
766 (:include ert-test-result)))
770 767
771 768
772(defun ert--record-backtrace () 769(defun ert--record-backtrace ()
@@ -779,7 +776,7 @@ and is displayed in front of the value of MESSAGE-FORM."
779 ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we 776 ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we
780 ;; already have `ert-results-rerun-test-debugging-errors-at-point'. 777 ;; already have `ert-results-rerun-test-debugging-errors-at-point'.
781 ;; For batch use, however, printing the backtrace may be useful. 778 ;; For batch use, however, printing the backtrace may be useful.
782 (loop 779 (cl-loop
783 ;; 6 is the number of frames our own debugger adds (when 780 ;; 6 is the number of frames our own debugger adds (when
784 ;; compiled; more when interpreted). FIXME: Need to describe a 781 ;; compiled; more when interpreted). FIXME: Need to describe a
785 ;; procedure for determining this constant. 782 ;; procedure for determining this constant.
@@ -796,33 +793,33 @@ and is displayed in front of the value of MESSAGE-FORM."
796 (print-level 8) 793 (print-level 8)
797 (print-length 50)) 794 (print-length 50))
798 (dolist (frame backtrace) 795 (dolist (frame backtrace)
799 (ecase (first frame) 796 (cl-ecase (car frame)
800 ((nil) 797 ((nil)
801 ;; Special operator. 798 ;; Special operator.
802 (destructuring-bind (special-operator &rest arg-forms) 799 (cl-destructuring-bind (special-operator &rest arg-forms)
803 (cdr frame) 800 (cdr frame)
804 (insert 801 (insert
805 (format " %S\n" (list* special-operator arg-forms))))) 802 (format " %S\n" (cons special-operator arg-forms)))))
806 ((t) 803 ((t)
807 ;; Function call. 804 ;; Function call.
808 (destructuring-bind (fn &rest args) (cdr frame) 805 (cl-destructuring-bind (fn &rest args) (cdr frame)
809 (insert (format " %S(" fn)) 806 (insert (format " %S(" fn))
810 (loop for firstp = t then nil 807 (cl-loop for firstp = t then nil
811 for arg in args do 808 for arg in args do
812 (unless firstp 809 (unless firstp
813 (insert " ")) 810 (insert " "))
814 (insert (format "%S" arg))) 811 (insert (format "%S" arg)))
815 (insert ")\n"))))))) 812 (insert ")\n")))))))
816 813
817;; A container for the state of the execution of a single test and 814;; A container for the state of the execution of a single test and
818;; environment data needed during its execution. 815;; environment data needed during its execution.
819(defstruct ert--test-execution-info 816(cl-defstruct ert--test-execution-info
820 (test (assert nil)) 817 (test (cl-assert nil))
821 (result (assert nil)) 818 (result (cl-assert nil))
822 ;; A thunk that may be called when RESULT has been set to its final 819 ;; A thunk that may be called when RESULT has been set to its final
823 ;; value and test execution should be terminated. Should not 820 ;; value and test execution should be terminated. Should not
824 ;; return. 821 ;; return.
825 (exit-continuation (assert nil)) 822 (exit-continuation (cl-assert nil))
826 ;; The binding of `debugger' outside of the execution of the test. 823 ;; The binding of `debugger' outside of the execution of the test.
827 next-debugger 824 next-debugger
828 ;; The binding of `ert-debug-on-error' that is in effect for the 825 ;; The binding of `ert-debug-on-error' that is in effect for the
@@ -831,7 +828,7 @@ and is displayed in front of the value of MESSAGE-FORM."
831 ;; don't remember whether this feature is important.) 828 ;; don't remember whether this feature is important.)
832 ert-debug-on-error) 829 ert-debug-on-error)
833 830
834(defun ert--run-test-debugger (info debugger-args) 831(defun ert--run-test-debugger (info args)
835 "During a test run, `debugger' is bound to a closure that calls this function. 832 "During a test run, `debugger' is bound to a closure that calls this function.
836 833
837This function records failures and errors and either terminates 834This function records failures and errors and either terminates
@@ -839,21 +836,21 @@ the test silently or calls the interactive debugger, as
839appropriate. 836appropriate.
840 837
841INFO is the ert--test-execution-info corresponding to this test 838INFO is the ert--test-execution-info corresponding to this test
842run. DEBUGGER-ARGS are the arguments to `debugger'." 839run. ARGS are the arguments to `debugger'."
843 (destructuring-bind (first-debugger-arg &rest more-debugger-args) 840 (cl-destructuring-bind (first-debugger-arg &rest more-debugger-args)
844 debugger-args 841 args
845 (ecase first-debugger-arg 842 (cl-ecase first-debugger-arg
846 ((lambda debug t exit nil) 843 ((lambda debug t exit nil)
847 (apply (ert--test-execution-info-next-debugger info) debugger-args)) 844 (apply (ert--test-execution-info-next-debugger info) args))
848 (error 845 (error
849 (let* ((condition (first more-debugger-args)) 846 (let* ((condition (car more-debugger-args))
850 (type (case (car condition) 847 (type (cl-case (car condition)
851 ((quit) 'quit) 848 ((quit) 'quit)
852 (otherwise 'failed))) 849 (otherwise 'failed)))
853 (backtrace (ert--record-backtrace)) 850 (backtrace (ert--record-backtrace))
854 (infos (reverse ert--infos))) 851 (infos (reverse ert--infos)))
855 (setf (ert--test-execution-info-result info) 852 (setf (ert--test-execution-info-result info)
856 (ecase type 853 (cl-ecase type
857 (quit 854 (quit
858 (make-ert-test-quit :condition condition 855 (make-ert-test-quit :condition condition
859 :backtrace backtrace 856 :backtrace backtrace
@@ -864,39 +861,42 @@ run. DEBUGGER-ARGS are the arguments to `debugger'."
864 :infos infos)))) 861 :infos infos))))
865 ;; Work around Emacs's heuristic (in eval.c) for detecting 862 ;; Work around Emacs's heuristic (in eval.c) for detecting
866 ;; errors in the debugger. 863 ;; errors in the debugger.
867 (incf num-nonmacro-input-events) 864 (cl-incf num-nonmacro-input-events)
868 ;; FIXME: We should probably implement more fine-grained 865 ;; FIXME: We should probably implement more fine-grained
869 ;; control a la non-t `debug-on-error' here. 866 ;; control a la non-t `debug-on-error' here.
870 (cond 867 (cond
871 ((ert--test-execution-info-ert-debug-on-error info) 868 ((ert--test-execution-info-ert-debug-on-error info)
872 (apply (ert--test-execution-info-next-debugger info) debugger-args)) 869 (apply (ert--test-execution-info-next-debugger info) args))
873 (t)) 870 (t))
874 (funcall (ert--test-execution-info-exit-continuation info))))))) 871 (funcall (ert--test-execution-info-exit-continuation info)))))))
875 872
876(defun ert--run-test-internal (ert-test-execution-info) 873(defun ert--run-test-internal (test-execution-info)
877 "Low-level function to run a test according to ERT-TEST-EXECUTION-INFO. 874 "Low-level function to run a test according to TEST-EXECUTION-INFO.
878 875
879This mainly sets up debugger-related bindings." 876This mainly sets up debugger-related bindings."
880 (lexical-let ((info ert-test-execution-info)) 877 (setf (ert--test-execution-info-next-debugger test-execution-info) debugger
881 (setf (ert--test-execution-info-next-debugger info) debugger 878 (ert--test-execution-info-ert-debug-on-error test-execution-info)
882 (ert--test-execution-info-ert-debug-on-error info) ert-debug-on-error) 879 ert-debug-on-error)
883 (catch 'ert--pass 880 (catch 'ert--pass
884 ;; For now, each test gets its own temp buffer and its own 881 ;; For now, each test gets its own temp buffer and its own
885 ;; window excursion, just to be safe. If this turns out to be 882 ;; window excursion, just to be safe. If this turns out to be
886 ;; too expensive, we can remove it. 883 ;; too expensive, we can remove it.
887 (with-temp-buffer 884 (with-temp-buffer
888 (save-window-excursion 885 (save-window-excursion
889 (let ((debugger (lambda (&rest debugger-args) 886 (let ((debugger (lambda (&rest args)
890 (ert--run-test-debugger info debugger-args))) 887 (ert--run-test-debugger test-execution-info
891 (debug-on-error t) 888 args)))
892 (debug-on-quit t) 889 (debug-on-error t)
893 ;; FIXME: Do we need to store the old binding of this 890 (debug-on-quit t)
894 ;; and consider it in `ert--run-test-debugger'? 891 ;; FIXME: Do we need to store the old binding of this
895 (debug-ignored-errors nil) 892 ;; and consider it in `ert--run-test-debugger'?
896 (ert--infos '())) 893 (debug-ignored-errors nil)
897 (funcall (ert-test-body (ert--test-execution-info-test info)))))) 894 (ert--infos '()))
898 (ert-pass)) 895 (funcall (ert-test-body (ert--test-execution-info-test
899 (setf (ert--test-execution-info-result info) (make-ert-test-passed))) 896 test-execution-info))))))
897 (ert-pass))
898 (setf (ert--test-execution-info-result test-execution-info)
899 (make-ert-test-passed))
900 nil) 900 nil)
901 901
902(defun ert--force-message-log-buffer-truncation () 902(defun ert--force-message-log-buffer-truncation ()
@@ -934,18 +934,18 @@ The elements are of type `ert-test'.")
934 934
935Returns the result and stores it in ERT-TEST's `most-recent-result' slot." 935Returns the result and stores it in ERT-TEST's `most-recent-result' slot."
936 (setf (ert-test-most-recent-result ert-test) nil) 936 (setf (ert-test-most-recent-result ert-test) nil)
937 (block error 937 (cl-block error
938 (lexical-let ((begin-marker 938 (let ((begin-marker
939 (with-current-buffer (get-buffer-create "*Messages*") 939 (with-current-buffer (get-buffer-create "*Messages*")
940 (set-marker (make-marker) (point-max))))) 940 (set-marker (make-marker) (point-max)))))
941 (unwind-protect 941 (unwind-protect
942 (lexical-let ((info (make-ert--test-execution-info 942 (let ((info (make-ert--test-execution-info
943 :test ert-test 943 :test ert-test
944 :result 944 :result
945 (make-ert-test-aborted-with-non-local-exit) 945 (make-ert-test-aborted-with-non-local-exit)
946 :exit-continuation (lambda () 946 :exit-continuation (lambda ()
947 (return-from error nil)))) 947 (cl-return-from error nil))))
948 (should-form-accu (list))) 948 (should-form-accu (list)))
949 (unwind-protect 949 (unwind-protect
950 (let ((ert--should-execution-observer 950 (let ((ert--should-execution-observer
951 (lambda (form-description) 951 (lambda (form-description)
@@ -987,32 +987,32 @@ t -- Always matches.
987 RESULT." 987 RESULT."
988 ;; It would be easy to add `member' and `eql' types etc., but I 988 ;; It would be easy to add `member' and `eql' types etc., but I
989 ;; haven't bothered yet. 989 ;; haven't bothered yet.
990 (etypecase result-type 990 (cl-etypecase result-type
991 ((member nil) nil) 991 ((member nil) nil)
992 ((member t) t) 992 ((member t) t)
993 ((member :failed) (ert-test-failed-p result)) 993 ((member :failed) (ert-test-failed-p result))
994 ((member :passed) (ert-test-passed-p result)) 994 ((member :passed) (ert-test-passed-p result))
995 (cons 995 (cons
996 (destructuring-bind (operator &rest operands) result-type 996 (cl-destructuring-bind (operator &rest operands) result-type
997 (ecase operator 997 (cl-ecase operator
998 (and 998 (and
999 (case (length operands) 999 (cl-case (length operands)
1000 (0 t) 1000 (0 t)
1001 (t 1001 (t
1002 (and (ert-test-result-type-p result (first operands)) 1002 (and (ert-test-result-type-p result (car operands))
1003 (ert-test-result-type-p result `(and ,@(rest operands))))))) 1003 (ert-test-result-type-p result `(and ,@(cdr operands)))))))
1004 (or 1004 (or
1005 (case (length operands) 1005 (cl-case (length operands)
1006 (0 nil) 1006 (0 nil)
1007 (t 1007 (t
1008 (or (ert-test-result-type-p result (first operands)) 1008 (or (ert-test-result-type-p result (car operands))
1009 (ert-test-result-type-p result `(or ,@(rest operands))))))) 1009 (ert-test-result-type-p result `(or ,@(cdr operands)))))))
1010 (not 1010 (not
1011 (assert (eql (length operands) 1)) 1011 (cl-assert (eql (length operands) 1))
1012 (not (ert-test-result-type-p result (first operands)))) 1012 (not (ert-test-result-type-p result (car operands))))
1013 (satisfies 1013 (satisfies
1014 (assert (eql (length operands) 1)) 1014 (cl-assert (eql (length operands) 1))
1015 (funcall (first operands) result))))))) 1015 (funcall (car operands) result)))))))
1016 1016
1017(defun ert-test-result-expected-p (test result) 1017(defun ert-test-result-expected-p (test result)
1018 "Return non-nil if TEST's expected result type matches RESULT." 1018 "Return non-nil if TEST's expected result type matches RESULT."
@@ -1053,9 +1053,9 @@ set implied by them without checking whether it is really
1053contained in UNIVERSE." 1053contained in UNIVERSE."
1054 ;; This code needs to match the etypecase in 1054 ;; This code needs to match the etypecase in
1055 ;; `ert-insert-human-readable-selector'. 1055 ;; `ert-insert-human-readable-selector'.
1056 (etypecase selector 1056 (cl-etypecase selector
1057 ((member nil) nil) 1057 ((member nil) nil)
1058 ((member t) (etypecase universe 1058 ((member t) (cl-etypecase universe
1059 (list universe) 1059 (list universe)
1060 ((member t) (ert-select-tests "" universe)))) 1060 ((member t) (ert-select-tests "" universe))))
1061 ((member :new) (ert-select-tests 1061 ((member :new) (ert-select-tests
@@ -1083,7 +1083,7 @@ contained in UNIVERSE."
1083 universe)) 1083 universe))
1084 ((member :unexpected) (ert-select-tests `(not :expected) universe)) 1084 ((member :unexpected) (ert-select-tests `(not :expected) universe))
1085 (string 1085 (string
1086 (etypecase universe 1086 (cl-etypecase universe
1087 ((member t) (mapcar #'ert-get-test 1087 ((member t) (mapcar #'ert-get-test
1088 (apropos-internal selector #'ert-test-boundp))) 1088 (apropos-internal selector #'ert-test-boundp)))
1089 (list (ert--remove-if-not (lambda (test) 1089 (list (ert--remove-if-not (lambda (test)
@@ -1093,51 +1093,51 @@ contained in UNIVERSE."
1093 universe)))) 1093 universe))))
1094 (ert-test (list selector)) 1094 (ert-test (list selector))
1095 (symbol 1095 (symbol
1096 (assert (ert-test-boundp selector)) 1096 (cl-assert (ert-test-boundp selector))
1097 (list (ert-get-test selector))) 1097 (list (ert-get-test selector)))
1098 (cons 1098 (cons
1099 (destructuring-bind (operator &rest operands) selector 1099 (cl-destructuring-bind (operator &rest operands) selector
1100 (ecase operator 1100 (cl-ecase operator
1101 (member 1101 (member
1102 (mapcar (lambda (purported-test) 1102 (mapcar (lambda (purported-test)
1103 (etypecase purported-test 1103 (cl-etypecase purported-test
1104 (symbol (assert (ert-test-boundp purported-test)) 1104 (symbol (cl-assert (ert-test-boundp purported-test))
1105 (ert-get-test purported-test)) 1105 (ert-get-test purported-test))
1106 (ert-test purported-test))) 1106 (ert-test purported-test)))
1107 operands)) 1107 operands))
1108 (eql 1108 (eql
1109 (assert (eql (length operands) 1)) 1109 (cl-assert (eql (length operands) 1))
1110 (ert-select-tests `(member ,@operands) universe)) 1110 (ert-select-tests `(member ,@operands) universe))
1111 (and 1111 (and
1112 ;; Do these definitions of AND, NOT and OR satisfy de 1112 ;; Do these definitions of AND, NOT and OR satisfy de
1113 ;; Morgan's laws? Should they? 1113 ;; Morgan's laws? Should they?
1114 (case (length operands) 1114 (cl-case (length operands)
1115 (0 (ert-select-tests 't universe)) 1115 (0 (ert-select-tests 't universe))
1116 (t (ert-select-tests `(and ,@(rest operands)) 1116 (t (ert-select-tests `(and ,@(cdr operands))
1117 (ert-select-tests (first operands) 1117 (ert-select-tests (car operands)
1118 universe))))) 1118 universe)))))
1119 (not 1119 (not
1120 (assert (eql (length operands) 1)) 1120 (cl-assert (eql (length operands) 1))
1121 (let ((all-tests (ert-select-tests 't universe))) 1121 (let ((all-tests (ert-select-tests 't universe)))
1122 (ert--set-difference all-tests 1122 (ert--set-difference all-tests
1123 (ert-select-tests (first operands) 1123 (ert-select-tests (car operands)
1124 all-tests)))) 1124 all-tests))))
1125 (or 1125 (or
1126 (case (length operands) 1126 (cl-case (length operands)
1127 (0 (ert-select-tests 'nil universe)) 1127 (0 (ert-select-tests 'nil universe))
1128 (t (ert--union (ert-select-tests (first operands) universe) 1128 (t (ert--union (ert-select-tests (car operands) universe)
1129 (ert-select-tests `(or ,@(rest operands)) 1129 (ert-select-tests `(or ,@(cdr operands))
1130 universe))))) 1130 universe)))))
1131 (tag 1131 (tag
1132 (assert (eql (length operands) 1)) 1132 (cl-assert (eql (length operands) 1))
1133 (let ((tag (first operands))) 1133 (let ((tag (car operands)))
1134 (ert-select-tests `(satisfies 1134 (ert-select-tests `(satisfies
1135 ,(lambda (test) 1135 ,(lambda (test)
1136 (member tag (ert-test-tags test)))) 1136 (member tag (ert-test-tags test))))
1137 universe))) 1137 universe)))
1138 (satisfies 1138 (satisfies
1139 (assert (eql (length operands) 1)) 1139 (cl-assert (eql (length operands) 1))
1140 (ert--remove-if-not (first operands) 1140 (ert--remove-if-not (car operands)
1141 (ert-select-tests 't universe)))))))) 1141 (ert-select-tests 't universe))))))))
1142 1142
1143(defun ert--insert-human-readable-selector (selector) 1143(defun ert--insert-human-readable-selector (selector)
@@ -1146,26 +1146,27 @@ contained in UNIVERSE."
1146 ;; `backtrace' slot of the result objects in the 1146 ;; `backtrace' slot of the result objects in the
1147 ;; `most-recent-result' slots of test case objects in (eql ...) or 1147 ;; `most-recent-result' slots of test case objects in (eql ...) or
1148 ;; (member ...) selectors. 1148 ;; (member ...) selectors.
1149 (labels ((rec (selector) 1149 (cl-labels ((rec (selector)
1150 ;; This code needs to match the etypecase in `ert-select-tests'. 1150 ;; This code needs to match the etypecase in
1151 (etypecase selector 1151 ;; `ert-select-tests'.
1152 ((or (member nil t 1152 (cl-etypecase selector
1153 :new :failed :passed 1153 ((or (member nil t
1154 :expected :unexpected) 1154 :new :failed :passed
1155 string 1155 :expected :unexpected)
1156 symbol) 1156 string
1157 selector) 1157 symbol)
1158 (ert-test 1158 selector)
1159 (if (ert-test-name selector) 1159 (ert-test
1160 (make-symbol (format "<%S>" (ert-test-name selector))) 1160 (if (ert-test-name selector)
1161 (make-symbol "<unnamed test>"))) 1161 (make-symbol (format "<%S>" (ert-test-name selector)))
1162 (cons 1162 (make-symbol "<unnamed test>")))
1163 (destructuring-bind (operator &rest operands) selector 1163 (cons
1164 (ecase operator 1164 (cl-destructuring-bind (operator &rest operands) selector
1165 ((member eql and not or) 1165 (cl-ecase operator
1166 `(,operator ,@(mapcar #'rec operands))) 1166 ((member eql and not or)
1167 ((member tag satisfies) 1167 `(,operator ,@(mapcar #'rec operands)))
1168 selector))))))) 1168 ((member tag satisfies)
1169 selector)))))))
1169 (insert (format "%S" (rec selector))))) 1170 (insert (format "%S" (rec selector)))))
1170 1171
1171 1172
@@ -1182,21 +1183,21 @@ contained in UNIVERSE."
1182;; that corresponds to this run in order to be able to update the 1183;; that corresponds to this run in order to be able to update the
1183;; statistics correctly when a test is re-run interactively and has a 1184;; statistics correctly when a test is re-run interactively and has a
1184;; different result than before. 1185;; different result than before.
1185(defstruct ert--stats 1186(cl-defstruct ert--stats
1186 (selector (assert nil)) 1187 (selector (cl-assert nil))
1187 ;; The tests, in order. 1188 ;; The tests, in order.
1188 (tests (assert nil) :type vector) 1189 (tests (cl-assert nil) :type vector)
1189 ;; A map of test names (or the test objects themselves for unnamed 1190 ;; A map of test names (or the test objects themselves for unnamed
1190 ;; tests) to indices into the `tests' vector. 1191 ;; tests) to indices into the `tests' vector.
1191 (test-map (assert nil) :type hash-table) 1192 (test-map (cl-assert nil) :type hash-table)
1192 ;; The results of the tests during this run, in order. 1193 ;; The results of the tests during this run, in order.
1193 (test-results (assert nil) :type vector) 1194 (test-results (cl-assert nil) :type vector)
1194 ;; The start times of the tests, in order, as reported by 1195 ;; The start times of the tests, in order, as reported by
1195 ;; `current-time'. 1196 ;; `current-time'.
1196 (test-start-times (assert nil) :type vector) 1197 (test-start-times (cl-assert nil) :type vector)
1197 ;; The end times of the tests, in order, as reported by 1198 ;; The end times of the tests, in order, as reported by
1198 ;; `current-time'. 1199 ;; `current-time'.
1199 (test-end-times (assert nil) :type vector) 1200 (test-end-times (cl-assert nil) :type vector)
1200 (passed-expected 0) 1201 (passed-expected 0)
1201 (passed-unexpected 0) 1202 (passed-unexpected 0)
1202 (failed-expected 0) 1203 (failed-expected 0)
@@ -1246,21 +1247,25 @@ Also changes the counters in STATS to match."
1246 (results (ert--stats-test-results stats)) 1247 (results (ert--stats-test-results stats))
1247 (old-test (aref tests pos)) 1248 (old-test (aref tests pos))
1248 (map (ert--stats-test-map stats))) 1249 (map (ert--stats-test-map stats)))
1249 (flet ((update (d) 1250 (cl-flet ((update (d)
1250 (if (ert-test-result-expected-p (aref tests pos) 1251 (if (ert-test-result-expected-p (aref tests pos)
1251 (aref results pos)) 1252 (aref results pos))
1252 (etypecase (aref results pos) 1253 (cl-etypecase (aref results pos)
1253 (ert-test-passed (incf (ert--stats-passed-expected stats) d)) 1254 (ert-test-passed
1254 (ert-test-failed (incf (ert--stats-failed-expected stats) d)) 1255 (cl-incf (ert--stats-passed-expected stats) d))
1255 (null) 1256 (ert-test-failed
1256 (ert-test-aborted-with-non-local-exit) 1257 (cl-incf (ert--stats-failed-expected stats) d))
1257 (ert-test-quit)) 1258 (null)
1258 (etypecase (aref results pos) 1259 (ert-test-aborted-with-non-local-exit)
1259 (ert-test-passed (incf (ert--stats-passed-unexpected stats) d)) 1260 (ert-test-quit))
1260 (ert-test-failed (incf (ert--stats-failed-unexpected stats) d)) 1261 (cl-etypecase (aref results pos)
1261 (null) 1262 (ert-test-passed
1262 (ert-test-aborted-with-non-local-exit) 1263 (cl-incf (ert--stats-passed-unexpected stats) d))
1263 (ert-test-quit))))) 1264 (ert-test-failed
1265 (cl-incf (ert--stats-failed-unexpected stats) d))
1266 (null)
1267 (ert-test-aborted-with-non-local-exit)
1268 (ert-test-quit)))))
1264 ;; Adjust counters to remove the result that is currently in stats. 1269 ;; Adjust counters to remove the result that is currently in stats.
1265 (update -1) 1270 (update -1)
1266 ;; Put new test and result into stats. 1271 ;; Put new test and result into stats.
@@ -1278,11 +1283,11 @@ Also changes the counters in STATS to match."
1278SELECTOR is the selector that was used to select TESTS." 1283SELECTOR is the selector that was used to select TESTS."
1279 (setq tests (ert--coerce-to-vector tests)) 1284 (setq tests (ert--coerce-to-vector tests))
1280 (let ((map (make-hash-table :size (length tests)))) 1285 (let ((map (make-hash-table :size (length tests))))
1281 (loop for i from 0 1286 (cl-loop for i from 0
1282 for test across tests 1287 for test across tests
1283 for key = (ert--stats-test-key test) do 1288 for key = (ert--stats-test-key test) do
1284 (assert (not (gethash key map))) 1289 (cl-assert (not (gethash key map)))
1285 (setf (gethash key map) i)) 1290 (setf (gethash key map) i))
1286 (make-ert--stats :selector selector 1291 (make-ert--stats :selector selector
1287 :tests tests 1292 :tests tests
1288 :test-map map 1293 :test-map map
@@ -1324,8 +1329,8 @@ SELECTOR is the selector that was used to select TESTS."
1324 (force-mode-line-update) 1329 (force-mode-line-update)
1325 (unwind-protect 1330 (unwind-protect
1326 (progn 1331 (progn
1327 (loop for test in tests do 1332 (cl-loop for test in tests do
1328 (ert-run-or-rerun-test stats test listener)) 1333 (ert-run-or-rerun-test stats test listener))
1329 (setq abortedp nil)) 1334 (setq abortedp nil))
1330 (setf (ert--stats-aborted-p stats) abortedp) 1335 (setf (ert--stats-aborted-p stats) abortedp)
1331 (setf (ert--stats-end-time stats) (current-time)) 1336 (setf (ert--stats-end-time stats) (current-time))
@@ -1349,7 +1354,7 @@ SELECTOR is the selector that was used to select TESTS."
1349 "Return a character that represents the test result RESULT. 1354 "Return a character that represents the test result RESULT.
1350 1355
1351EXPECTEDP specifies whether the result was expected." 1356EXPECTEDP specifies whether the result was expected."
1352 (let ((s (etypecase result 1357 (let ((s (cl-etypecase result
1353 (ert-test-passed ".P") 1358 (ert-test-passed ".P")
1354 (ert-test-failed "fF") 1359 (ert-test-failed "fF")
1355 (null "--") 1360 (null "--")
@@ -1361,7 +1366,7 @@ EXPECTEDP specifies whether the result was expected."
1361 "Return a string that represents the test result RESULT. 1366 "Return a string that represents the test result RESULT.
1362 1367
1363EXPECTEDP specifies whether the result was expected." 1368EXPECTEDP specifies whether the result was expected."
1364 (let ((s (etypecase result 1369 (let ((s (cl-etypecase result
1365 (ert-test-passed '("passed" "PASSED")) 1370 (ert-test-passed '("passed" "PASSED"))
1366 (ert-test-failed '("failed" "FAILED")) 1371 (ert-test-failed '("failed" "FAILED"))
1367 (null '("unknown" "UNKNOWN")) 1372 (null '("unknown" "UNKNOWN"))
@@ -1383,9 +1388,9 @@ Ensures a final newline is inserted."
1383 "Insert `ert-info' infos from RESULT into current buffer. 1388 "Insert `ert-info' infos from RESULT into current buffer.
1384 1389
1385RESULT must be an `ert-test-result-with-condition'." 1390RESULT must be an `ert-test-result-with-condition'."
1386 (check-type result ert-test-result-with-condition) 1391 (cl-check-type result ert-test-result-with-condition)
1387 (dolist (info (ert-test-result-with-condition-infos result)) 1392 (dolist (info (ert-test-result-with-condition-infos result))
1388 (destructuring-bind (prefix . message) info 1393 (cl-destructuring-bind (prefix . message) info
1389 (let ((begin (point)) 1394 (let ((begin (point))
1390 (indentation (make-string (+ (length prefix) 4) ?\s)) 1395 (indentation (make-string (+ (length prefix) 4) ?\s))
1391 (end nil)) 1396 (end nil))
@@ -1421,14 +1426,14 @@ Returns the stats object."
1421 (ert-run-tests 1426 (ert-run-tests
1422 selector 1427 selector
1423 (lambda (event-type &rest event-args) 1428 (lambda (event-type &rest event-args)
1424 (ecase event-type 1429 (cl-ecase event-type
1425 (run-started 1430 (run-started
1426 (destructuring-bind (stats) event-args 1431 (cl-destructuring-bind (stats) event-args
1427 (message "Running %s tests (%s)" 1432 (message "Running %s tests (%s)"
1428 (length (ert--stats-tests stats)) 1433 (length (ert--stats-tests stats))
1429 (ert--format-time-iso8601 (ert--stats-start-time stats))))) 1434 (ert--format-time-iso8601 (ert--stats-start-time stats)))))
1430 (run-ended 1435 (run-ended
1431 (destructuring-bind (stats abortedp) event-args 1436 (cl-destructuring-bind (stats abortedp) event-args
1432 (let ((unexpected (ert-stats-completed-unexpected stats)) 1437 (let ((unexpected (ert-stats-completed-unexpected stats))
1433 (expected-failures (ert--stats-failed-expected stats))) 1438 (expected-failures (ert--stats-failed-expected stats)))
1434 (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n" 1439 (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n"
@@ -1446,19 +1451,19 @@ Returns the stats object."
1446 (format "\n%s expected failures" expected-failures))) 1451 (format "\n%s expected failures" expected-failures)))
1447 (unless (zerop unexpected) 1452 (unless (zerop unexpected)
1448 (message "%s unexpected results:" unexpected) 1453 (message "%s unexpected results:" unexpected)
1449 (loop for test across (ert--stats-tests stats) 1454 (cl-loop for test across (ert--stats-tests stats)
1450 for result = (ert-test-most-recent-result test) do 1455 for result = (ert-test-most-recent-result test) do
1451 (when (not (ert-test-result-expected-p test result)) 1456 (when (not (ert-test-result-expected-p test result))
1452 (message "%9s %S" 1457 (message "%9s %S"
1453 (ert-string-for-test-result result nil) 1458 (ert-string-for-test-result result nil)
1454 (ert-test-name test)))) 1459 (ert-test-name test))))
1455 (message "%s" ""))))) 1460 (message "%s" "")))))
1456 (test-started 1461 (test-started
1457 ) 1462 )
1458 (test-ended 1463 (test-ended
1459 (destructuring-bind (stats test result) event-args 1464 (cl-destructuring-bind (stats test result) event-args
1460 (unless (ert-test-result-expected-p test result) 1465 (unless (ert-test-result-expected-p test result)
1461 (etypecase result 1466 (cl-etypecase result
1462 (ert-test-passed 1467 (ert-test-passed
1463 (message "Test %S passed unexpectedly" (ert-test-name test))) 1468 (message "Test %S passed unexpectedly" (ert-test-name test)))
1464 (ert-test-result-with-condition 1469 (ert-test-result-with-condition
@@ -1484,7 +1489,7 @@ Returns the stats object."
1484 (ert--pp-with-indentation-and-newline 1489 (ert--pp-with-indentation-and-newline
1485 (ert-test-result-with-condition-condition result))) 1490 (ert-test-result-with-condition-condition result)))
1486 (goto-char (1- (point-max))) 1491 (goto-char (1- (point-max)))
1487 (assert (looking-at "\n")) 1492 (cl-assert (looking-at "\n"))
1488 (delete-char 1) 1493 (delete-char 1)
1489 (message "Test %S condition:" (ert-test-name test)) 1494 (message "Test %S condition:" (ert-test-name test))
1490 (message "%s" (buffer-string)))) 1495 (message "%s" (buffer-string))))
@@ -1532,7 +1537,7 @@ the tests)."
1532 (1 font-lock-keyword-face nil t) 1537 (1 font-lock-keyword-face nil t)
1533 (2 font-lock-function-name-face nil t))))) 1538 (2 font-lock-function-name-face nil t)))))
1534 1539
1535(defun* ert--remove-from-list (list-var element &key key test) 1540(cl-defun ert--remove-from-list (list-var element &key key test)
1536 "Remove ELEMENT from the value of LIST-VAR if present. 1541 "Remove ELEMENT from the value of LIST-VAR if present.
1537 1542
1538This can be used as an inverse of `add-to-list'." 1543This can be used as an inverse of `add-to-list'."
@@ -1557,7 +1562,7 @@ If ADD-DEFAULT-TO-PROMPT is non-nil, PROMPT will be modified to
1557include the default, if any. 1562include the default, if any.
1558 1563
1559Signals an error if no test name was read." 1564Signals an error if no test name was read."
1560 (etypecase default 1565 (cl-etypecase default
1561 (string (let ((symbol (intern-soft default))) 1566 (string (let ((symbol (intern-soft default)))
1562 (unless (and symbol (ert-test-boundp symbol)) 1567 (unless (and symbol (ert-test-boundp symbol))
1563 (setq default nil)))) 1568 (setq default nil))))
@@ -1614,11 +1619,11 @@ Nothing more than an interactive interface to `ert-make-test-unbound'."
1614;;; Display of test progress and results. 1619;;; Display of test progress and results.
1615 1620
1616;; An entry in the results buffer ewoc. There is one entry per test. 1621;; An entry in the results buffer ewoc. There is one entry per test.
1617(defstruct ert--ewoc-entry 1622(cl-defstruct ert--ewoc-entry
1618 (test (assert nil)) 1623 (test (cl-assert nil))
1619 ;; If the result of this test was expected, its ewoc entry is hidden 1624 ;; If the result of this test was expected, its ewoc entry is hidden
1620 ;; initially. 1625 ;; initially.
1621 (hidden-p (assert nil)) 1626 (hidden-p (cl-assert nil))
1622 ;; An ewoc entry may be collapsed to hide details such as the error 1627 ;; An ewoc entry may be collapsed to hide details such as the error
1623 ;; condition. 1628 ;; condition.
1624 ;; 1629 ;;
@@ -1694,7 +1699,7 @@ Also sets `ert--results-progress-bar-button-begin'."
1694 ((ert--stats-current-test stats) 'running) 1699 ((ert--stats-current-test stats) 'running)
1695 ((ert--stats-end-time stats) 'finished) 1700 ((ert--stats-end-time stats) 'finished)
1696 (t 'preparing)))) 1701 (t 'preparing))))
1697 (ecase state 1702 (cl-ecase state
1698 (preparing 1703 (preparing
1699 (insert "")) 1704 (insert ""))
1700 (aborted 1705 (aborted
@@ -1705,12 +1710,12 @@ Also sets `ert--results-progress-bar-button-begin'."
1705 (t 1710 (t
1706 (insert "Aborted.")))) 1711 (insert "Aborted."))))
1707 (running 1712 (running
1708 (assert (ert--stats-current-test stats)) 1713 (cl-assert (ert--stats-current-test stats))
1709 (insert "Running test: ") 1714 (insert "Running test: ")
1710 (ert-insert-test-name-button (ert-test-name 1715 (ert-insert-test-name-button (ert-test-name
1711 (ert--stats-current-test stats)))) 1716 (ert--stats-current-test stats))))
1712 (finished 1717 (finished
1713 (assert (not (ert--stats-current-test stats))) 1718 (cl-assert (not (ert--stats-current-test stats)))
1714 (insert "Finished."))) 1719 (insert "Finished.")))
1715 (insert "\n") 1720 (insert "\n")
1716 (if (ert--stats-end-time stats) 1721 (if (ert--stats-end-time stats)
@@ -1813,7 +1818,7 @@ non-nil, returns the face for expected results.."
1813(defun ert-face-for-stats (stats) 1818(defun ert-face-for-stats (stats)
1814 "Return a face that represents STATS." 1819 "Return a face that represents STATS."
1815 (cond ((ert--stats-aborted-p stats) 'nil) 1820 (cond ((ert--stats-aborted-p stats) 'nil)
1816 ((plusp (ert-stats-completed-unexpected stats)) 1821 ((cl-plusp (ert-stats-completed-unexpected stats))
1817 (ert-face-for-test-result nil)) 1822 (ert-face-for-test-result nil))
1818 ((eql (ert-stats-completed-expected stats) (ert-stats-total stats)) 1823 ((eql (ert-stats-completed-expected stats) (ert-stats-total stats))
1819 (ert-face-for-test-result t)) 1824 (ert-face-for-test-result t))
@@ -1824,7 +1829,7 @@ non-nil, returns the face for expected results.."
1824 (let* ((test (ert--ewoc-entry-test entry)) 1829 (let* ((test (ert--ewoc-entry-test entry))
1825 (stats ert--results-stats) 1830 (stats ert--results-stats)
1826 (result (let ((pos (ert--stats-test-pos stats test))) 1831 (result (let ((pos (ert--stats-test-pos stats test)))
1827 (assert pos) 1832 (cl-assert pos)
1828 (aref (ert--stats-test-results stats) pos))) 1833 (aref (ert--stats-test-results stats) pos)))
1829 (hiddenp (ert--ewoc-entry-hidden-p entry)) 1834 (hiddenp (ert--ewoc-entry-hidden-p entry))
1830 (expandedp (ert--ewoc-entry-expanded-p entry)) 1835 (expandedp (ert--ewoc-entry-expanded-p entry))
@@ -1850,7 +1855,7 @@ non-nil, returns the face for expected results.."
1850 (ert--string-first-line (ert-test-documentation test)) 1855 (ert--string-first-line (ert-test-documentation test))
1851 'font-lock-face 'font-lock-doc-face) 1856 'font-lock-face 'font-lock-doc-face)
1852 "\n")) 1857 "\n"))
1853 (etypecase result 1858 (cl-etypecase result
1854 (ert-test-passed 1859 (ert-test-passed
1855 (if (ert-test-result-expected-p test result) 1860 (if (ert-test-result-expected-p test result)
1856 (insert " passed\n") 1861 (insert " passed\n")
@@ -1908,9 +1913,10 @@ BUFFER-NAME, if non-nil, is the buffer name to use."
1908 (make-string (ert-stats-total stats) 1913 (make-string (ert-stats-total stats)
1909 (ert-char-for-test-result nil t))) 1914 (ert-char-for-test-result nil t)))
1910 (set (make-local-variable 'ert--results-listener) listener) 1915 (set (make-local-variable 'ert--results-listener) listener)
1911 (loop for test across (ert--stats-tests stats) do 1916 (cl-loop for test across (ert--stats-tests stats) do
1912 (ewoc-enter-last ewoc 1917 (ewoc-enter-last ewoc
1913 (make-ert--ewoc-entry :test test :hidden-p t))) 1918 (make-ert--ewoc-entry :test test
1919 :hidden-p t)))
1914 (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) 1920 (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats)
1915 (goto-char (1- (point-max))) 1921 (goto-char (1- (point-max)))
1916 buffer))))) 1922 buffer)))))
@@ -1945,21 +1951,21 @@ and how to display message."
1945 default nil)) 1951 default nil))
1946 nil)) 1952 nil))
1947 (unless message-fn (setq message-fn 'message)) 1953 (unless message-fn (setq message-fn 'message))
1948 (lexical-let ((output-buffer-name output-buffer-name) 1954 (let ((output-buffer-name output-buffer-name)
1949 buffer 1955 buffer
1950 listener 1956 listener
1951 (message-fn message-fn)) 1957 (message-fn message-fn))
1952 (setq listener 1958 (setq listener
1953 (lambda (event-type &rest event-args) 1959 (lambda (event-type &rest event-args)
1954 (ecase event-type 1960 (cl-ecase event-type
1955 (run-started 1961 (run-started
1956 (destructuring-bind (stats) event-args 1962 (cl-destructuring-bind (stats) event-args
1957 (setq buffer (ert--setup-results-buffer stats 1963 (setq buffer (ert--setup-results-buffer stats
1958 listener 1964 listener
1959 output-buffer-name)) 1965 output-buffer-name))
1960 (pop-to-buffer buffer))) 1966 (pop-to-buffer buffer)))
1961 (run-ended 1967 (run-ended
1962 (destructuring-bind (stats abortedp) event-args 1968 (cl-destructuring-bind (stats abortedp) event-args
1963 (funcall message-fn 1969 (funcall message-fn
1964 "%sRan %s tests, %s results were as expected%s" 1970 "%sRan %s tests, %s results were as expected%s"
1965 (if (not abortedp) 1971 (if (not abortedp)
@@ -1976,19 +1982,19 @@ and how to display message."
1976 ert--results-ewoc) 1982 ert--results-ewoc)
1977 stats))) 1983 stats)))
1978 (test-started 1984 (test-started
1979 (destructuring-bind (stats test) event-args 1985 (cl-destructuring-bind (stats test) event-args
1980 (with-current-buffer buffer 1986 (with-current-buffer buffer
1981 (let* ((ewoc ert--results-ewoc) 1987 (let* ((ewoc ert--results-ewoc)
1982 (pos (ert--stats-test-pos stats test)) 1988 (pos (ert--stats-test-pos stats test))
1983 (node (ewoc-nth ewoc pos))) 1989 (node (ewoc-nth ewoc pos)))
1984 (assert node) 1990 (cl-assert node)
1985 (setf (ert--ewoc-entry-test (ewoc-data node)) test) 1991 (setf (ert--ewoc-entry-test (ewoc-data node)) test)
1986 (aset ert--results-progress-bar-string pos 1992 (aset ert--results-progress-bar-string pos
1987 (ert-char-for-test-result nil t)) 1993 (ert-char-for-test-result nil t))
1988 (ert--results-update-stats-display-maybe ewoc stats) 1994 (ert--results-update-stats-display-maybe ewoc stats)
1989 (ewoc-invalidate ewoc node))))) 1995 (ewoc-invalidate ewoc node)))))
1990 (test-ended 1996 (test-ended
1991 (destructuring-bind (stats test result) event-args 1997 (cl-destructuring-bind (stats test result) event-args
1992 (with-current-buffer buffer 1998 (with-current-buffer buffer
1993 (let* ((ewoc ert--results-ewoc) 1999 (let* ((ewoc ert--results-ewoc)
1994 (pos (ert--stats-test-pos stats test)) 2000 (pos (ert--stats-test-pos stats test))
@@ -2020,28 +2026,28 @@ and how to display message."
2020(define-derived-mode ert-results-mode special-mode "ERT-Results" 2026(define-derived-mode ert-results-mode special-mode "ERT-Results"
2021 "Major mode for viewing results of ERT test runs.") 2027 "Major mode for viewing results of ERT test runs.")
2022 2028
2023(loop for (key binding) in 2029(cl-loop for (key binding) in
2024 '(;; Stuff that's not in the menu. 2030 '( ;; Stuff that's not in the menu.
2025 ("\t" forward-button) 2031 ("\t" forward-button)
2026 ([backtab] backward-button) 2032 ([backtab] backward-button)
2027 ("j" ert-results-jump-between-summary-and-result) 2033 ("j" ert-results-jump-between-summary-and-result)
2028 ("L" ert-results-toggle-printer-limits-for-test-at-point) 2034 ("L" ert-results-toggle-printer-limits-for-test-at-point)
2029 ("n" ert-results-next-test) 2035 ("n" ert-results-next-test)
2030 ("p" ert-results-previous-test) 2036 ("p" ert-results-previous-test)
2031 ;; Stuff that is in the menu. 2037 ;; Stuff that is in the menu.
2032 ("R" ert-results-rerun-all-tests) 2038 ("R" ert-results-rerun-all-tests)
2033 ("r" ert-results-rerun-test-at-point) 2039 ("r" ert-results-rerun-test-at-point)
2034 ("d" ert-results-rerun-test-at-point-debugging-errors) 2040 ("d" ert-results-rerun-test-at-point-debugging-errors)
2035 ("." ert-results-find-test-at-point-other-window) 2041 ("." ert-results-find-test-at-point-other-window)
2036 ("b" ert-results-pop-to-backtrace-for-test-at-point) 2042 ("b" ert-results-pop-to-backtrace-for-test-at-point)
2037 ("m" ert-results-pop-to-messages-for-test-at-point) 2043 ("m" ert-results-pop-to-messages-for-test-at-point)
2038 ("l" ert-results-pop-to-should-forms-for-test-at-point) 2044 ("l" ert-results-pop-to-should-forms-for-test-at-point)
2039 ("h" ert-results-describe-test-at-point) 2045 ("h" ert-results-describe-test-at-point)
2040 ("D" ert-delete-test) 2046 ("D" ert-delete-test)
2041 ("T" ert-results-pop-to-timings) 2047 ("T" ert-results-pop-to-timings)
2042 ) 2048 )
2043 do 2049 do
2044 (define-key ert-results-mode-map key binding)) 2050 (define-key ert-results-mode-map key binding))
2045 2051
2046(easy-menu-define ert-results-mode-menu ert-results-mode-map 2052(easy-menu-define ert-results-mode-menu ert-results-mode-map
2047 "Menu for `ert-results-mode'." 2053 "Menu for `ert-results-mode'."
@@ -2121,15 +2127,15 @@ To be used in the ERT results buffer."
2121EWOC-FN specifies the direction and should be either `ewoc-prev' 2127EWOC-FN specifies the direction and should be either `ewoc-prev'
2122or `ewoc-next'. If there are no more nodes in that direction, an 2128or `ewoc-next'. If there are no more nodes in that direction, an
2123error is signaled with the message ERROR-MESSAGE." 2129error is signaled with the message ERROR-MESSAGE."
2124 (loop 2130 (cl-loop
2125 (setq node (funcall ewoc-fn ert--results-ewoc node)) 2131 (setq node (funcall ewoc-fn ert--results-ewoc node))
2126 (when (null node) 2132 (when (null node)
2127 (error "%s" error-message)) 2133 (error "%s" error-message))
2128 (unless (ert--ewoc-entry-hidden-p (ewoc-data node)) 2134 (unless (ert--ewoc-entry-hidden-p (ewoc-data node))
2129 (goto-char (ewoc-location node)) 2135 (goto-char (ewoc-location node))
2130 (return)))) 2136 (cl-return))))
2131 2137
2132(defun ert--results-expand-collapse-button-action (button) 2138(defun ert--results-expand-collapse-button-action (_button)
2133 "Expand or collapse the test node BUTTON belongs to." 2139 "Expand or collapse the test node BUTTON belongs to."
2134 (let* ((ewoc ert--results-ewoc) 2140 (let* ((ewoc ert--results-ewoc)
2135 (node (save-excursion 2141 (node (save-excursion
@@ -2158,11 +2164,11 @@ To be used in the ERT results buffer."
2158(defun ert--ewoc-position (ewoc node) 2164(defun ert--ewoc-position (ewoc node)
2159 ;; checkdoc-order: nil 2165 ;; checkdoc-order: nil
2160 "Return the position of NODE in EWOC, or nil if NODE is not in EWOC." 2166 "Return the position of NODE in EWOC, or nil if NODE is not in EWOC."
2161 (loop for i from 0 2167 (cl-loop for i from 0
2162 for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here) 2168 for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here)
2163 do (when (eql node node-here) 2169 do (when (eql node node-here)
2164 (return i)) 2170 (cl-return i))
2165 finally (return nil))) 2171 finally (cl-return nil)))
2166 2172
2167(defun ert-results-jump-between-summary-and-result () 2173(defun ert-results-jump-between-summary-and-result ()
2168 "Jump back and forth between the test run summary and individual test results. 2174 "Jump back and forth between the test run summary and individual test results.
@@ -2210,7 +2216,7 @@ To be used in the ERT results buffer."
2210 "Return the test at point, or nil. 2216 "Return the test at point, or nil.
2211 2217
2212To be used in the ERT results buffer." 2218To be used in the ERT results buffer."
2213 (assert (eql major-mode 'ert-results-mode)) 2219 (cl-assert (eql major-mode 'ert-results-mode))
2214 (if (ert--results-test-node-or-null-at-point) 2220 (if (ert--results-test-node-or-null-at-point)
2215 (let* ((node (ert--results-test-node-at-point)) 2221 (let* ((node (ert--results-test-node-at-point))
2216 (test (ert--ewoc-entry-test (ewoc-data node)))) 2222 (test (ert--ewoc-entry-test (ewoc-data node))))
@@ -2282,9 +2288,9 @@ definition."
2282 (point)) 2288 (point))
2283 ((eventp last-command-event) 2289 ((eventp last-command-event)
2284 (posn-point (event-start last-command-event))) 2290 (posn-point (event-start last-command-event)))
2285 (t (assert nil)))) 2291 (t (cl-assert nil))))
2286 2292
2287(defun ert--results-progress-bar-button-action (button) 2293(defun ert--results-progress-bar-button-action (_button)
2288 "Jump to details for the test represented by the character clicked in BUTTON." 2294 "Jump to details for the test represented by the character clicked in BUTTON."
2289 (goto-char (ert--button-action-position)) 2295 (goto-char (ert--button-action-position))
2290 (ert-results-jump-between-summary-and-result)) 2296 (ert-results-jump-between-summary-and-result))
@@ -2294,7 +2300,7 @@ definition."
2294 2300
2295To be used in the ERT results buffer." 2301To be used in the ERT results buffer."
2296 (interactive) 2302 (interactive)
2297 (assert (eql major-mode 'ert-results-mode)) 2303 (cl-assert (eql major-mode 'ert-results-mode))
2298 (let ((selector (ert--stats-selector ert--results-stats))) 2304 (let ((selector (ert--stats-selector ert--results-stats)))
2299 (ert-run-tests-interactively selector (buffer-name)))) 2305 (ert-run-tests-interactively selector (buffer-name))))
2300 2306
@@ -2303,13 +2309,13 @@ To be used in the ERT results buffer."
2303 2309
2304To be used in the ERT results buffer." 2310To be used in the ERT results buffer."
2305 (interactive) 2311 (interactive)
2306 (destructuring-bind (test redefinition-state) 2312 (cl-destructuring-bind (test redefinition-state)
2307 (ert--results-test-at-point-allow-redefinition) 2313 (ert--results-test-at-point-allow-redefinition)
2308 (when (null test) 2314 (when (null test)
2309 (error "No test at point")) 2315 (error "No test at point"))
2310 (let* ((stats ert--results-stats) 2316 (let* ((stats ert--results-stats)
2311 (progress-message (format "Running %stest %S" 2317 (progress-message (format "Running %stest %S"
2312 (ecase redefinition-state 2318 (cl-ecase redefinition-state
2313 ((nil) "") 2319 ((nil) "")
2314 (redefined "new definition of ") 2320 (redefined "new definition of ")
2315 (deleted "deleted ")) 2321 (deleted "deleted "))
@@ -2350,7 +2356,7 @@ To be used in the ERT results buffer."
2350 (stats ert--results-stats) 2356 (stats ert--results-stats)
2351 (pos (ert--stats-test-pos stats test)) 2357 (pos (ert--stats-test-pos stats test))
2352 (result (aref (ert--stats-test-results stats) pos))) 2358 (result (aref (ert--stats-test-results stats) pos)))
2353 (etypecase result 2359 (cl-etypecase result
2354 (ert-test-passed (error "Test passed, no backtrace available")) 2360 (ert-test-passed (error "Test passed, no backtrace available"))
2355 (ert-test-result-with-condition 2361 (ert-test-result-with-condition
2356 (let ((backtrace (ert-test-result-with-condition-backtrace result)) 2362 (let ((backtrace (ert-test-result-with-condition-backtrace result))
@@ -2408,13 +2414,14 @@ To be used in the ERT results buffer."
2408 (ert-simple-view-mode) 2414 (ert-simple-view-mode)
2409 (if (null (ert-test-result-should-forms result)) 2415 (if (null (ert-test-result-should-forms result))
2410 (insert "\n(No should forms during this test.)\n") 2416 (insert "\n(No should forms during this test.)\n")
2411 (loop for form-description in (ert-test-result-should-forms result) 2417 (cl-loop for form-description
2412 for i from 1 do 2418 in (ert-test-result-should-forms result)
2413 (insert "\n") 2419 for i from 1 do
2414 (insert (format "%s: " i)) 2420 (insert "\n")
2415 (let ((begin (point))) 2421 (insert (format "%s: " i))
2416 (ert--pp-with-indentation-and-newline form-description) 2422 (let ((begin (point)))
2417 (ert--make-xrefs-region begin (point))))) 2423 (ert--pp-with-indentation-and-newline form-description)
2424 (ert--make-xrefs-region begin (point)))))
2418 (goto-char (point-min)) 2425 (goto-char (point-min))
2419 (insert "`should' forms executed during test `") 2426 (insert "`should' forms executed during test `")
2420 (ert-insert-test-name-button (ert-test-name test)) 2427 (ert-insert-test-name-button (ert-test-name test))
@@ -2443,17 +2450,16 @@ To be used in the ERT results buffer."
2443To be used in the ERT results buffer." 2450To be used in the ERT results buffer."
2444 (interactive) 2451 (interactive)
2445 (let* ((stats ert--results-stats) 2452 (let* ((stats ert--results-stats)
2446 (start-times (ert--stats-test-start-times stats))
2447 (end-times (ert--stats-test-end-times stats))
2448 (buffer (get-buffer-create "*ERT timings*")) 2453 (buffer (get-buffer-create "*ERT timings*"))
2449 (data (loop for test across (ert--stats-tests stats) 2454 (data (cl-loop for test across (ert--stats-tests stats)
2450 for start-time across (ert--stats-test-start-times stats) 2455 for start-time across (ert--stats-test-start-times
2451 for end-time across (ert--stats-test-end-times stats) 2456 stats)
2452 collect (list test 2457 for end-time across (ert--stats-test-end-times stats)
2453 (float-time (subtract-time end-time 2458 collect (list test
2454 start-time)))))) 2459 (float-time (subtract-time
2460 end-time start-time))))))
2455 (setq data (sort data (lambda (a b) 2461 (setq data (sort data (lambda (a b)
2456 (> (second a) (second b))))) 2462 (> (cl-second a) (cl-second b)))))
2457 (pop-to-buffer buffer) 2463 (pop-to-buffer buffer)
2458 (let ((inhibit-read-only t)) 2464 (let ((inhibit-read-only t))
2459 (buffer-disable-undo) 2465 (buffer-disable-undo)
@@ -2462,13 +2468,13 @@ To be used in the ERT results buffer."
2462 (if (null data) 2468 (if (null data)
2463 (insert "(No data)\n") 2469 (insert "(No data)\n")
2464 (insert (format "%-3s %8s %8s\n" "" "time" "cumul")) 2470 (insert (format "%-3s %8s %8s\n" "" "time" "cumul"))
2465 (loop for (test time) in data 2471 (cl-loop for (test time) in data
2466 for cumul-time = time then (+ cumul-time time) 2472 for cumul-time = time then (+ cumul-time time)
2467 for i from 1 do 2473 for i from 1 do
2468 (let ((begin (point))) 2474 (progn
2469 (insert (format "%3s: %8.3f %8.3f " i time cumul-time)) 2475 (insert (format "%3s: %8.3f %8.3f " i time cumul-time))
2470 (ert-insert-test-name-button (ert-test-name test)) 2476 (ert-insert-test-name-button (ert-test-name test))
2471 (insert "\n")))) 2477 (insert "\n"))))
2472 (goto-char (point-min)) 2478 (goto-char (point-min))
2473 (insert "Tests by run time (seconds):\n\n") 2479 (insert "Tests by run time (seconds):\n\n")
2474 (forward-line 1)))) 2480 (forward-line 1))))
@@ -2481,7 +2487,7 @@ To be used in the ERT results buffer."
2481 (error "Requires Emacs 24")) 2487 (error "Requires Emacs 24"))
2482 (let (test-name 2488 (let (test-name
2483 test-definition) 2489 test-definition)
2484 (etypecase test-or-test-name 2490 (cl-etypecase test-or-test-name
2485 (symbol (setq test-name test-or-test-name 2491 (symbol (setq test-name test-or-test-name
2486 test-definition (ert-get-test test-or-test-name))) 2492 test-definition (ert-get-test test-or-test-name)))
2487 (ert-test (setq test-name (ert-test-name test-or-test-name) 2493 (ert-test (setq test-name (ert-test-name test-or-test-name)
diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el
index 540e0166ec2..d9c5316b1b8 100644
--- a/lisp/emacs-lisp/nadvice.el
+++ b/lisp/emacs-lisp/nadvice.el
@@ -402,6 +402,56 @@ of the piece of advice."
402 (if (fboundp function-name) 402 (if (fboundp function-name)
403 (symbol-function function-name)))))) 403 (symbol-function function-name))))))
404 404
405;; When code is advised, called-interactively-p needs to be taught to skip
406;; the advising frames.
407;; FIXME: This Major Ugly Hack won't handle calls to called-interactively-p
408;; done from the advised function if the deepest advice is an around advice!
409;; In other cases (calls from an advice or calls from the advised function when
410;; the deepest advice is not an around advice), it should hopefully get
411;; it right.
412(add-hook 'called-interactively-p-functions
413 #'advice--called-interactively-skip)
414(defun advice--called-interactively-skip (origi frame1 frame2)
415 (let* ((i origi)
416 (get-next-frame
417 (lambda ()
418 (setq frame1 frame2)
419 (setq frame2 (internal--called-interactively-p--get-frame i))
420 ;; (message "Advice Frame %d = %S" i frame2)
421 (setq i (1+ i)))))
422 (when (and (eq (nth 1 frame2) 'apply)
423 (progn
424 (funcall get-next-frame)
425 (advice--p (indirect-function (nth 1 frame2)))))
426 (funcall get-next-frame)
427 ;; If we now have the symbol, this was the head advice and
428 ;; we're done.
429 (while (advice--p (nth 1 frame1))
430 ;; This was an inner advice called from some earlier advice.
431 ;; The stack frames look different depending on the particular
432 ;; kind of the earlier advice.
433 (let ((inneradvice (nth 1 frame1)))
434 (if (and (eq (nth 1 frame2) 'apply)
435 (progn
436 (funcall get-next-frame)
437 (advice--p (indirect-function
438 (nth 1 frame2)))))
439 ;; The earlier advice was something like a before/after
440 ;; advice where the "next" code is called directly by the
441 ;; advice--p object.
442 (funcall get-next-frame)
443 ;; It's apparently an around advice, where the "next" is
444 ;; called by the body of the advice in any way it sees fit,
445 ;; so we need to skip the frames of that body.
446 (while
447 (progn
448 (funcall get-next-frame)
449 (not (and (eq (nth 1 frame2) 'apply)
450 (eq (nth 3 frame2) inneradvice)))))
451 (funcall get-next-frame)
452 (funcall get-next-frame))))
453 (- i origi 1))))
454
405 455
406(provide 'nadvice) 456(provide 'nadvice)
407;;; nadvice.el ends here 457;;; nadvice.el ends here
diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el
index c6fff7aa443..722e6270e95 100644
--- a/lisp/emacs-lisp/trace.el
+++ b/lisp/emacs-lisp/trace.el
@@ -1,4 +1,4 @@
1;;; trace.el --- tracing facility for Emacs Lisp functions 1;;; trace.el --- tracing facility for Emacs Lisp functions -*- lexical-binding: t -*-
2 2
3;; Copyright (C) 1993, 1998, 2000-2012 Free Software Foundation, Inc. 3;; Copyright (C) 1993, 1998, 2000-2012 Free Software Foundation, Inc.
4 4
@@ -151,18 +151,15 @@
151 151
152;;; Code: 152;;; Code:
153 153
154(require 'advice)
155
156(defgroup trace nil 154(defgroup trace nil
157 "Tracing facility for Emacs Lisp functions." 155 "Tracing facility for Emacs Lisp functions."
158 :prefix "trace-" 156 :prefix "trace-"
159 :group 'lisp) 157 :group 'lisp)
160 158
161;;;###autoload 159;;;###autoload
162(defcustom trace-buffer (purecopy "*trace-output*") 160(defcustom trace-buffer "*trace-output*"
163 "Trace output will by default go to that buffer." 161 "Trace output will by default go to that buffer."
164 :type 'string 162 :type 'string)
165 :group 'trace)
166 163
167;; Current level of traced function invocation: 164;; Current level of traced function invocation:
168(defvar trace-level 0) 165(defvar trace-level 0)
@@ -176,78 +173,109 @@
176(defvar inhibit-trace nil 173(defvar inhibit-trace nil
177 "If non-nil, all tracing is temporarily inhibited.") 174 "If non-nil, all tracing is temporarily inhibited.")
178 175
179(defun trace-entry-message (function level argument-bindings) 176(defun trace-entry-message (function level args context)
180 ;; Generates a string that describes that FUNCTION has been entered at 177 "Generate a string that describes that FUNCTION has been entered.
181 ;; trace LEVEL with ARGUMENT-BINDINGS. 178LEVEL is the trace level, ARGS is the list of arguments passed to FUNCTION,
182 (format "%s%s%d -> %s: %s\n" 179and CONTEXT is a string describing the dynamic context (e.g. values of
183 (mapconcat 'char-to-string (make-string (1- level) ?|) " ") 180some global variables)."
184 (if (> level 1) " " "") 181 (let ((print-circle t))
185 level 182 (format "%s%s%d -> %S%s\n"
186 function 183 (mapconcat 'char-to-string (make-string (1- level) ?|) " ")
187 (let ((print-circle t)) 184 (if (> level 1) " " "")
188 (mapconcat (lambda (binding) 185 level
189 (concat 186 (cons function args)
190 (symbol-name (ad-arg-binding-field binding 'name)) 187 context)))
191 "=" 188
192 ;; do this so we'll see strings: 189(defun trace-exit-message (function level value context)
193 (prin1-to-string 190 "Generate a string that describes that FUNCTION has exited.
194 (ad-arg-binding-field binding 'value)))) 191LEVEL is the trace level, VALUE value returned by FUNCTION,
195 argument-bindings 192and CONTEXT is a string describing the dynamic context (e.g. values of
196 " ")))) 193some global variables)."
197 194 (let ((print-circle t))
198(defun trace-exit-message (function level value) 195 (format "%s%s%d <- %s: %S%s\n"
199 ;; Generates a string that describes that FUNCTION has been exited at 196 (mapconcat 'char-to-string (make-string (1- level) ?|) " ")
200 ;; trace LEVEL and that it returned VALUE. 197 (if (> level 1) " " "")
201 (format "%s%s%d <- %s: %s\n" 198 level
202 (mapconcat 'char-to-string (make-string (1- level) ?|) " ") 199 function
203 (if (> level 1) " " "") 200 ;; Do this so we'll see strings:
204 level 201 value
205 function 202 context)))
206 ;; do this so we'll see strings: 203
207 (let ((print-circle t)) (prin1-to-string value)))) 204(defvar trace--timer nil)
208 205
209(defun trace-make-advice (function buffer background) 206(defun trace-make-advice (function buffer background context)
210 ;; Builds the piece of advice to be added to FUNCTION's advice info 207 "Build the piece of advice to be added to trace FUNCTION.
211 ;; so that it will generate the proper trace output in BUFFER 208FUNCTION is the name of the traced function.
212 ;; (quietly if BACKGROUND is t). 209BUFFER is the buffer where the trace should be printed.
213 (ad-make-advice 210BACKGROUND if nil means to display BUFFER.
214 trace-advice-name nil t 211CONTEXT if non-nil should be a function that returns extra info that should
215 `(advice 212be printed along with the arguments in the trace."
216 lambda () 213 (lambda (body &rest args)
217 (let ((trace-level (1+ trace-level)) 214 (let ((trace-level (1+ trace-level))
218 (trace-buffer (get-buffer-create ,buffer))) 215 (trace-buffer (get-buffer-create buffer))
219 (unless inhibit-trace 216 (ctx (funcall context)))
220 (with-current-buffer trace-buffer 217 (unless inhibit-trace
221 (set (make-local-variable 'window-point-insertion-type) t) 218 (with-current-buffer trace-buffer
222 ,(unless background '(display-buffer trace-buffer)) 219 (set (make-local-variable 'window-point-insertion-type) t)
223 (goto-char (point-max)) 220 (unless (or background trace--timer
224 ;; Insert a separator from previous trace output: 221 (get-buffer-window trace-buffer 'visible))
225 (if (= trace-level 1) (insert trace-separator)) 222 (setq trace--timer
226 (insert 223 ;; Postpone the display to some later time, in case we
227 (trace-entry-message 224 ;; can't actually do it now.
228 ',function trace-level ad-arg-bindings)))) 225 (run-with-timer 0 nil
229 ad-do-it 226 (lambda ()
230 (unless inhibit-trace 227 (setq trace--timer nil)
231 (with-current-buffer trace-buffer 228 (display-buffer trace-buffer)))))
232 ,(unless background '(display-buffer trace-buffer)) 229 (goto-char (point-max))
233 (goto-char (point-max)) 230 ;; Insert a separator from previous trace output:
234 (insert 231 (if (= trace-level 1) (insert trace-separator))
235 (trace-exit-message 232 (insert
236 ',function trace-level ad-return-value)))))))) 233 (trace-entry-message
237 234 function trace-level args ctx))))
238(defun trace-function-internal (function buffer background) 235 (let ((result))
239 ;; Adds trace advice for FUNCTION and activates it. 236 (unwind-protect
240 (ad-add-advice 237 (setq result (list (apply body args)))
241 function 238 (unless inhibit-trace
242 (trace-make-advice function (or buffer trace-buffer) background) 239 (let ((ctx (funcall context)))
243 'around 'last) 240 (with-current-buffer trace-buffer
244 (ad-activate function nil)) 241 (unless background (display-buffer trace-buffer))
242 (goto-char (point-max))
243 (insert
244 (trace-exit-message
245 function
246 trace-level
247 (if result (car result) '\!non-local\ exit\!)
248 ctx))))))
249 (car result)))))
250
251(defun trace-function-internal (function buffer background context)
252 "Add trace advice for FUNCTION."
253 (advice-add
254 function :around
255 (trace-make-advice function (or buffer trace-buffer) background
256 (or context (lambda () "")))
257 `((name . ,trace-advice-name))))
245 258
246(defun trace-is-traced (function) 259(defun trace-is-traced (function)
247 (ad-find-advice function 'around trace-advice-name)) 260 (advice-member-p trace-advice-name function))
261
262(defun trace--read-args (prompt)
263 (cons
264 (intern (completing-read prompt obarray 'fboundp t))
265 (when current-prefix-arg
266 (list
267 (read-buffer "Output to buffer: " trace-buffer)
268 (let ((exp
269 (let ((minibuffer-completing-symbol t))
270 (read-from-minibuffer "Context expression: "
271 nil read-expression-map t
272 'read-expression-history))))
273 `(lambda ()
274 (let ((print-circle t))
275 (concat " [" (prin1-to-string ,exp) "]"))))))))
248 276
249;;;###autoload 277;;;###autoload
250(defun trace-function (function &optional buffer) 278(defun trace-function-foreground (function &optional buffer context)
251 "Traces FUNCTION with trace output going to BUFFER. 279 "Traces FUNCTION with trace output going to BUFFER.
252For every call of FUNCTION Lisp-style trace messages that display argument 280For every call of FUNCTION Lisp-style trace messages that display argument
253and return values will be inserted into BUFFER. This function generates the 281and return values will be inserted into BUFFER. This function generates the
@@ -255,14 +283,11 @@ trace advice for FUNCTION and activates it together with any other advice
255there might be!! The trace BUFFER will popup whenever FUNCTION is called. 283there might be!! The trace BUFFER will popup whenever FUNCTION is called.
256Do not use this to trace functions that switch buffers or do any other 284Do not use this to trace functions that switch buffers or do any other
257display oriented stuff, use `trace-function-background' instead." 285display oriented stuff, use `trace-function-background' instead."
258 (interactive 286 (interactive (trace--read-args "Trace function: "))
259 (list 287 (trace-function-internal function buffer nil context))
260 (intern (completing-read "Trace function: " obarray 'fboundp t))
261 (read-buffer "Output to buffer: " trace-buffer)))
262 (trace-function-internal function buffer nil))
263 288
264;;;###autoload 289;;;###autoload
265(defun trace-function-background (function &optional buffer) 290(defun trace-function-background (function &optional buffer context)
266 "Traces FUNCTION with trace output going quietly to BUFFER. 291 "Traces FUNCTION with trace output going quietly to BUFFER.
267When this tracing is enabled, every call to FUNCTION writes 292When this tracing is enabled, every call to FUNCTION writes
268a Lisp-style trace message (showing the arguments and return value) 293a Lisp-style trace message (showing the arguments and return value)
@@ -272,12 +297,11 @@ The trace output goes to BUFFER quietly, without changing
272the window or buffer configuration. 297the window or buffer configuration.
273 298
274BUFFER defaults to `trace-buffer'." 299BUFFER defaults to `trace-buffer'."
275 (interactive 300 (interactive (trace--read-args "Trace function in background: "))
276 (list 301 (trace-function-internal function buffer t context))
277 (intern 302
278 (completing-read "Trace function in background: " obarray 'fboundp t)) 303;;;###autoload
279 (read-buffer "Output to buffer: " trace-buffer))) 304(defalias 'trace-function 'trace-function-foreground)
280 (trace-function-internal function buffer t))
281 305
282(defun untrace-function (function) 306(defun untrace-function (function)
283 "Untraces FUNCTION and possibly activates all remaining advice. 307 "Untraces FUNCTION and possibly activates all remaining advice.
@@ -285,16 +309,14 @@ Activation is performed with `ad-update', hence remaining advice will get
285activated only if the advice of FUNCTION is currently active. If FUNCTION 309activated only if the advice of FUNCTION is currently active. If FUNCTION
286was not traced this is a noop." 310was not traced this is a noop."
287 (interactive 311 (interactive
288 (list (ad-read-advised-function "Untrace function" 'trace-is-traced))) 312 (list (intern (completing-read "Untrace function: "
289 (when (trace-is-traced function) 313 obarray #'trace-is-traced t))))
290 (ad-remove-advice function 'around trace-advice-name) 314 (advice-remove function trace-advice-name))
291 (ad-update function)))
292 315
293(defun untrace-all () 316(defun untrace-all ()
294 "Untraces all currently traced functions." 317 "Untraces all currently traced functions."
295 (interactive) 318 (interactive)
296 (ad-do-advised-functions (function) 319 (mapatoms #'untrace-function))
297 (untrace-function function)))
298 320
299(provide 'trace) 321(provide 'trace)
300 322
diff --git a/lisp/erc/ChangeLog b/lisp/erc/ChangeLog
index e0a88461dc9..ca7edd1aa88 100644
--- a/lisp/erc/ChangeLog
+++ b/lisp/erc/ChangeLog
@@ -1,3 +1,16 @@
12012-11-19 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 Use cl-lib instead of cl, and interactive-p => called-interactively-p.
4 * erc-track.el, erc-networks.el, erc-netsplit.el, erc-dcc.el:
5 * erc-backend.el: Use cl-lib, nth, pcase, and called-interactively-p
6 instead of cl.
7 * erc-speedbar.el, erc-services.el, erc-pcomplete.el, erc-notify.el:
8 * erc-match.el, erc-log.el, erc-join.el, erc-ezbounce.el:
9 * erc-capab.el: Don't require cl since we don't use it.
10 * erc.el: Use cl-lib, nth, pcase, and called-interactively-p i.s.o cl.
11 (erc-lurker-ignore-chars, erc-common-server-suffixes):
12 Move before first use.
13
12012-11-16 Glenn Morris <rgm@gnu.org> 142012-11-16 Glenn Morris <rgm@gnu.org>
2 15
3 * erc.el (erc-modules): Add "notifications". Tweak "hecomplete" doc. 16 * erc.el (erc-modules): Add "notifications". Tweak "hecomplete" doc.
diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el
index 90b96d7c763..a3d0ebe121f 100644
--- a/lisp/erc/erc-backend.el
+++ b/lisp/erc/erc-backend.el
@@ -98,7 +98,7 @@
98;;; Code: 98;;; Code:
99 99
100(require 'erc-compat) 100(require 'erc-compat)
101(eval-when-compile (require 'cl)) 101(eval-when-compile (require 'cl-lib))
102;; There's a fairly strong mutual dependency between erc.el and erc-backend.el. 102;; There's a fairly strong mutual dependency between erc.el and erc-backend.el.
103;; Luckily, erc.el does not need erc-backend.el for macroexpansion whereas the 103;; Luckily, erc.el does not need erc-backend.el for macroexpansion whereas the
104;; reverse is true: 104;; reverse is true:
@@ -109,7 +109,7 @@
109(defvar erc-server-responses (make-hash-table :test #'equal) 109(defvar erc-server-responses (make-hash-table :test #'equal)
110 "Hashtable mapping server responses to their handler hooks.") 110 "Hashtable mapping server responses to their handler hooks.")
111 111
112(defstruct (erc-response (:conc-name erc-response.)) 112(cl-defstruct (erc-response (:conc-name erc-response.))
113 (unparsed "" :type string) 113 (unparsed "" :type string)
114 (sender "" :type string) 114 (sender "" :type string)
115 (command "" :type string) 115 (command "" :type string)
@@ -950,7 +950,7 @@ PROCs `process-buffer' is `current-buffer' when this function is called."
950 (push str (erc-response.command-args msg)))) 950 (push str (erc-response.command-args msg))))
951 951
952 (setf (erc-response.contents msg) 952 (setf (erc-response.contents msg)
953 (first (erc-response.command-args msg))) 953 (car (erc-response.command-args msg)))
954 954
955 (setf (erc-response.command-args msg) 955 (setf (erc-response.command-args msg)
956 (nreverse (erc-response.command-args msg))) 956 (nreverse (erc-response.command-args msg)))
@@ -1045,7 +1045,7 @@ Finds hooks by looking in the `erc-server-responses' hashtable."
1045 (name &rest name) 1045 (name &rest name)
1046 &optional sexp sexp def-body)) 1046 &optional sexp sexp def-body))
1047 1047
1048(defmacro* define-erc-response-handler ((name &rest aliases) 1048(cl-defmacro define-erc-response-handler ((name &rest aliases)
1049 &optional extra-fn-doc extra-var-doc 1049 &optional extra-fn-doc extra-var-doc
1050 &rest fn-body) 1050 &rest fn-body)
1051 "Define an ERC handler hook/function pair. 1051 "Define an ERC handler hook/function pair.
@@ -1154,11 +1154,11 @@ add things to `%s' instead."
1154 "") 1154 "")
1155 name hook-name)) 1155 name hook-name))
1156 (fn-alternates 1156 (fn-alternates
1157 (loop for alias in aliases 1157 (cl-loop for alias in aliases
1158 collect (intern (format "erc-server-%s" alias)))) 1158 collect (intern (format "erc-server-%s" alias))))
1159 (var-alternates 1159 (var-alternates
1160 (loop for alias in aliases 1160 (cl-loop for alias in aliases
1161 collect (intern (format "erc-server-%s-functions" alias))))) 1161 collect (intern (format "erc-server-%s-functions" alias)))))
1162 `(prog2 1162 `(prog2
1163 ;; Normal hook variable. 1163 ;; Normal hook variable.
1164 (defvar ,hook-name ',fn-name ,(format hook-doc name)) 1164 (defvar ,hook-name ',fn-name ,(format hook-doc name))
@@ -1172,19 +1172,19 @@ add things to `%s' instead."
1172 (put ',hook-name 'definition-name ',name) 1172 (put ',hook-name 'definition-name ',name)
1173 1173
1174 ;; Hashtable map of responses to hook variables 1174 ;; Hashtable map of responses to hook variables
1175 ,@(loop for response in (cons name aliases) 1175 ,@(cl-loop for response in (cons name aliases)
1176 for var in (cons hook-name var-alternates) 1176 for var in (cons hook-name var-alternates)
1177 collect `(puthash ,(format "%s" response) ',var 1177 collect `(puthash ,(format "%s" response) ',var
1178 erc-server-responses)) 1178 erc-server-responses))
1179 ;; Alternates. 1179 ;; Alternates.
1180 ;; Functions are defaliased, hook variables are defvared so we 1180 ;; Functions are defaliased, hook variables are defvared so we
1181 ;; can add hooks to one alias, but not another. 1181 ;; can add hooks to one alias, but not another.
1182 ,@(loop for fn in fn-alternates 1182 ,@(cl-loop for fn in fn-alternates
1183 for var in var-alternates 1183 for var in var-alternates
1184 for a in aliases 1184 for a in aliases
1185 nconc (list `(defalias ',fn ',fn-name) 1185 nconc (list `(defalias ',fn ',fn-name)
1186 `(defvar ,var ',fn-name ,(format hook-doc a)) 1186 `(defvar ,var ',fn-name ,(format hook-doc a))
1187 `(put ',var 'definition-name ',hook-name)))))) 1187 `(put ',var 'definition-name ',hook-name))))))
1188 1188
1189(define-erc-response-handler (ERROR) 1189(define-erc-response-handler (ERROR)
1190 "Handle an ERROR command from the server." nil 1190 "Handle an ERROR command from the server." nil
@@ -1196,10 +1196,10 @@ add things to `%s' instead."
1196(define-erc-response-handler (INVITE) 1196(define-erc-response-handler (INVITE)
1197 "Handle invitation messages." 1197 "Handle invitation messages."
1198 nil 1198 nil
1199 (let ((target (first (erc-response.command-args parsed))) 1199 (let ((target (car (erc-response.command-args parsed)))
1200 (chnl (erc-response.contents parsed))) 1200 (chnl (erc-response.contents parsed)))
1201 (multiple-value-bind (nick login host) 1201 (pcase-let ((`(,nick ,login ,host)
1202 (values-list (erc-parse-user (erc-response.sender parsed))) 1202 (erc-parse-user (erc-response.sender parsed))))
1203 (setq erc-invitation chnl) 1203 (setq erc-invitation chnl)
1204 (when (string= target (erc-current-nick)) 1204 (when (string= target (erc-current-nick))
1205 (erc-display-message 1205 (erc-display-message
@@ -1212,8 +1212,8 @@ add things to `%s' instead."
1212 nil 1212 nil
1213 (let ((chnl (erc-response.contents parsed)) 1213 (let ((chnl (erc-response.contents parsed))
1214 (buffer nil)) 1214 (buffer nil))
1215 (multiple-value-bind (nick login host) 1215 (pcase-let ((`(,nick ,login ,host)
1216 (values-list (erc-parse-user (erc-response.sender parsed))) 1216 (erc-parse-user (erc-response.sender parsed))))
1217 ;; strip the stupid combined JOIN facility (IRC 2.9) 1217 ;; strip the stupid combined JOIN facility (IRC 2.9)
1218 (if (string-match "^\\(.*\\)?\^g.*$" chnl) 1218 (if (string-match "^\\(.*\\)?\^g.*$" chnl)
1219 (setq chnl (match-string 1 chnl))) 1219 (setq chnl (match-string 1 chnl)))
@@ -1249,12 +1249,12 @@ add things to `%s' instead."
1249 1249
1250(define-erc-response-handler (KICK) 1250(define-erc-response-handler (KICK)
1251 "Handle kick messages received from the server." nil 1251 "Handle kick messages received from the server." nil
1252 (let* ((ch (first (erc-response.command-args parsed))) 1252 (let* ((ch (nth 0 (erc-response.command-args parsed)))
1253 (tgt (second (erc-response.command-args parsed))) 1253 (tgt (nth 1 (erc-response.command-args parsed)))
1254 (reason (erc-trim-string (erc-response.contents parsed))) 1254 (reason (erc-trim-string (erc-response.contents parsed)))
1255 (buffer (erc-get-buffer ch proc))) 1255 (buffer (erc-get-buffer ch proc)))
1256 (multiple-value-bind (nick login host) 1256 (pcase-let ((`(,nick ,login ,host)
1257 (values-list (erc-parse-user (erc-response.sender parsed))) 1257 (erc-parse-user (erc-response.sender parsed))))
1258 (erc-remove-channel-member buffer tgt) 1258 (erc-remove-channel-member buffer tgt)
1259 (cond 1259 (cond
1260 ((string= tgt (erc-current-nick)) 1260 ((string= tgt (erc-current-nick))
@@ -1277,11 +1277,11 @@ add things to `%s' instead."
1277 1277
1278(define-erc-response-handler (MODE) 1278(define-erc-response-handler (MODE)
1279 "Handle server mode changes." nil 1279 "Handle server mode changes." nil
1280 (let ((tgt (first (erc-response.command-args parsed))) 1280 (let ((tgt (car (erc-response.command-args parsed)))
1281 (mode (mapconcat 'identity (cdr (erc-response.command-args parsed)) 1281 (mode (mapconcat 'identity (cdr (erc-response.command-args parsed))
1282 " "))) 1282 " ")))
1283 (multiple-value-bind (nick login host) 1283 (pcase-let ((`(,nick ,login ,host)
1284 (values-list (erc-parse-user (erc-response.sender parsed))) 1284 (erc-parse-user (erc-response.sender parsed))))
1285 (erc-log (format "MODE: %s -> %s: %s" nick tgt mode)) 1285 (erc-log (format "MODE: %s -> %s: %s" nick tgt mode))
1286 ;; dirty hack 1286 ;; dirty hack
1287 (let ((buf (cond ((erc-channel-p tgt) 1287 (let ((buf (cond ((erc-channel-p tgt)
@@ -1305,8 +1305,8 @@ add things to `%s' instead."
1305 "Handle nick change messages." nil 1305 "Handle nick change messages." nil
1306 (let ((nn (erc-response.contents parsed)) 1306 (let ((nn (erc-response.contents parsed))
1307 bufs) 1307 bufs)
1308 (multiple-value-bind (nick login host) 1308 (pcase-let ((`(,nick ,login ,host)
1309 (values-list (erc-parse-user (erc-response.sender parsed))) 1309 (erc-parse-user (erc-response.sender parsed))))
1310 (setq bufs (erc-buffer-list-with-nick nick proc)) 1310 (setq bufs (erc-buffer-list-with-nick nick proc))
1311 (erc-log (format "NICK: %s -> %s" nick nn)) 1311 (erc-log (format "NICK: %s -> %s" nick nn))
1312 ;; if we had a query with this user, make sure future messages will be 1312 ;; if we had a query with this user, make sure future messages will be
@@ -1340,11 +1340,11 @@ add things to `%s' instead."
1340 1340
1341(define-erc-response-handler (PART) 1341(define-erc-response-handler (PART)
1342 "Handle part messages." nil 1342 "Handle part messages." nil
1343 (let* ((chnl (first (erc-response.command-args parsed))) 1343 (let* ((chnl (car (erc-response.command-args parsed)))
1344 (reason (erc-trim-string (erc-response.contents parsed))) 1344 (reason (erc-trim-string (erc-response.contents parsed)))
1345 (buffer (erc-get-buffer chnl proc))) 1345 (buffer (erc-get-buffer chnl proc)))
1346 (multiple-value-bind (nick login host) 1346 (pcase-let ((`(,nick ,login ,host)
1347 (values-list (erc-parse-user (erc-response.sender parsed))) 1347 (erc-parse-user (erc-response.sender parsed))))
1348 (erc-remove-channel-member buffer nick) 1348 (erc-remove-channel-member buffer nick)
1349 (erc-display-message parsed 'notice buffer 1349 (erc-display-message parsed 'notice buffer
1350 'PART ?n nick ?u login 1350 'PART ?n nick ?u login
@@ -1361,7 +1361,7 @@ add things to `%s' instead."
1361 1361
1362(define-erc-response-handler (PING) 1362(define-erc-response-handler (PING)
1363 "Handle ping messages." nil 1363 "Handle ping messages." nil
1364 (let ((pinger (first (erc-response.command-args parsed)))) 1364 (let ((pinger (car (erc-response.command-args parsed))))
1365 (erc-log (format "PING: %s" pinger)) 1365 (erc-log (format "PING: %s" pinger))
1366 ;; ping response to the server MUST be forced, or you can lose big 1366 ;; ping response to the server MUST be forced, or you can lose big
1367 (erc-server-send (format "PONG :%s" pinger) t) 1367 (erc-server-send (format "PONG :%s" pinger) t)
@@ -1379,7 +1379,7 @@ add things to `%s' instead."
1379 (when erc-verbose-server-ping 1379 (when erc-verbose-server-ping
1380 (erc-display-message 1380 (erc-display-message
1381 parsed 'notice proc 'PONG 1381 parsed 'notice proc 'PONG
1382 ?h (first (erc-response.command-args parsed)) ?i erc-server-lag 1382 ?h (car (erc-response.command-args parsed)) ?i erc-server-lag
1383 ?s (if (/= erc-server-lag 1) "s" ""))) 1383 ?s (if (/= erc-server-lag 1) "s" "")))
1384 (erc-update-mode-line)))) 1384 (erc-update-mode-line))))
1385 1385
@@ -1451,8 +1451,8 @@ add things to `%s' instead."
1451 "Another user has quit IRC." nil 1451 "Another user has quit IRC." nil
1452 (let ((reason (erc-response.contents parsed)) 1452 (let ((reason (erc-response.contents parsed))
1453 bufs) 1453 bufs)
1454 (multiple-value-bind (nick login host) 1454 (pcase-let ((`(,nick ,login ,host)
1455 (values-list (erc-parse-user (erc-response.sender parsed))) 1455 (erc-parse-user (erc-response.sender parsed))))
1456 (setq bufs (erc-buffer-list-with-nick nick proc)) 1456 (setq bufs (erc-buffer-list-with-nick nick proc))
1457 (erc-remove-user nick) 1457 (erc-remove-user nick)
1458 (setq reason (erc-wash-quit-reason reason nick login host)) 1458 (setq reason (erc-wash-quit-reason reason nick login host))
@@ -1462,12 +1462,12 @@ add things to `%s' instead."
1462 1462
1463(define-erc-response-handler (TOPIC) 1463(define-erc-response-handler (TOPIC)
1464 "The channel topic has changed." nil 1464 "The channel topic has changed." nil
1465 (let* ((ch (first (erc-response.command-args parsed))) 1465 (let* ((ch (car (erc-response.command-args parsed)))
1466 (topic (erc-trim-string (erc-response.contents parsed))) 1466 (topic (erc-trim-string (erc-response.contents parsed)))
1467 (time (format-time-string erc-server-timestamp-format 1467 (time (format-time-string erc-server-timestamp-format
1468 (current-time)))) 1468 (current-time))))
1469 (multiple-value-bind (nick login host) 1469 (pcase-let ((`(,nick ,login ,host)
1470 (values-list (erc-parse-user (erc-response.sender parsed))) 1470 (erc-parse-user (erc-response.sender parsed))))
1471 (erc-update-channel-member ch nick nick nil nil nil host login) 1471 (erc-update-channel-member ch nick nick nil nil nil host login)
1472 (erc-update-channel-topic ch (format "%s\C-o (%s, %s)" topic nick time)) 1472 (erc-update-channel-topic ch (format "%s\C-o (%s, %s)" topic nick time))
1473 (erc-display-message parsed 'notice (erc-get-buffer ch proc) 1473 (erc-display-message parsed 'notice (erc-get-buffer ch proc)
@@ -1477,8 +1477,8 @@ add things to `%s' instead."
1477(define-erc-response-handler (WALLOPS) 1477(define-erc-response-handler (WALLOPS)
1478 "Display a WALLOPS message." nil 1478 "Display a WALLOPS message." nil
1479 (let ((message (erc-response.contents parsed))) 1479 (let ((message (erc-response.contents parsed)))
1480 (multiple-value-bind (nick login host) 1480 (pcase-let ((`(,nick ,login ,host)
1481 (values-list (erc-parse-user (erc-response.sender parsed))) 1481 (erc-parse-user (erc-response.sender parsed))))
1482 (erc-display-message 1482 (erc-display-message
1483 parsed 'notice nil 1483 parsed 'notice nil
1484 'WALLOPS ?n nick ?m message)))) 1484 'WALLOPS ?n nick ?m message))))
@@ -1486,7 +1486,7 @@ add things to `%s' instead."
1486(define-erc-response-handler (001) 1486(define-erc-response-handler (001)
1487 "Set `erc-server-current-nick' to reflect server settings and display the welcome message." 1487 "Set `erc-server-current-nick' to reflect server settings and display the welcome message."
1488 nil 1488 nil
1489 (erc-set-current-nick (first (erc-response.command-args parsed))) 1489 (erc-set-current-nick (car (erc-response.command-args parsed)))
1490 (erc-update-mode-line) ; needed here? 1490 (erc-update-mode-line) ; needed here?
1491 (setq erc-nick-change-attempt-count 0) 1491 (setq erc-nick-change-attempt-count 0)
1492 (setq erc-default-nicks (if (consp erc-nick) erc-nick (list erc-nick))) 1492 (setq erc-default-nicks (if (consp erc-nick) erc-nick (list erc-nick)))
@@ -1507,16 +1507,16 @@ add things to `%s' instead."
1507 1507
1508(define-erc-response-handler (004) 1508(define-erc-response-handler (004)
1509 "Display the server's identification." nil 1509 "Display the server's identification." nil
1510 (multiple-value-bind (server-name server-version) 1510 (pcase-let ((`(,server-name ,server-version)
1511 (values-list (cdr (erc-response.command-args parsed))) 1511 (cdr (erc-response.command-args parsed))))
1512 (setq erc-server-version server-version) 1512 (setq erc-server-version server-version)
1513 (setq erc-server-announced-name server-name) 1513 (setq erc-server-announced-name server-name)
1514 (erc-update-mode-line-buffer (process-buffer proc)) 1514 (erc-update-mode-line-buffer (process-buffer proc))
1515 (erc-display-message 1515 (erc-display-message
1516 parsed 'notice proc 1516 parsed 'notice proc
1517 's004 ?s server-name ?v server-version 1517 's004 ?s server-name ?v server-version
1518 ?U (fourth (erc-response.command-args parsed)) 1518 ?U (nth 3 (erc-response.command-args parsed))
1519 ?C (fifth (erc-response.command-args parsed))))) 1519 ?C (nth 4 (erc-response.command-args parsed)))))
1520 1520
1521(define-erc-response-handler (005) 1521(define-erc-response-handler (005)
1522 "Set the variable `erc-server-parameters' and display the received message. 1522 "Set the variable `erc-server-parameters' and display the received message.
@@ -1547,7 +1547,7 @@ A server may send more than one 005 message."
1547 1547
1548(define-erc-response-handler (221) 1548(define-erc-response-handler (221)
1549 "Display the current user modes." nil 1549 "Display the current user modes." nil
1550 (let* ((nick (first (erc-response.command-args parsed))) 1550 (let* ((nick (car (erc-response.command-args parsed)))
1551 (modes (mapconcat 'identity 1551 (modes (mapconcat 'identity
1552 (cdr (erc-response.command-args parsed)) " "))) 1552 (cdr (erc-response.command-args parsed)) " ")))
1553 (erc-set-modes nick modes) 1553 (erc-set-modes nick modes)
@@ -1576,8 +1576,8 @@ See `erc-display-server-message'." nil
1576 1576
1577(define-erc-response-handler (275) 1577(define-erc-response-handler (275)
1578 "Display secure connection message." nil 1578 "Display secure connection message." nil
1579 (multiple-value-bind (nick user message) 1579 (pcase-let ((`(,nick ,user ,message)
1580 (values-list (cdr (erc-response.command-args parsed))) 1580 (cdr (erc-response.command-args parsed))))
1581 (erc-display-message 1581 (erc-display-message
1582 parsed 'notice 'active 's275 1582 parsed 'notice 'active 's275
1583 ?n nick 1583 ?n nick
@@ -1612,8 +1612,8 @@ See `erc-display-server-message'." nil
1612 1612
1613(define-erc-response-handler (307) 1613(define-erc-response-handler (307)
1614 "Display nick-identified message." nil 1614 "Display nick-identified message." nil
1615 (multiple-value-bind (nick user message) 1615 (pcase-let ((`(,nick ,user ,message)
1616 (values-list (cdr (erc-response.command-args parsed))) 1616 (cdr (erc-response.command-args parsed))))
1617 (erc-display-message 1617 (erc-display-message
1618 parsed 'notice 'active 's307 1618 parsed 'notice 'active 's307
1619 ?n nick 1619 ?n nick
@@ -1624,8 +1624,8 @@ See `erc-display-server-message'." nil
1624 "WHOIS/WHOWAS notices." nil 1624 "WHOIS/WHOWAS notices." nil
1625 (let ((fname (erc-response.contents parsed)) 1625 (let ((fname (erc-response.contents parsed))
1626 (catalog-entry (intern (format "s%s" (erc-response.command parsed))))) 1626 (catalog-entry (intern (format "s%s" (erc-response.command parsed)))))
1627 (multiple-value-bind (nick user host) 1627 (pcase-let ((`(,nick ,user ,host)
1628 (values-list (cdr (erc-response.command-args parsed))) 1628 (cdr (erc-response.command-args parsed))))
1629 (erc-update-user-nick nick nick host nil fname user) 1629 (erc-update-user-nick nick nick host nil fname user)
1630 (erc-display-message 1630 (erc-display-message
1631 parsed 'notice 'active catalog-entry 1631 parsed 'notice 'active catalog-entry
@@ -1633,8 +1633,8 @@ See `erc-display-server-message'." nil
1633 1633
1634(define-erc-response-handler (312) 1634(define-erc-response-handler (312)
1635 "Server name response in WHOIS." nil 1635 "Server name response in WHOIS." nil
1636 (multiple-value-bind (nick server-host) 1636 (pcase-let ((`(,nick ,server-host))
1637 (values-list (cdr (erc-response.command-args parsed))) 1637 (cdr (erc-response.command-args parsed)))
1638 (erc-display-message 1638 (erc-display-message
1639 parsed 'notice 'active 's312 1639 parsed 'notice 'active 's312
1640 ?n nick ?s server-host ?c (erc-response.contents parsed)))) 1640 ?n nick ?s server-host ?c (erc-response.contents parsed))))
@@ -1655,8 +1655,8 @@ See `erc-display-server-message'." nil
1655 1655
1656(define-erc-response-handler (317) 1656(define-erc-response-handler (317)
1657 "IDLE notice." nil 1657 "IDLE notice." nil
1658 (multiple-value-bind (nick seconds-idle on-since time) 1658 (pcase-let ((`(,nick ,seconds-idle ,on-since ,time)
1659 (values-list (cdr (erc-response.command-args parsed))) 1659 (cdr (erc-response.command-args parsed))))
1660 (setq time (when on-since 1660 (setq time (when on-since
1661 (format-time-string erc-server-timestamp-format 1661 (format-time-string erc-server-timestamp-format
1662 (erc-string-to-emacs-time on-since)))) 1662 (erc-string-to-emacs-time on-since))))
@@ -1696,16 +1696,16 @@ See `erc-display-server-message'." nil
1696(define-erc-response-handler (322) 1696(define-erc-response-handler (322)
1697 "LIST notice." nil 1697 "LIST notice." nil
1698 (let ((topic (erc-response.contents parsed))) 1698 (let ((topic (erc-response.contents parsed)))
1699 (multiple-value-bind (channel num-users) 1699 (pcase-let ((`(,channel ,num-users)
1700 (values-list (cdr (erc-response.command-args parsed))) 1700 (cdr (erc-response.command-args parsed))))
1701 (add-to-list 'erc-channel-list (list channel)) 1701 (add-to-list 'erc-channel-list (list channel))
1702 (erc-update-channel-topic channel topic)))) 1702 (erc-update-channel-topic channel topic))))
1703 1703
1704(defun erc-server-322-message (proc parsed) 1704(defun erc-server-322-message (proc parsed)
1705 "Display a message for the 322 event." 1705 "Display a message for the 322 event."
1706 (let ((topic (erc-response.contents parsed))) 1706 (let ((topic (erc-response.contents parsed)))
1707 (multiple-value-bind (channel num-users) 1707 (pcase-let ((`(,channel ,num-users)
1708 (values-list (cdr (erc-response.command-args parsed))) 1708 (cdr (erc-response.command-args parsed))))
1709 (erc-display-message 1709 (erc-display-message
1710 parsed 'notice proc 's322 1710 parsed 'notice proc 's322
1711 ?c channel ?u num-users ?t (or topic ""))))) 1711 ?c channel ?u num-users ?t (or topic "")))))
@@ -1732,7 +1732,7 @@ See `erc-display-server-message'." nil
1732 "Channel creation date." nil 1732 "Channel creation date." nil
1733 (let ((channel (second (erc-response.command-args parsed))) 1733 (let ((channel (second (erc-response.command-args parsed)))
1734 (time (erc-string-to-emacs-time 1734 (time (erc-string-to-emacs-time
1735 (third (erc-response.command-args parsed))))) 1735 (nth 2 (erc-response.command-args parsed)))))
1736 (erc-display-message 1736 (erc-display-message
1737 parsed 'notice (erc-get-buffer channel proc) 1737 parsed 'notice (erc-get-buffer channel proc)
1738 's329 ?c channel ?t (format-time-string erc-server-timestamp-format 1738 's329 ?c channel ?t (format-time-string erc-server-timestamp-format
@@ -1749,7 +1749,7 @@ See `erc-display-server-message'." nil
1749 ;; authmsg == (aref parsed 5) 1749 ;; authmsg == (aref parsed 5)
1750 ;; The guesses below are, well, just that. -- Lawrence 2004/05/10 1750 ;; The guesses below are, well, just that. -- Lawrence 2004/05/10
1751 (let ((nick (second (erc-response.command-args parsed))) 1751 (let ((nick (second (erc-response.command-args parsed)))
1752 (authaccount (third (erc-response.command-args parsed))) 1752 (authaccount (nth 2 (erc-response.command-args parsed)))
1753 (authmsg (erc-response.contents parsed))) 1753 (authmsg (erc-response.contents parsed)))
1754 (erc-display-message parsed 'notice 'active 's330 1754 (erc-display-message parsed 'notice 'active 's330
1755 ?n nick ?a authmsg ?i authaccount))) 1755 ?n nick ?a authmsg ?i authaccount)))
@@ -1771,8 +1771,8 @@ See `erc-display-server-message'." nil
1771 1771
1772(define-erc-response-handler (333) 1772(define-erc-response-handler (333)
1773 "Who set the topic, and when." nil 1773 "Who set the topic, and when." nil
1774 (multiple-value-bind (channel nick time) 1774 (pcase-let ((`(,channel ,nick ,time)
1775 (values-list (cdr (erc-response.command-args parsed))) 1775 (cdr (erc-response.command-args parsed))))
1776 (setq time (format-time-string erc-server-timestamp-format 1776 (setq time (format-time-string erc-server-timestamp-format
1777 (erc-string-to-emacs-time time))) 1777 (erc-string-to-emacs-time time)))
1778 (erc-update-channel-topic channel 1778 (erc-update-channel-topic channel
@@ -1784,15 +1784,15 @@ See `erc-display-server-message'." nil
1784(define-erc-response-handler (341) 1784(define-erc-response-handler (341)
1785 "Let user know when an INVITE attempt has been sent successfully." 1785 "Let user know when an INVITE attempt has been sent successfully."
1786 nil 1786 nil
1787 (multiple-value-bind (nick channel) 1787 (pcase-let ((`(,nick ,channel)
1788 (values-list (cdr (erc-response.command-args parsed))) 1788 (cdr (erc-response.command-args parsed))))
1789 (erc-display-message parsed 'notice (erc-get-buffer channel proc) 1789 (erc-display-message parsed 'notice (erc-get-buffer channel proc)
1790 's341 ?n nick ?c channel))) 1790 's341 ?n nick ?c channel)))
1791 1791
1792(define-erc-response-handler (352) 1792(define-erc-response-handler (352)
1793 "WHO notice." nil 1793 "WHO notice." nil
1794 (multiple-value-bind (channel user host server nick away-flag) 1794 (pcase-let ((`(,channel ,user ,host ,server ,nick ,away-flag)
1795 (values-list (cdr (erc-response.command-args parsed))) 1795 (cdr (erc-response.command-args parsed))))
1796 (let ((full-name (erc-response.contents parsed)) 1796 (let ((full-name (erc-response.contents parsed))
1797 hopcount) 1797 hopcount)
1798 (when (string-match "\\(^[0-9]+ \\)\\(.*\\)$" full-name) 1798 (when (string-match "\\(^[0-9]+ \\)\\(.*\\)$" full-name)
@@ -1806,7 +1806,7 @@ See `erc-display-server-message'." nil
1806 1806
1807(define-erc-response-handler (353) 1807(define-erc-response-handler (353)
1808 "NAMES notice." nil 1808 "NAMES notice." nil
1809 (let ((channel (third (erc-response.command-args parsed))) 1809 (let ((channel (nth 2 (erc-response.command-args parsed)))
1810 (users (erc-response.contents parsed))) 1810 (users (erc-response.contents parsed)))
1811 (erc-display-message parsed 'notice (or (erc-get-buffer channel proc) 1811 (erc-display-message parsed 'notice (or (erc-get-buffer channel proc)
1812 'active) 1812 'active)
@@ -1821,8 +1821,8 @@ See `erc-display-server-message'." nil
1821 1821
1822(define-erc-response-handler (367) 1822(define-erc-response-handler (367)
1823 "Channel ban list entries." nil 1823 "Channel ban list entries." nil
1824 (multiple-value-bind (channel banmask setter time) 1824 (pcase-let ((`(,channel ,banmask ,setter ,time)
1825 (values-list (cdr (erc-response.command-args parsed))) 1825 (cdr (erc-response.command-args parsed))))
1826 ;; setter and time are not standard 1826 ;; setter and time are not standard
1827 (if setter 1827 (if setter
1828 (erc-display-message parsed 'notice 'active 's367-set-by 1828 (erc-display-message parsed 'notice 'active 's367-set-by
@@ -1845,8 +1845,8 @@ See `erc-display-server-message'." nil
1845 ;; FIXME: Yet more magic numbers in original code, I'm guessing this 1845 ;; FIXME: Yet more magic numbers in original code, I'm guessing this
1846 ;; command takes two arguments, and doesn't have any "contents". -- 1846 ;; command takes two arguments, and doesn't have any "contents". --
1847 ;; Lawrence 2004/05/10 1847 ;; Lawrence 2004/05/10
1848 (multiple-value-bind (from to) 1848 (pcase-let ((`(,from ,to)
1849 (values-list (cdr (erc-response.command-args parsed))) 1849 (cdr (erc-response.command-args parsed))))
1850 (erc-display-message parsed 'notice 'active 1850 (erc-display-message parsed 'notice 'active
1851 's379 ?c from ?f to))) 1851 's379 ?c from ?f to)))
1852 1852
@@ -1855,7 +1855,7 @@ See `erc-display-server-message'." nil
1855 (erc-display-message 1855 (erc-display-message
1856 parsed 'notice 'active 1856 parsed 'notice 'active
1857 's391 ?s (second (erc-response.command-args parsed)) 1857 's391 ?s (second (erc-response.command-args parsed))
1858 ?t (third (erc-response.command-args parsed)))) 1858 ?t (nth 2 (erc-response.command-args parsed))))
1859 1859
1860(define-erc-response-handler (401) 1860(define-erc-response-handler (401)
1861 "No such nick/channel." nil 1861 "No such nick/channel." nil
diff --git a/lisp/erc/erc-capab.el b/lisp/erc/erc-capab.el
index 08b9c67f6c0..e8201f2ea43 100644
--- a/lisp/erc/erc-capab.el
+++ b/lisp/erc/erc-capab.el
@@ -68,7 +68,6 @@
68;;; Code: 68;;; Code:
69 69
70(require 'erc) 70(require 'erc)
71(eval-when-compile (require 'cl))
72 71
73;;; Customization: 72;;; Customization:
74 73
diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el
index ed8440315eb..e31416f0e1a 100644
--- a/lisp/erc/erc-dcc.el
+++ b/lisp/erc/erc-dcc.el
@@ -54,9 +54,7 @@
54;;; Code: 54;;; Code:
55 55
56(require 'erc) 56(require 'erc)
57(eval-when-compile 57(eval-when-compile (require 'pcomplete))
58 (require 'cl)
59 (require 'pcomplete))
60 58
61;;;###autoload (autoload 'erc-dcc-mode "erc-dcc") 59;;;###autoload (autoload 'erc-dcc-mode "erc-dcc")
62(define-erc-module dcc nil 60(define-erc-module dcc nil
@@ -277,7 +275,7 @@ Argument IP is the address as a string. The result is also a string."
277 (* (nth 1 ips) 65536.0) 275 (* (nth 1 ips) 65536.0)
278 (* (nth 2 ips) 256.0) 276 (* (nth 2 ips) 256.0)
279 (nth 3 ips)))) 277 (nth 3 ips))))
280 (if (interactive-p) 278 (if (called-interactively-p 'interactive)
281 (message "%s is %.0f" ip res) 279 (message "%s is %.0f" ip res)
282 (format "%.0f" res))))) 280 (format "%.0f" res)))))
283 281
@@ -380,8 +378,8 @@ created subprocess, or nil."
380 (with-no-warnings ; obsolete since 23.1 378 (with-no-warnings ; obsolete since 23.1
381 (set-process-filter-multibyte process nil))))) 379 (set-process-filter-multibyte process nil)))))
382 (file-error 380 (file-error
383 (unless (and (string= "Cannot bind server socket" (cadr err)) 381 (unless (and (string= "Cannot bind server socket" (nth 1 err))
384 (string= "address already in use" (caddr err))) 382 (string= "address already in use" (nth 2 err)))
385 (signal (car err) (cdr err))) 383 (signal (car err) (cdr err)))
386 (setq port (1+ port)) 384 (setq port (1+ port))
387 (unless (< port upper) 385 (unless (< port upper)
@@ -434,38 +432,38 @@ where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc."
434 (pcomplete-here (append '("chat" "close" "get" "list") 432 (pcomplete-here (append '("chat" "close" "get" "list")
435 (when (fboundp 'make-network-process) '("send")))) 433 (when (fboundp 'make-network-process) '("send"))))
436 (pcomplete-here 434 (pcomplete-here
437 (case (intern (downcase (pcomplete-arg 1))) 435 (pcase (intern (downcase (pcomplete-arg 1)))
438 (chat (mapcar (lambda (elt) (plist-get elt :nick)) 436 (`chat (mapcar (lambda (elt) (plist-get elt :nick))
437 (erc-remove-if-not
438 #'(lambda (elt)
439 (eq (plist-get elt :type) 'CHAT))
440 erc-dcc-list)))
441 (`close (erc-delete-dups
442 (mapcar (lambda (elt) (symbol-name (plist-get elt :type)))
443 erc-dcc-list)))
444 (`get (mapcar #'erc-dcc-nick
439 (erc-remove-if-not 445 (erc-remove-if-not
440 #'(lambda (elt) 446 #'(lambda (elt)
441 (eq (plist-get elt :type) 'CHAT)) 447 (eq (plist-get elt :type) 'GET))
442 erc-dcc-list))) 448 erc-dcc-list)))
443 (close (erc-delete-dups 449 (`send (pcomplete-erc-all-nicks))))
444 (mapcar (lambda (elt) (symbol-name (plist-get elt :type)))
445 erc-dcc-list)))
446 (get (mapcar #'erc-dcc-nick
447 (erc-remove-if-not
448 #'(lambda (elt)
449 (eq (plist-get elt :type) 'GET))
450 erc-dcc-list)))
451 (send (pcomplete-erc-all-nicks))))
452 (pcomplete-here 450 (pcomplete-here
453 (case (intern (downcase (pcomplete-arg 2))) 451 (pcase (intern (downcase (pcomplete-arg 2)))
454 (get (mapcar (lambda (elt) (plist-get elt :file)) 452 (`get (mapcar (lambda (elt) (plist-get elt :file))
455 (erc-remove-if-not 453 (erc-remove-if-not
456 #'(lambda (elt) 454 #'(lambda (elt)
457 (and (eq (plist-get elt :type) 'GET) 455 (and (eq (plist-get elt :type) 'GET)
458 (erc-nick-equal-p (erc-extract-nick 456 (erc-nick-equal-p (erc-extract-nick
459 (plist-get elt :nick)) 457 (plist-get elt :nick))
460 (pcomplete-arg 1)))) 458 (pcomplete-arg 1))))
461 erc-dcc-list))) 459 erc-dcc-list)))
462 (close (mapcar #'erc-dcc-nick 460 (`close (mapcar #'erc-dcc-nick
463 (erc-remove-if-not 461 (erc-remove-if-not
464 #'(lambda (elt) 462 #'(lambda (elt)
465 (eq (plist-get elt :type) 463 (eq (plist-get elt :type)
466 (intern (upcase (pcomplete-arg 1))))) 464 (intern (upcase (pcomplete-arg 1)))))
467 erc-dcc-list))) 465 erc-dcc-list)))
468 (send (pcomplete-entries))))) 466 (`send (pcomplete-entries)))))
469 467
470(defun erc-dcc-do-CHAT-command (proc &optional nick) 468(defun erc-dcc-do-CHAT-command (proc &optional nick)
471 (when nick 469 (when nick
@@ -1248,7 +1246,7 @@ other client."
1248 1246
1249(defun erc-dcc-no-such-nick (proc parsed) 1247(defun erc-dcc-no-such-nick (proc parsed)
1250 "Detect and handle no-such-nick replies from the IRC server." 1248 "Detect and handle no-such-nick replies from the IRC server."
1251 (let* ((elt (erc-dcc-member :nick (second (erc-response.command-args parsed)) 1249 (let* ((elt (erc-dcc-member :nick (nth 1 (erc-response.command-args parsed))
1252 :parent proc)) 1250 :parent proc))
1253 (peer (plist-get elt :peer))) 1251 (peer (plist-get elt :peer)))
1254 (when (or (and (processp peer) (not (eq (process-status peer) 'open))) 1252 (when (or (and (processp peer) (not (eq (process-status peer) 'open)))
diff --git a/lisp/erc/erc-ezbounce.el b/lisp/erc/erc-ezbounce.el
index 5e5d6c2c188..6bcc17e4bc0 100644
--- a/lisp/erc/erc-ezbounce.el
+++ b/lisp/erc/erc-ezbounce.el
@@ -26,7 +26,6 @@
26;;; Code: 26;;; Code:
27 27
28(require 'erc) 28(require 'erc)
29(eval-when-compile (require 'cl))
30 29
31(defgroup erc-ezbounce nil 30(defgroup erc-ezbounce nil
32 "Interface to the EZBounce IRC bouncer (a virtual IRC server)" 31 "Interface to the EZBounce IRC bouncer (a virtual IRC server)"
diff --git a/lisp/erc/erc-join.el b/lisp/erc/erc-join.el
index ac6b311a0c4..e285cfb4ec5 100644
--- a/lisp/erc/erc-join.el
+++ b/lisp/erc/erc-join.el
@@ -34,7 +34,6 @@
34 34
35(require 'erc) 35(require 'erc)
36(require 'auth-source) 36(require 'auth-source)
37(eval-when-compile (require 'cl))
38 37
39(defgroup erc-autojoin nil 38(defgroup erc-autojoin nil
40 "Enable autojoining." 39 "Enable autojoining."
diff --git a/lisp/erc/erc-log.el b/lisp/erc/erc-log.el
index b3f3f5865a1..1ff2951e09e 100644
--- a/lisp/erc/erc-log.el
+++ b/lisp/erc/erc-log.el
@@ -93,9 +93,7 @@
93;;; Code: 93;;; Code:
94 94
95(require 'erc) 95(require 'erc)
96(eval-when-compile 96(eval-when-compile (require 'erc-networks))
97 (require 'erc-networks)
98 (require 'cl))
99 97
100(defgroup erc-log nil 98(defgroup erc-log nil
101 "Logging facilities for ERC." 99 "Logging facilities for ERC."
@@ -429,7 +427,8 @@ You can save every individual message by putting this function on
429 file t 'nomessage)))) 427 file t 'nomessage))))
430 (let ((coding-system-for-write coding-system)) 428 (let ((coding-system-for-write coding-system))
431 (write-region start end file t 'nomessage)))) 429 (write-region start end file t 'nomessage))))
432 (if (and erc-truncate-buffer-on-save (interactive-p)) 430 (if (and erc-truncate-buffer-on-save
431 (called-interactively-p 'interactive))
433 (progn 432 (progn
434 (let ((inhibit-read-only t)) (erase-buffer)) 433 (let ((inhibit-read-only t)) (erase-buffer))
435 (move-marker erc-last-saved-position (point-max)) 434 (move-marker erc-last-saved-position (point-max))
diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el
index 8dcdcb9e2e6..f1219427360 100644
--- a/lisp/erc/erc-match.el
+++ b/lisp/erc/erc-match.el
@@ -35,7 +35,6 @@
35;;; Code: 35;;; Code:
36 36
37(require 'erc) 37(require 'erc)
38(eval-when-compile (require 'cl))
39 38
40;; Customization: 39;; Customization:
41 40
diff --git a/lisp/erc/erc-netsplit.el b/lisp/erc/erc-netsplit.el
index fc4aeb10c84..cbaf62b1a61 100644
--- a/lisp/erc/erc-netsplit.el
+++ b/lisp/erc/erc-netsplit.el
@@ -31,7 +31,6 @@
31;;; Code: 31;;; Code:
32 32
33(require 'erc) 33(require 'erc)
34(eval-when-compile (require 'cl))
35 34
36(defgroup erc-netsplit nil 35(defgroup erc-netsplit nil
37 "Netsplit detection tries to automatically figure when a 36 "Netsplit detection tries to automatically figure when a
@@ -107,7 +106,7 @@ join from that split has been detected or not.")
107 (dolist (elt erc-netsplit-list) 106 (dolist (elt erc-netsplit-list)
108 (if (member nick (nthcdr 3 elt)) 107 (if (member nick (nthcdr 3 elt))
109 (progn 108 (progn
110 (if (not (caddr elt)) 109 (if (not (nth 2 elt))
111 (progn 110 (progn
112 (erc-display-message 111 (erc-display-message
113 parsed 'notice (process-buffer proc) 112 parsed 'notice (process-buffer proc)
@@ -149,7 +148,7 @@ join from that split has been detected or not.")
149 ;; element for this netsplit exists already 148 ;; element for this netsplit exists already
150 (progn 149 (progn
151 (setcdr (nthcdr 2 ass) (cons nick (nthcdr 3 ass))) 150 (setcdr (nthcdr 2 ass) (cons nick (nthcdr 3 ass)))
152 (when (caddr ass) 151 (when (nth 2 ass)
153 ;; There was already a netjoin for this netsplit, it 152 ;; There was already a netjoin for this netsplit, it
154 ;; seems like the old one didn't get finished... 153 ;; seems like the old one didn't get finished...
155 (erc-display-message 154 (erc-display-message
@@ -194,7 +193,7 @@ join from that split has been detected or not.")
194 nil 'notice 'active 193 nil 'notice 'active
195 'netsplit-wholeft ?s (car elt) 194 'netsplit-wholeft ?s (car elt)
196 ?n (mapconcat 'erc-extract-nick (nthcdr 3 elt) " ") 195 ?n (mapconcat 'erc-extract-nick (nthcdr 3 elt) " ")
197 ?t (if (caddr elt) 196 ?t (if (nth 2 elt)
198 "(joining)" 197 "(joining)"
199 ""))))) 198 "")))))
200 t) 199 t)
diff --git a/lisp/erc/erc-networks.el b/lisp/erc/erc-networks.el
index 89372555ccc..5089ff6b4ba 100644
--- a/lisp/erc/erc-networks.el
+++ b/lisp/erc/erc-networks.el
@@ -40,7 +40,7 @@
40;;; Code: 40;;; Code:
41 41
42(require 'erc) 42(require 'erc)
43(eval-when-compile (require 'cl)) 43(eval-when-compile (require 'cl-lib))
44 44
45;; Variables 45;; Variables
46 46
@@ -729,10 +729,10 @@ search for a match in `erc-networks-alist'."
729 (or 729 (or
730 ;; Loop through `erc-networks-alist' looking for a match. 730 ;; Loop through `erc-networks-alist' looking for a match.
731 (let ((server (or erc-server-announced-name erc-session-server))) 731 (let ((server (or erc-server-announced-name erc-session-server)))
732 (loop for (name matcher) in erc-networks-alist 732 (cl-loop for (name matcher) in erc-networks-alist
733 when (and matcher 733 when (and matcher
734 (string-match (concat matcher "\\'") server)) 734 (string-match (concat matcher "\\'") server))
735 do (return name))) 735 do (cl-return name)))
736 'Unknown))) 736 'Unknown)))
737 737
738(defun erc-network () 738(defun erc-network ()
@@ -789,8 +789,8 @@ As an example:
789 (cond ((numberp p) 789 (cond ((numberp p)
790 (push p result)) 790 (push p result))
791 ((listp p) 791 ((listp p)
792 (setq result (nconc (loop for i from (cadr p) downto (car p) 792 (setq result (nconc (cl-loop for i from (cadr p) downto (car p)
793 collect i) 793 collect i)
794 result))))) 794 result)))))
795 (nreverse result))) 795 (nreverse result)))
796 796
diff --git a/lisp/erc/erc-notify.el b/lisp/erc/erc-notify.el
index 0b5e99180d6..b9d7ff78cd8 100644
--- a/lisp/erc/erc-notify.el
+++ b/lisp/erc/erc-notify.el
@@ -30,9 +30,7 @@
30 30
31(require 'erc) 31(require 'erc)
32(require 'erc-networks) 32(require 'erc-networks)
33(eval-when-compile 33(eval-when-compile (require 'pcomplete))
34 (require 'cl)
35 (require 'pcomplete))
36 34
37;;;; Customizable variables 35;;;; Customizable variables
38 36
diff --git a/lisp/erc/erc-pcomplete.el b/lisp/erc/erc-pcomplete.el
index bb30fd90066..d6bb8019b15 100644
--- a/lisp/erc/erc-pcomplete.el
+++ b/lisp/erc/erc-pcomplete.el
@@ -43,7 +43,6 @@
43(require 'erc) 43(require 'erc)
44(require 'erc-compat) 44(require 'erc-compat)
45(require 'time-date) 45(require 'time-date)
46(eval-when-compile (require 'cl))
47 46
48(defgroup erc-pcomplete nil 47(defgroup erc-pcomplete nil
49 "Programmable completion for ERC" 48 "Programmable completion for ERC"
diff --git a/lisp/erc/erc-services.el b/lisp/erc/erc-services.el
index b3b80a5f851..b75ad8e9517 100644
--- a/lisp/erc/erc-services.el
+++ b/lisp/erc/erc-services.el
@@ -62,7 +62,7 @@
62 62
63(require 'erc) 63(require 'erc)
64(require 'erc-networks) 64(require 'erc-networks)
65(eval-when-compile (require 'cl)) 65(eval-when-compile (require 'cl-lib))
66 66
67;; Customization: 67;; Customization:
68 68
diff --git a/lisp/erc/erc-speedbar.el b/lisp/erc/erc-speedbar.el
index 4b98cf173be..22053945159 100644
--- a/lisp/erc/erc-speedbar.el
+++ b/lisp/erc/erc-speedbar.el
@@ -38,7 +38,6 @@
38(require 'erc) 38(require 'erc)
39(require 'speedbar) 39(require 'speedbar)
40(condition-case nil (require 'dframe) (error nil)) 40(condition-case nil (require 'dframe) (error nil))
41(eval-when-compile (require 'cl))
42 41
43;;; Customization: 42;;; Customization:
44 43
diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el
index a204584b400..976d2a21030 100644
--- a/lisp/erc/erc-track.el
+++ b/lisp/erc/erc-track.el
@@ -34,7 +34,7 @@
34;; * Add extensibility so that custom functions can track 34;; * Add extensibility so that custom functions can track
35;; custom modification types. 35;; custom modification types.
36 36
37(eval-when-compile (require 'cl)) 37(eval-when-compile (require 'cl-lib))
38(require 'erc) 38(require 'erc)
39(require 'erc-compat) 39(require 'erc-compat)
40(require 'erc-match) 40(require 'erc-match)
@@ -484,7 +484,7 @@ START is the minimum length of the name used."
484 484
485;;; Test: 485;;; Test:
486 486
487(assert 487(cl-assert
488 (and 488 (and
489 ;; verify examples from the doc strings 489 ;; verify examples from the doc strings
490 (equal (let ((erc-track-shorten-aggressively nil)) 490 (equal (let ((erc-track-shorten-aggressively nil))
@@ -869,7 +869,7 @@ Use `erc-make-mode-line-buffer-name' to create buttons."
869 (setq erc-modified-channels-alist 869 (setq erc-modified-channels-alist
870 (delete (assq buffer erc-modified-channels-alist) 870 (delete (assq buffer erc-modified-channels-alist)
871 erc-modified-channels-alist)) 871 erc-modified-channels-alist))
872 (when (interactive-p) 872 (when (called-interactively-p 'interactive)
873 (erc-modified-channels-display))) 873 (erc-modified-channels-display)))
874 874
875(defun erc-track-find-face (faces) 875(defun erc-track-find-face (faces)
@@ -980,7 +980,7 @@ is in `erc-mode'."
980 (add-to-list 'faces cur))) 980 (add-to-list 'faces cur)))
981 faces)) 981 faces))
982 982
983(assert 983(cl-assert
984 (let ((str "is bold")) 984 (let ((str "is bold"))
985 (put-text-property 3 (length str) 985 (put-text-property 3 (length str)
986 'face '(bold erc-current-nick-face) 986 'face '(bold erc-current-nick-face)
@@ -1030,17 +1030,17 @@ relative to `erc-track-switch-direction'"
1030 (let ((dir erc-track-switch-direction) 1030 (let ((dir erc-track-switch-direction)
1031 offset) 1031 offset)
1032 (when (< arg 0) 1032 (when (< arg 0)
1033 (setq dir (case dir 1033 (setq dir (pcase dir
1034 (oldest 'newest) 1034 (`oldest 'newest)
1035 (newest 'oldest) 1035 (`newest 'oldest)
1036 (mostactive 'leastactive) 1036 (`mostactive 'leastactive)
1037 (leastactive 'mostactive) 1037 (`leastactive 'mostactive)
1038 (importance 'oldest))) 1038 (`importance 'oldest)))
1039 (setq arg (- arg))) 1039 (setq arg (- arg)))
1040 (setq offset (case dir 1040 (setq offset (pcase dir
1041 ((oldest leastactive) 1041 ((or `oldest `leastactive)
1042 (- (length erc-modified-channels-alist) arg)) 1042 (- (length erc-modified-channels-alist) arg))
1043 (t (1- arg)))) 1043 (_ (1- arg))))
1044 ;; normalize out of range user input 1044 ;; normalize out of range user input
1045 (cond ((>= offset (length erc-modified-channels-alist)) 1045 (cond ((>= offset (length erc-modified-channels-alist))
1046 (setq offset (1- (length erc-modified-channels-alist)))) 1046 (setq offset (1- (length erc-modified-channels-alist))))
diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el
index 7cb6fbb595b..cec9718e751 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -67,7 +67,7 @@
67(defconst erc-version-string "Version 5.3" 67(defconst erc-version-string "Version 5.3"
68 "ERC version. This is used by function `erc-version'.") 68 "ERC version. This is used by function `erc-version'.")
69 69
70(eval-when-compile (require 'cl)) 70(eval-when-compile (require 'cl-lib))
71(require 'font-lock) 71(require 'font-lock)
72(require 'pp) 72(require 'pp)
73(require 'thingatpt) 73(require 'thingatpt)
@@ -369,7 +369,7 @@ If no server buffer exists, return nil."
369 (with-current-buffer ,buffer 369 (with-current-buffer ,buffer
370 ,@body))))) 370 ,@body)))))
371 371
372(defstruct (erc-server-user (:type vector) :named) 372(cl-defstruct (erc-server-user (:type vector) :named)
373 ;; User data 373 ;; User data
374 nickname host login full-name info 374 nickname host login full-name info
375 ;; Buffers 375 ;; Buffers
@@ -379,7 +379,7 @@ If no server buffer exists, return nil."
379 (buffers nil) 379 (buffers nil)
380 ) 380 )
381 381
382(defstruct (erc-channel-user (:type vector) :named) 382(cl-defstruct (erc-channel-user (:type vector) :named)
383 op voice 383 op voice
384 ;; Last message time (in the form of the return value of 384 ;; Last message time (in the form of the return value of
385 ;; (current-time) 385 ;; (current-time)
@@ -1386,7 +1386,7 @@ If BUFFER is nil, the current buffer is used."
1386 t)) 1386 t))
1387 (erc-server-send (format "ISON %s" nick)) 1387 (erc-server-send (format "ISON %s" nick))
1388 (while (eq erc-online-p 'unknown) (accept-process-output)) 1388 (while (eq erc-online-p 'unknown) (accept-process-output))
1389 (if (interactive-p) 1389 (if (called-interactively-p 'interactive)
1390 (message "%s is %sonline" 1390 (message "%s is %sonline"
1391 (or erc-online-p nick) 1391 (or erc-online-p nick)
1392 (if erc-online-p "" "not ")) 1392 (if erc-online-p "" "not "))
@@ -2157,11 +2157,11 @@ functions in here get called with the parameters SERVER and NICK."
2157 (list :server server :port port :nick nick :password passwd))) 2157 (list :server server :port port :nick nick :password passwd)))
2158 2158
2159;;;###autoload 2159;;;###autoload
2160(defun* erc (&key (server (erc-compute-server)) 2160(cl-defun erc (&key (server (erc-compute-server))
2161 (port (erc-compute-port)) 2161 (port (erc-compute-port))
2162 (nick (erc-compute-nick)) 2162 (nick (erc-compute-nick))
2163 password 2163 password
2164 (full-name (erc-compute-full-name))) 2164 (full-name (erc-compute-full-name)))
2165 "ERC is a powerful, modular, and extensible IRC client. 2165 "ERC is a powerful, modular, and extensible IRC client.
2166This function is the main entry point for ERC. 2166This function is the main entry point for ERC.
2167 2167
@@ -2383,24 +2383,24 @@ If STRING is nil, the function does nothing."
2383 (while list 2383 (while list
2384 (setq elt (car list)) 2384 (setq elt (car list))
2385 (cond ((integerp elt) ; POSITION 2385 (cond ((integerp elt) ; POSITION
2386 (incf (car list) shift)) 2386 (cl-incf (car list) shift))
2387 ((or (atom elt) ; nil, EXTENT 2387 ((or (atom elt) ; nil, EXTENT
2388 ;; (eq t (car elt)) ; (t . TIME) 2388 ;; (eq t (car elt)) ; (t . TIME)
2389 (markerp (car elt))) ; (MARKER . DISTANCE) 2389 (markerp (car elt))) ; (MARKER . DISTANCE)
2390 nil) 2390 nil)
2391 ((integerp (car elt)) ; (BEGIN . END) 2391 ((integerp (car elt)) ; (BEGIN . END)
2392 (incf (car elt) shift) 2392 (cl-incf (car elt) shift)
2393 (incf (cdr elt) shift)) 2393 (cl-incf (cdr elt) shift))
2394 ((stringp (car elt)) ; (TEXT . POSITION) 2394 ((stringp (car elt)) ; (TEXT . POSITION)
2395 (incf (cdr elt) (* (if (natnump (cdr elt)) 1 -1) shift))) 2395 (cl-incf (cdr elt) (* (if (natnump (cdr elt)) 1 -1) shift)))
2396 ((null (car elt)) ; (nil PROPERTY VALUE BEG . END) 2396 ((null (car elt)) ; (nil PROPERTY VALUE BEG . END)
2397 (let ((cons (nthcdr 3 elt))) 2397 (let ((cons (nthcdr 3 elt)))
2398 (incf (car cons) shift) 2398 (cl-incf (car cons) shift)
2399 (incf (cdr cons) shift))) 2399 (cl-incf (cdr cons) shift)))
2400 ((and (featurep 'xemacs) 2400 ((and (featurep 'xemacs)
2401 (extentp (car elt))) ; (EXTENT START END) 2401 (extentp (car elt))) ; (EXTENT START END)
2402 (incf (nth 1 elt) shift) 2402 (cl-incf (nth 1 elt) shift)
2403 (incf (nth 2 elt) shift))) 2403 (cl-incf (nth 2 elt) shift)))
2404 (setq list (cdr list)))))) 2404 (setq list (cdr list))))))
2405 2405
2406(defvar erc-valid-nick-regexp "[]a-zA-Z^[;\\`_{}|][]^[;\\`_{}|a-zA-Z0-9-]*" 2406(defvar erc-valid-nick-regexp "[]a-zA-Z^[;\\`_{}|][]^[;\\`_{}|a-zA-Z0-9-]*"
@@ -2477,6 +2477,13 @@ purposes."
2477 :group 'erc-lurker 2477 :group 'erc-lurker
2478 :type 'boolean) 2478 :type 'boolean)
2479 2479
2480(defcustom erc-lurker-ignore-chars "`_"
2481 "Characters at the end of a nick to strip for activity tracking purposes.
2482
2483See also `erc-lurker-trim-nicks'."
2484 :group 'erc-lurker
2485 :type 'string)
2486
2480(defun erc-lurker-maybe-trim (nick) 2487(defun erc-lurker-maybe-trim (nick)
2481 "Maybe trim trailing `erc-lurker-ignore-chars' from NICK. 2488 "Maybe trim trailing `erc-lurker-ignore-chars' from NICK.
2482 2489
@@ -2491,13 +2498,6 @@ non-nil."
2491 "" nick) 2498 "" nick)
2492 nick)) 2499 nick))
2493 2500
2494(defcustom erc-lurker-ignore-chars "`_"
2495 "Characters at the end of a nick to strip for activity tracking purposes.
2496
2497See also `erc-lurker-trim-nicks'."
2498 :group 'erc-lurker
2499 :type 'string)
2500
2501(defcustom erc-lurker-hide-list nil 2501(defcustom erc-lurker-hide-list nil
2502 "List of IRC type messages to hide when sent by lurkers. 2502 "List of IRC type messages to hide when sent by lurkers.
2503 2503
@@ -2580,7 +2580,8 @@ updates of `erc-lurker-state'."
2580 (server 2580 (server
2581 (erc-canonicalize-server-name erc-server-announced-name))) 2581 (erc-canonicalize-server-name erc-server-announced-name)))
2582 (when (equal command "PRIVMSG") 2582 (when (equal command "PRIVMSG")
2583 (when (>= (incf erc-lurker-cleanup-count) erc-lurker-cleanup-interval) 2583 (when (>= (cl-incf erc-lurker-cleanup-count)
2584 erc-lurker-cleanup-interval)
2584 (setq erc-lurker-cleanup-count 0) 2585 (setq erc-lurker-cleanup-count 0)
2585 (erc-lurker-cleanup)) 2586 (erc-lurker-cleanup))
2586 (unless (gethash server erc-lurker-state) 2587 (unless (gethash server erc-lurker-state)
@@ -2605,6 +2606,17 @@ server within `erc-lurker-threshold-time'. See also
2605 (time-subtract (current-time) last-PRIVMSG-time)) 2606 (time-subtract (current-time) last-PRIVMSG-time))
2606 erc-lurker-threshold-time)))) 2607 erc-lurker-threshold-time))))
2607 2608
2609(defcustom erc-common-server-suffixes
2610 '(("openprojects.net$" . "OPN")
2611 ("freenode.net$" . "freenode")
2612 ("oftc.net$" . "OFTC"))
2613 "Alist of common server name suffixes.
2614This variable is used in mode-line display to save screen
2615real estate. Set it to nil if you want to avoid changing
2616displayed hostnames."
2617 :group 'erc-mode-line-and-header
2618 :type 'alist)
2619
2608(defun erc-canonicalize-server-name (server) 2620(defun erc-canonicalize-server-name (server)
2609 "Returns the canonical network name for SERVER if any, 2621 "Returns the canonical network name for SERVER if any,
2610otherwise `erc-server-announced-name'. SERVER is matched against 2622otherwise `erc-server-announced-name'. SERVER is matched against
@@ -3115,37 +3127,37 @@ If SERVER is non-nil, use that, rather than the current server."
3115 (add-to-list 'symlist 3127 (add-to-list 'symlist
3116 (cons (erc-once-with-server-event 3128 (cons (erc-once-with-server-event
3117 311 `(string= ,nick 3129 311 `(string= ,nick
3118 (second 3130 (nth 1
3119 (erc-response.command-args parsed)))) 3131 (erc-response.command-args parsed))))
3120 'erc-server-311-functions)) 3132 'erc-server-311-functions))
3121 (add-to-list 'symlist 3133 (add-to-list 'symlist
3122 (cons (erc-once-with-server-event 3134 (cons (erc-once-with-server-event
3123 312 `(string= ,nick 3135 312 `(string= ,nick
3124 (second 3136 (nth 1
3125 (erc-response.command-args parsed)))) 3137 (erc-response.command-args parsed))))
3126 'erc-server-312-functions)) 3138 'erc-server-312-functions))
3127 (add-to-list 'symlist 3139 (add-to-list 'symlist
3128 (cons (erc-once-with-server-event 3140 (cons (erc-once-with-server-event
3129 318 `(string= ,nick 3141 318 `(string= ,nick
3130 (second 3142 (nth 1
3131 (erc-response.command-args parsed)))) 3143 (erc-response.command-args parsed))))
3132 'erc-server-318-functions)) 3144 'erc-server-318-functions))
3133 (add-to-list 'symlist 3145 (add-to-list 'symlist
3134 (cons (erc-once-with-server-event 3146 (cons (erc-once-with-server-event
3135 319 `(string= ,nick 3147 319 `(string= ,nick
3136 (second 3148 (nth 1
3137 (erc-response.command-args parsed)))) 3149 (erc-response.command-args parsed))))
3138 'erc-server-319-functions)) 3150 'erc-server-319-functions))
3139 (add-to-list 'symlist 3151 (add-to-list 'symlist
3140 (cons (erc-once-with-server-event 3152 (cons (erc-once-with-server-event
3141 320 `(string= ,nick 3153 320 `(string= ,nick
3142 (second 3154 (nth 1
3143 (erc-response.command-args parsed)))) 3155 (erc-response.command-args parsed))))
3144 'erc-server-320-functions)) 3156 'erc-server-320-functions))
3145 (add-to-list 'symlist 3157 (add-to-list 'symlist
3146 (cons (erc-once-with-server-event 3158 (cons (erc-once-with-server-event
3147 330 `(string= ,nick 3159 330 `(string= ,nick
3148 (second 3160 (nth 1
3149 (erc-response.command-args parsed)))) 3161 (erc-response.command-args parsed))))
3150 'erc-server-330-functions)) 3162 'erc-server-330-functions))
3151 (add-to-list 'symlist 3163 (add-to-list 'symlist
@@ -4328,8 +4340,8 @@ See also: `erc-echo-notice-in-user-buffers',
4328 4340
4329(defun erc-banlist-store (proc parsed) 4341(defun erc-banlist-store (proc parsed)
4330 "Record ban entries for a channel." 4342 "Record ban entries for a channel."
4331 (multiple-value-bind (channel mask whoset) 4343 (pcase-let ((`(,channel ,mask ,whoset)
4332 (values-list (cdr (erc-response.command-args parsed))) 4344 (cdr (erc-response.command-args parsed))))
4333 ;; Determine to which buffer the message corresponds 4345 ;; Determine to which buffer the message corresponds
4334 (let ((buffer (erc-get-buffer channel proc))) 4346 (let ((buffer (erc-get-buffer channel proc)))
4335 (with-current-buffer buffer 4347 (with-current-buffer buffer
@@ -4340,7 +4352,7 @@ See also: `erc-echo-notice-in-user-buffers',
4340 4352
4341(defun erc-banlist-finished (proc parsed) 4353(defun erc-banlist-finished (proc parsed)
4342 "Record that we have received the banlist." 4354 "Record that we have received the banlist."
4343 (let* ((channel (second (erc-response.command-args parsed))) 4355 (let* ((channel (nth 1 (erc-response.command-args parsed)))
4344 (buffer (erc-get-buffer channel proc))) 4356 (buffer (erc-get-buffer channel proc)))
4345 (with-current-buffer buffer 4357 (with-current-buffer buffer
4346 (put 'erc-channel-banlist 'received-from-server t))) 4358 (put 'erc-channel-banlist 'received-from-server t)))
@@ -4349,7 +4361,7 @@ See also: `erc-echo-notice-in-user-buffers',
4349(defun erc-banlist-update (proc parsed) 4361(defun erc-banlist-update (proc parsed)
4350 "Check MODE commands for bans and update the banlist appropriately." 4362 "Check MODE commands for bans and update the banlist appropriately."
4351 ;; FIXME: Possibly incorrect. -- Lawrence 2004-05-11 4363 ;; FIXME: Possibly incorrect. -- Lawrence 2004-05-11
4352 (let* ((tgt (first (erc-response.command-args parsed))) 4364 (let* ((tgt (car (erc-response.command-args parsed)))
4353 (mode (erc-response.contents parsed)) 4365 (mode (erc-response.contents parsed))
4354 (whoset (erc-response.sender parsed)) 4366 (whoset (erc-response.sender parsed))
4355 (buffer (erc-get-buffer tgt proc))) 4367 (buffer (erc-get-buffer tgt proc)))
@@ -6000,7 +6012,7 @@ entry of `channel-members'."
6000 (if cuser 6012 (if cuser
6001 (setq op (erc-channel-user-op cuser) 6013 (setq op (erc-channel-user-op cuser)
6002 voice (erc-channel-user-voice cuser))) 6014 voice (erc-channel-user-voice cuser)))
6003 (if (interactive-p) 6015 (if (called-interactively-p 'interactive)
6004 (message "%s is %s@%s%s%s" 6016 (message "%s is %s@%s%s%s"
6005 nick login host 6017 nick login host
6006 (if full-name (format " (%s)" full-name) "") 6018 (if full-name (format " (%s)" full-name) "")
@@ -6088,17 +6100,6 @@ Otherwise, use the `erc-header-line' face."
6088 :group 'erc-paranoia 6100 :group 'erc-paranoia
6089 :type 'boolean) 6101 :type 'boolean)
6090 6102
6091(defcustom erc-common-server-suffixes
6092 '(("openprojects.net$" . "OPN")
6093 ("freenode.net$" . "freenode")
6094 ("oftc.net$" . "OFTC"))
6095 "Alist of common server name suffixes.
6096This variable is used in mode-line display to save screen
6097real estate. Set it to nil if you want to avoid changing
6098displayed hostnames."
6099 :group 'erc-mode-line-and-header
6100 :type 'alist)
6101
6102(defcustom erc-mode-line-away-status-format 6103(defcustom erc-mode-line-away-status-format
6103 "(AWAY since %a %b %d %H:%M) " 6104 "(AWAY since %a %b %d %H:%M) "
6104 "When you're away on a server, this is shown in the mode line. 6105 "When you're away on a server, this is shown in the mode line.
@@ -6302,7 +6303,7 @@ If optional argument HERE is non-nil, insert version number at point."
6302 (format "ERC %s (GNU Emacs %s)" erc-version-string emacs-version))) 6303 (format "ERC %s (GNU Emacs %s)" erc-version-string emacs-version)))
6303 (if here 6304 (if here
6304 (insert version-string) 6305 (insert version-string)
6305 (if (interactive-p) 6306 (if (called-interactively-p 'interactive)
6306 (message "%s" version-string) 6307 (message "%s" version-string)
6307 version-string)))) 6308 version-string))))
6308 6309
@@ -6322,7 +6323,7 @@ If optional argument HERE is non-nil, insert version number at point."
6322 ", "))) 6323 ", ")))
6323 (if here 6324 (if here
6324 (insert string) 6325 (insert string)
6325 (if (interactive-p) 6326 (if (called-interactively-p 'interactive)
6326 (message "%s" string) 6327 (message "%s" string)
6327 string)))) 6328 string))))
6328 6329
diff --git a/lisp/eshell/em-cmpl.el b/lisp/eshell/em-cmpl.el
index aa8aae2d245..b4c86e39e86 100644
--- a/lisp/eshell/em-cmpl.el
+++ b/lisp/eshell/em-cmpl.el
@@ -297,6 +297,8 @@ to writing a completion function."
297 (define-key eshell-command-map [? ] 'pcomplete-expand) 297 (define-key eshell-command-map [? ] 'pcomplete-expand)
298 (define-key eshell-mode-map [tab] 'eshell-pcomplete) 298 (define-key eshell-mode-map [tab] 'eshell-pcomplete)
299 (define-key eshell-mode-map [(control ?i)] 'eshell-pcomplete) 299 (define-key eshell-mode-map [(control ?i)] 'eshell-pcomplete)
300 (add-hook 'completion-at-point-functions
301 #'pcomplete-completions-at-point nil t)
300 ;; jww (1999-10-19): Will this work on anything but X? 302 ;; jww (1999-10-19): Will this work on anything but X?
301 (if (featurep 'xemacs) 303 (if (featurep 'xemacs)
302 (define-key eshell-mode-map [iso-left-tab] 'pcomplete-reverse) 304 (define-key eshell-mode-map [iso-left-tab] 'pcomplete-reverse)
@@ -452,9 +454,9 @@ to writing a completion function."
452(defun eshell-pcomplete () 454(defun eshell-pcomplete ()
453 "Eshell wrapper for `pcomplete'." 455 "Eshell wrapper for `pcomplete'."
454 (interactive) 456 (interactive)
455 (if eshell-cmpl-ignore-case 457 (condition-case nil
456 (pcomplete-expand-and-complete) ; hack workaround for bug#12838 458 (pcomplete)
457 (pcomplete))) 459 (text-read-only (completion-at-point)))) ; Workaround for bug#12838.
458 460
459(provide 'em-cmpl) 461(provide 'em-cmpl)
460 462
diff --git a/lisp/faces.el b/lisp/faces.el
index 9e0ca962499..f8dc4783cbb 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -487,44 +487,44 @@ with the `default' face (which is always completely specified)."
487(defalias 'face-background-pixmap 'face-stipple) 487(defalias 'face-background-pixmap 'face-stipple)
488 488
489 489
490;; FIXME all of these -p functions ignore inheritance (cf face-stipple). 490(defun face-underline-p (face &optional frame inherit)
491;; Ie, a face that inherits from an underlined face but does not
492;; specify :underline will return nil.
493;; So these functions don't actually tell you anything about how the
494;; face will _appear_. So not very useful IMO.
495(defun face-underline-p (face &optional frame)
496 "Return non-nil if FACE specifies a non-nil underlining. 491 "Return non-nil if FACE specifies a non-nil underlining.
497If the optional argument FRAME is given, report on face FACE in that frame. 492If the optional argument FRAME is given, report on face FACE in that frame.
498If FRAME is t, report on the defaults for face FACE (for new frames). 493If FRAME is t, report on the defaults for face FACE (for new frames).
499If FRAME is omitted or nil, use the selected frame." 494If FRAME is omitted or nil, use the selected frame.
500 (face-attribute-specified-or (face-attribute face :underline frame) nil)) 495Optional argument INHERIT is passed to `face-attribute'."
496 (face-attribute-specified-or
497 (face-attribute face :underline frame inherit) nil))
501 498
502 499
503(defun face-inverse-video-p (face &optional frame) 500(defun face-inverse-video-p (face &optional frame inherit)
504 "Return non-nil if FACE specifies a non-nil inverse-video. 501 "Return non-nil if FACE specifies a non-nil inverse-video.
505If the optional argument FRAME is given, report on face FACE in that frame. 502If the optional argument FRAME is given, report on face FACE in that frame.
506If FRAME is t, report on the defaults for face FACE (for new frames). 503If FRAME is t, report on the defaults for face FACE (for new frames).
507If FRAME is omitted or nil, use the selected frame." 504If FRAME is omitted or nil, use the selected frame.
508 (eq (face-attribute face :inverse-video frame) t)) 505Optional argument INHERIT is passed to `face-attribute'."
506 (eq (face-attribute face :inverse-video frame inherit) t))
509 507
510 508
511(defun face-bold-p (face &optional frame) 509(defun face-bold-p (face &optional frame inherit)
512 "Return non-nil if the font of FACE is bold on FRAME. 510 "Return non-nil if the font of FACE is bold on FRAME.
513If the optional argument FRAME is given, report on face FACE in that frame. 511If the optional argument FRAME is given, report on face FACE in that frame.
514If FRAME is t, report on the defaults for face FACE (for new frames). 512If FRAME is t, report on the defaults for face FACE (for new frames).
515If FRAME is omitted or nil, use the selected frame. 513If FRAME is omitted or nil, use the selected frame.
514Optional argument INHERIT is passed to `face-attribute'.
516Use `face-attribute' for finer control." 515Use `face-attribute' for finer control."
517 (let ((bold (face-attribute face :weight frame))) 516 (let ((bold (face-attribute face :weight frame inherit)))
518 (memq bold '(semi-bold bold extra-bold ultra-bold)))) 517 (memq bold '(semi-bold bold extra-bold ultra-bold))))
519 518
520 519
521(defun face-italic-p (face &optional frame) 520(defun face-italic-p (face &optional frame inherit)
522 "Return non-nil if the font of FACE is italic on FRAME. 521 "Return non-nil if the font of FACE is italic on FRAME.
523If the optional argument FRAME is given, report on face FACE in that frame. 522If the optional argument FRAME is given, report on face FACE in that frame.
524If FRAME is t, report on the defaults for face FACE (for new frames). 523If FRAME is t, report on the defaults for face FACE (for new frames).
525If FRAME is omitted or nil, use the selected frame. 524If FRAME is omitted or nil, use the selected frame.
525Optional argument INHERIT is passed to `face-attribute'.
526Use `face-attribute' for finer control." 526Use `face-attribute' for finer control."
527 (let ((italic (face-attribute face :slant frame))) 527 (let ((italic (face-attribute face :slant frame inherit)))
528 (memq italic '(italic oblique)))) 528 (memq italic '(italic oblique))))
529 529
530 530
@@ -862,7 +862,7 @@ Use `set-face-attribute' to ``unspecify'' underlining."
862 'set-face-underline "24.3") 862 'set-face-underline "24.3")
863 863
864 864
865(defun set-face-inverse-video-p (face inverse-video-p &optional frame) 865(defun set-face-inverse-video (face inverse-video-p &optional frame)
866 "Specify whether face FACE is in inverse video. 866 "Specify whether face FACE is in inverse video.
867INVERSE-VIDEO-P non-nil means FACE displays explicitly in inverse video. 867INVERSE-VIDEO-P non-nil means FACE displays explicitly in inverse video.
868INVERSE-VIDEO-P nil means FACE explicitly is not in inverse video. 868INVERSE-VIDEO-P nil means FACE explicitly is not in inverse video.
@@ -870,14 +870,13 @@ FRAME nil or not specified means change face on all frames.
870Use `set-face-attribute' to ``unspecify'' the inverse video attribute." 870Use `set-face-attribute' to ``unspecify'' the inverse video attribute."
871 (interactive 871 (interactive
872 (let ((list (read-face-and-attribute :inverse-video))) 872 (let ((list (read-face-and-attribute :inverse-video)))
873 (list (car list) (eq (car (cdr list)) t)))) 873 (list (car list) (if (cadr list) t))))
874 (set-face-attribute face frame :inverse-video inverse-video-p)) 874 (set-face-attribute face frame :inverse-video inverse-video-p))
875 875
876(define-obsolete-function-alias 'set-face-inverse-video-p
877 'set-face-inverse-video "24.4")
876 878
877;; The -p suffix is a hostage to fortune. What if we want to extend 879(defun set-face-bold (face bold-p &optional frame)
878;; this to allow more than boolean options? Exactly this happened
879;; to set-face-underline-p.
880(defun set-face-bold-p (face bold-p &optional frame)
881 "Specify whether face FACE is bold. 880 "Specify whether face FACE is bold.
882BOLD-P non-nil means FACE should explicitly display bold. 881BOLD-P non-nil means FACE should explicitly display bold.
883BOLD-P nil means FACE should explicitly display non-bold. 882BOLD-P nil means FACE should explicitly display non-bold.
@@ -887,8 +886,10 @@ Use `set-face-attribute' or `modify-face' for finer control."
887 (make-face-unbold face frame) 886 (make-face-unbold face frame)
888 (make-face-bold face frame))) 887 (make-face-bold face frame)))
889 888
889(define-obsolete-function-alias 'set-face-bold-p 'set-face-bold "24.4")
890
890 891
891(defun set-face-italic-p (face italic-p &optional frame) 892(defun set-face-italic (face italic-p &optional frame)
892 "Specify whether face FACE is italic. 893 "Specify whether face FACE is italic.
893ITALIC-P non-nil means FACE should explicitly display italic. 894ITALIC-P non-nil means FACE should explicitly display italic.
894ITALIC-P nil means FACE should explicitly display non-italic. 895ITALIC-P nil means FACE should explicitly display non-italic.
@@ -898,6 +899,8 @@ Use `set-face-attribute' or `modify-face' for finer control."
898 (make-face-unitalic face frame) 899 (make-face-unitalic face frame)
899 (make-face-italic face frame))) 900 (make-face-italic face frame)))
900 901
902(define-obsolete-function-alias 'set-face-italic-p 'set-face-italic "24.4")
903
901 904
902(defalias 'set-face-background-pixmap 'set-face-stipple) 905(defalias 'set-face-background-pixmap 'set-face-stipple)
903 906
diff --git a/lisp/files.el b/lisp/files.el
index 8e8a178caab..496f9bf8fa4 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -730,7 +730,7 @@ The path separator is colon in GNU and GNU-like systems."
730 ;; This is a case where .elc makes a lot of sense. 730 ;; This is a case where .elc makes a lot of sense.
731 (interactive (list (let ((completion-ignored-extensions 731 (interactive (list (let ((completion-ignored-extensions
732 (remove ".elc" completion-ignored-extensions))) 732 (remove ".elc" completion-ignored-extensions)))
733 (read-file-name "Load file: ")))) 733 (read-file-name "Load file: " nil nil 'lambda))))
734 (load (expand-file-name file) nil nil t)) 734 (load (expand-file-name file) nil nil t))
735 735
736(defun locate-file (filename path &optional suffixes predicate) 736(defun locate-file (filename path &optional suffixes predicate)
@@ -3433,7 +3433,7 @@ DIR is the name of the directory.
3433CLASS is the name of a variable class (a symbol). 3433CLASS is the name of a variable class (a symbol).
3434MTIME is the recorded modification time of the directory-local 3434MTIME is the recorded modification time of the directory-local
3435variables file associated with this entry. This time is a list 3435variables file associated with this entry. This time is a list
3436of two integers (the same format as `file-attributes'), and is 3436of integers (the same format as `file-attributes'), and is
3437used to test whether the cache entry is still valid. 3437used to test whether the cache entry is still valid.
3438Alternatively, MTIME can be nil, which means the entry is always 3438Alternatively, MTIME can be nil, which means the entry is always
3439considered valid.") 3439considered valid.")
diff --git a/lisp/find-cmd.el b/lisp/find-cmd.el
index 6589bac0c6a..4cf5b85c81a 100644
--- a/lisp/find-cmd.el
+++ b/lisp/find-cmd.el
@@ -63,6 +63,7 @@
63 (cnewer . (1)) 63 (cnewer . (1))
64 (ctime . (1)) 64 (ctime . (1))
65 (empty . (0)) 65 (empty . (0))
66 (executable . (0))
66 (false . (0)) 67 (false . (0))
67 (fstype . (1)) 68 (fstype . (1))
68 (gid . (1)) 69 (gid . (1))
@@ -70,37 +71,43 @@
70 (ilname . (1)) 71 (ilname . (1))
71 (iname . (1)) 72 (iname . (1))
72 (inum . (1)) 73 (inum . (1))
73 (iwholename . (1)) 74 (ipath . (1))
74 (iregex . (1)) 75 (iregex . (1))
76 (iwholename . (1))
75 (links . (1)) 77 (links . (1))
76 (lname . (1)) 78 (lname . (1))
77 (mmin . (1)) 79 (mmin . (1))
78 (mtime . (1)) 80 (mtime . (1))
79 (name . (1)) 81 (name . (1))
80 (newer . (1)) 82 (newer . (1))
81 (nouser . (0))
82 (nogroup . (0)) 83 (nogroup . (0))
84 (nouser . (0))
83 (path . (1)) 85 (path . (1))
84 (perm . (0)) 86 (perm . (0))
87 (readable . (0))
85 (regex . (1)) 88 (regex . (1))
86 (wholename . (1)) 89 (samefile . (1))
87 (size . (1)) 90 (size . (1))
88 (true . (0)) 91 (true . (0))
89 (type . (1)) 92 (type . (1))
90 (uid . (1)) 93 (uid . (1))
91 (used . (1)) 94 (used . (1))
92 (user . (1)) 95 (user . (1))
96 (wholename . (1))
97 (writable . (0))
93 (xtype . (nil)) 98 (xtype . (nil))
94 99
95 ;; normal options (always true) 100 ;; normal options (always true)
101 (daystart . (0))
96 (depth . (0)) 102 (depth . (0))
97 (maxdepth . (1)) 103 (maxdepth . (1))
98 (mindepth . (1)) 104 (mindepth . (1))
99 (mount . (0)) 105 (mount . (0))
100 (noleaf . (0)) 106 (noleaf . (0))
101 (xdev . (0))
102 (ignore_readdir_race . (0)) 107 (ignore_readdir_race . (0))
103 (noignore_readdir_race . (0)) 108 (noignore_readdir_race . (0))
109 (regextype . (1))
110 (xdev . (0))
104 111
105 ;; actions 112 ;; actions
106 (delete . (0)) 113 (delete . (0))
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index dd493d383a3..d0dfd100f44 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,3 +1,8 @@
12012-11-19 Katsumi Yamaoka <yamaoka@jpl.org>
2
3 * message.el (message-get-reply-headers):
4 Make sure the reply goes to the author if it is a wide reply.
5
12012-11-16 Jan Tatarik <jan.tatarik@gmail.com> 62012-11-16 Jan Tatarik <jan.tatarik@gmail.com>
2 7
3 * gnus-score.el (gnus-score-body): 8 * gnus-score.el (gnus-score-body):
diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el
index 8905acb9d1f..5a2b4334582 100644
--- a/lisp/gnus/message.el
+++ b/lisp/gnus/message.el
@@ -6730,11 +6730,16 @@ The function is called with one parameter, a cons cell ..."
6730 ", ")) 6730 ", "))
6731 mct (message-fetch-field "mail-copies-to") 6731 mct (message-fetch-field "mail-copies-to")
6732 author (or (message-fetch-field "mail-reply-to") 6732 author (or (message-fetch-field "mail-reply-to")
6733 (message-fetch-field "reply-to") 6733 (message-fetch-field "reply-to"))
6734 (message-fetch-field "from")
6735 "")
6736 mft (and message-use-mail-followup-to 6734 mft (and message-use-mail-followup-to
6737 (message-fetch-field "mail-followup-to")))) 6735 (message-fetch-field "mail-followup-to")))
6736 ;; Make sure this message goes to the author if this is a wide
6737 ;; reply, since Reply-To address may be a list address a mailing
6738 ;; list server added.
6739 (when (and wide author)
6740 (setq cc (concat author ", " cc)))
6741 (when (or wide (not author))
6742 (setq author (or (message-fetch-field "from") ""))))
6738 6743
6739 ;; Handle special values of Mail-Copies-To. 6744 ;; Handle special values of Mail-Copies-To.
6740 (when mct 6745 (when mct
diff --git a/lisp/json.el b/lisp/json.el
index 8167bfe93f2..b1ea03120dc 100644
--- a/lisp/json.el
+++ b/lisp/json.el
@@ -51,7 +51,6 @@
51 51
52;;; Code: 52;;; Code:
53 53
54(eval-when-compile (require 'cl))
55 54
56;; Compatibility code 55;; Compatibility code
57 56
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index ec321d00506..07da0b3dc16 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -1270,9 +1270,10 @@ target of the symlink differ."
1270 res-uid 1270 res-uid
1271 ;; 3. File gid. 1271 ;; 3. File gid.
1272 res-gid 1272 res-gid
1273 ;; 4. Last access time, as a list of two integers. First 1273 ;; 4. Last access time, as a list of integers. Normally this
1274 ;; integer has high-order 16 bits of time, second has low 16 1274 ;; would be in the same format as `current-time', but the
1275 ;; bits. 1275 ;; subseconds part is not currently implemented, and (0 0)
1276 ;; denotes an unknown time.
1276 ;; 5. Last modification time, likewise. 1277 ;; 5. Last modification time, likewise.
1277 ;; 6. Last status change time, likewise. 1278 ;; 6. Last status change time, likewise.
1278 '(0 0) '(0 0) '(0 0) ;CCC how to find out? 1279 '(0 0) '(0 0) '(0 0) ;CCC how to find out?
@@ -1980,6 +1981,7 @@ file names."
1980 (error "Unknown operation `%s', must be `copy' or `rename'" op)) 1981 (error "Unknown operation `%s', must be `copy' or `rename'" op))
1981 (let ((t1 (tramp-tramp-file-p filename)) 1982 (let ((t1 (tramp-tramp-file-p filename))
1982 (t2 (tramp-tramp-file-p newname)) 1983 (t2 (tramp-tramp-file-p newname))
1984 (length (nth 7 (file-attributes (file-truename filename))))
1983 (context (and preserve-selinux-context 1985 (context (and preserve-selinux-context
1984 (apply 'file-selinux-context (list filename)))) 1986 (apply 'file-selinux-context (list filename))))
1985 pr tm) 1987 pr tm)
@@ -2009,8 +2011,9 @@ file names."
2009 ok-if-already-exists keep-date preserve-uid-gid)) 2011 ok-if-already-exists keep-date preserve-uid-gid))
2010 2012
2011 ;; Try out-of-band operation. 2013 ;; Try out-of-band operation.
2012 ((tramp-method-out-of-band-p 2014 ((and
2013 v1 (nth 7 (file-attributes (file-truename filename)))) 2015 (tramp-method-out-of-band-p v1 length)
2016 (tramp-method-out-of-band-p v2 length))
2014 (tramp-do-copy-or-rename-file-out-of-band 2017 (tramp-do-copy-or-rename-file-out-of-band
2015 op filename newname keep-date)) 2018 op filename newname keep-date))
2016 2019
@@ -2038,8 +2041,7 @@ file names."
2038 2041
2039 ;; If the Tramp file has an out-of-band method, the 2042 ;; If the Tramp file has an out-of-band method, the
2040 ;; corresponding copy-program can be invoked. 2043 ;; corresponding copy-program can be invoked.
2041 ((tramp-method-out-of-band-p 2044 ((tramp-method-out-of-band-p v length)
2042 v (nth 7 (file-attributes (file-truename filename))))
2043 (tramp-do-copy-or-rename-file-out-of-band 2045 (tramp-do-copy-or-rename-file-out-of-band
2044 op filename newname keep-date)) 2046 op filename newname keep-date))
2045 2047
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index caaae5d553e..d6f2177b03b 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -3767,6 +3767,7 @@ Invokes `password-read' if available, `read-passwd' else."
3767 ("oct" . 10) ("nov" . 11) ("dec" . 12)) 3767 ("oct" . 10) ("nov" . 11) ("dec" . 12))
3768 "Alist mapping month names to integers.") 3768 "Alist mapping month names to integers.")
3769 3769
3770;; FIXME: Shouldn't this also look at any subseconds parts of T1 and T2?
3770;;;###tramp-autoload 3771;;;###tramp-autoload
3771(defun tramp-time-less-p (t1 t2) 3772(defun tramp-time-less-p (t1 t2)
3772 "Say whether time value T1 is less than time value T2." 3773 "Say whether time value T1 is less than time value T2."
@@ -3776,6 +3777,7 @@ Invokes `password-read' if available, `read-passwd' else."
3776 (and (= (car t1) (car t2)) 3777 (and (= (car t1) (car t2))
3777 (< (nth 1 t1) (nth 1 t2))))) 3778 (< (nth 1 t1) (nth 1 t2)))))
3778 3779
3780;; FIXME: Shouldn't this also look at any subseconds parts of T1 and T2?
3779(defun tramp-time-subtract (t1 t2) 3781(defun tramp-time-subtract (t1 t2)
3780 "Subtract two time values. 3782 "Subtract two time values.
3781Return the difference in the format of a time value." 3783Return the difference in the format of a time value."
diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el
index 9e55976a8bd..13cf7356e7f 100644
--- a/lisp/pcomplete.el
+++ b/lisp/pcomplete.el
@@ -833,7 +833,8 @@ this is `comint-dynamic-complete-functions'."
833 . ,(lambda (comps) 833 . ,(lambda (comps)
834 (sort comps pcomplete-compare-entry-function))) 834 (sort comps pcomplete-compare-entry-function)))
835 ,@(cdr (completion-file-name-table s p a))) 835 ,@(cdr (completion-file-name-table s p a)))
836 (let ((completion-ignored-extensions nil)) 836 (let ((completion-ignored-extensions nil)
837 (completion-ignore-case pcomplete-ignore-case))
837 (completion-table-with-predicate 838 (completion-table-with-predicate
838 #'comint-completion-file-name-table pred 'strict s p a)))))) 839 #'comint-completion-file-name-table pred 'strict s p a))))))
839 840
diff --git a/lisp/play/gamegrid.el b/lisp/play/gamegrid.el
index a3ea4af4651..8af877c7843 100644
--- a/lisp/play/gamegrid.el
+++ b/lisp/play/gamegrid.el
@@ -175,7 +175,7 @@ static unsigned char gamegrid_bits[] = {
175 175
176(defun gamegrid-make-mono-tty-face () 176(defun gamegrid-make-mono-tty-face ()
177 (let ((face (make-face 'gamegrid-mono-tty-face))) 177 (let ((face (make-face 'gamegrid-mono-tty-face)))
178 (set-face-inverse-video-p face t) 178 (set-face-inverse-video face t)
179 face)) 179 face))
180 180
181(defun gamegrid-make-color-tty-face (color) 181(defun gamegrid-make-color-tty-face (color)
diff --git a/lisp/profiler.el b/lisp/profiler.el
index 38c0c0b83a7..00b51ffe099 100644
--- a/lisp/profiler.el
+++ b/lisp/profiler.el
@@ -404,7 +404,6 @@ RET: expand or collapse"))
404 404
405(defvar profiler-report-mode-map 405(defvar profiler-report-mode-map
406 (let ((map (make-sparse-keymap))) 406 (let ((map (make-sparse-keymap)))
407 ;; FIXME: Add menu.
408 (define-key map "n" 'profiler-report-next-entry) 407 (define-key map "n" 'profiler-report-next-entry)
409 (define-key map "p" 'profiler-report-previous-entry) 408 (define-key map "p" 'profiler-report-previous-entry)
410 ;; I find it annoying more than helpful to not be able to navigate 409 ;; I find it annoying more than helpful to not be able to navigate
@@ -424,8 +423,43 @@ RET: expand or collapse"))
424 (define-key map "D" 'profiler-report-descending-sort) 423 (define-key map "D" 'profiler-report-descending-sort)
425 (define-key map "=" 'profiler-report-compare-profile) 424 (define-key map "=" 'profiler-report-compare-profile)
426 (define-key map (kbd "C-x C-w") 'profiler-report-write-profile) 425 (define-key map (kbd "C-x C-w") 'profiler-report-write-profile)
427 (define-key map "q" 'quit-window) 426 (easy-menu-define profiler-report-menu map "Menu for Profiler Report mode."
428 map)) 427 '("Profiler"
428 ["Next Entry" profiler-report-next-entry :active t
429 :help "Move to next entry"]
430 ["Previous Entry" profiler-report-previous-entry :active t
431 :help "Move to previous entry"]
432 "--"
433 ["Toggle Entry" profiler-report-toggle-entry
434 :active (profiler-report-calltree-at-point)
435 :help "Expand or collapse the current entry"]
436 ["Find Entry" profiler-report-find-entry
437 ;; FIXME should deactivate if not on a known function.
438 :active (profiler-report-calltree-at-point)
439 :help "Find the definition of the current entry"]
440 ["Describe Entry" profiler-report-describe-entry
441 :active (profiler-report-calltree-at-point)
442 :help "Show the documentation of the current entry"]
443 "--"
444 ["Show Calltree" profiler-report-render-calltree
445 :active profiler-report-reversed
446 :help "Show calltree view"]
447 ["Show Reversed Calltree" profiler-report-render-reversed-calltree
448 :active (not profiler-report-reversed)
449 :help "Show reversed calltree view"]
450 ["Sort Ascending" profiler-report-ascending-sort
451 :active (not (eq profiler-report-order 'ascending))
452 :help "Sort calltree view in ascending order"]
453 ["Sort Descending" profiler-report-descending-sort
454 :active (not (eq profiler-report-order 'descending))
455 :help "Sort calltree view in descending order"]
456 "--"
457 ["Compare Profile..." profiler-report-compare-profile :active t
458 :help "Compare current profile with another"]
459 ["Write Profile..." profiler-report-write-profile :active t
460 :help "Write current profile to a file"]))
461 map)
462 "Keymap for `profiler-report-mode'.")
429 463
430(defun profiler-report-make-buffer-name (profile) 464(defun profiler-report-make-buffer-name (profile)
431 (format "*%s-Profiler-Report %s*" 465 (format "*%s-Profiler-Report %s*"
@@ -529,11 +563,15 @@ otherwise collapse."
529(defun profiler-report-find-entry (&optional event) 563(defun profiler-report-find-entry (&optional event)
530 "Find entry at point." 564 "Find entry at point."
531 (interactive (list last-nonmenu-event)) 565 (interactive (list last-nonmenu-event))
532 (if event (posn-set-point (event-end event))) 566 (with-current-buffer
533 (let ((tree (profiler-report-calltree-at-point))) 567 (if event (window-buffer (posn-window (event-start event)))
534 (when tree 568 (current-buffer))
535 (let ((entry (profiler-calltree-entry tree))) 569 (and event (setq event (event-end event))
536 (find-function entry))))) 570 (posn-set-point event))
571 (let ((tree (profiler-report-calltree-at-point)))
572 (when tree
573 (let ((entry (profiler-calltree-entry tree)))
574 (find-function entry))))))
537 575
538(defun profiler-report-describe-entry () 576(defun profiler-report-describe-entry ()
539 "Describe entry at point." 577 "Describe entry at point."
diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el
index 949b0252bf1..550c5f5a129 100644
--- a/lisp/progmodes/python.el
+++ b/lisp/progmodes/python.el
@@ -202,13 +202,12 @@
202 202
203(require 'ansi-color) 203(require 'ansi-color)
204(require 'comint) 204(require 'comint)
205(eval-when-compile (require 'cl-lib))
205 206
206(eval-when-compile 207;; Avoid compiler warnings
207 (require 'cl) 208(defvar view-return-to-alist)
208 ;; Avoid compiler warnings 209(defvar compilation-error-regexp-alist)
209 (defvar view-return-to-alist) 210(defvar outline-heading-end-regexp)
210 (defvar compilation-error-regexp-alist)
211 (defvar outline-heading-end-regexp))
212 211
213(autoload 'comint-mode "comint") 212(autoload 'comint-mode "comint")
214 213
@@ -364,12 +363,24 @@ This variant of `rx' supports common python named REGEXPS."
364 "Return non-nil if point is on TYPE using SYNTAX-PPSS. 363 "Return non-nil if point is on TYPE using SYNTAX-PPSS.
365TYPE can be `comment', `string' or `paren'. It returns the start 364TYPE can be `comment', `string' or `paren'. It returns the start
366character address of the specified TYPE." 365character address of the specified TYPE."
366 (declare (compiler-macro
367 (lambda (form)
368 (pcase type
369 (`'comment
370 `(let ((ppss (or ,syntax-ppss (syntax-ppss))))
371 (and (nth 4 ppss) (nth 8 ppss))))
372 (`'string
373 `(let ((ppss (or ,syntax-ppss (syntax-ppss))))
374 (and (nth 3 ppss) (nth 8 ppss))))
375 (`'paren
376 `(nth 1 (or ,syntax-ppss (syntax-ppss))))
377 (_ form)))))
367 (let ((ppss (or syntax-ppss (syntax-ppss)))) 378 (let ((ppss (or syntax-ppss (syntax-ppss))))
368 (case type 379 (pcase type
369 (comment (and (nth 4 ppss) (nth 8 ppss))) 380 (`comment (and (nth 4 ppss) (nth 8 ppss)))
370 (string (and (not (nth 4 ppss)) (nth 8 ppss))) 381 (`string (and (nth 3 ppss) (nth 8 ppss)))
371 (paren (nth 1 ppss)) 382 (`paren (nth 1 ppss))
372 (t nil)))) 383 (_ nil))))
373 384
374(defun python-syntax-context-type (&optional syntax-ppss) 385(defun python-syntax-context-type (&optional syntax-ppss)
375 "Return the context type using SYNTAX-PPSS. 386 "Return the context type using SYNTAX-PPSS.
@@ -481,8 +492,8 @@ The type returned can be `comment', `string' or `paren'."
481 (when (re-search-forward re limit t) 492 (when (re-search-forward re limit t)
482 (while (and (python-syntax-context 'paren) 493 (while (and (python-syntax-context 'paren)
483 (re-search-forward re limit t))) 494 (re-search-forward re limit t)))
484 (if (and (not (python-syntax-context 'paren)) 495 (if (not (or (python-syntax-context 'paren)
485 (not (equal (char-after (point-marker)) ?=))) 496 (equal (char-after (point-marker)) ?=)))
486 t 497 t
487 (set-match-data nil))))) 498 (set-match-data nil)))))
488 (1 font-lock-variable-name-face nil nil)) 499 (1 font-lock-variable-name-face nil nil))
@@ -516,7 +527,7 @@ is used to limit the scan."
516 (while (and (< i 3) 527 (while (and (< i 3)
517 (or (not limit) (< (+ point i) limit)) 528 (or (not limit) (< (+ point i) limit))
518 (eq (char-after (+ point i)) quote-char)) 529 (eq (char-after (+ point i)) quote-char))
519 (incf i)) 530 (cl-incf i))
520 i)) 531 i))
521 532
522(defun python-syntax-stringify () 533(defun python-syntax-stringify ()
@@ -723,17 +734,17 @@ START is the buffer position where the sexp starts."
723 (save-restriction 734 (save-restriction
724 (widen) 735 (widen)
725 (save-excursion 736 (save-excursion
726 (case context-status 737 (pcase context-status
727 ('no-indent 0) 738 (`no-indent 0)
728 ;; When point is after beginning of block just add one level 739 ;; When point is after beginning of block just add one level
729 ;; of indentation relative to the context-start 740 ;; of indentation relative to the context-start
730 ('after-beginning-of-block 741 (`after-beginning-of-block
731 (goto-char context-start) 742 (goto-char context-start)
732 (+ (current-indentation) python-indent-offset)) 743 (+ (current-indentation) python-indent-offset))
733 ;; When after a simple line just use previous line 744 ;; When after a simple line just use previous line
734 ;; indentation, in the case current line starts with a 745 ;; indentation, in the case current line starts with a
735 ;; `python-indent-dedenters' de-indent one level. 746 ;; `python-indent-dedenters' de-indent one level.
736 ('after-line 747 (`after-line
737 (- 748 (-
738 (save-excursion 749 (save-excursion
739 (goto-char context-start) 750 (goto-char context-start)
@@ -746,11 +757,11 @@ START is the buffer position where the sexp starts."
746 ;; When inside of a string, do nothing. just use the current 757 ;; When inside of a string, do nothing. just use the current
747 ;; indentation. XXX: perhaps it would be a good idea to 758 ;; indentation. XXX: perhaps it would be a good idea to
748 ;; invoke standard text indentation here 759 ;; invoke standard text indentation here
749 ('inside-string 760 (`inside-string
750 (goto-char context-start) 761 (goto-char context-start)
751 (current-indentation)) 762 (current-indentation))
752 ;; After backslash we have several possibilities. 763 ;; After backslash we have several possibilities.
753 ('after-backslash 764 (`after-backslash
754 (cond 765 (cond
755 ;; Check if current line is a dot continuation. For this 766 ;; Check if current line is a dot continuation. For this
756 ;; the current line must start with a dot and previous 767 ;; the current line must start with a dot and previous
@@ -816,7 +827,7 @@ START is the buffer position where the sexp starts."
816 (+ (current-indentation) python-indent-offset))))) 827 (+ (current-indentation) python-indent-offset)))))
817 ;; When inside a paren there's a need to handle nesting 828 ;; When inside a paren there's a need to handle nesting
818 ;; correctly 829 ;; correctly
819 ('inside-paren 830 (`inside-paren
820 (cond 831 (cond
821 ;; If current line closes the outermost open paren use the 832 ;; If current line closes the outermost open paren use the
822 ;; current indentation of the context-start line. 833 ;; current indentation of the context-start line.
@@ -2164,11 +2175,11 @@ INPUT."
2164 'default) 2175 'default)
2165 (t nil))) 2176 (t nil)))
2166 (completion-code 2177 (completion-code
2167 (case completion-context 2178 (pcase completion-context
2168 (pdb python-shell-completion-pdb-string-code) 2179 (`pdb python-shell-completion-pdb-string-code)
2169 (import python-shell-completion-module-string-code) 2180 (`import python-shell-completion-module-string-code)
2170 (default python-shell-completion-string-code) 2181 (`default python-shell-completion-string-code)
2171 (t nil))) 2182 (_ nil)))
2172 (input 2183 (input
2173 (if (eq completion-context 'import) 2184 (if (eq completion-context 'import)
2174 (replace-regexp-in-string "^[ \t]+" "" line) 2185 (replace-regexp-in-string "^[ \t]+" "" line)
@@ -2492,17 +2503,17 @@ JUSTIFY should be used (if applicable) as in `fill-paragraph'."
2492 ;; Docstring styles may vary for oneliners and multi-liners. 2503 ;; Docstring styles may vary for oneliners and multi-liners.
2493 (> (count-matches "\n" str-start-pos str-end-pos) 0)) 2504 (> (count-matches "\n" str-start-pos str-end-pos) 0))
2494 (delimiters-style 2505 (delimiters-style
2495 (case python-fill-docstring-style 2506 (pcase python-fill-docstring-style
2496 ;; delimiters-style is a cons cell with the form 2507 ;; delimiters-style is a cons cell with the form
2497 ;; (START-NEWLINES . END-NEWLINES). When any of the sexps 2508 ;; (START-NEWLINES . END-NEWLINES). When any of the sexps
2498 ;; is NIL means to not add any newlines for start or end 2509 ;; is NIL means to not add any newlines for start or end
2499 ;; of docstring. See `python-fill-docstring-style' for a 2510 ;; of docstring. See `python-fill-docstring-style' for a
2500 ;; graphic idea of each style. 2511 ;; graphic idea of each style.
2501 (django (cons 1 1)) 2512 (`django (cons 1 1))
2502 (onetwo (and multi-line-p (cons 1 2))) 2513 (`onetwo (and multi-line-p (cons 1 2)))
2503 (pep-257 (and multi-line-p (cons nil 2))) 2514 (`pep-257 (and multi-line-p (cons nil 2)))
2504 (pep-257-nn (and multi-line-p (cons nil 1))) 2515 (`pep-257-nn (and multi-line-p (cons nil 1)))
2505 (symmetric (and multi-line-p (cons 1 1))))) 2516 (`symmetric (and multi-line-p (cons 1 1)))))
2506 (docstring-p (save-excursion 2517 (docstring-p (save-excursion
2507 ;; Consider docstrings those strings which 2518 ;; Consider docstrings those strings which
2508 ;; start on a line by themselves. 2519 ;; start on a line by themselves.
@@ -2703,7 +2714,7 @@ The skeleton will be bound to python-skeleton-NAME."
2703 (easy-menu-add-item 2714 (easy-menu-add-item
2704 nil '("Python" "Skeletons") 2715 nil '("Python" "Skeletons")
2705 `[,(format 2716 `[,(format
2706 "Insert %s" (caddr (split-string (symbol-name skeleton) "-"))) 2717 "Insert %s" (nth 2 (split-string (symbol-name skeleton) "-")))
2707 ,skeleton t])))) 2718 ,skeleton t]))))
2708 2719
2709;;; FFAP 2720;;; FFAP
diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el
index 64b87d9e436..d84d57cad22 100644
--- a/lisp/progmodes/sql.el
+++ b/lisp/progmodes/sql.el
@@ -736,15 +736,15 @@ this variable is nil, that buffer is shown using
736 736
737(defvar sql-imenu-generic-expression 737(defvar sql-imenu-generic-expression
738 ;; Items are in reverse order because they are rendered in reverse. 738 ;; Items are in reverse order because they are rendered in reverse.
739 '(("Rules/Defaults" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*\\(rule\\|default\\)\\s-+\\(\\w+\\)" 3) 739 '(("Rules/Defaults" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*\\(?:rule\\|default\\)\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\s-+\\(\\w+\\)" 1)
740 ("Sequences" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*sequence\\s-+\\(\\w+\\)" 2) 740 ("Sequences" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*sequence\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1)
741 ("Triggers" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*trigger\\s-+\\(\\w+\\)" 2) 741 ("Triggers" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*trigger\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1)
742 ("Functions" "^\\s-*\\(create\\s-+\\(\\w+\\s-+\\)*\\)?function\\s-+\\(\\w+\\)" 3) 742 ("Functions" "^\\s-*\\(?:create\\s-+\\(?:\\w+\\s-+\\)*\\)?function\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1)
743 ("Procedures" "^\\s-*\\(create\\s-+\\(\\w+\\s-+\\)*\\)?proc\\(edure\\)?\\s-+\\(\\w+\\)" 4) 743 ("Procedures" "^\\s-*\\(?:create\\s-+\\(?:\\w+\\s-+\\)*\\)?proc\\(?:edure\\)?\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1)
744 ("Packages" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*package\\s-+\\(body\\s-+\\)?\\(\\w+\\)" 3) 744 ("Packages" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*package\\s-+\\(?:body\\s-+\\)?\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1)
745 ("Types" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*type\\s-+\\(body\\s-+\\)?\\(\\w+\\)" 3) 745 ("Types" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*type\\s-+\\(?:body\\s-+\\)?\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1)
746 ("Indexes" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*index\\s-+\\(\\w+\\)" 2) 746 ("Indexes" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*index\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1)
747 ("Tables/Views" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*\\(table\\|view\\)\\s-+\\(\\w+\\)" 3)) 747 ("Tables/Views" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*\\(?:table\\|view\\)\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1))
748 "Define interesting points in the SQL buffer for `imenu'. 748 "Define interesting points in the SQL buffer for `imenu'.
749 749
750This is used to set `imenu-generic-expression' when SQL mode is 750This is used to set `imenu-generic-expression' when SQL mode is
@@ -1339,6 +1339,7 @@ Based on `comint-mode-map'.")
1339 "\\(?:\\w+\\s-+\\)*" ;; optional intervening keywords 1339 "\\(?:\\w+\\s-+\\)*" ;; optional intervening keywords
1340 "\\(?:table\\|view\\|\\(?:package\\|type\\)\\(?:\\s-+body\\)?\\|proc\\(?:edure\\)?" 1340 "\\(?:table\\|view\\|\\(?:package\\|type\\)\\(?:\\s-+body\\)?\\|proc\\(?:edure\\)?"
1341 "\\|function\\|trigger\\|sequence\\|rule\\|default\\)\\s-+" 1341 "\\|function\\|trigger\\|sequence\\|rule\\|default\\)\\s-+"
1342 "\\(?:if\\s-+not\\s-+exists\\s-+\\)?" ;; IF NOT EXISTS
1342 "\\(\\w+\\)") 1343 "\\(\\w+\\)")
1343 1 'font-lock-function-name-face)) 1344 1 'font-lock-function-name-face))
1344 1345
diff --git a/lisp/ps-bdf.el b/lisp/ps-bdf.el
index a82e03ceda7..477aee1b2da 100644
--- a/lisp/ps-bdf.el
+++ b/lisp/ps-bdf.el
@@ -70,20 +70,15 @@ for BDFNAME."
70 70
71(defsubst bdf-file-mod-time (filename) 71(defsubst bdf-file-mod-time (filename)
72 "Return modification time of FILENAME. 72 "Return modification time of FILENAME.
73The value is a list of two integers, the first integer has high-order 73The value is a list of integers in the same format as `current-time'."
7416 bits, the second has low 16 bits."
75 (nth 5 (file-attributes filename))) 74 (nth 5 (file-attributes filename)))
76 75
77(defun bdf-file-newer-than-time (filename mod-time) 76(defun bdf-file-newer-than-time (filename mod-time)
78 "Return non-nil if and only if FILENAME is newer than MOD-TIME. 77 "Return non-nil if and only if FILENAME is newer than MOD-TIME.
79MOD-TIME is a modification time as a list of two integers, the first 78MOD-TIME is a modification time as a list of integers in the same
80integer has high-order 16 bits, the second has low 16 bits." 79format as `current-time'."
81 (let* ((new-mod-time (bdf-file-mod-time filename)) 80 (let ((new-mod-time (bdf-file-mod-time filename)))
82 (new-time (car new-mod-time)) 81 (time-less-p mod-time new-mod-time)))
83 (time (car mod-time)))
84 (or (> new-time time)
85 (and (= new-time time)
86 (> (nth 1 new-mod-time) (nth 1 mod-time))))))
87 82
88(defun bdf-find-file (bdfname) 83(defun bdf-find-file (bdfname)
89 "Return a buffer visiting a bdf file BDFNAME. 84 "Return a buffer visiting a bdf file BDFNAME.
@@ -178,8 +173,8 @@ FONT-INFO is a list of the following format:
178 (BDFFILE MOD-TIME FONT-BOUNDING-BOX 173 (BDFFILE MOD-TIME FONT-BOUNDING-BOX
179 RELATIVE-COMPOSE BASELINE-OFFSET CODE-RANGE MAXLEN OFFSET-VECTOR) 174 RELATIVE-COMPOSE BASELINE-OFFSET CODE-RANGE MAXLEN OFFSET-VECTOR)
180 175
181MOD-TIME is last modification time as a list of two integers, the 176MOD-TIME is last modification time as a list of integers in the
182first integer has high-order 16 bits, the second has low 16 bits. 177same format as `current-time'.
183 178
184SIZE is a size of the font on 72 dpi device. This value is got 179SIZE is a size of the font on 72 dpi device. This value is got
185from SIZE record of the font. 180from SIZE record of the font.
diff --git a/lisp/simple.el b/lisp/simple.el
index aed945d6e13..5867561da26 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -4583,6 +4583,9 @@ lines."
4583 (unless (and auto-window-vscroll try-vscroll 4583 (unless (and auto-window-vscroll try-vscroll
4584 ;; Only vscroll for single line moves 4584 ;; Only vscroll for single line moves
4585 (= (abs arg) 1) 4585 (= (abs arg) 1)
4586 ;; Under scroll-conservatively, the display engine
4587 ;; does this better.
4588 (zerop scroll-conservatively)
4586 ;; But don't vscroll in a keyboard macro. 4589 ;; But don't vscroll in a keyboard macro.
4587 (not defining-kbd-macro) 4590 (not defining-kbd-macro)
4588 (not executing-kbd-macro) 4591 (not executing-kbd-macro)
diff --git a/lisp/subr.el b/lisp/subr.el
index 8410897fd6f..c0479d35987 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -1191,8 +1191,6 @@ is converted into a string by expressing it in decimal."
1191(make-obsolete 'unfocus-frame "it does nothing." "22.1") 1191(make-obsolete 'unfocus-frame "it does nothing." "22.1")
1192(make-obsolete 'make-variable-frame-local 1192(make-obsolete 'make-variable-frame-local
1193 "explicitly check for a frame-parameter instead." "22.2") 1193 "explicitly check for a frame-parameter instead." "22.2")
1194(make-obsolete 'interactive-p 'called-interactively-p "23.2")
1195(set-advertised-calling-convention 'called-interactively-p '(kind) "23.1")
1196(set-advertised-calling-convention 1194(set-advertised-calling-convention
1197 'all-completions '(string collection &optional predicate) "23.1") 1195 'all-completions '(string collection &optional predicate) "23.1")
1198(set-advertised-calling-convention 'unintern '(name obarray) "23.3") 1196(set-advertised-calling-convention 'unintern '(name obarray) "23.3")
@@ -3963,6 +3961,152 @@ The properties used on SYMBOL are `composefunc', `sendfunc',
3963 (put symbol 'abortfunc (or abortfunc 'kill-buffer)) 3961 (put symbol 'abortfunc (or abortfunc 'kill-buffer))
3964 (put symbol 'hookvar (or hookvar 'mail-send-hook))) 3962 (put symbol 'hookvar (or hookvar 'mail-send-hook)))
3965 3963
3964(defvar called-interactively-p-functions nil
3965 "Special hook called to skip special frames in `called-interactively-p'.
3966The functions are called with 3 arguments: (I FRAME1 FRAME2),
3967where FRAME1 is a \"current frame\", FRAME2 is the next frame,
3968I is the index of the frame after FRAME2. It should return nil
3969if those frames don't seem special and otherwise, it should return
3970the number of frames to skip (minus 1).")
3971
3972(defmacro internal--called-interactively-p--get-frame (n)
3973 ;; `sym' will hold a global variable, which will be used kind of like C's
3974 ;; "static" variables.
3975 (let ((sym (make-symbol "base-index")))
3976 `(progn
3977 (defvar ,sym
3978 (let ((i 1))
3979 (while (not (eq (nth 1 (backtrace-frame i))
3980 'called-interactively-p))
3981 (setq i (1+ i)))
3982 i))
3983 ;; (unless (eq (nth 1 (backtrace-frame ,sym)) 'called-interactively-p)
3984 ;; (error "called-interactively-p: %s is out-of-sync!" ,sym))
3985 (backtrace-frame (+ ,sym ,n)))))
3986
3987(defun called-interactively-p (&optional kind)
3988 "Return t if the containing function was called by `call-interactively'.
3989If KIND is `interactive', then only return t if the call was made
3990interactively by the user, i.e. not in `noninteractive' mode nor
3991when `executing-kbd-macro'.
3992If KIND is `any', on the other hand, it will return t for any kind of
3993interactive call, including being called as the binding of a key or
3994from a keyboard macro, even in `noninteractive' mode.
3995
3996This function is very brittle, it may fail to return the intended result when
3997the code is debugged, advised, or instrumented in some form. Some macros and
3998special forms (such as `condition-case') may also sometimes wrap their bodies
3999in a `lambda', so any call to `called-interactively-p' from those bodies will
4000indicate whether that lambda (rather than the surrounding function) was called
4001interactively.
4002
4003Instead of using this function, it is cleaner and more reliable to give your
4004function an extra optional argument whose `interactive' spec specifies
4005non-nil unconditionally (\"p\" is a good way to do this), or via
4006\(not (or executing-kbd-macro noninteractive)).
4007
4008The only known proper use of `interactive' for KIND is in deciding
4009whether to display a helpful message, or how to display it. If you're
4010thinking of using it for any other purpose, it is quite likely that
4011you're making a mistake. Think: what do you want to do when the
4012command is called from a keyboard macro?"
4013 (declare (advertised-calling-convention (kind) "23.1"))
4014 (when (not (and (eq kind 'interactive)
4015 (or executing-kbd-macro noninteractive)))
4016 (let* ((i 1) ;; 0 is the called-interactively-p frame.
4017 frame nextframe
4018 (get-next-frame
4019 (lambda ()
4020 (setq frame nextframe)
4021 (setq nextframe (internal--called-interactively-p--get-frame i))
4022 ;; (message "Frame %d = %S" i nextframe)
4023 (setq i (1+ i)))))
4024 (funcall get-next-frame) ;; Get the first frame.
4025 (while
4026 ;; FIXME: The edebug and advice handling should be made modular and
4027 ;; provided directly by edebug.el and nadvice.el.
4028 (progn
4029 ;; frame =(backtrace-frame i-2)
4030 ;; nextframe=(backtrace-frame i-1)
4031 (funcall get-next-frame)
4032 ;; `pcase' would be a fairly good fit here, but it sometimes moves
4033 ;; branches within local functions, which then messes up the
4034 ;; `backtrace-frame' data we get,
4035 (or
4036 ;; Skip special forms (from non-compiled code).
4037 (and frame (null (car frame)))
4038 ;; Skip also `interactive-p' (because we don't want to know if
4039 ;; interactive-p was called interactively but if it's caller was)
4040 ;; and `byte-code' (idem; this appears in subexpressions of things
4041 ;; like condition-case, which are wrapped in a separate bytecode
4042 ;; chunk).
4043 ;; FIXME: For lexical-binding code, this is much worse,
4044 ;; because the frames look like "byte-code -> funcall -> #[...]",
4045 ;; which is not a reliable signature.
4046 (memq (nth 1 frame) '(interactive-p 'byte-code))
4047 ;; Skip package-specific stack-frames.
4048 (let ((skip (run-hook-with-args-until-success
4049 'called-interactively-p-functions
4050 i frame nextframe)))
4051 (pcase skip
4052 (`nil nil)
4053 (`0 t)
4054 (_ (setq i (+ i skip -1)) (funcall get-next-frame)))))))
4055 ;; Now `frame' should be "the function from which we were called".
4056 (pcase (cons frame nextframe)
4057 ;; No subr calls `interactive-p', so we can rule that out.
4058 (`((,_ ,(pred (lambda (f) (subrp (indirect-function f)))) . ,_) . ,_) nil)
4059 ;; Somehow, I sometimes got `command-execute' rather than
4060 ;; `call-interactively' on my stacktrace !?
4061 ;;(`(,_ . (t command-execute . ,_)) t)
4062 (`(,_ . (t call-interactively . ,_)) t)))))
4063
4064(defun interactive-p ()
4065 "Return t if the containing function was run directly by user input.
4066This means that the function was called with `call-interactively'
4067\(which includes being called as the binding of a key)
4068and input is currently coming from the keyboard (not a keyboard macro),
4069and Emacs is not running in batch mode (`noninteractive' is nil).
4070
4071The only known proper use of `interactive-p' is in deciding whether to
4072display a helpful message, or how to display it. If you're thinking
4073of using it for any other purpose, it is quite likely that you're
4074making a mistake. Think: what do you want to do when the command is
4075called from a keyboard macro or in batch mode?
4076
4077To test whether your function was called with `call-interactively',
4078either (i) add an extra optional argument and give it an `interactive'
4079spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
4080use `called-interactively-p'."
4081 (declare (obsolete called-interactively-p "23.2"))
4082 (called-interactively-p 'interactive))
4083
4084(defun function-arity (f &optional num)
4085 "Return the (MIN . MAX) arity of F.
4086If the maximum arity is infinite, MAX is `many'.
4087F can be a function or a macro.
4088If NUM is non-nil, return non-nil iff F can be called with NUM args."
4089 (if (symbolp f) (setq f (indirect-function f)))
4090 (if (eq (car-safe f) 'macro) (setq f (cdr f)))
4091 (let ((res
4092 (if (subrp f)
4093 (let ((x (subr-arity f)))
4094 (if (eq (cdr x) 'unevalled) (cons (car x) 'many)))
4095 (let* ((args (if (consp f) (cadr f) (aref f 0)))
4096 (max (length args))
4097 (opt (memq '&optional args))
4098 (rest (memq '&rest args))
4099 (min (- max (length opt))))
4100 (if opt
4101 (cons min (if rest 'many (1- max)))
4102 (if rest
4103 (cons (- max (length rest)) 'many)
4104 (cons min max)))))))
4105 (if (not num)
4106 res
4107 (and (>= num (car res))
4108 (or (eq 'many (cdr res)) (<= num (cdr res)))))))
4109
3966(defun set-temporary-overlay-map (map &optional keep-pred) 4110(defun set-temporary-overlay-map (map &optional keep-pred)
3967 "Set MAP as a temporary keymap taking precedence over most other keymaps. 4111 "Set MAP as a temporary keymap taking precedence over most other keymaps.
3968Note that this does NOT take precedence over the \"overriding\" maps 4112Note that this does NOT take precedence over the \"overriding\" maps
diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el
index 42e09b65750..95dab10101b 100644
--- a/lisp/term/w32-win.el
+++ b/lisp/term/w32-win.el
@@ -91,7 +91,7 @@
91(declare-function w32-send-sys-command "w32fns.c") 91(declare-function w32-send-sys-command "w32fns.c")
92(declare-function set-message-beep "w32fns.c") 92(declare-function set-message-beep "w32fns.c")
93 93
94(declare-function cygwin-convert-path-from-windows "cygw32.c" 94(declare-function cygwin-convert-file-name-from-windows "cygw32.c"
95 (path &optional absolute_p)) 95 (path &optional absolute_p))
96 96
97;; Conditional on new-fontset so bootstrapping works on non-GUI compiles 97;; Conditional on new-fontset so bootstrapping works on non-GUI compiles
@@ -108,7 +108,7 @@
108 108
109(defun w32-handle-dropped-file (window file-name) 109(defun w32-handle-dropped-file (window file-name)
110 (let ((f (if (eq system-type 'cygwin) 110 (let ((f (if (eq system-type 'cygwin)
111 (cygwin-convert-path-from-windows file-name t) 111 (cygwin-convert-file-name-from-windows file-name t)
112 (subst-char-in-string ?\\ ?/ file-name))) 112 (subst-char-in-string ?\\ ?/ file-name)))
113 (coding (or file-name-coding-system 113 (coding (or file-name-coding-system
114 default-file-name-coding-system))) 114 default-file-name-coding-system)))
diff --git a/lisp/textmodes/table.el b/lisp/textmodes/table.el
index 3d9f88a43c9..6db15b7ec2a 100644
--- a/lisp/textmodes/table.el
+++ b/lisp/textmodes/table.el
@@ -5210,7 +5210,7 @@ instead of the current buffer and returns the OBJECT."
5210 "Update cell face according to the current mode." 5210 "Update cell face according to the current mode."
5211 (if (featurep 'xemacs) 5211 (if (featurep 'xemacs)
5212 (set-face-property 'table-cell 'underline table-fixed-width-mode) 5212 (set-face-property 'table-cell 'underline table-fixed-width-mode)
5213 (set-face-inverse-video-p 'table-cell table-fixed-width-mode))) 5213 (set-face-inverse-video 'table-cell table-fixed-width-mode)))
5214 5214
5215(table--update-cell-face) 5215(table--update-cell-face)
5216 5216
diff --git a/lisp/uniquify.el b/lisp/uniquify.el
index 3619d499419..2b4794c9cc2 100644
--- a/lisp/uniquify.el
+++ b/lisp/uniquify.el
@@ -183,10 +183,9 @@ contains the name of the directory which the buffer is visiting.")
183;; Internal variables used free 183;; Internal variables used free
184(defvar uniquify-possibly-resolvable nil) 184(defvar uniquify-possibly-resolvable nil)
185 185
186(defvar uniquify-managed nil 186(defvar-local uniquify-managed nil
187 "Non-nil if the name of this buffer is managed by uniquify. 187 "Non-nil if the name of this buffer is managed by uniquify.
188It actually holds the list of `uniquify-item's corresponding to the conflict.") 188It actually holds the list of `uniquify-item's corresponding to the conflict.")
189(make-variable-buffer-local 'uniquify-managed)
190(put 'uniquify-managed 'permanent-local t) 189(put 'uniquify-managed 'permanent-local t)
191 190
192;; Used in desktop.el to save the non-uniquified buffer name 191;; Used in desktop.el to save the non-uniquified buffer name
@@ -464,27 +463,34 @@ For use on `kill-buffer-hook'."
464;; rename-buffer and create-file-buffer. (Setting find-file-hook isn't 463;; rename-buffer and create-file-buffer. (Setting find-file-hook isn't
465;; sufficient.) 464;; sufficient.)
466 465
467(defadvice rename-buffer (after rename-buffer-uniquify activate) 466(advice-add 'rename-buffer :around #'uniquify--rename-buffer-advice)
467(defun uniquify--rename-buffer-advice (rb-fun newname &optional unique &rest args)
468 "Uniquify buffer names with parts of directory name." 468 "Uniquify buffer names with parts of directory name."
469 (let ((retval (apply rb-fun newname unique args)))
469 (uniquify-maybe-rerationalize-w/o-cb) 470 (uniquify-maybe-rerationalize-w/o-cb)
470 (if (null (ad-get-arg 1)) ; no UNIQUE argument. 471 (if (null unique)
471 ;; Mark this buffer so it won't be renamed by uniquify. 472 ;; Mark this buffer so it won't be renamed by uniquify.
472 (setq uniquify-managed nil) 473 (setq uniquify-managed nil)
473 (when uniquify-buffer-name-style 474 (when uniquify-buffer-name-style
474 ;; Rerationalize w.r.t the new name. 475 ;; Rerationalize w.r.t the new name.
475 (uniquify-rationalize-file-buffer-names 476 (uniquify-rationalize-file-buffer-names
476 (ad-get-arg 0) 477 newname
477 (uniquify-buffer-file-name (current-buffer)) 478 (uniquify-buffer-file-name (current-buffer))
478 (current-buffer)) 479 (current-buffer))
479 (setq ad-return-value (buffer-name (current-buffer)))))) 480 (setq retval (buffer-name (current-buffer)))))
481 retval))
480 482
481(defadvice create-file-buffer (after create-file-buffer-uniquify activate) 483
484(advice-add 'create-file-buffer :around #'uniquify--create-file-buffer-advice)
485(defun uniquify--create-file-buffer-advice (cfb-fun filename &rest args)
482 "Uniquify buffer names with parts of directory name." 486 "Uniquify buffer names with parts of directory name."
487 (let ((retval (apply cfb-fun filename args)))
483 (if uniquify-buffer-name-style 488 (if uniquify-buffer-name-style
484 (let ((filename (expand-file-name (directory-file-name (ad-get-arg 0))))) 489 (let ((filename (expand-file-name (directory-file-name filename))))
485 (uniquify-rationalize-file-buffer-names 490 (uniquify-rationalize-file-buffer-names
486 (file-name-nondirectory filename) 491 (file-name-nondirectory filename)
487 (file-name-directory filename) ad-return-value)))) 492 (file-name-directory filename) retval)))
493 retval))
488 494
489;;; The End 495;;; The End
490 496
@@ -496,9 +502,8 @@ For use on `kill-buffer-hook'."
496 (set-buffer buf) 502 (set-buffer buf)
497 (when uniquify-managed 503 (when uniquify-managed
498 (push (cons buf (uniquify-item-base (car uniquify-managed))) buffers))) 504 (push (cons buf (uniquify-item-base (car uniquify-managed))) buffers)))
499 (dolist (fun '(rename-buffer create-file-buffer)) 505 (advice-remove 'rename-buffer #'uniquify--rename-buffer-advice)
500 (ad-remove-advice fun 'after (intern (concat (symbol-name fun) "-uniquify"))) 506 (advice-remove 'create-file-buffer #'uniquify--create-file-buffer-advice)
501 (ad-update fun))
502 (dolist (buf buffers) 507 (dolist (buf buffers)
503 (set-buffer (car buf)) 508 (set-buffer (car buf))
504 (rename-buffer (cdr buf) t)))) 509 (rename-buffer (cdr buf) t))))
diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el
index 26c64ce2ad3..0c023b0f7f4 100644
--- a/lisp/vc/diff-mode.el
+++ b/lisp/vc/diff-mode.el
@@ -575,19 +575,21 @@ next hunk if TRY-HARDER is non-nil; otherwise signal an error."
575(easy-mmode-define-navigation 575(easy-mmode-define-navigation
576 diff-hunk diff-hunk-header-re "hunk" diff-end-of-hunk diff-restrict-view 576 diff-hunk diff-hunk-header-re "hunk" diff-end-of-hunk diff-restrict-view
577 (when diff-auto-refine-mode 577 (when diff-auto-refine-mode
578 (setq diff--auto-refine-data (cons (current-buffer) (point-marker))) 578 (unless (prog1 diff--auto-refine-data
579 (run-at-time 0.0 nil 579 (setq diff--auto-refine-data
580 (lambda () 580 (cons (current-buffer) (point-marker))))
581 (when diff--auto-refine-data 581 (run-at-time 0.0 nil
582 (let ((buffer (car diff--auto-refine-data)) 582 (lambda ()
583 (point (cdr diff--auto-refine-data))) 583 (when diff--auto-refine-data
584 (setq diff--auto-refine-data nil) 584 (let ((buffer (car diff--auto-refine-data))
585 (with-local-quit 585 (point (cdr diff--auto-refine-data)))
586 (when (buffer-live-p buffer) 586 (setq diff--auto-refine-data nil)
587 (with-current-buffer buffer 587 (with-local-quit
588 (save-excursion 588 (when (buffer-live-p buffer)
589 (goto-char point) 589 (with-current-buffer buffer
590 (diff-refine-hunk))))))))))) 590 (save-excursion
591 (goto-char point)
592 (diff-refine-hunk))))))))))))
591 593
592(easy-mmode-define-navigation 594(easy-mmode-define-navigation
593 diff-file diff-file-header-re "file" diff-end-of-file) 595 diff-file diff-file-header-re "file" diff-end-of-file)
diff --git a/lisp/window.el b/lisp/window.el
index d378ea5ff14..52909fa9e5f 100644
--- a/lisp/window.el
+++ b/lisp/window.el
@@ -5870,7 +5870,12 @@ the selected window or never appeared in it before, or if
5870 :version "24.3") 5870 :version "24.3")
5871 5871
5872(defun switch-to-buffer (buffer-or-name &optional norecord force-same-window) 5872(defun switch-to-buffer (buffer-or-name &optional norecord force-same-window)
5873 "Switch to buffer BUFFER-OR-NAME in the selected window. 5873 "Display buffer BUFFER-OR-NAME in the selected window.
5874
5875WARNING: This is NOT the way to work on another buffer temporarily
5876within a Lisp program! Use `set-buffer' instead. That avoids
5877messing with the window-buffer correspondences.
5878
5874If the selected window cannot display the specified 5879If the selected window cannot display the specified
5875buffer (e.g. if it is a minibuffer window or strongly dedicated 5880buffer (e.g. if it is a minibuffer window or strongly dedicated
5876to another buffer), call `pop-to-buffer' to select the buffer in 5881to another buffer), call `pop-to-buffer' to select the buffer in