aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKenichi Handa2012-11-23 23:36:24 +0900
committerKenichi Handa2012-11-23 23:36:24 +0900
commit2aaec2d9be5cec44ea3b59cba476fd3e091f2fc9 (patch)
tree3711b97807201b7eeaa066003b1c3a4ce929e5bb
parente1d276cbf9e18f13101328f56bed1a1c0a66e63a (diff)
parente7d0e5ee247a155a268ffbf80bedbe25e15b5032 (diff)
downloademacs-2aaec2d9be5cec44ea3b59cba476fd3e091f2fc9.tar.gz
emacs-2aaec2d9be5cec44ea3b59cba476fd3e091f2fc9.zip
-rw-r--r--ChangeLog22
-rw-r--r--admin/CPP-DEFINES7
-rw-r--r--admin/ChangeLog12
-rw-r--r--admin/notes/copyright4
-rw-r--r--autogen/config.in15
-rwxr-xr-xautogen/configure65
-rw-r--r--configure.ac43
-rw-r--r--doc/emacs/ChangeLog6
-rw-r--r--doc/emacs/display.texi99
-rw-r--r--doc/lispref/ChangeLog22
-rw-r--r--doc/lispref/debugging.texi64
-rw-r--r--doc/lispref/display.texi47
-rw-r--r--doc/lispref/elisp.texi1
-rw-r--r--doc/lispref/os.texi4
-rw-r--r--doc/lispref/tips.texi14
-rw-r--r--doc/lispref/windows.texi3
-rw-r--r--doc/misc/ChangeLog16
-rw-r--r--doc/misc/calc.texi171
-rw-r--r--etc/ChangeLog4
-rw-r--r--etc/NEWS37
-rw-r--r--lib-src/ChangeLog23
-rw-r--r--lib-src/emacsclient.c27
-rw-r--r--lib-src/etags.c68
-rw-r--r--lib-src/movemail.c14
-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
-rw-r--r--nt/ChangeLog31
-rw-r--r--nt/config.nt6
-rw-r--r--nt/gmake.defs8
-rw-r--r--nt/inc/dirent.h (renamed from src/ndir.h)9
-rw-r--r--nt/inc/stdint.h3
-rw-r--r--nt/inc/sys/dir.h6
-rw-r--r--nt/inc/unistd.h11
-rw-r--r--nt/nmake.defs3
-rw-r--r--src/ChangeLog146
-rw-r--r--src/alloc.c12
-rw-r--r--src/bytecode.c4
-rw-r--r--src/cygw32.c20
-rw-r--r--src/data.c21
-rw-r--r--src/dired.c205
-rw-r--r--src/emacs.c2
-rw-r--r--src/eval.c132
-rw-r--r--src/fileio.c48
-rw-r--r--src/frame.h15
-rw-r--r--src/lisp.h6
-rw-r--r--src/lread.c3
-rw-r--r--src/makefile.w32-in10
-rw-r--r--src/msdos.c15
-rw-r--r--src/nsterm.m25
-rw-r--r--src/sysdep.c102
-rw-r--r--src/w32.c35
-rw-r--r--src/w32.h2
-rw-r--r--src/w32fns.c6
-rw-r--r--src/w32term.c17
-rw-r--r--src/w32term.h2
-rw-r--r--src/xdisp.c175
-rw-r--r--src/xftfont.c4
-rw-r--r--src/xterm.c18
-rw-r--r--test/ChangeLog15
-rw-r--r--test/automated/advice-tests.el129
-rw-r--r--test/automated/ert-tests.el132
-rw-r--r--test/automated/ert-x-tests.el50
114 files changed, 2592 insertions, 2005 deletions
diff --git a/ChangeLog b/ChangeLog
index 05e1a14d55d..03815e86ff8 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,25 @@
12012-11-23 Paul Eggert <eggert@cs.ucla.edu>
2
3 Assume POSIX 1003.1-1988 or later for dirent.h (Bug#12958).
4 * configure.ac: Do not check for dirent.h or closdir.
5
62012-11-21 Paul Eggert <eggert@cs.ucla.edu>
7
8 Assume POSIX 1003.1-1988 or later for unistd.h (Bug#12945).
9 * configure.ac: Do not check for getcwd or getwd.
10
112012-11-21 Glenn Morris <rgm@gnu.org>
12
13 * configure.ac (--enable-profiling): Doc fix.
14
152012-11-20 Paul Eggert <eggert@cs.ucla.edu>
16
17 Improve static checking of integer overflow and stack smashing.
18 * configure.ac (WARN_CFLAGS): Add -Wstack-protector
19 if using GCC 4.7.2 or later on a platform with
20 at least 64-bit long int. This improves static checking on these
21 platforms, when configured with --enable-gcc-warnings.
22
12012-11-17 Paul Eggert <eggert@cs.ucla.edu> 232012-11-17 Paul Eggert <eggert@cs.ucla.edu>
2 24
3 Assume POSIX 1003.1-1988 or later for fcntl.h (Bug#12881). 25 Assume POSIX 1003.1-1988 or later for fcntl.h (Bug#12881).
diff --git a/admin/CPP-DEFINES b/admin/CPP-DEFINES
index ae8673452a3..f4105f00c47 100644
--- a/admin/CPP-DEFINES
+++ b/admin/CPP-DEFINES
@@ -86,7 +86,6 @@ anymore, so they can be removed.
86AMPERSAND_FULL_NAME 86AMPERSAND_FULL_NAME
87BROKEN_DATAGRAM_SOCKETS 87BROKEN_DATAGRAM_SOCKETS
88BROKEN_FIONREAD 88BROKEN_FIONREAD
89BROKEN_GETWD
90BROKEN_GET_CURRENT_DIR_NAME 89BROKEN_GET_CURRENT_DIR_NAME
91BROKEN_NON_BLOCKING_CONNECT 90BROKEN_NON_BLOCKING_CONNECT
92BROKEN_PTY_READ_AFTER_EAGAIN 91BROKEN_PTY_READ_AFTER_EAGAIN
@@ -119,7 +118,6 @@ HAVE_CFMAKERAW
119HAVE_CFSETSPEED 118HAVE_CFSETSPEED
120HAVE_CLOCK_GETTIME 119HAVE_CLOCK_GETTIME
121HAVE_CLOCK_SETTIME 120HAVE_CLOCK_SETTIME
122HAVE_CLOSEDIR
123HAVE_COFF_H 121HAVE_COFF_H
124HAVE_COM_ERR_H 122HAVE_COM_ERR_H
125HAVE_COPYSIGN 123HAVE_COPYSIGN
@@ -144,7 +142,6 @@ HAVE_DES_H
144HAVE_DEV_PTMX 142HAVE_DEV_PTMX
145HAVE_DIALOGS 143HAVE_DIALOGS
146HAVE_DIFFTIME 144HAVE_DIFFTIME
147HAVE_DIRENT_H
148HAVE_DUP2 145HAVE_DUP2
149HAVE_ENDGRENT 146HAVE_ENDGRENT
150HAVE_ENDPWENT 147HAVE_ENDPWENT
@@ -161,7 +158,6 @@ HAVE_FUTIMESAT
161HAVE_GAI_STRERROR 158HAVE_GAI_STRERROR
162HAVE_GCONF 159HAVE_GCONF
163HAVE_GETADDRINFO 160HAVE_GETADDRINFO
164HAVE_GETCWD
165HAVE_GETDELIM 161HAVE_GETDELIM
166HAVE_GETGRENT 162HAVE_GETGRENT
167HAVE_GETHOSTNAME 163HAVE_GETHOSTNAME
@@ -178,7 +174,6 @@ HAVE_GETRLIMIT
178HAVE_GETRUSAGE 174HAVE_GETRUSAGE
179HAVE_GETSOCKNAME 175HAVE_GETSOCKNAME
180HAVE_GETTIMEOFDAY 176HAVE_GETTIMEOFDAY
181HAVE_GETWD
182HAVE_GET_CURRENT_DIR_NAME 177HAVE_GET_CURRENT_DIR_NAME
183HAVE_GHOSTSCRIPT 178HAVE_GHOSTSCRIPT
184HAVE_GIF 179HAVE_GIF
@@ -304,7 +299,6 @@ HAVE_SIGNED_SIG_ATOMIC_T
304HAVE_SIGNED_WCHAR_T 299HAVE_SIGNED_WCHAR_T
305HAVE_SIGNED_WINT_T 300HAVE_SIGNED_WINT_T
306HAVE_SIGSET_T 301HAVE_SIGSET_T
307HAVE_SIZE_T
308HAVE_SNPRINTF 302HAVE_SNPRINTF
309HAVE_SOCKETS 303HAVE_SOCKETS
310HAVE_SOUND 304HAVE_SOUND
@@ -369,7 +363,6 @@ HAVE_TM_ZONE
369HAVE_TOUCHLOCK 363HAVE_TOUCHLOCK
370HAVE_TZNAME 364HAVE_TZNAME
371HAVE_TZSET 365HAVE_TZSET
372HAVE_UNISTD_H
373HAVE_UNSIGNED_LONG_LONG_INT 366HAVE_UNSIGNED_LONG_LONG_INT
374HAVE_UTIL_H 367HAVE_UTIL_H
375HAVE_UTIMENSAT 368HAVE_UTIMENSAT
diff --git a/admin/ChangeLog b/admin/ChangeLog
index 3d76f9dd2ba..fe75ae57a6d 100644
--- a/admin/ChangeLog
+++ b/admin/ChangeLog
@@ -1,3 +1,15 @@
12012-11-23 Paul Eggert <eggert@cs.ucla.edu>
2
3 Assume POSIX 1003.1-1988 or later for dirent.h (Bug#12958).
4 * CPP-DEFINES (HAVE_CLOSEDIR, HAVE_DIRENT_H): Remove.
5 * notes/copyright: Adjust to src/ndir.h -> nt/inc/dirent.h renaming.
6
72012-11-21 Paul Eggert <eggert@cs.ucla.edu>
8
9 Assume POSIX 1003.1-1988 or later for unistd.h (Bug#12945).
10 * CPP-DEFINES (BROKEN_GETWD, HAVE_GETCWD, HAVE_GETWD, HAVE_SIZE_T)
11 (HAVE_UNISTD_H): Remove.
12
12012-11-17 Paul Eggert <eggert@cs.ucla.edu> 132012-11-17 Paul Eggert <eggert@cs.ucla.edu>
2 14
3 Assume POSIX 1003.1-1988 or later for fcntl.h (Bug#12881). 15 Assume POSIX 1003.1-1988 or later for fcntl.h (Bug#12881).
diff --git a/admin/notes/copyright b/admin/notes/copyright
index 72b7d7e2d23..173ff83343a 100644
--- a/admin/notes/copyright
+++ b/admin/notes/copyright
@@ -380,7 +380,7 @@ Makefile.in does now.
380src/gmalloc.c 380src/gmalloc.c
381 - contains numerous copyrights from the GNU C library. Leave them alone. 381 - contains numerous copyrights from the GNU C library. Leave them alone.
382 382
383src/ndir.h 383nt/inc/dirent.h
384 - see comments below. This file is OK to be released with Emacs 384 - see comments below. This file is OK to be released with Emacs
385 22, but we may want to revisit it afterwards. 385 22, but we may want to revisit it afterwards.
386 386
@@ -429,7 +429,7 @@ admin/check-doc-strings
429 File says it's in the public domain, but that might not make it so. 429 File says it's in the public domain, but that might not make it so.
430 430
431etc/e/eterm-color.ti 431etc/e/eterm-color.ti
432src/ndir.h 432nt/inc/dirent.h
433 On legal advice from Matt Norwood, the following comment was added 433 On legal advice from Matt Norwood, the following comment was added
434 to these files in Feb/Mar 2007: 434 to these files in Feb/Mar 2007:
435 435
diff --git a/autogen/config.in b/autogen/config.in
index 9f664063761..c0fb1f34bf4 100644
--- a/autogen/config.in
+++ b/autogen/config.in
@@ -50,9 +50,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
50/* Define to the number of bits in type 'wint_t'. */ 50/* Define to the number of bits in type 'wint_t'. */
51#undef BITSIZEOF_WINT_T 51#undef BITSIZEOF_WINT_T
52 52
53/* Define if getwd should not be used. */
54#undef BROKEN_GETWD
55
56/* Define if get_current_dir_name should not be used. */ 53/* Define if get_current_dir_name should not be used. */
57#undef BROKEN_GET_CURRENT_DIR_NAME 54#undef BROKEN_GET_CURRENT_DIR_NAME
58 55
@@ -256,9 +253,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
256/* Define to 1 if you have the `clock_settime' function. */ 253/* Define to 1 if you have the `clock_settime' function. */
257#undef HAVE_CLOCK_SETTIME 254#undef HAVE_CLOCK_SETTIME
258 255
259/* Define to 1 if you have the `closedir' function. */
260#undef HAVE_CLOSEDIR
261
262/* Define to 1 if you have the <coff.h> header file. */ 256/* Define to 1 if you have the <coff.h> header file. */
263#undef HAVE_COFF_H 257#undef HAVE_COFF_H
264 258
@@ -342,9 +336,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
342/* Define to 1 if you have the `difftime' function. */ 336/* Define to 1 if you have the `difftime' function. */
343#undef HAVE_DIFFTIME 337#undef HAVE_DIFFTIME
344 338
345/* Define to 1 if you have the <dirent.h> header file. */
346#undef HAVE_DIRENT_H
347
348/* Define to 1 if you have the 'dup2' function. */ 339/* Define to 1 if you have the 'dup2' function. */
349#undef HAVE_DUP2 340#undef HAVE_DUP2
350 341
@@ -402,9 +393,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
402/* Define to 1 if you have the `getaddrinfo' function. */ 393/* Define to 1 if you have the `getaddrinfo' function. */
403#undef HAVE_GETADDRINFO 394#undef HAVE_GETADDRINFO
404 395
405/* Define to 1 if you have the `getcwd' function. */
406#undef HAVE_GETCWD
407
408/* Define to 1 if you have the `getdelim' function. */ 396/* Define to 1 if you have the `getdelim' function. */
409#undef HAVE_GETDELIM 397#undef HAVE_GETDELIM
410 398
@@ -453,9 +441,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
453/* Define to 1 if you have the `gettimeofday' function. */ 441/* Define to 1 if you have the `gettimeofday' function. */
454#undef HAVE_GETTIMEOFDAY 442#undef HAVE_GETTIMEOFDAY
455 443
456/* Define to 1 if you have the `getwd' function. */
457#undef HAVE_GETWD
458
459/* Define to 1 if you have the `get_current_dir_name' function. */ 444/* Define to 1 if you have the `get_current_dir_name' function. */
460#undef HAVE_GET_CURRENT_DIR_NAME 445#undef HAVE_GET_CURRENT_DIR_NAME
461 446
diff --git a/autogen/configure b/autogen/configure
index afcf9a73fa6..fbb2efbc860 100755
--- a/autogen/configure
+++ b/autogen/configure
@@ -2058,8 +2058,9 @@ Optional Features:
2058 enable compile time checks for the Lisp_Object data 2058 enable compile time checks for the Lisp_Object data
2059 type. This is useful for development for catching 2059 type. This is useful for development for catching
2060 certain types of bugs. 2060 certain types of bugs.
2061 --enable-profiling build emacs with profiling support. This might not 2061 --enable-profiling build emacs with low-level, gprof profiling support.
2062 work on all platforms 2062 Mainly useful for debugging Emacs itself. May not
2063 work on all platforms. Stops profiler.el working.
2063 --enable-autodepend automatically generate dependencies to .h-files. 2064 --enable-autodepend automatically generate dependencies to .h-files.
2064 Requires GNU Make and Gcc. Enabled if GNU Make and 2065 Requires GNU Make and Gcc. Enabled if GNU Make and
2065 Gcc is found 2066 Gcc is found
@@ -3213,7 +3214,6 @@ as_fn_append ac_header_list " sys/resource.h"
3213as_fn_append ac_header_list " sys/utsname.h" 3214as_fn_append ac_header_list " sys/utsname.h"
3214as_fn_append ac_header_list " pwd.h" 3215as_fn_append ac_header_list " pwd.h"
3215as_fn_append ac_header_list " utmp.h" 3216as_fn_append ac_header_list " utmp.h"
3216as_fn_append ac_header_list " dirent.h"
3217as_fn_append ac_header_list " util.h" 3217as_fn_append ac_header_list " util.h"
3218as_fn_append ac_header_list " sys/socket.h" 3218as_fn_append ac_header_list " sys/socket.h"
3219as_fn_append ac_header_list " stdlib.h" 3219as_fn_append ac_header_list " stdlib.h"
@@ -7257,6 +7257,8 @@ fi
7257 nw="$nw -Wfloat-equal" # warns about high-quality code 7257 nw="$nw -Wfloat-equal" # warns about high-quality code
7258 nw="$nw -Winline" # OK to ignore 'inline' 7258 nw="$nw -Winline" # OK to ignore 'inline'
7259 nw="$nw -Wjump-misses-init" # We sometimes safely jump over init. 7259 nw="$nw -Wjump-misses-init" # We sometimes safely jump over init.
7260 nw="$nw -Wstrict-overflow" # OK to optimize assuming that
7261 # signed overflow has undefined behavior
7260 nw="$nw -Wsync-nand" # irrelevant here, and provokes ObjC warning 7262 nw="$nw -Wsync-nand" # irrelevant here, and provokes ObjC warning
7261 nw="$nw -Wunsafe-loop-optimizations" # OK to suppress unsafe optimizations 7263 nw="$nw -Wunsafe-loop-optimizations" # OK to suppress unsafe optimizations
7262 7264
@@ -7264,11 +7266,38 @@ fi
7264 # <http://lists.gnu.org/archive/html/emacs-diffs/2011-11/msg00265.html>. 7266 # <http://lists.gnu.org/archive/html/emacs-diffs/2011-11/msg00265.html>.
7265 nw="$nw -Wshadow" 7267 nw="$nw -Wshadow"
7266 7268
7267 # The following lines should be removable at some point. 7269 # The following line should be removable at some point.
7268 nw="$nw -Wstack-protector"
7269 nw="$nw -Wstrict-overflow"
7270 nw="$nw -Wsuggest-attribute=pure" 7270 nw="$nw -Wsuggest-attribute=pure"
7271 7271
7272 { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to use -Wstack-protector" >&5
7273$as_echo_n "checking whether to use -Wstack-protector... " >&6; }
7274 cat confdefs.h - <<_ACEOF >conftest.$ac_ext
7275/* end confdefs.h. */
7276#if (1 <= __LONG_MAX__ >> 31 >> 31 \
7277 && 4 < __GNUC__ + (7 < __GNUC_MINOR__ + (2 <= __GNUC_PATCHLEVEL__)))
7278 /* OK */
7279 #else
7280 #error "Not GCC, or GCC before 4.7.2, or 'long int' has < 64 bits."
7281 #endif
7282
7283int
7284main ()
7285{
7286
7287 ;
7288 return 0;
7289}
7290_ACEOF
7291if ac_fn_c_try_cpp "$LINENO"; then :
7292 { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
7293$as_echo "yes" >&6; }
7294else
7295 { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
7296$as_echo "no" >&6; }
7297 nw="$nw -Wstack-protector"
7298fi
7299rm -f conftest.err conftest.$ac_ext
7300
7272 7301
7273 7302
7274 if test -n "$GCC"; then 7303 if test -n "$GCC"; then
@@ -8779,8 +8808,6 @@ done
8779 8808
8780 8809
8781 8810
8782
8783
8784{ $as_echo "$as_me:${as_lineno-$LINENO}: checking if personality LINUX32 can be set" >&5 8811{ $as_echo "$as_me:${as_lineno-$LINENO}: checking if personality LINUX32 can be set" >&5
8785$as_echo_n "checking if personality LINUX32 can be set... " >&6; } 8812$as_echo_n "checking if personality LINUX32 can be set... " >&6; }
8786cat confdefs.h - <<_ACEOF >conftest.$ac_ext 8813cat confdefs.h - <<_ACEOF >conftest.$ac_ext
@@ -13444,10 +13471,10 @@ esac
13444 13471
13445 13472
13446for ac_func in gethostname \ 13473for ac_func in gethostname \
13447closedir getrusage get_current_dir_name \ 13474getrusage get_current_dir_name \
13448lrand48 \ 13475lrand48 \
13449select getpagesize setlocale \ 13476select getpagesize setlocale \
13450utimes getrlimit setrlimit getcwd shutdown getaddrinfo \ 13477utimes getrlimit setrlimit shutdown getaddrinfo \
13451strsignal setitimer \ 13478strsignal setitimer \
13452sendto recvfrom getsockname getpeername getifaddrs freeifaddrs \ 13479sendto recvfrom getsockname getpeername getifaddrs freeifaddrs \
13453gai_strerror mkstemp getline getdelim fsync sync \ 13480gai_strerror mkstemp getline getdelim fsync sync \
@@ -13468,24 +13495,6 @@ fi
13468done 13495done
13469 13496
13470 13497
13471if test $opsys = unixware; then
13472
13473$as_echo "#define BROKEN_GETWD 1" >>confdefs.h
13474
13475else
13476 for ac_func in getwd
13477do :
13478 ac_fn_c_check_func "$LINENO" "getwd" "ac_cv_func_getwd"
13479if test "x$ac_cv_func_getwd" = x""yes; then :
13480 cat >>confdefs.h <<_ACEOF
13481#define HAVE_GETWD 1
13482_ACEOF
13483
13484fi
13485done
13486
13487fi
13488
13489## Eric Backus <ericb@lsid.hp.com> says, HP-UX 9.x on HP 700 machines 13498## Eric Backus <ericb@lsid.hp.com> says, HP-UX 9.x on HP 700 machines
13490## has a broken `rint' in some library versions including math library 13499## has a broken `rint' in some library versions including math library
13491## version number A.09.05. 13500## version number A.09.05.
diff --git a/configure.ac b/configure.ac
index 1884cc7ccf7..7dda0010f28 100644
--- a/configure.ac
+++ b/configure.ac
@@ -329,10 +329,15 @@ if test "${enableval}" != "no"; then
329fi) 329fi)
330 330
331 331
332dnl The name of this option is unfortunate. It predates, and has no
333dnl relation to, the "sampling-based elisp profiler" added in 24.3.
334dnl Actually, it stops it working.
335dnl http://lists.gnu.org/archive/html/emacs-devel/2012-11/msg00393.html
332AC_ARG_ENABLE(profiling, 336AC_ARG_ENABLE(profiling,
333[AS_HELP_STRING([--enable-profiling], 337[AS_HELP_STRING([--enable-profiling],
334 [build emacs with profiling support. 338 [build emacs with low-level, gprof profiling support.
335 This might not work on all platforms])], 339 Mainly useful for debugging Emacs itself. May not work on
340 all platforms. Stops profiler.el working.])],
336[ac_enable_profiling="${enableval}"],[]) 341[ac_enable_profiling="${enableval}"],[])
337if test x$ac_enable_profiling != x ; then 342if test x$ac_enable_profiling != x ; then
338 PROFILING_CFLAGS="-DPROFILING=1 -pg" 343 PROFILING_CFLAGS="-DPROFILING=1 -pg"
@@ -710,6 +715,8 @@ else
710 nw="$nw -Wfloat-equal" # warns about high-quality code 715 nw="$nw -Wfloat-equal" # warns about high-quality code
711 nw="$nw -Winline" # OK to ignore 'inline' 716 nw="$nw -Winline" # OK to ignore 'inline'
712 nw="$nw -Wjump-misses-init" # We sometimes safely jump over init. 717 nw="$nw -Wjump-misses-init" # We sometimes safely jump over init.
718 nw="$nw -Wstrict-overflow" # OK to optimize assuming that
719 # signed overflow has undefined behavior
713 nw="$nw -Wsync-nand" # irrelevant here, and provokes ObjC warning 720 nw="$nw -Wsync-nand" # irrelevant here, and provokes ObjC warning
714 nw="$nw -Wunsafe-loop-optimizations" # OK to suppress unsafe optimizations 721 nw="$nw -Wunsafe-loop-optimizations" # OK to suppress unsafe optimizations
715 722
@@ -717,11 +724,23 @@ else
717 # <http://lists.gnu.org/archive/html/emacs-diffs/2011-11/msg00265.html>. 724 # <http://lists.gnu.org/archive/html/emacs-diffs/2011-11/msg00265.html>.
718 nw="$nw -Wshadow" 725 nw="$nw -Wshadow"
719 726
720 # The following lines should be removable at some point. 727 # The following line should be removable at some point.
721 nw="$nw -Wstack-protector"
722 nw="$nw -Wstrict-overflow"
723 nw="$nw -Wsuggest-attribute=pure" 728 nw="$nw -Wsuggest-attribute=pure"
724 729
730 AC_MSG_CHECKING([whether to use -Wstack-protector])
731 AC_PREPROC_IFELSE(
732 [AC_LANG_PROGRAM(
733 [[#if (1 <= __LONG_MAX__ >> 31 >> 31 \
734 && 4 < __GNUC__ + (7 < __GNUC_MINOR__ + (2 <= __GNUC_PATCHLEVEL__)))
735 /* OK */
736 #else
737 #error "Not GCC, or GCC before 4.7.2, or 'long int' has < 64 bits."
738 #endif
739 ]])],
740 [AC_MSG_RESULT(yes)],
741 [AC_MSG_RESULT(no)
742 nw="$nw -Wstack-protector"])
743
725 gl_MANYWARN_ALL_GCC([ws]) 744 gl_MANYWARN_ALL_GCC([ws])
726 gl_MANYWARN_COMPLEMENT([ws], [$ws], [$nw]) 745 gl_MANYWARN_COMPLEMENT([ws], [$ws], [$nw])
727 for w in $ws; do 746 for w in $ws; do
@@ -1270,7 +1289,7 @@ AC_CHECK_HEADERS_ONCE(
1270 linux/version.h sys/systeminfo.h 1289 linux/version.h sys/systeminfo.h
1271 coff.h pty.h 1290 coff.h pty.h
1272 sys/vlimit.h sys/resource.h 1291 sys/vlimit.h sys/resource.h
1273 sys/utsname.h pwd.h utmp.h dirent.h util.h) 1292 sys/utsname.h pwd.h utmp.h util.h)
1274 1293
1275AC_MSG_CHECKING(if personality LINUX32 can be set) 1294AC_MSG_CHECKING(if personality LINUX32 can be set)
1276AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <sys/personality.h>]], [[personality (PER_LINUX32)]])], 1295AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <sys/personality.h>]], [[personality (PER_LINUX32)]])],
@@ -2872,10 +2891,10 @@ AC_SUBST(BLESSMAIL_TARGET)
2872 2891
2873 2892
2874AC_CHECK_FUNCS(gethostname \ 2893AC_CHECK_FUNCS(gethostname \
2875closedir getrusage get_current_dir_name \ 2894getrusage get_current_dir_name \
2876lrand48 \ 2895lrand48 \
2877select getpagesize setlocale \ 2896select getpagesize setlocale \
2878utimes getrlimit setrlimit getcwd shutdown getaddrinfo \ 2897utimes getrlimit setrlimit shutdown getaddrinfo \
2879strsignal setitimer \ 2898strsignal setitimer \
2880sendto recvfrom getsockname getpeername getifaddrs freeifaddrs \ 2899sendto recvfrom getsockname getpeername getifaddrs freeifaddrs \
2881gai_strerror mkstemp getline getdelim fsync sync \ 2900gai_strerror mkstemp getline getdelim fsync sync \
@@ -2884,14 +2903,6 @@ getpwent endpwent getgrent endgrent \
2884touchlock \ 2903touchlock \
2885cfmakeraw cfsetspeed copysign __executable_start) 2904cfmakeraw cfsetspeed copysign __executable_start)
2886 2905
2887dnl getwd appears to be buggy on SVR4.2, so we don't use it.
2888if test $opsys = unixware; then
2889 dnl In case some other test ends up checking for getwd.
2890 AC_DEFINE(BROKEN_GETWD, 1, [Define if getwd should not be used.])
2891else
2892 AC_CHECK_FUNCS(getwd)
2893fi
2894
2895## Eric Backus <ericb@lsid.hp.com> says, HP-UX 9.x on HP 700 machines 2906## Eric Backus <ericb@lsid.hp.com> says, HP-UX 9.x on HP 700 machines
2896## has a broken `rint' in some library versions including math library 2907## has a broken `rint' in some library versions including math library
2897## version number A.09.05. 2908## version number A.09.05.
diff --git a/doc/emacs/ChangeLog b/doc/emacs/ChangeLog
index dc5fa539cd1..af22f0628d1 100644
--- a/doc/emacs/ChangeLog
+++ b/doc/emacs/ChangeLog
@@ -1,3 +1,9 @@
12012-11-21 Dani Moncayo <dmoncayo@gmail.com>
2
3 * display.texi (Auto Scrolling): Fix some inaccuracies, plus
4 clarifications (Bug#12865).
5 (Horizontal Scrolling): Clarifications.
6
12012-11-18 Dani Moncayo <dmoncayo@gmail.com> 72012-11-18 Dani Moncayo <dmoncayo@gmail.com>
2 8
3 * mark.texi (Disabled Transient Mark): Doc fixes (Bug#12746). 9 * mark.texi (Disabled Transient Mark): Doc fixes (Bug#12746).
diff --git a/doc/emacs/display.texi b/doc/emacs/display.texi
index b6ab4913f9c..876c46bdf1a 100644
--- a/doc/emacs/display.texi
+++ b/doc/emacs/display.texi
@@ -213,59 +213,62 @@ entire current defun onto the screen if possible.
213@node Auto Scrolling 213@node Auto Scrolling
214@section Automatic Scrolling 214@section Automatic Scrolling
215 215
216@cindex automatic scrolling
216 Emacs performs @dfn{automatic scrolling} when point moves out of the 217 Emacs performs @dfn{automatic scrolling} when point moves out of the
217visible portion of the text. 218visible portion of the text. Normally, automatic scrolling centers
219point vertically in the window, but there are several ways to alter
220this behavior.
218 221
219@vindex scroll-conservatively 222@vindex scroll-conservatively
220 Normally, this centers point vertically within the window. However, 223 If you set @code{scroll-conservatively} to a small number @var{n},
221if you set @code{scroll-conservatively} to a small number @var{n}, 224then moving point just a little off the screen (no more than @var{n}
222then if you move point just a little off the screen (less than @var{n} 225lines) causes Emacs to scroll just enough to bring point back on
223lines), Emacs scrolls the text just far enough to bring point back on 226screen; if doing so fails to make point visible, Emacs scrolls just
224screen. If doing so fails to make point visible, Emacs centers point 227far enough to center point in the window. If you set
225in the window. By default, @code{scroll-conservatively} is@tie{}0. 228@code{scroll-conservatively} to a large number (larger than 100),
226If you set @code{scroll-conservatively} to a large number (larger than 229automatic scrolling never centers point, no matter how far point
227100), Emacs will never center point as result of scrolling, even if 230moves; Emacs always scrolls text just enough to bring point into view,
228point moves far away from the text previously displayed in the window. 231either at the top or bottom of the window depending on the scroll
229With such a large value, Emacs will always scroll text just enough for 232direction. By default, @code{scroll-conservatively} is@tie{}0, which
230bringing point into view, so point will end up at the top or bottom of 233means to always center point in the window.
231the window, depending on the scroll direction.
232 234
233@vindex scroll-step 235@vindex scroll-step
234 An alternative way of controlling how Emacs scrolls text is by 236 Another way to control automatic scrolling is to customize the
235customizing the variable @code{scroll-step}. Its value determines how 237variable @code{scroll-step}. Its value determines the number of lines
236many lines to scroll the window when point moves off the screen. If 238by which to automatically scroll, when point moves off the screen. If
237moving by that number of lines fails to bring point back into view, 239scrolling by that number of lines fails to bring point back into view,
238point is centered instead. The default value is zero, which causes 240point is centered instead. The default value is zero, which (by
239point to always be centered after scrolling. 241default) causes point to always be centered after scrolling.
240
241 Since both @code{scroll-conservatively} and @code{scroll-step}
242control automatic scrolling in contradicting ways, you should set only
243one of them. If you customize both, the value of
244@code{scroll-conservatively} takes precedence.
245 242
246@cindex aggressive scrolling 243@cindex aggressive scrolling
247@vindex scroll-up-aggressively 244@vindex scroll-up-aggressively
248@vindex scroll-down-aggressively 245@vindex scroll-down-aggressively
249 When the window does scroll by a distance longer than 246 A third way to control automatic scrolling is to customize the
250@code{scroll-step}, you can control how aggressively it scrolls by 247variables @code{scroll-up-aggressively} and
251setting the variables @code{scroll-up-aggressively} and 248@code{scroll-down-aggressively}, which directly specify the vertical
252@code{scroll-down-aggressively}. The value of 249position of point after scrolling. The value of
253@code{scroll-up-aggressively} should be either @code{nil}, or a 250@code{scroll-up-aggressively} should be either @code{nil} (the
254fraction @var{f} between 0 and 1. A fraction specifies where on the 251default), or a floating point number @var{f} between 0 and 1. The
255screen to put point when scrolling upward, i.e.@: forward. When point 252latter means that when point goes below the bottom window edge (i.e.@:
256goes off the window end, the new start position is chosen to put point 253scrolling forward), Emacs scrolls the window so that point is @var{f}
257@var{f} parts of the window height from the bottom margin. Thus, 254parts of the window height from the bottom window edge. Thus, larger
258larger @var{f} means more aggressive scrolling: more new text is 255@var{f} means more aggressive scrolling: more new text is brought into
259brought into view. The default value, @code{nil}, is equivalent to 256view. The default value, @code{nil}, is equivalent to 0.5.
2600.5. 257
261 258 Likewise, @code{scroll-down-aggressively} is used when point goes
262 Likewise, @code{scroll-down-aggressively} is used for scrolling 259above the bottom window edge (i.e.@: scrolling backward). The value
263down, i.e.@: backward. The value specifies how far point should be 260specifies how far point should be from the top margin of the window
264placed from the top margin of the window; thus, as with 261after scrolling. Thus, as with @code{scroll-up-aggressively}, a
265@code{scroll-up-aggressively}, a larger value is more aggressive. 262larger value is more aggressive.
266 263
267 These two variables are ignored if either @code{scroll-step} or 264 Note that the variables @code{scroll-conservatively},
268@code{scroll-conservatively} are set to a non-zero value. 265@code{scroll-step}, and @code{scroll-up-aggressively} /
266@code{scroll-down-aggressively} control automatic scrolling in
267contradictory ways. Therefore, you should pick no more than one of
268these methods to customize automatic scrolling. In case you customize
269multiple variables, the order of priority is:
270@code{scroll-conservatively}, then @code{scroll-step}, and finally
271@code{scroll-up-aggressively} / @code{scroll-down-aggressively}.
269 272
270@vindex scroll-margin 273@vindex scroll-margin
271 The variable @code{scroll-margin} restricts how close point can come 274 The variable @code{scroll-margin} restricts how close point can come
@@ -295,10 +298,10 @@ the cursor is left at the edge instead.)
295 298
296@vindex hscroll-margin 299@vindex hscroll-margin
297 The variable @code{hscroll-margin} controls how close point can get 300 The variable @code{hscroll-margin} controls how close point can get
298to the window's edges before automatic scrolling occurs. It is 301to the window's left and right edges before automatic scrolling
299measured in columns. For example, if the value is 5, then moving 302occurs. It is measured in columns. For example, if the value is 5,
300point within 5 columns of an edge causes horizontal scrolling away 303then moving point within 5 columns of an edge causes horizontal
301from that edge. 304scrolling away from that edge.
302 305
303@vindex hscroll-step 306@vindex hscroll-step
304 The variable @code{hscroll-step} determines how many columns to 307 The variable @code{hscroll-step} determines how many columns to
diff --git a/doc/lispref/ChangeLog b/doc/lispref/ChangeLog
index a5295adc368..99e21bac469 100644
--- a/doc/lispref/ChangeLog
+++ b/doc/lispref/ChangeLog
@@ -1,3 +1,25 @@
12012-11-21 Glenn Morris <rgm@gnu.org>
2
3 * display.texi (Attribute Functions):
4 Update for set-face-* name changes.
5 Add new "inherit" argument for face-bold-p etc.
6 Move description of this argument to a common section, like "frame".
7
8 * debugging.texi (Profiling): New section.
9 (Debugging): Mention profiling in the introduction.
10 * tips.texi (Compilation Tips): Move profiling to separate section.
11 * elisp.texi: Add Profiling to detailed menu.
12
132012-11-21 Martin Rudalics <rudalics@gmx.at>
14
15 * windows.texi (Display Action Functions): Fix recently added
16 example. Suggested by Michael Heerdegen.
17
182012-11-21 Paul Eggert <eggert@cs.ucla.edu>
19
20 Minor cleanup for times as lists of four integers.
21 * os.texi (Time Parsing): Time values can now be four integers.
22
12012-11-18 Glenn Morris <rgm@gnu.org> 232012-11-18 Glenn Morris <rgm@gnu.org>
2 24
3 * loading.texi (How Programs Do Loading): Add eager macro expansion. 25 * loading.texi (How Programs Do Loading): Add eager macro expansion.
diff --git a/doc/lispref/debugging.texi b/doc/lispref/debugging.texi
index 11532b19781..3439a8ae152 100644
--- a/doc/lispref/debugging.texi
+++ b/doc/lispref/debugging.texi
@@ -32,6 +32,9 @@ program.
32@item 32@item
33You can use the ERT package to write regression tests for the program. 33You can use the ERT package to write regression tests for the program.
34@xref{Top,the ERT manual,, ERT, ERT: Emacs Lisp Regression Testing}. 34@xref{Top,the ERT manual,, ERT, ERT: Emacs Lisp Regression Testing}.
35
36@item
37You can profile the program to get hints about how to make it more efficient.
35@end itemize 38@end itemize
36 39
37 Other useful tools for debugging input and output problems are the 40 Other useful tools for debugging input and output problems are the
@@ -43,6 +46,7 @@ function (@pxref{Terminal Output}).
43* Edebug:: A source-level Emacs Lisp debugger. 46* Edebug:: A source-level Emacs Lisp debugger.
44* Syntax Errors:: How to find syntax errors. 47* Syntax Errors:: How to find syntax errors.
45* Test Coverage:: Ensuring you have tested all branches in your code. 48* Test Coverage:: Ensuring you have tested all branches in your code.
49* Profiling:: Measuring the resources that your code uses.
46@end menu 50@end menu
47 51
48@node Debugger 52@node Debugger
@@ -809,3 +813,63 @@ never return. If it ever does return, you get a run-time error.
809 Edebug also has a coverage testing feature (@pxref{Coverage 813 Edebug also has a coverage testing feature (@pxref{Coverage
810Testing}). These features partly duplicate each other, and it would 814Testing}). These features partly duplicate each other, and it would
811be cleaner to combine them. 815be cleaner to combine them.
816
817
818@node Profiling
819@section Profiling
820@cindex profiling
821@cindex measuring resource usage
822@cindex memory usage
823
824If your program is working correctly, but you want to make it run more
825quickly or efficiently, the first thing to do is @dfn{profile} your
826code so that you know how it is using resources. If you find that one
827particular function is responsible for a significant portion of the
828runtime, you can start looking for ways to optimize that piece.
829
830Emacs has built-in support for this. To begin profiling, type
831@kbd{M-x profiler-start}. You can choose to profile by processor
832usage, memory usage, or both. After doing some work, type
833@kbd{M-x profiler-report} to display a summary buffer for each
834resource that you chose to profile. The names of the report buffers
835include the times at which the reports were generated, so you can
836generate another report later on without erasing previous results.
837When you have finished profiling, type @kbd{M-x profiler-stop} (there
838is a small overhead associated with profiling).
839
840The profiler report buffer shows, on each line, a function that was
841called, followed by how much resource (processor or memory) it used in
842absolute and percentage times since profiling started. If a given
843line has a @samp{+} symbol at the left-hand side, you can expand that
844line by typing @key{RET}, in order to see the function(s) called by
845the higher-level function. Pressing @key{RET} again will collapse
846back to the original state.
847
848Press @kbd{j} or @kbd{mouse-2} to jump to the definition of a function.
849Press @kbd{d} to view a function's documentation.
850You can save a profile to a file using @kbd{C-x C-w}.
851You can compare two profiles using @kbd{=}.
852
853@c FIXME reversed calltree?
854
855@cindex @file{elp.el}
856@cindex timing programs
857The @file{elp} library offers an alternative approach. See the file
858@file{elp.el} for instructions.
859
860@cindex @file{benchmark.el}
861@cindex benchmarking
862You can check the speed of individual Emacs Lisp forms using the
863@file{benchmark} library. See the functions @code{benchmark-run} and
864@code{benchmark-run-compiled} in @file{benchmark.el}.
865
866@c Not worth putting in the printed manual.
867@ifnottex
868@cindex --enable-profiling option of configure
869For low-level profiling of Emacs itself, you can build it using the
870@option{--enable-profiling} option of @command{configure}. When Emacs
871exits, it generates a file @file{gmon.out} that you can examine using
872the @command{gprof} utility. This feature is mainly useful for
873debugging Emacs. It actually stops the Lisp-level @kbd{M-x
874profiler-@dots{}} commands described above from working.
875@end ifnottex
diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi
index 475a9550f99..5148c6ec22e 100644
--- a/doc/lispref/display.texi
+++ b/doc/lispref/display.texi
@@ -2425,12 +2425,12 @@ This sets the @code{:stipple} attribute of @var{face} to
2425This sets the @code{:font} attribute of @var{face} to @var{font}. 2425This sets the @code{:font} attribute of @var{face} to @var{font}.
2426@end deffn 2426@end deffn
2427 2427
2428@defun set-face-bold-p face bold-p &optional frame 2428@defun set-face-bold face bold-p &optional frame
2429This sets the @code{:weight} attribute of @var{face} to @var{normal} 2429This sets the @code{:weight} attribute of @var{face} to @var{normal}
2430if @var{bold-p} is @code{nil}, and to @var{bold} otherwise. 2430if @var{bold-p} is @code{nil}, and to @var{bold} otherwise.
2431@end defun 2431@end defun
2432 2432
2433@defun set-face-italic-p face italic-p &optional frame 2433@defun set-face-italic face italic-p &optional frame
2434This sets the @code{:slant} attribute of @var{face} to @var{normal} if 2434This sets the @code{:slant} attribute of @var{face} to @var{normal} if
2435@var{italic-p} is @code{nil}, and to @var{italic} otherwise. 2435@var{italic-p} is @code{nil}, and to @var{italic} otherwise.
2436@end defun 2436@end defun
@@ -2440,7 +2440,7 @@ This sets the @code{:underline} attribute of @var{face} to
2440@var{underline}. 2440@var{underline}.
2441@end defun 2441@end defun
2442 2442
2443@defun set-face-inverse-video-p face inverse-video-p &optional frame 2443@defun set-face-inverse-video face inverse-video-p &optional frame
2444This sets the @code{:inverse-video} attribute of @var{face} to 2444This sets the @code{:inverse-video} attribute of @var{face} to
2445@var{inverse-video-p}. 2445@var{inverse-video-p}.
2446@end defun 2446@end defun
@@ -2453,59 +2453,48 @@ This swaps the foreground and background colors of face @var{face}.
2453don't specify @var{frame}, they refer to the selected frame; @code{t} 2453don't specify @var{frame}, they refer to the selected frame; @code{t}
2454refers to the default data for new frames. They return the symbol 2454refers to the default data for new frames. They return the symbol
2455@code{unspecified} if the face doesn't define any value for that 2455@code{unspecified} if the face doesn't define any value for that
2456attribute. 2456attribute. If @var{inherit} is @code{nil}, only an attribute directly
2457defined by the face is returned. If @var{inherit} is non-@code{nil},
2458any faces specified by its @code{:inherit} attribute are considered as
2459well, and if @var{inherit} is a face or a list of faces, then they are
2460also considered, until a specified attribute is found. To ensure that
2461the return value is always specified, use a value of @code{default} for
2462@var{inherit}.
2463
2464@defun face-font face &optional frame
2465This function returns the name of the font of face @var{face}.
2466@end defun
2457 2467
2458@defun face-foreground face &optional frame inherit 2468@defun face-foreground face &optional frame inherit
2459@defunx face-background face &optional frame inherit 2469@defunx face-background face &optional frame inherit
2460These functions return the foreground color (or background color, 2470These functions return the foreground color (or background color,
2461respectively) of face @var{face}, as a string. 2471respectively) of face @var{face}, as a string.
2462
2463If @var{inherit} is @code{nil}, only a color directly defined by the face is
2464returned. If @var{inherit} is non-@code{nil}, any faces specified by its
2465@code{:inherit} attribute are considered as well, and if @var{inherit}
2466is a face or a list of faces, then they are also considered, until a
2467specified color is found. To ensure that the return value is always
2468specified, use a value of @code{default} for @var{inherit}.
2469@end defun 2472@end defun
2470 2473
2471@defun face-stipple face &optional frame inherit 2474@defun face-stipple face &optional frame inherit
2472This function returns the name of the background stipple pattern of face 2475This function returns the name of the background stipple pattern of face
2473@var{face}, or @code{nil} if it doesn't have one. 2476@var{face}, or @code{nil} if it doesn't have one.
2474
2475If @var{inherit} is @code{nil}, only a stipple directly defined by the
2476face is returned. If @var{inherit} is non-@code{nil}, any faces
2477specified by its @code{:inherit} attribute are considered as well, and
2478if @var{inherit} is a face or a list of faces, then they are also
2479considered, until a specified stipple is found. To ensure that the
2480return value is always specified, use a value of @code{default} for
2481@var{inherit}.
2482@end defun
2483
2484@defun face-font face &optional frame
2485This function returns the name of the font of face @var{face}.
2486@end defun 2477@end defun
2487 2478
2488@defun face-bold-p face &optional frame 2479@defun face-bold-p face &optional frame inherit
2489This function returns a non-@code{nil} value if the @code{:weight} 2480This function returns a non-@code{nil} value if the @code{:weight}
2490attribute of @var{face} is bolder than normal (i.e., one of 2481attribute of @var{face} is bolder than normal (i.e., one of
2491@code{semi-bold}, @code{bold}, @code{extra-bold}, or 2482@code{semi-bold}, @code{bold}, @code{extra-bold}, or
2492@code{ultra-bold}). Otherwise, it returns @code{nil}. 2483@code{ultra-bold}). Otherwise, it returns @code{nil}.
2493@end defun 2484@end defun
2494 2485
2495@defun face-italic-p face &optional frame 2486@defun face-italic-p face &optional frame inherit
2496This function returns a non-@code{nil} value if the @code{:slant} 2487This function returns a non-@code{nil} value if the @code{:slant}
2497attribute of @var{face} is @code{italic} or @code{oblique}, and 2488attribute of @var{face} is @code{italic} or @code{oblique}, and
2498@code{nil} otherwise. 2489@code{nil} otherwise.
2499@end defun 2490@end defun
2500 2491
2501@c Note the weasel words. A face that inherits from an underlined 2492@defun face-underline-p face &optional frame inherit
2502@c face but does not specify :underline will return nil.
2503@defun face-underline-p face &optional frame
2504This function returns non-@code{nil} if face @var{face} specifies 2493This function returns non-@code{nil} if face @var{face} specifies
2505a non-@code{nil} @code{:underline} attribute. 2494a non-@code{nil} @code{:underline} attribute.
2506@end defun 2495@end defun
2507 2496
2508@defun face-inverse-video-p face &optional frame 2497@defun face-inverse-video-p face &optional frame inherit
2509This function returns non-@code{nil} if face @var{face} specifies 2498This function returns non-@code{nil} if face @var{face} specifies
2510a non-@code{nil} @code{:inverse-video} attribute. 2499a non-@code{nil} @code{:inverse-video} attribute.
2511@end defun 2500@end defun
diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi
index a70558bf09f..cb00b5e9889 100644
--- a/doc/lispref/elisp.texi
+++ b/doc/lispref/elisp.texi
@@ -617,6 +617,7 @@ Debugging Lisp Programs
617* Edebug:: A source-level Emacs Lisp debugger. 617* Edebug:: A source-level Emacs Lisp debugger.
618* Syntax Errors:: How to find syntax errors. 618* Syntax Errors:: How to find syntax errors.
619* Test Coverage:: Ensuring you have tested all branches in your code. 619* Test Coverage:: Ensuring you have tested all branches in your code.
620* Profiling:: Measuring the resources that your code uses.
620 621
621The Lisp Debugger 622The Lisp Debugger
622 623
diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi
index 2f06e207fc4..7552aaccc53 100644
--- a/doc/lispref/os.texi
+++ b/doc/lispref/os.texi
@@ -1373,8 +1373,8 @@ on others, years as early as 1901 do work.
1373@node Time Parsing 1373@node Time Parsing
1374@section Parsing and Formatting Times 1374@section Parsing and Formatting Times
1375 1375
1376 These functions convert time values (lists of two or three integers) 1376 These functions convert time values to text in a string, and vice versa.
1377to text in a string, and vice versa. 1377Time values are lists of two to four integers (@pxref{Time of Day}).
1378 1378
1379@defun date-to-time string 1379@defun date-to-time string
1380This function parses the time-string @var{string} and returns the 1380This function parses the time-string @var{string} and returns the
diff --git a/doc/lispref/tips.texi b/doc/lispref/tips.texi
index 4336baa128f..bba416d5614 100644
--- a/doc/lispref/tips.texi
+++ b/doc/lispref/tips.texi
@@ -460,18 +460,8 @@ Lisp programs.
460 460
461@itemize @bullet 461@itemize @bullet
462@item 462@item
463@cindex profiling 463Profile your program, to find out where the time is being spent.
464@cindex timing programs 464@xref{Profiling}.
465@cindex @file{elp.el}
466Profile your program with the @file{elp} library. See the file
467@file{elp.el} for instructions.
468
469@item
470@cindex @file{benchmark.el}
471@cindex benchmarking
472Check the speed of individual Emacs Lisp forms using the
473@file{benchmark} library. See the functions @code{benchmark-run} and
474@code{benchmark-run-compiled} in @file{benchmark.el}.
475 465
476@item 466@item
477Use iteration rather than recursion whenever possible. 467Use iteration rather than recursion whenever possible.
diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi
index b8581b1cc62..e515b24db93 100644
--- a/doc/lispref/windows.texi
+++ b/doc/lispref/windows.texi
@@ -2038,7 +2038,8 @@ Evaluating the form above will cause @code{display-buffer} to proceed as
2038follows: If `*foo*' already appears on a visible or iconified frame, it 2038follows: If `*foo*' already appears on a visible or iconified frame, it
2039will reuse its window. Otherwise, it will try to pop up a new window 2039will reuse its window. Otherwise, it will try to pop up a new window
2040or, if that is impossible, a new frame. If all these steps fail, it 2040or, if that is impossible, a new frame. If all these steps fail, it
2041will try to use some existing window. 2041will proceed using whatever @code{display-buffer-base-action} and
2042@code{display-buffer-fallback-action} prescribe.
2042 2043
2043 Furthermore, @code{display-buffer} will try to adjust a reused window 2044 Furthermore, @code{display-buffer} will try to adjust a reused window
2044(provided `*foo*' was put by @code{display-buffer} there before) or a 2045(provided `*foo*' was put by @code{display-buffer} there before) or a
diff --git a/doc/misc/ChangeLog b/doc/misc/ChangeLog
index 39931f3a779..6be52213a4a 100644
--- a/doc/misc/ChangeLog
+++ b/doc/misc/ChangeLog
@@ -1,7 +1,19 @@
12012-11-22 Paul Eggert <eggert@cs.ucla.edu>
2
3 * calc.texi: Fix TeX issues with capitals followed by ".", "?", "!".
4 (Date Forms): Correct off-by-one error in explanation of
5 Julian day numbers. Give Gregorian equivalent of its origin.
6
72012-11-22 Jay Belanger <jay.p.belanger@gmail.com>
8
9 * doc/misc/calc.texi (Date Forms): Mention the customizable
10 Gregorian-Julian switch.
11 (Customizing Calc): Mention the variable `calc-gregorian-switch'.
12
12012-11-17 Paul Eggert <eggert@cs.ucla.edu> 132012-11-17 Paul Eggert <eggert@cs.ucla.edu>
2 14
3 Calc now uses the Gregorian calendar for all dates, 15 Calc now uses the Gregorian calendar for all dates (Bug#12633).
4 and uses January 1, 1 AD as its day number 1. 16 It also uses January 1, 1 AD as its day number 1.
5 * calc.texi (Date Forms): Document this. 17 * calc.texi (Date Forms): Document this.
6 18
72012-11-16 Glenn Morris <rgm@gnu.org> 192012-11-16 Glenn Morris <rgm@gnu.org>
diff --git a/doc/misc/calc.texi b/doc/misc/calc.texi
index 6daceb4d41a..0ce1efbff58 100644
--- a/doc/misc/calc.texi
+++ b/doc/misc/calc.texi
@@ -1186,7 +1186,7 @@ since the large integer arithmetic was there anyway it seemed only
1186fair to give the user direct access to it, which in turn made it 1186fair to give the user direct access to it, which in turn made it
1187practical to support fractions as well as floats. All these features 1187practical to support fractions as well as floats. All these features
1188inspired me to look around for other data types that might be worth 1188inspired me to look around for other data types that might be worth
1189having. 1189having.
1190 1190
1191Around this time, my friend Rick Koshi showed me his nifty new HP-28 1191Around this time, my friend Rick Koshi showed me his nifty new HP-28
1192calculator. It allowed the user to manipulate formulas as well as 1192calculator. It allowed the user to manipulate formulas as well as
@@ -4461,7 +4461,7 @@ date by one or several months. @xref{Date Arithmetic}, for more.
4461Friday the 13th? @xref{Types Answer 5, 5}. (@bullet{}) 4461Friday the 13th? @xref{Types Answer 5, 5}. (@bullet{})
4462 4462
4463(@bullet{}) @strong{Exercise 6.} How many leap years will there be 4463(@bullet{}) @strong{Exercise 6.} How many leap years will there be
4464between now and the year 10001 A.D.? @xref{Types Answer 6, 6}. (@bullet{}) 4464between now and the year 10001 AD@? @xref{Types Answer 6, 6}. (@bullet{})
4465 4465
4466@cindex Slope and angle of a line 4466@cindex Slope and angle of a line
4467@cindex Angle and slope of a line 4467@cindex Angle and slope of a line
@@ -5693,7 +5693,7 @@ on the stack, we want to be able to type @kbd{*} and get the result
5693rearranged. (This one is rather tricky; the solution at the end of 5693rearranged. (This one is rather tricky; the solution at the end of
5694this chapter uses 6 rewrite rules. Hint: The @samp{constant(x)} 5694this chapter uses 6 rewrite rules. Hint: The @samp{constant(x)}
5695condition tests whether @samp{x} is a number.) @xref{Rewrites Answer 5695condition tests whether @samp{x} is a number.) @xref{Rewrites Answer
56966, 6}. (@bullet{}) 56966, 6}. (@bullet{})
5697 5697
5698Just for kicks, try adding the rule @code{2+3 := 6} to @code{EvalRules}. 5698Just for kicks, try adding the rule @code{2+3 := 6} to @code{EvalRules}.
5699What happens? (Be sure to remove this rule afterward, or you might get 5699What happens? (Be sure to remove this rule afterward, or you might get
@@ -8697,7 +8697,7 @@ Multiplying by the conjugate helps because @expr{(a+b) (a-b) = a^2 - b^2}.
8697@smallexample 8697@smallexample
8698@group 8698@group
8699 ___ 8699 ___
87001: V 2 87001: V 2
8701 . 8701 .
8702 8702
8703 a r a*(b+c) := a*b + a*c 8703 a r a*(b+c) := a*b + a*c
@@ -8897,7 +8897,7 @@ Note that this rule does not mention @samp{O} at all, so it will
8897apply to any product-of-sum it encounters---this rule may surprise 8897apply to any product-of-sum it encounters---this rule may surprise
8898you if you put it into @code{EvalRules}! 8898you if you put it into @code{EvalRules}!
8899 8899
8900In the second rule, the sum of two O's is changed to the smaller O. 8900In the second rule, the sum of two O's is changed to the smaller O@.
8901The optional constant coefficients are there mostly so that 8901The optional constant coefficients are there mostly so that
8902@samp{O(x^2) - O(x^3)} and @samp{O(x^3) - O(x^2)} are handled 8902@samp{O(x^2) - O(x^3)} and @samp{O(x^3) - O(x^2)} are handled
8903as well as @samp{O(x^2) + O(x^3)}. 8903as well as @samp{O(x^2) + O(x^3)}.
@@ -10987,10 +10987,10 @@ Input is flexible; date forms can be entered in any of the usual
10987notations for dates and times. @xref{Date Formats}. 10987notations for dates and times. @xref{Date Formats}.
10988 10988
10989Date forms are stored internally as numbers, specifically the number 10989Date forms are stored internally as numbers, specifically the number
10990of days since midnight on the morning of January 1 of the year 1 AD. 10990of days since midnight on the morning of December 31 of the year 1 BC@.
10991If the internal number is an integer, the form represents a date only; 10991If the internal number is an integer, the form represents a date only;
10992if the internal number is a fraction or float, the form represents 10992if the internal number is a fraction or float, the form represents
10993a date and time. For example, @samp{<6:00am Wed Jan 9, 1991>} 10993a date and time. For example, @samp{<6:00am Thu Jan 10, 1991>}
10994is represented by the number 726842.25. The standard precision of 10994is represented by the number 726842.25. The standard precision of
1099512 decimal digits is enough to ensure that a (reasonable) date and 1099512 decimal digits is enough to ensure that a (reasonable) date and
10996time can be stored without roundoff error. 10996time can be stored without roundoff error.
@@ -11010,55 +11010,70 @@ You can use the @kbd{v p} (@code{calc-pack}) and @kbd{v u}
11010of a date form. @xref{Packing and Unpacking}. 11010of a date form. @xref{Packing and Unpacking}.
11011 11011
11012Date forms can go arbitrarily far into the future or past. Negative 11012Date forms can go arbitrarily far into the future or past. Negative
11013year numbers represent years BC. There is no ``year 0''; the day 11013year numbers represent years BC@. There is no ``year 0''; the day
11014before @samp{<Mon Jan 1, +1>} is @samp{<Sun Dec 31, -1>}. These are 11014before @samp{<Mon Jan 1, +1>} is @samp{<Sun Dec 31, -1>}. These are
11015days 1 and 0 respectively in Calc's internal numbering scheme. The 11015days 1 and 0 respectively in Calc's internal numbering scheme. The
11016Gregorian calendar is used for all dates, including dates before the 11016Gregorian calendar is used for all dates, including dates before the
11017Gregorian calendar was invented. Thus Calc's use of the day number 11017Gregorian calendar was invented (although that can be configured; see
11018@mathit{-10000} to represent August 15, 28 BC should be taken with a 11018below). Thus Calc's use of the day number @mathit{-10000} to
11019grain of salt. 11019represent August 15, 28 BC should be taken with a grain of salt.
11020 11020
11021@cindex Julian calendar 11021@cindex Julian calendar
11022@cindex Gregorian calendar 11022@cindex Gregorian calendar
11023Some historical background: The Julian calendar was created by 11023Some historical background: The Julian calendar was created by
11024Julius Caesar in the year 46 BC as an attempt to fix the confusion 11024Julius Caesar in the year 46 BC as an attempt to fix the confusion
11025caused by the irregular Roman calendar that was used before that time. 11025caused by the irregular Roman calendar that was used before that time.
11026The Julian calendar introduced an extra day in 11026The Julian calendar introduced an extra day in all years divisible by
11027all years divisible by four. After some initial confusion, the 11027four. After some initial confusion, the calendar was adopted around
11028calendar was adopted around the year we call 8 AD, although the years were 11028the year we call 8 AD@. Some centuries later it became
11029numbered differently and did not necessarily begin on January 1. Some centuries 11029apparent that the Julian year of 365.25 days was itself not quite
11030later it became apparent that the Julian year of 365.25 days was 11030right. In 1582 Pope Gregory XIII introduced the Gregorian calendar,
11031itself not quite right. In 1582 Pope Gregory XIII introduced the 11031which added the new rule that years divisible by 100, but not by 400,
11032Gregorian calendar, which added the new rule that years divisible 11032were not to be considered leap years despite being divisible by four.
11033by 100, but not by 400, were not to be considered leap years 11033Many countries delayed adoption of the Gregorian calendar
11034despite being divisible by four. Many countries delayed adoption 11034because of religious differences. For example, Great Britain and the
11035of the Gregorian calendar because of religious differences, and 11035British colonies switched to the Gregorian calendar in September
11036used differing year numbers and start-of-year for other reasons; 110361752, when the Julian calendar was eleven days behind the
11037for example, in early 1752 England changed the start of its year from 11037Gregorian calendar. That year in Britain, the day after September 2
11038March 25 to January 1, and in September it switched to the Gregorian 11038was September 14. To take another example, Russia did not adopt the
11039calendar: in England, the day after December 31, 1750 was January 1, 11039Gregorian calendar until 1918, and that year in Russia the day after
110401750 and the day after March 24, 1750 was March 25, 1751, but the day 11040January 31 was February 14. Calc's reckoning therefore matches English
11041after December 31, 1751 was January 1, 1752 and the day after 11041practice starting in 1752 and Russian practice starting in 1918, but
11042September 2, 1752 was September 14, 1752. To take another example, 11042disagrees with earlier dates in both countries.
11043Russia switched both year numbering and start-of-year in 1700, but did 11043
11044not adopt the Gregorian calendar until 1918. Calc's reckoning 11044When the Julian calendar was introduced, it had January 1 as the first
11045therefore matches English practice starting in 1752 and Russian 11045day of the year. By the Middle Ages, many European countries
11046practice starting in 1918, but disagrees with earlier dates in both 11046had changed the beginning of a new year to a different date, often to
11047countries. 11047a religious festival. Almost all countries reverted to using January 1
11048 11048as the beginning of the year by the time they adopted the Gregorian
11049Today's timekeepers introduce an occasional ``leap second'' as 11049calendar.
11050well, but Calc does not take these minor effects into account. 11050
11051(If it did, it would have to report a non-integer number of days 11051Some calendars attempt to mimic the historical situation by using the
11052between, say, @samp{<12:00am Mon Jan 1, 1900>} and 11052Gregorian calendar for recent dates and the Julian calendar for older
11053dates. The @code{cal} program in most Unix implementations does this,
11054for example. While January 1 wasn't always the beginning of a calendar
11055year, these hybrid calendars still use January 1 as the beginning of
11056the year even for older dates. The customizable variable
11057@code{calc-gregorian-switch} (@pxref{Customizing Calc}) can be set to
11058have Calc's date forms switch from the Julian to Gregorian calendar at
11059any specified date.
11060
11061Today's timekeepers introduce an occasional ``leap second''.
11062These do not occur regularly and Calc does not take these minor
11063effects into account. (If it did, it would have to report a
11064non-integer number of days between, say,
11065@samp{<12:00am Mon Jan 1, 1900>} and
11053@samp{<12:00am Sat Jan 1, 2000>}.) 11066@samp{<12:00am Sat Jan 1, 2000>}.)
11054 11067
11055@cindex Julian day counting 11068@cindex Julian day counting
11056Another day counting system in common use is, confusingly, also called 11069Another day counting system in common use is, confusingly, also called
11057``Julian.'' The Julian day number is the numbers of days since 11070``Julian.'' Julian days go from noon to noon. The Julian day number
1105812:00 noon (GMT) on Jan 1, 4713 BC, which in Calc's scheme (in GMT) 11071is the numbers of days since 12:00 noon (GMT) on November 24, 4714 BC
11059is @mathit{-1721423.5} (recall that Calc starts at midnight instead 11072in the Gregorian calendar (i.e., January 1, 4713 BC in the Julian
11060of noon). Thus to convert a Calc date code obtained by unpacking a 11073calendar). In Calc's scheme (in GMT) the Julian day origin is
11061date form into a Julian day number, simply add 1721423.5 after 11074@mathit{-1721422.5}, because Calc starts at midnight instead of noon.
11075Thus to convert a Calc date code obtained by unpacking a
11076date form into a Julian day number, simply add 1721422.5 after
11062compensating for the time zone difference. The built-in @kbd{t J} 11077compensating for the time zone difference. The built-in @kbd{t J}
11063command performs this conversion for you. 11078command performs this conversion for you.
11064 11079
@@ -11090,7 +11105,7 @@ the Julian cycle as an astronomical dating system; this idea was taken
11090up by other astronomers. (At the time, noon was the start of the 11105up by other astronomers. (At the time, noon was the start of the
11091astronomical day. Herschel originally suggested counting the days 11106astronomical day. Herschel originally suggested counting the days
11092since Jan 1, 4713 BC at noon Alexandria time; this was later amended to 11107since Jan 1, 4713 BC at noon Alexandria time; this was later amended to
11093noon GMT.) Julian day numbering is largely used in astronomy. 11108noon GMT@.) Julian day numbering is largely used in astronomy.
11094 11109
11095@cindex Unix time format 11110@cindex Unix time format
11096The Unix operating system measures time as an integer number of 11111The Unix operating system measures time as an integer number of
@@ -12638,7 +12653,7 @@ are simplified with their unit definitions in mind.
12638A common technique is to set the simplification mode down to the lowest 12653A common technique is to set the simplification mode down to the lowest
12639amount of simplification you will allow to be applied automatically, then 12654amount of simplification you will allow to be applied automatically, then
12640use manual commands like @kbd{a s} and @kbd{c c} (@code{calc-clean}) to 12655use manual commands like @kbd{a s} and @kbd{c c} (@code{calc-clean}) to
12641perform higher types of simplifications on demand. 12656perform higher types of simplifications on demand.
12642@node Declarations, Display Modes, Simplification Modes, Mode Settings 12657@node Declarations, Display Modes, Simplification Modes, Mode Settings
12643@section Declarations 12658@section Declarations
12644 12659
@@ -12989,7 +13004,7 @@ The @code{dneg} function checks for negative reals. The @code{dnonneg}
12989function checks for nonnegative reals, i.e., reals greater than or 13004function checks for nonnegative reals, i.e., reals greater than or
12990equal to zero. Note that Calc's algebraic simplifications, which are 13005equal to zero. Note that Calc's algebraic simplifications, which are
12991effectively applied to all conditions in rewrite rules, can simplify 13006effectively applied to all conditions in rewrite rules, can simplify
12992an expression like @expr{x > 0} to 1 or 0 using @code{dpos}. 13007an expression like @expr{x > 0} to 1 or 0 using @code{dpos}.
12993So the actual functions @code{dpos}, @code{dneg}, and @code{dnonneg} 13008So the actual functions @code{dpos}, @code{dneg}, and @code{dnonneg}
12994are rarely necessary. 13009are rarely necessary.
12995 13010
@@ -13424,7 +13439,7 @@ the time part. The punctuation characters (including spaces) must
13424match exactly; letter fields must correspond to suitable text in 13439match exactly; letter fields must correspond to suitable text in
13425the input. If this doesn't work, Calc checks if the input is a 13440the input. If this doesn't work, Calc checks if the input is a
13426simple number; if so, the number is interpreted as a number of days 13441simple number; if so, the number is interpreted as a number of days
13427since Jan 1, 1 AD. Otherwise, Calc tries a much more relaxed and 13442since Jan 1, 1 AD@. Otherwise, Calc tries a much more relaxed and
13428flexible algorithm which is described in the next section. 13443flexible algorithm which is described in the next section.
13429 13444
13430Weekday names are ignored during reading. 13445Weekday names are ignored during reading.
@@ -14653,7 +14668,7 @@ Subscripts use double square brackets: @samp{a[[i]]}.
14653The @kbd{d W} (@code{calc-maple-language}) command selects the 14668The @kbd{d W} (@code{calc-maple-language}) command selects the
14654conventions of Maple. 14669conventions of Maple.
14655 14670
14656Maple's language is much like C. Underscores are allowed in symbol 14671Maple's language is much like C@. Underscores are allowed in symbol
14657names; square brackets are used for subscripts; explicit @samp{*}s for 14672names; square brackets are used for subscripts; explicit @samp{*}s for
14658multiplications are required. Use either @samp{^} or @samp{**} to 14673multiplications are required. Use either @samp{^} or @samp{**} to
14659denote powers. 14674denote powers.
@@ -16714,7 +16729,7 @@ number (i.e., pervasively).
16714If the simplification mode is set below basic simplification, it is raised 16729If the simplification mode is set below basic simplification, it is raised
16715for the purposes of this command. Thus, @kbd{c c} applies the basic 16730for the purposes of this command. Thus, @kbd{c c} applies the basic
16716simplifications even if their automatic application is disabled. 16731simplifications even if their automatic application is disabled.
16717@xref{Simplification Modes}. 16732@xref{Simplification Modes}.
16718 16733
16719@cindex Roundoff errors, correcting 16734@cindex Roundoff errors, correcting
16720A numeric prefix argument to @kbd{c c} sets the floating-point precision 16735A numeric prefix argument to @kbd{c c} sets the floating-point precision
@@ -16791,7 +16806,7 @@ additional argument from the top of the stack.
16791@pindex calc-date 16806@pindex calc-date
16792@tindex date 16807@tindex date
16793The @kbd{t D} (@code{calc-date}) [@code{date}] command converts a 16808The @kbd{t D} (@code{calc-date}) [@code{date}] command converts a
16794date form into a number, measured in days since Jan 1, 1 AD. The 16809date form into a number, measured in days since Jan 1, 1 AD@. The
16795result will be an integer if @var{date} is a pure date form, or a 16810result will be an integer if @var{date} is a pure date form, or a
16796fraction or float if @var{date} is a date/time form. Or, if its 16811fraction or float if @var{date} is a date/time form. Or, if its
16797argument is a number, it converts this number into a date form. 16812argument is a number, it converts this number into a date form.
@@ -16829,7 +16844,7 @@ The last two arguments default to zero if omitted.
16829@cindex Julian day counts, conversions 16844@cindex Julian day counts, conversions
16830The @kbd{t J} (@code{calc-julian}) [@code{julian}] command converts 16845The @kbd{t J} (@code{calc-julian}) [@code{julian}] command converts
16831a date form into a Julian day count, which is the number of days 16846a date form into a Julian day count, which is the number of days
16832since noon (GMT) on Jan 1, 4713 BC. A pure date is converted to an 16847since noon (GMT) on Jan 1, 4713 BC@. A pure date is converted to an
16833integer Julian count representing noon of that day. A date/time form 16848integer Julian count representing noon of that day. A date/time form
16834is converted to an exact floating-point Julian count, adjusted to 16849is converted to an exact floating-point Julian count, adjusted to
16835interpret the date form in the current time zone but the Julian 16850interpret the date form in the current time zone but the Julian
@@ -18975,7 +18990,7 @@ modulo operation as numbers 39 and below.) If @var{m} is a power of
18975ten, however, the numbers should be completely unbiased. 18990ten, however, the numbers should be completely unbiased.
18976 18991
18977The Gaussian random numbers generated by @samp{random(0.0)} use the 18992The Gaussian random numbers generated by @samp{random(0.0)} use the
18978``polar'' method described in Knuth section 3.4.1C. This method 18993``polar'' method described in Knuth section 3.4.1C@. This method
18979generates a pair of Gaussian random numbers at a time, so only every 18994generates a pair of Gaussian random numbers at a time, so only every
18980other call to @samp{random(0.0)} will require significant calculations. 18995other call to @samp{random(0.0)} will require significant calculations.
18981 18996
@@ -22175,7 +22190,7 @@ Use @kbd{a v} if you want the variables to ignore their stored values.
22175If you give a numeric prefix argument of 2 to @kbd{a v}, it simplifies 22190If you give a numeric prefix argument of 2 to @kbd{a v}, it simplifies
22176using Calc's algebraic simplifications; @pxref{Simplifying Formulas}. 22191using Calc's algebraic simplifications; @pxref{Simplifying Formulas}.
22177If you give a numeric prefix of 3 or more, it uses Extended 22192If you give a numeric prefix of 3 or more, it uses Extended
22178Simplification mode (@kbd{a e}). 22193Simplification mode (@kbd{a e}).
22179 22194
22180If you give a negative prefix argument @mathit{-1}, @mathit{-2}, or @mathit{-3}, 22195If you give a negative prefix argument @mathit{-1}, @mathit{-2}, or @mathit{-3},
22181it simplifies in the corresponding mode but only works on the top-level 22196it simplifies in the corresponding mode but only works on the top-level
@@ -22248,7 +22263,7 @@ If inequalities with opposite direction (e.g., @samp{<} and @samp{>})
22248are mapped, the direction of the second inequality is reversed to 22263are mapped, the direction of the second inequality is reversed to
22249match the first: Using @kbd{a M +} on @samp{a < b} and @samp{a > 2} 22264match the first: Using @kbd{a M +} on @samp{a < b} and @samp{a > 2}
22250reverses the latter to get @samp{2 < a}, which then allows the 22265reverses the latter to get @samp{2 < a}, which then allows the
22251combination @samp{a + 2 < b + a}, which the algebraic simplifications 22266combination @samp{a + 2 < b + a}, which the algebraic simplifications
22252can reduce to @samp{2 < b}. 22267can reduce to @samp{2 < b}.
22253 22268
22254Using @kbd{a M *}, @kbd{a M /}, @kbd{a M n}, or @kbd{a M &} to negate 22269Using @kbd{a M *}, @kbd{a M /}, @kbd{a M n}, or @kbd{a M &} to negate
@@ -22395,7 +22410,7 @@ common special case of regular arithmetic commands like @kbd{+} and
22395@kbd{Q} [@code{sqrt}], the arguments are simply popped from the stack 22410@kbd{Q} [@code{sqrt}], the arguments are simply popped from the stack
22396and collected into a suitable function call, which is then simplified 22411and collected into a suitable function call, which is then simplified
22397(the arguments being simplified first as part of the process, as 22412(the arguments being simplified first as part of the process, as
22398described above). 22413described above).
22399 22414
22400Even the basic set of simplifications are too numerous to describe 22415Even the basic set of simplifications are too numerous to describe
22401completely here, but this section will describe the ones that apply to the 22416completely here, but this section will describe the ones that apply to the
@@ -22701,7 +22716,7 @@ the algebraic simplification mode, which is the default simplification
22701mode. If you have switched to a different simplification mode, you can 22716mode. If you have switched to a different simplification mode, you can
22702switch back with the @kbd{m A} command. Even in other simplification 22717switch back with the @kbd{m A} command. Even in other simplification
22703modes, the @kbd{a s} command will use these algebraic simplifications to 22718modes, the @kbd{a s} command will use these algebraic simplifications to
22704simplify the formula. 22719simplify the formula.
22705 22720
22706There is a variable, @code{AlgSimpRules}, in which you can put rewrites 22721There is a variable, @code{AlgSimpRules}, in which you can put rewrites
22707to be applied. Its use is analogous to @code{EvalRules}, 22722to be applied. Its use is analogous to @code{EvalRules},
@@ -22738,7 +22753,7 @@ This allows easier comparison of products; for example, the basic
22738simplifications will not change @expr{x y + y x} to @expr{2 x y}, 22753simplifications will not change @expr{x y + y x} to @expr{2 x y},
22739but the algebraic simplifications; it first rewrites the sum to 22754but the algebraic simplifications; it first rewrites the sum to
22740@expr{x y + x y} which can then be recognized as a sum of identical 22755@expr{x y + x y} which can then be recognized as a sum of identical
22741terms. 22756terms.
22742 22757
22743The canonical ordering used to sort terms of products has the 22758The canonical ordering used to sort terms of products has the
22744property that real-valued numbers, interval forms and infinities 22759property that real-valued numbers, interval forms and infinities
@@ -22781,10 +22796,10 @@ factor in the numerator and denominator, it is canceled out;
22781for example, @expr{(4 x + 6) / 8 x} simplifies to @expr{(2 x + 3) / 4 x}. 22796for example, @expr{(4 x + 6) / 8 x} simplifies to @expr{(2 x + 3) / 4 x}.
22782 22797
22783Non-constant common factors are not found even by algebraic 22798Non-constant common factors are not found even by algebraic
22784simplifications. To cancel the factor @expr{a} in 22799simplifications. To cancel the factor @expr{a} in
22785@expr{(a x + a) / a^2} you could first use @kbd{j M} on the product 22800@expr{(a x + a) / a^2} you could first use @kbd{j M} on the product
22786@expr{a x} to Merge the numerator to @expr{a (1+x)}, which can then be 22801@expr{a x} to Merge the numerator to @expr{a (1+x)}, which can then be
22787simplified successfully. 22802simplified successfully.
22788 22803
22789@tex 22804@tex
22790\bigskip 22805\bigskip
@@ -22937,7 +22952,7 @@ as is @expr{x^2 >= 0} if @expr{x} is known to be real.
22937@tindex esimplify 22952@tindex esimplify
22938Calc is capable of performing some simplifications which may sometimes 22953Calc is capable of performing some simplifications which may sometimes
22939be desired but which are not ``safe'' in all cases. The @kbd{a e} 22954be desired but which are not ``safe'' in all cases. The @kbd{a e}
22940(@code{calc-simplify-extended}) [@code{esimplify}] command 22955(@code{calc-simplify-extended}) [@code{esimplify}] command
22941applies the algebraic simplifications as well as these extended, or 22956applies the algebraic simplifications as well as these extended, or
22942``unsafe'', simplifications. Use this only if you know the values in 22957``unsafe'', simplifications. Use this only if you know the values in
22943your formula lie in the restricted ranges for which these 22958your formula lie in the restricted ranges for which these
@@ -23581,10 +23596,10 @@ forever!)
23581@vindex IntegSimpRules 23596@vindex IntegSimpRules
23582Another set of rules, stored in @code{IntegSimpRules}, are applied 23597Another set of rules, stored in @code{IntegSimpRules}, are applied
23583every time the integrator uses algebraic simplifications to simplify an 23598every time the integrator uses algebraic simplifications to simplify an
23584intermediate result. For example, putting the rule 23599intermediate result. For example, putting the rule
23585@samp{twice(x) := 2 x} into @code{IntegSimpRules} would tell Calc to 23600@samp{twice(x) := 2 x} into @code{IntegSimpRules} would tell Calc to
23586convert the @code{twice} function into a form it knows whenever 23601convert the @code{twice} function into a form it knows whenever
23587integration is attempted. 23602integration is attempted.
23588 23603
23589One more way to influence the integrator is to define a function with 23604One more way to influence the integrator is to define a function with
23590the @kbd{Z F} command (@pxref{Algebraic Definitions}). Calc's 23605the @kbd{Z F} command (@pxref{Algebraic Definitions}). Calc's
@@ -26749,7 +26764,7 @@ meta-variable @expr{v}. As usual, if this meta-variable has already
26749been matched to something else the two values must be equal; if the 26764been matched to something else the two values must be equal; if the
26750meta-variable is new then it is bound to the result of the expression. 26765meta-variable is new then it is bound to the result of the expression.
26751This variable can then appear in later conditions, and on the righthand 26766This variable can then appear in later conditions, and on the righthand
26752side of the rule. 26767side of the rule.
26753In fact, @expr{v} may be any pattern in which case the result of 26768In fact, @expr{v} may be any pattern in which case the result of
26754evaluating @expr{x} is matched to that pattern, binding any 26769evaluating @expr{x} is matched to that pattern, binding any
26755meta-variables that appear in that pattern. Note that @code{let} 26770meta-variables that appear in that pattern. Note that @code{let}
@@ -27503,7 +27518,7 @@ but only when algebraic simplifications are used to simplify the
27503formula. The variable @code{AlgSimpRules} holds rules for this purpose. 27518formula. The variable @code{AlgSimpRules} holds rules for this purpose.
27504The @kbd{a s} command will apply @code{EvalRules} and 27519The @kbd{a s} command will apply @code{EvalRules} and
27505@code{AlgSimpRules} to the formula, as well as all of its built-in 27520@code{AlgSimpRules} to the formula, as well as all of its built-in
27506simplifications. 27521simplifications.
27507 27522
27508Most of the special limitations for @code{EvalRules} don't apply to 27523Most of the special limitations for @code{EvalRules} don't apply to
27509@code{AlgSimpRules}. Calc simply does an @kbd{a r AlgSimpRules} 27524@code{AlgSimpRules}. Calc simply does an @kbd{a r AlgSimpRules}
@@ -27511,7 +27526,7 @@ command with an infinite repeat count as the first step of algebraic
27511simplifications. It then applies its own built-in simplifications 27526simplifications. It then applies its own built-in simplifications
27512throughout the formula, and then repeats these two steps (along with 27527throughout the formula, and then repeats these two steps (along with
27513applying the default simplifications) until no further changes are 27528applying the default simplifications) until no further changes are
27514possible. 27529possible.
27515 27530
27516@cindex @code{ExtSimpRules} variable 27531@cindex @code{ExtSimpRules} variable
27517@cindex @code{UnitSimpRules} variable 27532@cindex @code{UnitSimpRules} variable
@@ -28946,9 +28961,9 @@ to select the lefthand side, execute your commands, then type
28946All current modes apply when an @samp{=>} operator is computed, 28961All current modes apply when an @samp{=>} operator is computed,
28947including the current simplification mode. Recall that the 28962including the current simplification mode. Recall that the
28948formula @samp{arcsin(sin(x))} will not be handled by Calc's algebraic 28963formula @samp{arcsin(sin(x))} will not be handled by Calc's algebraic
28949simplifications, but Calc's unsafe simplifications will reduce it to 28964simplifications, but Calc's unsafe simplifications will reduce it to
28950@samp{x}. If you enter @samp{arcsin(sin(x)) =>} normally, the result 28965@samp{x}. If you enter @samp{arcsin(sin(x)) =>} normally, the result
28951will be @samp{arcsin(sin(x)) => arcsin(sin(x))}. If you change to 28966will be @samp{arcsin(sin(x)) => arcsin(sin(x))}. If you change to
28952Extended Simplification mode, the result will be 28967Extended Simplification mode, the result will be
28953@samp{arcsin(sin(x)) => x}. However, just pressing @kbd{a e} 28968@samp{arcsin(sin(x)) => x}. However, just pressing @kbd{a e}
28954once will have no effect on @samp{arcsin(sin(x)) => arcsin(sin(x))}, 28969once will have no effect on @samp{arcsin(sin(x)) => arcsin(sin(x))},
@@ -29566,7 +29581,7 @@ plot on any text-only printer.
29566@kindex g O 29581@kindex g O
29567@pindex calc-graph-output 29582@pindex calc-graph-output
29568The @kbd{g O} (@code{calc-graph-output}) command sets the name of the 29583The @kbd{g O} (@code{calc-graph-output}) command sets the name of the
29569output file used by GNUPLOT. For some devices, notably @code{x11} and 29584output file used by GNUPLOT@. For some devices, notably @code{x11} and
29570@code{windows}, there is no output file and this information is not 29585@code{windows}, there is no output file and this information is not
29571used. Many other ``devices'' are really file formats like 29586used. Many other ``devices'' are really file formats like
29572@code{postscript}; in these cases the output in the desired format 29587@code{postscript}; in these cases the output in the desired format
@@ -29638,7 +29653,7 @@ window in the upper-left corner of the screen. This command has no
29638effect if the current device is @code{windows}. 29653effect if the current device is @code{windows}.
29639 29654
29640The buffer called @samp{*Gnuplot Trail*} holds a transcript of the 29655The buffer called @samp{*Gnuplot Trail*} holds a transcript of the
29641session with GNUPLOT. This shows the commands Calc has ``typed'' to 29656session with GNUPLOT@. This shows the commands Calc has ``typed'' to
29642GNUPLOT and the responses it has received. Calc tries to notice when an 29657GNUPLOT and the responses it has received. Calc tries to notice when an
29643error message has appeared here and display the buffer for you when 29658error message has appeared here and display the buffer for you when
29644this happens. You can check this buffer yourself if you suspect 29659this happens. You can check this buffer yourself if you suspect
@@ -33249,7 +33264,7 @@ in the range @samp{[0 ..@: 60)}.
33249 33264
33250Date forms are stored as @samp{(date @var{n})}, where @var{n} is 33265Date forms are stored as @samp{(date @var{n})}, where @var{n} is
33251a real number that counts days since midnight on the morning of 33266a real number that counts days since midnight on the morning of
33252January 1, 1 AD. If @var{n} is an integer, this is a pure date 33267January 1, 1 AD@. If @var{n} is an integer, this is a pure date
33253form. If @var{n} is a fraction or float, this is a date/time form. 33268form. If @var{n} is a fraction or float, this is a date/time form.
33254 33269
33255Modulo forms are stored as @samp{(mod @var{n} @var{m})}, where @var{m} is a 33270Modulo forms are stored as @samp{(mod @var{n} @var{m})}, where @var{m} is a
@@ -33757,7 +33772,7 @@ objects into a definite, consistent order. The @code{beforep}
33757function is used by the @kbd{V S} vector-sorting command, and also 33772function is used by the @kbd{V S} vector-sorting command, and also
33758by Calc's algebraic simplifications to put the terms of a product into 33773by Calc's algebraic simplifications to put the terms of a product into
33759canonical order: This allows @samp{x y + y x} to be simplified easily to 33774canonical order: This allows @samp{x y + y x} to be simplified easily to
33760@samp{2 x y}. 33775@samp{2 x y}.
33761@end defun 33776@end defun
33762 33777
33763@defun equal x y 33778@defun equal x y
@@ -35590,6 +35605,20 @@ number of undo steps that will be preserved; if
35590be preserved. The default value of @code{calc-undo-length} is @expr{100}. 35605be preserved. The default value of @code{calc-undo-length} is @expr{100}.
35591@end defvar 35606@end defvar
35592 35607
35608@defvar calc-gregorian-switch
35609See @ref{Date Forms}.@*
35610The variable @code{calc-gregorian-switch} is either a list of integers
35611@code{(@var{YEAR} @var{MONTH} @var{DAY})} or @code{nil}.
35612If it is @code{nil}, then Calc's date forms always represent Gregorian dates.
35613Otherwise, @code{calc-gregorian-switch} represents the date that the
35614calendar switches from Julian dates to Gregorian dates;
35615@code{(@var{YEAR} @var{MONTH} @var{DAY})} will be the first Gregorian
35616date. The customization buffer will offer several standard dates to
35617choose from, or the user can enter their own date.
35618
35619The default value of @code{calc-gregorian-switch} is @code{nil}.
35620@end defvar
35621
35593@node Reporting Bugs, Summary, Customizing Calc, Top 35622@node Reporting Bugs, Summary, Customizing Calc, Top
35594@appendix Reporting Bugs 35623@appendix Reporting Bugs
35595 35624
diff --git a/etc/ChangeLog b/etc/ChangeLog
index 60d4a7aa271..11dc42b7f45 100644
--- a/etc/ChangeLog
+++ b/etc/ChangeLog
@@ -1,3 +1,7 @@
12012-11-22 Paul Eggert <eggert@cs.ucla.edu>
2
3 * NEWS: Document Calc changes for Gregorian calendar (Bug#12633).
4
12012-10-26 Nicolas Goaziou <n.goaziou@gmail.com> 52012-10-26 Nicolas Goaziou <n.goaziou@gmail.com>
2 6
3 * refcards/orgcard.tex: Fix keybindings about 7 * refcards/orgcard.tex: Fix keybindings about
diff --git a/etc/NEWS b/etc/NEWS
index 57e40982af6..d1665fb3b70 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -29,9 +29,32 @@ so we will look at it and add it to the manual.
29 29
30* Changes in Specialized Modes and Packages in Emacs 24.4 30* Changes in Specialized Modes and Packages in Emacs 24.4
31 31
32** Calc
33
34*** Calc by default now uses the Gregorian calendar for all dates, and
35uses January 1, 1 AD as its day number 1. Previously Calc used the
36Julian calendar for dates before September 14, 1752, and it used
37December 31, 1 BC as its day number 1; the new scheme is more
38consistent with Calendar's calendrical system and day numbering.
39
40*** The new variable `calc-gregorian-switch' lets you configure the
41date when Calc switches from the Julian to the Gregorian calendar.
42Nil, the default value, means to always use the Gregorian calendar.
43The value (YEAR MONTH DAY) means to start using the Gregorian calendar
44on the given date.
45
32+++ 46+++
33** New function `ses-rename-cell' to give SES cells arbitrary names. 47** New function `ses-rename-cell' to give SES cells arbitrary names.
34 48
49** trace-function was largely rewritten.
50New features include:
51- no prompting for the destination buffer, unless a prefix-arg was used.
52- additionally to prompting for a destination buffer, when a prefix-arg is
53 used, the user can enter a "context", i.e. Lisp expression whose value at the
54 time the function is entered/exited will be printed along with the function
55 name and arguments. Useful to trace the value of (current-buffer) or
56 (point) when the function is invoked.
57
35 58
36* New Modes and Packages in Emacs 24.4 59* New Modes and Packages in Emacs 24.4
37** New nadvice.el package offering lighter-weight advice facilities. 60** New nadvice.el package offering lighter-weight advice facilities.
@@ -43,6 +66,10 @@ It is layered as:
43 66
44* Incompatible Lisp Changes in Emacs 24.4 67* Incompatible Lisp Changes in Emacs 24.4
45 68
69** nil and "unbound" are indistinguishable in symbol-function.
70`symbol-function' never signals `void-function' any more.
71`fboundp' returns non-nil if the symbol was `fset' to nil.
72
46** `defadvice' does not honor the `freeze' flag and cannot advise 73** `defadvice' does not honor the `freeze' flag and cannot advise
47special-forms any more. 74special-forms any more.
48 75
@@ -52,6 +79,7 @@ spurious warnings about an unused var.
52 79
53* Lisp changes in Emacs 24.4 80* Lisp changes in Emacs 24.4
54 81
82** time-to-seconds is not obsolete any more.
55** New function special-form-p. 83** New function special-form-p.
56** Docstrings can be made dynamic by adding a `dynamic-docstring-function' 84** Docstrings can be made dynamic by adding a `dynamic-docstring-function'
57text-property on the first char. 85text-property on the first char.
@@ -833,7 +861,7 @@ are deprecated and will be removed eventually.
833** New sampling-based Elisp profiler. 861** New sampling-based Elisp profiler.
834Try M-x profiler-start, do some work, and then call M-x profiler-report. 862Try M-x profiler-start, do some work, and then call M-x profiler-report.
835When finished, use M-x profiler-stop. The sampling rate can be based on 863When finished, use M-x profiler-stop. The sampling rate can be based on
836CPU time (only supported on some systems) or memory allocations. 864CPU time or memory allocations.
837 865
838+++ 866+++
839** CL-style generalized variables are now in core Elisp. 867** CL-style generalized variables are now in core Elisp.
@@ -1034,9 +1062,10 @@ takes precedence over most other maps for a short while (normally one key).
1034Pass --with-w32 to configure. The default remains the X11 interface. 1062Pass --with-w32 to configure. The default remains the X11 interface.
1035 1063
1036** Two new functions are available in Cygwin builds: 1064** Two new functions are available in Cygwin builds:
1037`cygwin-convert-path-from-windows' and `cygwin-convert-path-to-windows'. 1065`cygwin-convert-file-name-from-windows' and
1038These functions allow Lisp code to access the Cygwin file-name mapping 1066`cygwin-convert-file-name-to-windows'. These functions allow Lisp
1039machinery to convert between Cygwin and Windows-native file names. 1067code to access the Cygwin file-name mapping machinery to convert
1068between Cygwin and Windows-native file and directory names.
1040 1069
1041** When invoked with the -nw switch to run on the Windows text-mode terminal, 1070** When invoked with the -nw switch to run on the Windows text-mode terminal,
1042Emacs now supports mouse highlight, help-echo (in the echo area), and 1071Emacs now supports mouse highlight, help-echo (in the echo area), and
diff --git a/lib-src/ChangeLog b/lib-src/ChangeLog
index 926297b6dd3..b85ba12a5b2 100644
--- a/lib-src/ChangeLog
+++ b/lib-src/ChangeLog
@@ -1,3 +1,26 @@
12012-11-23 Paul Eggert <eggert@cs.ucla.edu>
2
3 movemail: treat EACCES etc. failures as permanent
4 * movemail.c (main): Treat any link failure other than EEXIST as a
5 permanent failure, not just EPERM. EACCES, for example.
6
72012-11-21 Paul Eggert <eggert@cs.ucla.edu>
8
9 Assume POSIX 1003.1-1988 or later for unistd.h (Bug#12945).
10 * emacsclient.c (getcwd): Remove decl.
11 (get_current_dir_name): Assume getcwd exists.
12 * etags.c (HAVE_GETCWD): Remove.
13 (getcwd): Remove decl.
14 (NO_LONG_OPTIONS): Remove this. All uses removed.
15 Emacs always has GNU getopt.
16 (etags_getcwd): Assume getcwd exists.
17 * movemail.c (F_OK, X_OK, W_OK, R_OK): Remove.
18
192012-11-20 Paul Eggert <eggert@cs.ucla.edu>
20
21 * emacsclient.c (handle_sigcont, handle_sigtstp): Use raise (sig)
22 rather than kill (getpid (), sig), as it's simpler and safer.
23
12012-11-17 Juanma Barranquero <lekktu@gmail.com> 242012-11-17 Juanma Barranquero <lekktu@gmail.com>
2 25
3 * makefile.w32-in (SYSWAIT_H): New macro. 26 * makefile.w32-in (SYSWAIT_H): New macro.
diff --git a/lib-src/emacsclient.c b/lib-src/emacsclient.c
index 8d60d7961da..021ac6eb247 100644
--- a/lib-src/emacsclient.c
+++ b/lib-src/emacsclient.c
@@ -88,10 +88,7 @@ char *w32_getenv (char *);
88 88
89 89
90 90
91char *getenv (const char *), *getwd (char *); 91char *getenv (const char *);
92#ifdef HAVE_GETCWD
93char *(getcwd) (char *, size_t);
94#endif
95 92
96#ifndef VERSION 93#ifndef VERSION
97#define VERSION "unspecified" 94#define VERSION "unspecified"
@@ -223,7 +220,7 @@ get_current_dir_name (void)
223 char *buf; 220 char *buf;
224 const char *pwd; 221 const char *pwd;
225 struct stat dotstat, pwdstat; 222 struct stat dotstat, pwdstat;
226 /* If PWD is accurate, use it instead of calling getwd. PWD is 223 /* If PWD is accurate, use it instead of calling getcwd. PWD is
227 sometimes a nicer name, and using it may avoid a fatal error if a 224 sometimes a nicer name, and using it may avoid a fatal error if a
228 parent directory is searchable but not readable. */ 225 parent directory is searchable but not readable. */
229 if ((pwd = egetenv ("PWD")) != 0 226 if ((pwd = egetenv ("PWD")) != 0
@@ -240,7 +237,6 @@ get_current_dir_name (void)
240 buf = (char *) xmalloc (strlen (pwd) + 1); 237 buf = (char *) xmalloc (strlen (pwd) + 1);
241 strcpy (buf, pwd); 238 strcpy (buf, pwd);
242 } 239 }
243#ifdef HAVE_GETCWD
244 else 240 else
245 { 241 {
246 size_t buf_size = 1024; 242 size_t buf_size = 1024;
@@ -267,20 +263,6 @@ get_current_dir_name (void)
267 } 263 }
268 } 264 }
269 } 265 }
270#else
271 else
272 {
273 /* We need MAXPATHLEN here. */
274 buf = (char *) xmalloc (MAXPATHLEN + 1);
275 if (getwd (buf) == NULL)
276 {
277 int tmp_errno = errno;
278 free (buf);
279 errno = tmp_errno;
280 return NULL;
281 }
282 }
283#endif
284 return buf; 266 return buf;
285} 267}
286#endif 268#endif
@@ -1138,7 +1120,7 @@ handle_sigcont (int signalnum)
1138 else 1120 else
1139 { 1121 {
1140 /* We are in the background; cancel the continue. */ 1122 /* We are in the background; cancel the continue. */
1141 kill (getpid (), SIGSTOP); 1123 raise (SIGSTOP);
1142 } 1124 }
1143 1125
1144 signal (signalnum, handle_sigcont); 1126 signal (signalnum, handle_sigcont);
@@ -1165,7 +1147,7 @@ handle_sigtstp (int signalnum)
1165 sigprocmask (SIG_BLOCK, NULL, &set); 1147 sigprocmask (SIG_BLOCK, NULL, &set);
1166 sigdelset (&set, signalnum); 1148 sigdelset (&set, signalnum);
1167 signal (signalnum, SIG_DFL); 1149 signal (signalnum, SIG_DFL);
1168 kill (getpid (), signalnum); 1150 raise (signalnum);
1169 sigprocmask (SIG_SETMASK, &set, NULL); /* Let's the above signal through. */ 1151 sigprocmask (SIG_SETMASK, &set, NULL); /* Let's the above signal through. */
1170 signal (signalnum, handle_sigtstp); 1152 signal (signalnum, handle_sigtstp);
1171 1153
@@ -1592,7 +1574,6 @@ main (int argc, char **argv)
1592 cwd = get_current_dir_name (); 1574 cwd = get_current_dir_name ();
1593 if (cwd == 0) 1575 if (cwd == 0)
1594 { 1576 {
1595 /* getwd puts message in STRING if it fails. */
1596 message (TRUE, "%s: %s\n", progname, 1577 message (TRUE, "%s: %s\n", progname,
1597 "Cannot get current working directory"); 1578 "Cannot get current working directory");
1598 fail (); 1579 fail ();
diff --git a/lib-src/etags.c b/lib-src/etags.c
index ec415e9905f..b6af17b8edf 100644
--- a/lib-src/etags.c
+++ b/lib-src/etags.c
@@ -123,19 +123,9 @@ char pot_etags_version[] = "@(#) pot revision number is 17.38.1.4";
123# undef HAVE_NTGUI 123# undef HAVE_NTGUI
124# undef DOS_NT 124# undef DOS_NT
125# define DOS_NT 125# define DOS_NT
126# ifndef HAVE_GETCWD 126#endif /* WINDOWSNT */
127# define HAVE_GETCWD
128# endif /* undef HAVE_GETCWD */
129#else /* not WINDOWSNT */
130#endif /* !WINDOWSNT */
131 127
132#include <unistd.h> 128#include <unistd.h>
133#ifndef HAVE_UNISTD_H
134# if defined (HAVE_GETCWD) && !defined (WINDOWSNT)
135 extern char *getcwd (char *buf, size_t size);
136# endif
137#endif /* HAVE_UNISTD_H */
138
139#include <stdarg.h> 129#include <stdarg.h>
140#include <stdlib.h> 130#include <stdlib.h>
141#include <string.h> 131#include <string.h>
@@ -152,16 +142,7 @@ char pot_etags_version[] = "@(#) pot revision number is 17.38.1.4";
152# define assert(x) ((void) 0) 142# define assert(x) ((void) 0)
153#endif 143#endif
154 144
155#ifdef NO_LONG_OPTIONS /* define this if you don't have GNU getopt */ 145#include <getopt.h>
156# define NO_LONG_OPTIONS TRUE
157# define getopt_long(argc,argv,optstr,lopts,lind) getopt (argc, argv, optstr)
158 extern char *optarg;
159 extern int optind, opterr;
160#else
161# define NO_LONG_OPTIONS FALSE
162# include <getopt.h>
163#endif /* NO_LONG_OPTIONS */
164
165#include <regex.h> 146#include <regex.h>
166 147
167/* Define CTAGS to make the program "ctags" compatible with the usual one. 148/* Define CTAGS to make the program "ctags" compatible with the usual one.
@@ -869,11 +850,7 @@ print_help (argument *argbuffer)
869 printf ("Usage: %s [options] [[regex-option ...] file-name] ...\n\ 850 printf ("Usage: %s [options] [[regex-option ...] file-name] ...\n\
870\n\ 851\n\
871These are the options accepted by %s.\n", progname, progname); 852These are the options accepted by %s.\n", progname, progname);
872 if (NO_LONG_OPTIONS) 853 puts ("You may use unambiguous abbreviations for the long option names.");
873 puts ("WARNING: long option names do not work with this executable,\n\
874as it is not linked with GNU getopt.");
875 else
876 puts ("You may use unambiguous abbreviations for the long option names.");
877 puts (" A - as file name means read names from stdin (one per line).\n\ 854 puts (" A - as file name means read names from stdin (one per line).\n\
878Absolute names are stored in the output file as they are.\n\ 855Absolute names are stored in the output file as they are.\n\
879Relative ones are stored relative to the output file's directory.\n"); 856Relative ones are stored relative to the output file's directory.\n");
@@ -1065,9 +1042,9 @@ main (int argc, char **argv)
1065 1042
1066 /* When the optstring begins with a '-' getopt_long does not rearrange the 1043 /* When the optstring begins with a '-' getopt_long does not rearrange the
1067 non-options arguments to be at the end, but leaves them alone. */ 1044 non-options arguments to be at the end, but leaves them alone. */
1068 optstring = concat (NO_LONG_OPTIONS ? "" : "-", 1045 optstring = concat ("-ac:Cf:Il:o:r:RSVhH",
1069 "ac:Cf:Il:o:r:RSVhH", 1046 (CTAGS) ? "BxdtTuvw" : "Di:",
1070 (CTAGS) ? "BxdtTuvw" : "Di:"); 1047 "");
1071 1048
1072 while ((opt = getopt_long (argc, argv, optstring, longopts, NULL)) != EOF) 1049 while ((opt = getopt_long (argc, argv, optstring, longopts, NULL)) != EOF)
1073 switch (opt) 1050 switch (opt)
@@ -6333,8 +6310,8 @@ pfatal (const char *s1)
6333static void 6310static void
6334suggest_asking_for_help (void) 6311suggest_asking_for_help (void)
6335{ 6312{
6336 fprintf (stderr, "\tTry `%s %s' for a complete list of options.\n", 6313 fprintf (stderr, "\tTry `%s --help' for a complete list of options.\n",
6337 progname, NO_LONG_OPTIONS ? "-h" : "--help"); 6314 progname);
6338 exit (EXIT_FAILURE); 6315 exit (EXIT_FAILURE);
6339} 6316}
6340 6317
@@ -6372,7 +6349,6 @@ concat (const char *s1, const char *s2, const char *s3)
6372static char * 6349static char *
6373etags_getcwd (void) 6350etags_getcwd (void)
6374{ 6351{
6375#ifdef HAVE_GETCWD
6376 int bufsize = 200; 6352 int bufsize = 200;
6377 char *path = xnew (bufsize, char); 6353 char *path = xnew (bufsize, char);
6378 6354
@@ -6387,34 +6363,6 @@ etags_getcwd (void)
6387 6363
6388 canonicalize_filename (path); 6364 canonicalize_filename (path);
6389 return path; 6365 return path;
6390
6391#else /* not HAVE_GETCWD */
6392#if MSDOS
6393
6394 char *p, path[MAXPATHLEN + 1]; /* Fixed size is safe on MSDOS. */
6395
6396 getwd (path);
6397
6398 for (p = path; *p != '\0'; p++)
6399 if (*p == '\\')
6400 *p = '/';
6401 else
6402 *p = lowcase (*p);
6403
6404 return strdup (path);
6405#else /* not MSDOS */
6406 linebuffer path;
6407 FILE *pipe;
6408
6409 linebuffer_init (&path);
6410 pipe = (FILE *) popen ("pwd 2>/dev/null", "r");
6411 if (pipe == NULL || readline_internal (&path, pipe) == 0)
6412 pfatal ("pwd");
6413 pclose (pipe);
6414
6415 return path.buffer;
6416#endif /* not MSDOS */
6417#endif /* not HAVE_GETCWD */
6418} 6366}
6419 6367
6420/* Return a newly allocated string containing the file name of FILE 6368/* Return a newly allocated string containing the file name of FILE
diff --git a/lib-src/movemail.c b/lib-src/movemail.c
index cd329a110a8..264b3d292c6 100644
--- a/lib-src/movemail.c
+++ b/lib-src/movemail.c
@@ -96,13 +96,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
96#include <fcntl.h> 96#include <fcntl.h>
97#endif /* WINDOWSNT */ 97#endif /* WINDOWSNT */
98 98
99#ifndef F_OK
100#define F_OK 0
101#define X_OK 1
102#define W_OK 2
103#define R_OK 4
104#endif
105
106#ifdef WINDOWSNT 99#ifdef WINDOWSNT
107#include <sys/locking.h> 100#include <sys/locking.h>
108#endif 101#endif
@@ -335,11 +328,8 @@ main (int argc, char **argv)
335 328
336 tem = link (tempname, lockname); 329 tem = link (tempname, lockname);
337 330
338#ifdef EPERM 331 if (tem < 0 && errno != EEXIST)
339 if (tem < 0 && errno == EPERM) 332 pfatal_with_name (lockname);
340 fatal ("Unable to create hard link between %s and %s",
341 tempname, lockname);
342#endif
343 333
344 unlink (tempname); 334 unlink (tempname);
345 if (tem >= 0) 335 if (tem >= 0)
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
diff --git a/nt/ChangeLog b/nt/ChangeLog
index 95203b9d2fa..ae6cb231614 100644
--- a/nt/ChangeLog
+++ b/nt/ChangeLog
@@ -1,3 +1,34 @@
12012-11-23 Eli Zaretskii <eliz@gnu.org>
2
3 * gmake.defs (SWITCHCHAR): Define to // under MSYS, / otherwise.
4 (Bug#12955)
5
6 * nmake.defs (SWITCHCHAR): Define to /.
7
82012-11-23 Paul Eggert <eggert@cs.ucla.edu>
9
10 Assume POSIX 1003.1-1988 or later for dirent.h (Bug#12958).
11 * inc/dirent.h: Rename from ../src/ndir.h, with these changes:
12 (struct dirent): Rename from struct direct. All uses changed.
13 * inc/sys/dir.h: Remove.
14
152012-11-21 Paul Eggert <eggert@cs.ucla.edu>
16
17 Assume POSIX 1003.1-1988 or later for unistd.h (Bug#12945).
18 * config.nt (HAVE_GETCWD): Remove.
19
202012-11-21 Eli Zaretskii <eliz@gnu.org>
21
22 * nmake.defs: Use !if, not !ifdef. For the details, see
23 http://lists.gnu.org/archive/html/help-emacs-windows/2012-11/msg00027.html
24
25 * inc/stdint.h (INTPTR_MIN):
26 (PTRDIFF_MIN) [!__GNUC__]: Define for MSVC.
27
282012-11-18 Eli Zaretskii <eliz@gnu.org>
29
30 * inc/unistd.h: Don't include fcntl.h and don't define O_RDWR.
31
12012-11-17 Juanma Barranquero <lekktu@gmail.com> 322012-11-17 Juanma Barranquero <lekktu@gmail.com>
2 33
3 * config.nt: Sync with autogen/config.in. 34 * config.nt: Sync with autogen/config.in.
diff --git a/nt/config.nt b/nt/config.nt
index 57c18ad2789..1adcbca89be 100644
--- a/nt/config.nt
+++ b/nt/config.nt
@@ -411,12 +411,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
411/* Define to 1 if you have the `getaddrinfo' function. */ 411/* Define to 1 if you have the `getaddrinfo' function. */
412#undef HAVE_GETADDRINFO 412#undef HAVE_GETADDRINFO
413 413
414/* Define to 1 if you have the `getcwd' function.
415 If you think about defining HAVE_GETCWD, don't: the alternative
416 getwd is redefined on w32.c, and does not really return the current
417 directory, to get the desired results elsewhere in Emacs. */
418#undef HAVE_GETCWD
419
420/* Define to 1 if you have the `getdelim' function. */ 414/* Define to 1 if you have the `getdelim' function. */
421#undef HAVE_GETDELIM 415#undef HAVE_GETDELIM
422 416
diff --git a/nt/gmake.defs b/nt/gmake.defs
index 358c262db28..3d545fab975 100644
--- a/nt/gmake.defs
+++ b/nt/gmake.defs
@@ -69,10 +69,18 @@ sh_output := $(shell echo)
69ifeq "$(findstring ECHO, $(sh_output))" "ECHO" 69ifeq "$(findstring ECHO, $(sh_output))" "ECHO"
70THE_SHELL = $(COMSPEC)$(ComSpec) 70THE_SHELL = $(COMSPEC)$(ComSpec)
71SHELLTYPE=CMD 71SHELLTYPE=CMD
72SWITCHCHAR=/
72else 73else
73USING_SH = 1 74USING_SH = 1
74THE_SHELL = $(SHELL) 75THE_SHELL = $(SHELL)
75SHELLTYPE=SH 76SHELLTYPE=SH
77# MSYS needs to double the slash in cmd-style switches to avoid
78# interpreting /x as a Posix style file name reference
79ifneq ($(MSYSTEM),)
80SWITCHCHAR=//
81else
82SWITCHCHAR=/
83endif
76endif 84endif
77 85
78MAKETYPE=gmake 86MAKETYPE=gmake
diff --git a/src/ndir.h b/nt/inc/dirent.h
index cd7cdbe55f5..618f3beddf0 100644
--- a/src/ndir.h
+++ b/nt/inc/dirent.h
@@ -1,7 +1,5 @@
1/* 1/*
2 <dir.h> -- definitions for 4.2BSD-compatible directory access 2 <dirent.h> -- definitions for POSIX-compatible directory access
3
4 last edit: 09-Jul-1983 D A Gwyn
5 3
6 * The code here is forced by the interface, and is not subject to 4 * The code here is forced by the interface, and is not subject to
7 * copyright, constituting the only possible expression of the 5 * copyright, constituting the only possible expression of the
@@ -16,7 +14,7 @@
16#endif /* not WINDOWSNT */ 14#endif /* not WINDOWSNT */
17 /* NOTE: MAXNAMLEN must be one less than a multiple of 4 */ 15 /* NOTE: MAXNAMLEN must be one less than a multiple of 4 */
18 16
19struct direct /* data from readdir() */ 17struct dirent /* data from readdir() */
20 { 18 {
21 long d_ino; /* inode number of entry */ 19 long d_ino; /* inode number of entry */
22 unsigned short d_reclen; /* length of this record */ 20 unsigned short d_reclen; /* length of this record */
@@ -33,9 +31,8 @@ typedef struct
33 } DIR; /* stream data from opendir() */ 31 } DIR; /* stream data from opendir() */
34 32
35extern DIR *opendir (char *); 33extern DIR *opendir (char *);
36extern struct direct *readdir (DIR *); 34extern struct dirent *readdir (DIR *);
37extern void seekdir (DIR *, long); 35extern void seekdir (DIR *, long);
38extern void closedir (DIR *); 36extern void closedir (DIR *);
39 37
40#define rewinddir( dirp ) seekdir( dirp, 0L ) 38#define rewinddir( dirp ) seekdir( dirp, 0L )
41
diff --git a/nt/inc/stdint.h b/nt/inc/stdint.h
index 5c53fa18b55..97c9bbdaee9 100644
--- a/nt/inc/stdint.h
+++ b/nt/inc/stdint.h
@@ -37,6 +37,7 @@ typedef unsigned __int64 uint64_t;
37#define INT64_MAX 9223372036854775807i64 37#define INT64_MAX 9223372036854775807i64
38#define INT64_MIN (~INT64_MAX) 38#define INT64_MIN (~INT64_MAX)
39#define INTPTR_MAX INT64_MAX 39#define INTPTR_MAX INT64_MAX
40#define INTPTR_MIN INT64_MIN
40#define UINTMAX_MAX UINT64_MAX 41#define UINTMAX_MAX UINT64_MAX
41#define UINTMAX_MIN UINT64_MIN 42#define UINTMAX_MIN UINT64_MIN
42#define INTMAX_MAX INT64_MAX 43#define INTMAX_MAX INT64_MAX
@@ -51,6 +52,7 @@ typedef unsigned int uint32_t;
51#define INT32_MAX 2147483647 52#define INT32_MAX 2147483647
52#define INT32_MIN (~INT32_MAX) 53#define INT32_MIN (~INT32_MAX)
53#define INTPTR_MAX INT32_MAX 54#define INTPTR_MAX INT32_MAX
55#define INTPTR_MIN INT32_MIN
54#define UINTMAX_MAX UINT32_MAX 56#define UINTMAX_MAX UINT32_MAX
55#define UINTMAX_MIN UINT32_MIN 57#define UINTMAX_MIN UINT32_MIN
56#define INTMAX_MAX INT32_MAX 58#define INTMAX_MAX INT32_MAX
@@ -60,6 +62,7 @@ typedef unsigned int uint32_t;
60#endif 62#endif
61 63
62#define PTRDIFF_MAX INTPTR_MAX 64#define PTRDIFF_MAX INTPTR_MAX
65#define PTRDIFF_MIN INTPTR_MIN
63 66
64#endif /* !__GNUC__ */ 67#endif /* !__GNUC__ */
65 68
diff --git a/nt/inc/sys/dir.h b/nt/inc/sys/dir.h
deleted file mode 100644
index dc075cd7587..00000000000
--- a/nt/inc/sys/dir.h
+++ /dev/null
@@ -1,6 +0,0 @@
1/*
2 * map sys\dir.h to ..\..\..\src\ndir.h
3 */
4
5#include "..\..\..\src\ndir.h"
6
diff --git a/nt/inc/unistd.h b/nt/inc/unistd.h
index 0173fdbb943..e751ed124d3 100644
--- a/nt/inc/unistd.h
+++ b/nt/inc/unistd.h
@@ -26,17 +26,6 @@ extern int faccessat (int, char const *, int, int);
26#define AT_EACCESS 4 26#define AT_EACCESS 4
27#define AT_SYMLINK_NOFOLLOW 4096 27#define AT_SYMLINK_NOFOLLOW 4096
28 28
29/* Here are some more fcntl.h macros that default to gnulib-compatible
30 values. Include <fcntl.h> first, to make sure we don't override
31 its values if any. FIXME: If we know <fcntl.h> does not define
32 O_NOCTTY and O_RDWR, this can be replaced with a simple "#define
33 O_NOCTTY 0" and "#define O_RDWR 2". */
34#include <fcntl.h>
35#ifndef O_NOCTTY
36#define O_NOCTTY 0 29#define O_NOCTTY 0
37#endif
38#ifndef O_RDWR
39#define O_RDWR 2
40#endif
41 30
42#endif /* _UNISTD_H */ 31#endif /* _UNISTD_H */
diff --git a/nt/nmake.defs b/nt/nmake.defs
index 48809afc771..2c6bc66b673 100644
--- a/nt/nmake.defs
+++ b/nt/nmake.defs
@@ -22,6 +22,7 @@ all:
22 22
23THE_SHELL = $(COMSPEC) 23THE_SHELL = $(COMSPEC)
24SHELLTYPE=CMD 24SHELLTYPE=CMD
25SWITCHCHAR=/
25 26
26MAKETYPE=nmake 27MAKETYPE=nmake
27 28
@@ -116,7 +117,7 @@ RC_INCLUDE = -i
116 117
117USE_CRT_DLL = 1 118USE_CRT_DLL = 1
118 119
119!ifdef USE_CRT_DLL 120!if USE_CRT_DLL
120libc = msvcrt$(D).lib 121libc = msvcrt$(D).lib
121EMACS_EXTRA_C_FLAGS= -D_DLL -D_MT -DUSE_CRT_DLL=1 122EMACS_EXTRA_C_FLAGS= -D_DLL -D_MT -DUSE_CRT_DLL=1
122!else 123!else
diff --git a/src/ChangeLog b/src/ChangeLog
index 6dcddea2e63..c230b4bef24 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -8,6 +8,140 @@
8 * font.c (font_unparse_xlfd): Exclude special characters from the 8 * font.c (font_unparse_xlfd): Exclude special characters from the
9 generating XLFD name. 9 generating XLFD name.
10 10
112012-11-23 Eli Zaretskii <eliz@gnu.org>
12
13 * makefile.w32-in (globals.h, gl-stamp): Use $(SWITCHCHAR) instead
14 of a literal "/". (Bug#12955)
15 (gl-stamp): Invoke fc.exe directly, not through cmd.
16
172012-11-23 Paul Eggert <eggert@cs.ucla.edu>
18
19 Assume POSIX 1003.1-1988 or later for dirent.h (Bug#12958).
20 * dired.c: Assume HAVE_DIRENT_H.
21 (NAMLEN): Remove, replacing with ...
22 (dirent_namelen): New function. All uses changed. Use the GNU macro
23 _D_EXACT_NAMELEN if available, as it's faster than strlen.
24 (DIRENTRY): Remove, replacing all uses with 'struct dirent'.
25 (DIRENTRY_NONEMPTY): Remove. All callers now assume it's nonzero.
26 * makefile.w32-in (DIR_H): Remove. All uses replaced with
27 $(NT_INC)/dirent.h.
28 ($(BLD)/w32.$(O)): Do not depend on $(SRC)/ndir.h.
29 * ndir.h: Rename to ../nt/inc/dirent.h.
30 * sysdep.h (closedir) [!HAVE_CLOSEDIR]: Remove.
31 Do not include <dirent.h>; no longer needed.
32 * w32.c: Include <dirent.h> rather than "ndir.h".
33
342012-11-23 Chong Yidong <cyd@gnu.org>
35
36 * xftfont.c (xftfont_open): Remove duplicate assignment.
37
382012-11-22 Dmitry Antipov <dmantipov@yandex.ru>
39
40 * alloc.c (Fgarbage_collect): Unblock input after clearing
41 gc_in_progress to avoid note_mouse_highlight glitch with GC.
42 * frame.h (FRAME_MOUSE_UPDATE): New macro.
43 * msdos.c (IT_frame_up_to_date): Use it here...
44 * w32term.c (w32_frame_up_to_date): ...here...
45 * xterm.c (XTframe_up_to_date): ...and here...
46 * nsterm.m (ns_frame_up_to_date): ...but not here.
47 * lisp.h (Mouse_HLInfo): Remove mouse_face_deferred_gc member.
48 Adjust users.
49 * xdisp.c (message2_nolog, message3_nolog, note_mouse_highlight):
50 Do not check whether GC is in progress.
51
522012-11-22 Dmitry Antipov <dmantipov@yandex.ru>
53
54 * xdisp.c (window_buffer_changed): New function.
55 (update_menu_bar, update_tool_bar): Use it to
56 simplify large 'if' statements.
57 (redisplay_internal): Generalize commonly used
58 'tail' and 'frame' local variables.
59
602012-11-22 Eli Zaretskii <eliz@gnu.org>
61
62 * w32.c (getcwd): Fix the 2nd argument type, to prevent conflicts
63 with Windows system header.
64
652012-11-21 Paul Eggert <eggert@cs.ucla.edu>
66
67 Assume POSIX 1003.1-1988 or later for unistd.h (Bug#12945).
68 * alloc.c: Assume unistd.h exists.
69 * fileio.c (Fexpand_file_name) [DOS_NT]: Use getcwd, not getwd.
70 * sysdep.c (get_current_dir_name): Assume getcwd exists.
71 (getwd) [USG]: Remove; no longer needed.
72 (sys_subshell) [DOS_NT]: Use getcwd, not getwd.
73 * w32.c (getcwd): Rename from getwd, and switch to getcwd's API.
74 * w32.h (getcwd): Remove decl.
75
762012-11-21 Stefan Monnier <monnier@iro.umontreal.ca>
77
78 * xdisp.c (fast_set_selected_frame): Rename from update_tool_bar_unwind.
79 Make it set selected_window as well.
80 (update_tool_bar): Use it.
81
822012-11-21 Ken Brown <kbrown@cornell.edu>
83
84 * emacs.c (main): Set the G_SLICE environment variable for all
85 Cygwin builds, not just GTK builds. See
86 https://lists.gnu.org/archive/html/emacs-devel/2012-11/msg00368.html.
87
882012-11-21 Eli Zaretskii <eliz@gnu.org>
89
90 * w32.c (FILE_DEVICE_FILE_SYSTEM, METHOD_BUFFERED)
91 (FILE_ANY_ACCESS, CTL_CODE, FSCTL_GET_REPARSE_POINT) [_MSC_VER]:
92 Define for the MSVC compiler.
93
94 * w32term.h (EnumSystemLocalesW) [_MSC_VER]: Add a missing semi-colon.
95
96 * fileio.c (Fsubstitute_in_file_name, Ffile_name_directory)
97 (Fexpand_file_name) [DOS_NT]: Pass encoded file name to
98 dostounix_filename. Prevents crashes down the road, because
99 dostounix_filename assumes it gets a unibyte string. Reported by
100 Michel de Ruiter <michel@sentient.nl>, see
101 http://lists.gnu.org/archive/html/help-emacs-windows/2012-11/msg00017.html
102
1032012-11-20 Stefan Monnier <monnier@iro.umontreal.ca>
104
105 Conflate Qnil and Qunbound for `symbol-function'.
106 * alloc.c (Fmake_symbol): Initialize `function' to Qnil.
107 * lread.c (init_obarray): Set `function' fields to Qnil.
108 * eval.c (Fcommandp): Ignore Qunbound.
109 (Fautoload, eval_sub, Fapply, Ffuncall, Fmacroexpand):
110 * data.c (Ffset, Ffboundp, indirect_function, Findirect_function):
111 Test NILP rather than Qunbound.
112 (Ffmakunbound): Set to Qnil.
113 (Fsymbol_function): Never signal an error.
114 (Finteractive_form): Ignore Qunbound.
115
1162012-11-20 Paul Eggert <eggert@cs.ucla.edu>
117
118 * eval.c (interactive_p): Remove no-longer-used decl.
119
1202012-11-20 Dmitry Antipov <dmantipov@yandex.ru>
121
122 * xdisp.c (buffer_shared): Adjust comment.
123 (buffer_shared_and_changed): New function.
124 (prepare_menu_bars, redisplay_internal): Use it to
125 decide whether all windows or frames should be updated.
126 (window_outdated): New function.
127 (text_outside_line_unchanged_p, redisplay_window): Use it.
128 (redisplay_internal): Likewise. Fix indentation.
129
1302012-11-20 Stefan Monnier <monnier@iro.umontreal.ca>
131
132 * eval.c (Finteractive_p, Fcalled_interactively_p, interactive_p): Remove.
133 (syms_of_eval): Remove corresponding defsubr.
134 * bytecode.c (exec_byte_code): `interactive-p' is now a Lisp function.
135
1362012-11-19 Daniel Colascione <dancol@dancol.org>
137
138 * w32fns.c (Fx_file_dialog):
139 (Fx_file_dialog): Accomodate rename of cygwin_convert_path* to
140 cygwin_convert_file_name*.
141
142 * cygw32.c (Fcygwin_convert_path_to_windows, syms_of_cygw32):
143 Rename cygwin_convert_path* to cygwin_convert_file_name*.
144
112012-11-18 Paul Eggert <eggert@cs.ucla.edu> 1452012-11-18 Paul Eggert <eggert@cs.ucla.edu>
12 146
13 * nsterm.m (ns_select): Send SIGIO only to self, not to process group. 147 * nsterm.m (ns_select): Send SIGIO only to self, not to process group.
@@ -18,10 +152,10 @@
18 windows.h gets included before w32term.h uses some of its 152 windows.h gets included before w32term.h uses some of its
19 features, see below. 153 features, see below.
20 154
21 * w32term.h (LOCALE_ENUMPROCA, LOCALE_ENUMPROCW) [_MSC_VER]: New 155 * w32term.h (LOCALE_ENUMPROCA, LOCALE_ENUMPROCW) [_MSC_VER]:
22 typedefs. 156 New typedefs.
23 (EnumSystemLocalesA, EnumSystemLocalesW) [_MSC_VER]: New 157 (EnumSystemLocalesA, EnumSystemLocalesW) [_MSC_VER]:
24 prototypes. 158 New prototypes.
25 (EnumSystemLocales) [_MSC_VER]: Define if undefined. (Bug#12878) 159 (EnumSystemLocales) [_MSC_VER]: Define if undefined. (Bug#12878)
26 160
272012-11-18 Jan Djärv <jan.h.d@swipnet.se> 1612012-11-18 Jan Djärv <jan.h.d@swipnet.se>
@@ -313,8 +447,8 @@
313 * xdisp.c (try_scrolling): Fix correction of aggressive-scroll 447 * xdisp.c (try_scrolling): Fix correction of aggressive-scroll
314 amount when the scroll margins are too large. When scrolling 448 amount when the scroll margins are too large. When scrolling
315 backwards in the buffer, give up if cannot reach point or the 449 backwards in the buffer, give up if cannot reach point or the
316 scroll margin within a reasonable number of screen lines. Fixes 450 scroll margin within a reasonable number of screen lines.
317 point position in window under scroll-up/down-aggressively when 451 Fixes point position in window under scroll-up/down-aggressively when
318 point is positioned many lines beyond the window top/bottom. 452 point is positioned many lines beyond the window top/bottom.
319 (Bug#12811) 453 (Bug#12811)
320 454
diff --git a/src/alloc.c b/src/alloc.c
index a66a752f5dc..28c9b51dab4 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -63,10 +63,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
63#endif 63#endif
64 64
65#include <unistd.h> 65#include <unistd.h>
66#ifndef HAVE_UNISTD_H
67extern void *sbrk ();
68#endif
69
70#include <fcntl.h> 66#include <fcntl.h>
71 67
72#ifdef USE_GTK 68#ifdef USE_GTK
@@ -3212,7 +3208,7 @@ static struct Lisp_Symbol *symbol_free_list;
3212 3208
3213DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0, 3209DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
3214 doc: /* Return a newly allocated uninterned symbol whose name is NAME. 3210 doc: /* Return a newly allocated uninterned symbol whose name is NAME.
3215Its value and function definition are void, and its property list is nil. */) 3211Its value is void, and its function definition and property list are nil. */)
3216 (Lisp_Object name) 3212 (Lisp_Object name)
3217{ 3213{
3218 register Lisp_Object val; 3214 register Lisp_Object val;
@@ -3249,7 +3245,7 @@ Its value and function definition are void, and its property list is nil. */)
3249 set_symbol_plist (val, Qnil); 3245 set_symbol_plist (val, Qnil);
3250 p->redirect = SYMBOL_PLAINVAL; 3246 p->redirect = SYMBOL_PLAINVAL;
3251 SET_SYMBOL_VAL (p, Qunbound); 3247 SET_SYMBOL_VAL (p, Qunbound);
3252 set_symbol_function (val, Qunbound); 3248 set_symbol_function (val, Qnil);
3253 set_symbol_next (val, NULL); 3249 set_symbol_next (val, NULL);
3254 p->gcmarkbit = 0; 3250 p->gcmarkbit = 0;
3255 p->interned = SYMBOL_UNINTERNED; 3251 p->interned = SYMBOL_UNINTERNED;
@@ -5335,12 +5331,12 @@ See Info node `(elisp)Garbage Collection'. */)
5335 dump_zombies (); 5331 dump_zombies ();
5336#endif 5332#endif
5337 5333
5338 unblock_input ();
5339
5340 check_cons_list (); 5334 check_cons_list ();
5341 5335
5342 gc_in_progress = 0; 5336 gc_in_progress = 0;
5343 5337
5338 unblock_input ();
5339
5344 consing_since_gc = 0; 5340 consing_since_gc = 0;
5345 if (gc_cons_threshold < GC_DEFAULT_THRESHOLD / 10) 5341 if (gc_cons_threshold < GC_DEFAULT_THRESHOLD / 10)
5346 gc_cons_threshold = GC_DEFAULT_THRESHOLD / 10; 5342 gc_cons_threshold = GC_DEFAULT_THRESHOLD / 10;
diff --git a/src/bytecode.c b/src/bytecode.c
index 648813aed86..3267c7c8c76 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -1579,7 +1579,9 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
1579 NEXT; 1579 NEXT;
1580 1580
1581 CASE (Binteractive_p): /* Obsolete since 24.1. */ 1581 CASE (Binteractive_p): /* Obsolete since 24.1. */
1582 PUSH (Finteractive_p ()); 1582 BEFORE_POTENTIAL_GC ();
1583 PUSH (call0 (intern ("interactive-p")));
1584 AFTER_POTENTIAL_GC ();
1583 NEXT; 1585 NEXT;
1584 1586
1585 CASE (Bforward_char): 1587 CASE (Bforward_char):
diff --git a/src/cygw32.c b/src/cygw32.c
index 54f2076a891..d9777d5e22e 100644
--- a/src/cygw32.c
+++ b/src/cygw32.c
@@ -106,22 +106,24 @@ conv_filename_from_w32_unicode (const wchar_t* in, int absolute_p)
106 return unbind_to (count, DECODE_FILE (converted)); 106 return unbind_to (count, DECODE_FILE (converted));
107} 107}
108 108
109DEFUN ("cygwin-convert-path-to-windows", 109DEFUN ("cygwin-convert-file-name-to-windows",
110 Fcygwin_convert_path_to_windows, Scygwin_convert_path_to_windows, 110 Fcygwin_convert_file_name_to_windows,
111 Scygwin_convert_file_name_to_windows,
111 1, 2, 0, 112 1, 2, 0,
112 doc: /* Convert PATH to a Windows path. If ABSOLUTE-P if 113 doc: /* Convert PATH to a Windows path. If ABSOLUTE-P is
113 non-nil, return an absolute path.*/) 114non-nil, return an absolute path.*/)
114 (Lisp_Object path, Lisp_Object absolute_p) 115 (Lisp_Object path, Lisp_Object absolute_p)
115{ 116{
116 return from_unicode ( 117 return from_unicode (
117 conv_filename_to_w32_unicode (path, EQ (absolute_p, Qnil) ? 0 : 1)); 118 conv_filename_to_w32_unicode (path, EQ (absolute_p, Qnil) ? 0 : 1));
118} 119}
119 120
120DEFUN ("cygwin-convert-path-from-windows", 121DEFUN ("cygwin-convert-file-name-from-windows",
121 Fcygwin_convert_path_from_windows, Scygwin_convert_path_from_windows, 122 Fcygwin_convert_file_name_from_windows,
123 Scygwin_convert_file_name_from_windows,
122 1, 2, 0, 124 1, 2, 0,
123 doc: /* Convert a Windows path to a Cygwin path. If ABSOLUTE-P 125 doc: /* Convert a Windows path to a Cygwin path. If ABSOLUTE-P
124 if non-nil, return an absolute path.*/) 126is non-nil, return an absolute path.*/)
125 (Lisp_Object path, Lisp_Object absolute_p) 127 (Lisp_Object path, Lisp_Object absolute_p)
126{ 128{
127 return conv_filename_from_w32_unicode (to_unicode (path, &path), 129 return conv_filename_from_w32_unicode (to_unicode (path, &path),
@@ -131,6 +133,6 @@ DEFUN ("cygwin-convert-path-from-windows",
131void 133void
132syms_of_cygw32 (void) 134syms_of_cygw32 (void)
133{ 135{
134 defsubr (&Scygwin_convert_path_from_windows); 136 defsubr (&Scygwin_convert_file_name_from_windows);
135 defsubr (&Scygwin_convert_path_to_windows); 137 defsubr (&Scygwin_convert_file_name_to_windows);
136} 138}
diff --git a/src/data.c b/src/data.c
index 09899400b68..5fc6afaaa03 100644
--- a/src/data.c
+++ b/src/data.c
@@ -543,12 +543,13 @@ DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0,
543 return (EQ (valcontents, Qunbound) ? Qnil : Qt); 543 return (EQ (valcontents, Qunbound) ? Qnil : Qt);
544} 544}
545 545
546/* FIXME: Make it an alias for function-symbol! */
546DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0, 547DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0,
547 doc: /* Return t if SYMBOL's function definition is not void. */) 548 doc: /* Return t if SYMBOL's function definition is not void. */)
548 (register Lisp_Object symbol) 549 (register Lisp_Object symbol)
549{ 550{
550 CHECK_SYMBOL (symbol); 551 CHECK_SYMBOL (symbol);
551 return EQ (XSYMBOL (symbol)->function, Qunbound) ? Qnil : Qt; 552 return NILP (XSYMBOL (symbol)->function) ? Qnil : Qt;
552} 553}
553 554
554DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0, 555DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0,
@@ -564,14 +565,14 @@ Return SYMBOL. */)
564} 565}
565 566
566DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0, 567DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0,
567 doc: /* Make SYMBOL's function definition be void. 568 doc: /* Make SYMBOL's function definition be nil.
568Return SYMBOL. */) 569Return SYMBOL. */)
569 (register Lisp_Object symbol) 570 (register Lisp_Object symbol)
570{ 571{
571 CHECK_SYMBOL (symbol); 572 CHECK_SYMBOL (symbol);
572 if (NILP (symbol) || EQ (symbol, Qt)) 573 if (NILP (symbol) || EQ (symbol, Qt))
573 xsignal1 (Qsetting_constant, symbol); 574 xsignal1 (Qsetting_constant, symbol);
574 set_symbol_function (symbol, Qunbound); 575 set_symbol_function (symbol, Qnil);
575 return symbol; 576 return symbol;
576} 577}
577 578
@@ -580,9 +581,7 @@ DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0,
580 (register Lisp_Object symbol) 581 (register Lisp_Object symbol)
581{ 582{
582 CHECK_SYMBOL (symbol); 583 CHECK_SYMBOL (symbol);
583 if (!EQ (XSYMBOL (symbol)->function, Qunbound))
584 return XSYMBOL (symbol)->function; 584 return XSYMBOL (symbol)->function;
585 xsignal1 (Qvoid_function, symbol);
586} 585}
587 586
588DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0, 587DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0,
@@ -613,7 +612,7 @@ DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
613 612
614 function = XSYMBOL (symbol)->function; 613 function = XSYMBOL (symbol)->function;
615 614
616 if (!NILP (Vautoload_queue) && !EQ (function, Qunbound)) 615 if (!NILP (Vautoload_queue) && !NILP (function))
617 Vautoload_queue = Fcons (Fcons (symbol, function), Vautoload_queue); 616 Vautoload_queue = Fcons (Fcons (symbol, function), Vautoload_queue);
618 617
619 if (AUTOLOADP (function)) 618 if (AUTOLOADP (function))
@@ -714,7 +713,7 @@ Value, if non-nil, is a list \(interactive SPEC). */)
714{ 713{
715 Lisp_Object fun = indirect_function (cmd); /* Check cycles. */ 714 Lisp_Object fun = indirect_function (cmd); /* Check cycles. */
716 715
717 if (NILP (fun) || EQ (fun, Qunbound)) 716 if (NILP (fun))
718 return Qnil; 717 return Qnil;
719 718
720 /* Use an `interactive-form' property if present, analogous to the 719 /* Use an `interactive-form' property if present, analogous to the
@@ -2008,10 +2007,10 @@ indirect_function (register Lisp_Object object)
2008 2007
2009 for (;;) 2008 for (;;)
2010 { 2009 {
2011 if (!SYMBOLP (hare) || EQ (hare, Qunbound)) 2010 if (!SYMBOLP (hare) || NILP (hare))
2012 break; 2011 break;
2013 hare = XSYMBOL (hare)->function; 2012 hare = XSYMBOL (hare)->function;
2014 if (!SYMBOLP (hare) || EQ (hare, Qunbound)) 2013 if (!SYMBOLP (hare) || NILP (hare))
2015 break; 2014 break;
2016 hare = XSYMBOL (hare)->function; 2015 hare = XSYMBOL (hare)->function;
2017 2016
@@ -2038,10 +2037,10 @@ function chain of symbols. */)
2038 2037
2039 /* Optimize for no indirection. */ 2038 /* Optimize for no indirection. */
2040 result = object; 2039 result = object;
2041 if (SYMBOLP (result) && !EQ (result, Qunbound) 2040 if (SYMBOLP (result) && !NILP (result)
2042 && (result = XSYMBOL (result)->function, SYMBOLP (result))) 2041 && (result = XSYMBOL (result)->function, SYMBOLP (result)))
2043 result = indirect_function (result); 2042 result = indirect_function (result);
2044 if (!EQ (result, Qunbound)) 2043 if (!NILP (result))
2045 return result; 2044 return result;
2046 2045
2047 if (NILP (noerror)) 2046 if (NILP (noerror))
diff --git a/src/dired.c b/src/dired.c
index 4986f845101..3530b74ecb4 100644
--- a/src/dired.c
+++ b/src/dired.c
@@ -31,44 +31,10 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
31#include <errno.h> 31#include <errno.h>
32#include <unistd.h> 32#include <unistd.h>
33 33
34/* The d_nameln member of a struct dirent includes the '\0' character
35 on some systems, but not on others. What's worse, you can't tell
36 at compile-time which one it will be, since it really depends on
37 the sort of system providing the filesystem you're reading from,
38 not the system you are running on. Paul Eggert
39 <eggert@bi.twinsun.com> says this occurs when Emacs is running on a
40 SunOS 4.1.2 host, reading a directory that is remote-mounted from a
41 Solaris 2.1 host and is in a native Solaris 2.1 filesystem.
42
43 Since applying strlen to the name always works, we'll just do that. */
44#define NAMLEN(p) strlen (p->d_name)
45
46#ifdef HAVE_DIRENT_H
47
48#include <dirent.h> 34#include <dirent.h>
49#define DIRENTRY struct dirent
50
51#else /* not HAVE_DIRENT_H */
52
53#include <sys/dir.h>
54#include <sys/stat.h>
55
56#define DIRENTRY struct direct
57
58extern DIR *opendir (char *);
59extern struct direct *readdir (DIR *);
60
61#endif /* HAVE_DIRENT_H */
62
63#include <filemode.h> 35#include <filemode.h>
64#include <stat-time.h> 36#include <stat-time.h>
65 37
66#ifdef MSDOS
67#define DIRENTRY_NONEMPTY(p) ((p)->d_name[0] != 0)
68#else
69#define DIRENTRY_NONEMPTY(p) ((p)->d_ino)
70#endif
71
72#include "lisp.h" 38#include "lisp.h"
73#include "systime.h" 39#include "systime.h"
74#include "character.h" 40#include "character.h"
@@ -88,6 +54,17 @@ static Lisp_Object Qfile_attributes_lessp;
88 54
89static ptrdiff_t scmp (const char *, const char *, ptrdiff_t); 55static ptrdiff_t scmp (const char *, const char *, ptrdiff_t);
90 56
57/* Return the number of bytes in DP's name. */
58static ptrdiff_t
59dirent_namelen (struct dirent *dp)
60{
61#ifdef _D_EXACT_NAMLEN
62 return _D_EXACT_NAMLEN (dp);
63#else
64 return strlen (dp->d_name);
65#endif
66}
67
91#ifdef WINDOWSNT 68#ifdef WINDOWSNT
92Lisp_Object 69Lisp_Object
93directory_files_internal_w32_unwind (Lisp_Object arg) 70directory_files_internal_w32_unwind (Lisp_Object arg)
@@ -124,7 +101,7 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full,
124 bool needsep = 0; 101 bool needsep = 0;
125 ptrdiff_t count = SPECPDL_INDEX (); 102 ptrdiff_t count = SPECPDL_INDEX ();
126 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; 103 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
127 DIRENTRY *dp; 104 struct dirent *dp;
128#ifdef WINDOWSNT 105#ifdef WINDOWSNT
129 Lisp_Object w32_save = Qnil; 106 Lisp_Object w32_save = Qnil;
130#endif 107#endif
@@ -209,6 +186,11 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full,
209 /* Loop reading blocks until EOF or error. */ 186 /* Loop reading blocks until EOF or error. */
210 for (;;) 187 for (;;)
211 { 188 {
189 ptrdiff_t len;
190 bool wanted = 0;
191 Lisp_Object name, finalname;
192 struct gcpro gcpro1, gcpro2;
193
212 errno = 0; 194 errno = 0;
213 dp = readdir (d); 195 dp = readdir (d);
214 196
@@ -225,89 +207,81 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full,
225 if (dp == NULL) 207 if (dp == NULL)
226 break; 208 break;
227 209
228 if (DIRENTRY_NONEMPTY (dp)) 210 len = dirent_namelen (dp);
211 name = finalname = make_unibyte_string (dp->d_name, len);
212 GCPRO2 (finalname, name);
213
214 /* Note: DECODE_FILE can GC; it should protect its argument,
215 though. */
216 name = DECODE_FILE (name);
217 len = SBYTES (name);
218
219 /* Now that we have unwind_protect in place, we might as well
220 allow matching to be interrupted. */
221 immediate_quit = 1;
222 QUIT;
223
224 if (NILP (match)
225 || (0 <= re_search (bufp, SSDATA (name), len, 0, len, 0)))
226 wanted = 1;
227
228 immediate_quit = 0;
229
230 if (wanted)
229 { 231 {
230 ptrdiff_t len; 232 if (!NILP (full))
231 bool wanted = 0; 233 {
232 Lisp_Object name, finalname; 234 Lisp_Object fullname;
233 struct gcpro gcpro1, gcpro2; 235 ptrdiff_t nbytes = len + directory_nbytes + needsep;
236 ptrdiff_t nchars;
234 237
235 len = NAMLEN (dp); 238 fullname = make_uninit_multibyte_string (nbytes, nbytes);
236 name = finalname = make_unibyte_string (dp->d_name, len); 239 memcpy (SDATA (fullname), SDATA (directory),
237 GCPRO2 (finalname, name); 240 directory_nbytes);
238 241
239 /* Note: DECODE_FILE can GC; it should protect its argument, 242 if (needsep)
240 though. */ 243 SSET (fullname, directory_nbytes, DIRECTORY_SEP);
241 name = DECODE_FILE (name);
242 len = SBYTES (name);
243 244
244 /* Now that we have unwind_protect in place, we might as well 245 memcpy (SDATA (fullname) + directory_nbytes + needsep,
245 allow matching to be interrupted. */ 246 SDATA (name), len);
246 immediate_quit = 1;
247 QUIT;
248 247
249 if (NILP (match) 248 nchars = chars_in_text (SDATA (fullname), nbytes);
250 || (0 <= re_search (bufp, SSDATA (name), len, 0, len, 0)))
251 wanted = 1;
252 249
253 immediate_quit = 0; 250 /* Some bug somewhere. */
251 if (nchars > nbytes)
252 emacs_abort ();
254 253
255 if (wanted) 254 STRING_SET_CHARS (fullname, nchars);
256 { 255 if (nchars == nbytes)
257 if (!NILP (full)) 256 STRING_SET_UNIBYTE (fullname);
258 { 257
259 Lisp_Object fullname; 258 finalname = fullname;
260 ptrdiff_t nbytes = len + directory_nbytes + needsep;
261 ptrdiff_t nchars;
262
263 fullname = make_uninit_multibyte_string (nbytes, nbytes);
264 memcpy (SDATA (fullname), SDATA (directory),
265 directory_nbytes);
266
267 if (needsep)
268 SSET (fullname, directory_nbytes, DIRECTORY_SEP);
269
270 memcpy (SDATA (fullname) + directory_nbytes + needsep,
271 SDATA (name), len);
272
273 nchars = chars_in_text (SDATA (fullname), nbytes);
274
275 /* Some bug somewhere. */
276 if (nchars > nbytes)
277 emacs_abort ();
278
279 STRING_SET_CHARS (fullname, nchars);
280 if (nchars == nbytes)
281 STRING_SET_UNIBYTE (fullname);
282
283 finalname = fullname;
284 }
285 else
286 finalname = name;
287
288 if (attrs)
289 {
290 /* Construct an expanded filename for the directory entry.
291 Use the decoded names for input to Ffile_attributes. */
292 Lisp_Object decoded_fullname, fileattrs;
293 struct gcpro gcpro1, gcpro2;
294
295 decoded_fullname = fileattrs = Qnil;
296 GCPRO2 (decoded_fullname, fileattrs);
297
298 /* Both Fexpand_file_name and Ffile_attributes can GC. */
299 decoded_fullname = Fexpand_file_name (name, directory);
300 fileattrs = Ffile_attributes (decoded_fullname, id_format);
301
302 list = Fcons (Fcons (finalname, fileattrs), list);
303 UNGCPRO;
304 }
305 else
306 list = Fcons (finalname, list);
307 } 259 }
260 else
261 finalname = name;
308 262
309 UNGCPRO; 263 if (attrs)
264 {
265 /* Construct an expanded filename for the directory entry.
266 Use the decoded names for input to Ffile_attributes. */
267 Lisp_Object decoded_fullname, fileattrs;
268 struct gcpro gcpro1, gcpro2;
269
270 decoded_fullname = fileattrs = Qnil;
271 GCPRO2 (decoded_fullname, fileattrs);
272
273 /* Both Fexpand_file_name and Ffile_attributes can GC. */
274 decoded_fullname = Fexpand_file_name (name, directory);
275 fileattrs = Ffile_attributes (decoded_fullname, id_format);
276
277 list = Fcons (Fcons (finalname, fileattrs), list);
278 UNGCPRO;
279 }
280 else
281 list = Fcons (finalname, list);
310 } 282 }
283
284 UNGCPRO;
311 } 285 }
312 286
313 block_input (); 287 block_input ();
@@ -442,7 +416,8 @@ These are all file names in directory DIRECTORY which begin with FILE. */)
442 return file_name_completion (file, directory, 1, Qnil); 416 return file_name_completion (file, directory, 1, Qnil);
443} 417}
444 418
445static int file_name_completion_stat (Lisp_Object dirname, DIRENTRY *dp, struct stat *st_addr); 419static int file_name_completion_stat (Lisp_Object dirname, struct dirent *dp,
420 struct stat *st_addr);
446static Lisp_Object Qdefault_directory; 421static Lisp_Object Qdefault_directory;
447 422
448static Lisp_Object 423static Lisp_Object
@@ -499,7 +474,7 @@ file_name_completion (Lisp_Object file, Lisp_Object dirname, bool all_flag,
499 /* (att3b compiler bug requires do a null comparison this way) */ 474 /* (att3b compiler bug requires do a null comparison this way) */
500 while (1) 475 while (1)
501 { 476 {
502 DIRENTRY *dp; 477 struct dirent *dp;
503 ptrdiff_t len; 478 ptrdiff_t len;
504 bool canexclude = 0; 479 bool canexclude = 0;
505 480
@@ -517,11 +492,10 @@ file_name_completion (Lisp_Object file, Lisp_Object dirname, bool all_flag,
517 492
518 if (!dp) break; 493 if (!dp) break;
519 494
520 len = NAMLEN (dp); 495 len = dirent_namelen (dp);
521 496
522 QUIT; 497 QUIT;
523 if (! DIRENTRY_NONEMPTY (dp) 498 if (len < SCHARS (encoded_file)
524 || len < SCHARS (encoded_file)
525 || 0 <= scmp (dp->d_name, SSDATA (encoded_file), 499 || 0 <= scmp (dp->d_name, SSDATA (encoded_file),
526 SCHARS (encoded_file))) 500 SCHARS (encoded_file)))
527 continue; 501 continue;
@@ -806,9 +780,10 @@ scmp (const char *s1, const char *s2, ptrdiff_t len)
806} 780}
807 781
808static int 782static int
809file_name_completion_stat (Lisp_Object dirname, DIRENTRY *dp, struct stat *st_addr) 783file_name_completion_stat (Lisp_Object dirname, struct dirent *dp,
784 struct stat *st_addr)
810{ 785{
811 ptrdiff_t len = NAMLEN (dp); 786 ptrdiff_t len = dirent_namelen (dp);
812 ptrdiff_t pos = SCHARS (dirname); 787 ptrdiff_t pos = SCHARS (dirname);
813 int value; 788 int value;
814 USE_SAFE_ALLOCA; 789 USE_SAFE_ALLOCA;
diff --git a/src/emacs.c b/src/emacs.c
index d69dbfda7bf..b2b193e3a4f 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -715,7 +715,7 @@ main (int argc, char **argv)
715 stack_base = &dummy; 715 stack_base = &dummy;
716#endif 716#endif
717 717
718#if defined (USE_GTK) && defined (G_SLICE_ALWAYS_MALLOC) 718#ifdef G_SLICE_ALWAYS_MALLOC
719 /* This is used by the Cygwin build. */ 719 /* This is used by the Cygwin build. */
720 setenv ("G_SLICE", "always-malloc", 1); 720 setenv ("G_SLICE", "always-malloc", 1);
721#endif 721#endif
diff --git a/src/eval.c b/src/eval.c
index f8a76646352..34b20f6fc8e 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -114,7 +114,6 @@ Lisp_Object Vsignaling_function;
114Lisp_Object inhibit_lisp_code; 114Lisp_Object inhibit_lisp_code;
115 115
116static Lisp_Object funcall_lambda (Lisp_Object, ptrdiff_t, Lisp_Object *); 116static Lisp_Object funcall_lambda (Lisp_Object, ptrdiff_t, Lisp_Object *);
117static bool interactive_p (void);
118static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args); 117static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args);
119 118
120/* Functions to set Lisp_Object slots of struct specbinding. */ 119/* Functions to set Lisp_Object slots of struct specbinding. */
@@ -489,102 +488,6 @@ usage: (function ARG) */)
489} 488}
490 489
491 490
492DEFUN ("interactive-p", Finteractive_p, Sinteractive_p, 0, 0, 0,
493 doc: /* Return t if the containing function was run directly by user input.
494This means that the function was called with `call-interactively'
495\(which includes being called as the binding of a key)
496and input is currently coming from the keyboard (not a keyboard macro),
497and Emacs is not running in batch mode (`noninteractive' is nil).
498
499The only known proper use of `interactive-p' is in deciding whether to
500display a helpful message, or how to display it. If you're thinking
501of using it for any other purpose, it is quite likely that you're
502making a mistake. Think: what do you want to do when the command is
503called from a keyboard macro?
504
505To test whether your function was called with `call-interactively',
506either (i) add an extra optional argument and give it an `interactive'
507spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
508use `called-interactively-p'. */)
509 (void)
510{
511 return (INTERACTIVE && interactive_p ()) ? Qt : Qnil;
512}
513
514
515DEFUN ("called-interactively-p", Fcalled_interactively_p, Scalled_interactively_p, 0, 1, 0,
516 doc: /* Return t if the containing function was called by `call-interactively'.
517If KIND is `interactive', then only return t if the call was made
518interactively by the user, i.e. not in `noninteractive' mode nor
519when `executing-kbd-macro'.
520If KIND is `any', on the other hand, it will return t for any kind of
521interactive call, including being called as the binding of a key, or
522from a keyboard macro, or in `noninteractive' mode.
523
524The only known proper use of `interactive' for KIND is in deciding
525whether to display a helpful message, or how to display it. If you're
526thinking of using it for any other purpose, it is quite likely that
527you're making a mistake. Think: what do you want to do when the
528command is called from a keyboard macro?
529
530Instead of using this function, it is sometimes cleaner to give your
531function an extra optional argument whose `interactive' spec specifies
532non-nil unconditionally (\"p\" is a good way to do this), or via
533\(not (or executing-kbd-macro noninteractive)). */)
534 (Lisp_Object kind)
535{
536 return (((INTERACTIVE || !EQ (kind, intern ("interactive")))
537 && interactive_p ())
538 ? Qt : Qnil);
539}
540
541
542/* Return true if function in which this appears was called using
543 call-interactively and is not a built-in. */
544
545static bool
546interactive_p (void)
547{
548 struct backtrace *btp;
549 Lisp_Object fun;
550
551 btp = backtrace_list;
552
553 /* If this isn't a byte-compiled function, there may be a frame at
554 the top for Finteractive_p. If so, skip it. */
555 fun = Findirect_function (btp->function, Qnil);
556 if (SUBRP (fun) && (XSUBR (fun) == &Sinteractive_p
557 || XSUBR (fun) == &Scalled_interactively_p))
558 btp = btp->next;
559
560 /* If we're running an Emacs 18-style byte-compiled function, there
561 may be a frame for Fbytecode at the top level. In any version of
562 Emacs there can be Fbytecode frames for subexpressions evaluated
563 inside catch and condition-case. Skip past them.
564
565 If this isn't a byte-compiled function, then we may now be
566 looking at several frames for special forms. Skip past them. */
567 while (btp
568 && (EQ (btp->function, Qbytecode)
569 || btp->nargs == UNEVALLED))
570 btp = btp->next;
571
572 /* `btp' now points at the frame of the innermost function that isn't
573 a special form, ignoring frames for Finteractive_p and/or
574 Fbytecode at the top. If this frame is for a built-in function
575 (such as load or eval-region) return false. */
576 fun = Findirect_function (btp->function, Qnil);
577 if (SUBRP (fun))
578 return 0;
579
580 /* `btp' points to the frame of a Lisp function that called interactive-p.
581 Return t if that function was called interactively. */
582 if (btp && btp->next && EQ (btp->next->function, Qcall_interactively))
583 return 1;
584 return 0;
585}
586
587
588DEFUN ("defvaralias", Fdefvaralias, Sdefvaralias, 2, 3, 0, 491DEFUN ("defvaralias", Fdefvaralias, Sdefvaralias, 2, 3, 0,
589 doc: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE. 492 doc: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
590Aliased variables always have the same value; setting one sets the other. 493Aliased variables always have the same value; setting one sets the other.
@@ -696,8 +599,9 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
696 if (EQ ((--pdl)->symbol, sym) && !pdl->func 599 if (EQ ((--pdl)->symbol, sym) && !pdl->func
697 && EQ (pdl->old_value, Qunbound)) 600 && EQ (pdl->old_value, Qunbound))
698 { 601 {
699 message_with_string ("Warning: defvar ignored because %s is let-bound", 602 message_with_string
700 SYMBOL_NAME (sym), 1); 603 ("Warning: defvar ignored because %s is let-bound",
604 SYMBOL_NAME (sym), 1);
701 break; 605 break;
702 } 606 }
703 } 607 }
@@ -717,8 +621,8 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
717 /* A simple (defvar foo) with lexical scoping does "nothing" except 621 /* A simple (defvar foo) with lexical scoping does "nothing" except
718 declare that var to be dynamically scoped *locally* (i.e. within 622 declare that var to be dynamically scoped *locally* (i.e. within
719 the current file or let-block). */ 623 the current file or let-block). */
720 Vinternal_interpreter_environment = 624 Vinternal_interpreter_environment
721 Fcons (sym, Vinternal_interpreter_environment); 625 = Fcons (sym, Vinternal_interpreter_environment);
722 else 626 else
723 { 627 {
724 /* Simple (defvar <var>) should not count as a definition at all. 628 /* Simple (defvar <var>) should not count as a definition at all.
@@ -971,7 +875,7 @@ definitions to shadow the loaded ones for use in file byte-compilation. */)
971 if (NILP (tem)) 875 if (NILP (tem))
972 { 876 {
973 def = XSYMBOL (sym)->function; 877 def = XSYMBOL (sym)->function;
974 if (!EQ (def, Qunbound)) 878 if (!NILP (def))
975 continue; 879 continue;
976 } 880 }
977 break; 881 break;
@@ -986,7 +890,7 @@ definitions to shadow the loaded ones for use in file byte-compilation. */)
986 GCPRO1 (form); 890 GCPRO1 (form);
987 def = Fautoload_do_load (def, sym, Qmacro); 891 def = Fautoload_do_load (def, sym, Qmacro);
988 UNGCPRO; 892 UNGCPRO;
989 if (EQ (def, Qunbound) || !CONSP (def)) 893 if (!CONSP (def))
990 /* Not defined or definition not suitable. */ 894 /* Not defined or definition not suitable. */
991 break; 895 break;
992 if (!EQ (XCAR (def), Qmacro)) 896 if (!EQ (XCAR (def), Qmacro))
@@ -1811,12 +1715,12 @@ then strings and vectors are not accepted. */)
1811 1715
1812 fun = function; 1716 fun = function;
1813 1717
1814 fun = indirect_function (fun); /* Check cycles. */ 1718 fun = indirect_function (fun); /* Check cycles. */
1815 if (NILP (fun) || EQ (fun, Qunbound)) 1719 if (NILP (fun))
1816 return Qnil; 1720 return Qnil;
1817 1721
1818 /* Check an `interactive-form' property if present, analogous to the 1722 /* Check an `interactive-form' property if present, analogous to the
1819 function-documentation property. */ 1723 function-documentation property. */
1820 fun = function; 1724 fun = function;
1821 while (SYMBOLP (fun)) 1725 while (SYMBOLP (fun))
1822 { 1726 {
@@ -1876,7 +1780,7 @@ this does nothing and returns nil. */)
1876 CHECK_STRING (file); 1780 CHECK_STRING (file);
1877 1781
1878 /* If function is defined and not as an autoload, don't override. */ 1782 /* If function is defined and not as an autoload, don't override. */
1879 if (!EQ (XSYMBOL (function)->function, Qunbound) 1783 if (!NILP (XSYMBOL (function)->function)
1880 && !AUTOLOADP (XSYMBOL (function)->function)) 1784 && !AUTOLOADP (XSYMBOL (function)->function))
1881 return Qnil; 1785 return Qnil;
1882 1786
@@ -2055,7 +1959,7 @@ eval_sub (Lisp_Object form)
2055 1959
2056 /* Optimize for no indirection. */ 1960 /* Optimize for no indirection. */
2057 fun = original_fun; 1961 fun = original_fun;
2058 if (SYMBOLP (fun) && !EQ (fun, Qunbound) 1962 if (SYMBOLP (fun) && !NILP (fun)
2059 && (fun = XSYMBOL (fun)->function, SYMBOLP (fun))) 1963 && (fun = XSYMBOL (fun)->function, SYMBOLP (fun)))
2060 fun = indirect_function (fun); 1964 fun = indirect_function (fun);
2061 1965
@@ -2177,7 +2081,7 @@ eval_sub (Lisp_Object form)
2177 val = apply_lambda (fun, original_args); 2081 val = apply_lambda (fun, original_args);
2178 else 2082 else
2179 { 2083 {
2180 if (EQ (fun, Qunbound)) 2084 if (NILP (fun))
2181 xsignal1 (Qvoid_function, original_fun); 2085 xsignal1 (Qvoid_function, original_fun);
2182 if (!CONSP (fun)) 2086 if (!CONSP (fun))
2183 xsignal1 (Qinvalid_function, original_fun); 2087 xsignal1 (Qinvalid_function, original_fun);
@@ -2251,10 +2155,10 @@ usage: (apply FUNCTION &rest ARGUMENTS) */)
2251 numargs += nargs - 2; 2155 numargs += nargs - 2;
2252 2156
2253 /* Optimize for no indirection. */ 2157 /* Optimize for no indirection. */
2254 if (SYMBOLP (fun) && !EQ (fun, Qunbound) 2158 if (SYMBOLP (fun) && !NILP (fun)
2255 && (fun = XSYMBOL (fun)->function, SYMBOLP (fun))) 2159 && (fun = XSYMBOL (fun)->function, SYMBOLP (fun)))
2256 fun = indirect_function (fun); 2160 fun = indirect_function (fun);
2257 if (EQ (fun, Qunbound)) 2161 if (NILP (fun))
2258 { 2162 {
2259 /* Let funcall get the error. */ 2163 /* Let funcall get the error. */
2260 fun = args[0]; 2164 fun = args[0];
@@ -2728,7 +2632,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
2728 2632
2729 /* Optimize for no indirection. */ 2633 /* Optimize for no indirection. */
2730 fun = original_fun; 2634 fun = original_fun;
2731 if (SYMBOLP (fun) && !EQ (fun, Qunbound) 2635 if (SYMBOLP (fun) && !NILP (fun)
2732 && (fun = XSYMBOL (fun)->function, SYMBOLP (fun))) 2636 && (fun = XSYMBOL (fun)->function, SYMBOLP (fun)))
2733 fun = indirect_function (fun); 2637 fun = indirect_function (fun);
2734 2638
@@ -2816,7 +2720,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
2816 val = funcall_lambda (fun, numargs, args + 1); 2720 val = funcall_lambda (fun, numargs, args + 1);
2817 else 2721 else
2818 { 2722 {
2819 if (EQ (fun, Qunbound)) 2723 if (NILP (fun))
2820 xsignal1 (Qvoid_function, original_fun); 2724 xsignal1 (Qvoid_function, original_fun);
2821 if (!CONSP (fun)) 2725 if (!CONSP (fun))
2822 xsignal1 (Qinvalid_function, original_fun); 2726 xsignal1 (Qinvalid_function, original_fun);
@@ -3551,8 +3455,6 @@ alist of active lexical bindings. */);
3551 defsubr (&Sunwind_protect); 3455 defsubr (&Sunwind_protect);
3552 defsubr (&Scondition_case); 3456 defsubr (&Scondition_case);
3553 defsubr (&Ssignal); 3457 defsubr (&Ssignal);
3554 defsubr (&Sinteractive_p);
3555 defsubr (&Scalled_interactively_p);
3556 defsubr (&Scommandp); 3458 defsubr (&Scommandp);
3557 defsubr (&Sautoload); 3459 defsubr (&Sautoload);
3558 defsubr (&Sautoload_do_load); 3460 defsubr (&Sautoload_do_load);
diff --git a/src/fileio.c b/src/fileio.c
index 572f6d8ef83..442c66550d3 100644
--- a/src/fileio.c
+++ b/src/fileio.c
@@ -315,6 +315,7 @@ Given a Unix syntax file name, returns a string ending in slash. */)
315 register const char *beg; 315 register const char *beg;
316#else 316#else
317 register char *beg; 317 register char *beg;
318 Lisp_Object tem_fn;
318#endif 319#endif
319 register const char *p; 320 register const char *p;
320 Lisp_Object handler; 321 Lisp_Object handler;
@@ -374,10 +375,13 @@ Given a Unix syntax file name, returns a string ending in slash. */)
374 p = beg + strlen (beg); 375 p = beg + strlen (beg);
375 } 376 }
376 } 377 }
377 dostounix_filename (beg); 378 tem_fn = ENCODE_FILE (make_specified_string (beg, -1, p - beg,
378#endif /* DOS_NT */ 379 STRING_MULTIBYTE (filename)));
379 380 dostounix_filename (SSDATA (tem_fn));
381 return DECODE_FILE (tem_fn);
382#else /* DOS_NT */
380 return make_specified_string (beg, -1, p - beg, STRING_MULTIBYTE (filename)); 383 return make_specified_string (beg, -1, p - beg, STRING_MULTIBYTE (filename));
384#endif /* DOS_NT */
381} 385}
382 386
383DEFUN ("file-name-nondirectory", Ffile_name_nondirectory, 387DEFUN ("file-name-nondirectory", Ffile_name_nondirectory,
@@ -951,7 +955,18 @@ filesystem tree, not (expand-file-name ".." dirname). */)
951#ifdef DOS_NT 955#ifdef DOS_NT
952 /* Make sure directories are all separated with /, but 956 /* Make sure directories are all separated with /, but
953 avoid allocation of a new string when not required. */ 957 avoid allocation of a new string when not required. */
954 dostounix_filename (nm); 958 if (multibyte)
959 {
960 Lisp_Object tem_name = make_specified_string (nm, -1, strlen (nm),
961 multibyte);
962
963 tem_name = ENCODE_FILE (tem_name);
964 dostounix_filename (SSDATA (tem_name));
965 tem_name = DECODE_FILE (tem_name);
966 memcpy (nm, SSDATA (tem_name), SBYTES (tem_name) + 1);
967 }
968 else
969 dostounix_filename (nm);
955#ifdef WINDOWSNT 970#ifdef WINDOWSNT
956 if (IS_DIRECTORY_SEP (nm[1])) 971 if (IS_DIRECTORY_SEP (nm[1]))
957 { 972 {
@@ -1133,7 +1148,7 @@ filesystem tree, not (expand-file-name ".." dirname). */)
1133 newdir = "/"; 1148 newdir = "/";
1134 } 1149 }
1135 else 1150 else
1136 getwd (adir); 1151 getcwd (adir, MAXPATHLEN + 1);
1137 newdir = adir; 1152 newdir = adir;
1138 } 1153 }
1139 1154
@@ -1305,10 +1320,13 @@ filesystem tree, not (expand-file-name ".." dirname). */)
1305 target[0] = '/'; 1320 target[0] = '/';
1306 target[1] = ':'; 1321 target[1] = ':';
1307 } 1322 }
1308 dostounix_filename (target);
1309#endif /* DOS_NT */
1310
1311 result = make_specified_string (target, -1, o - target, multibyte); 1323 result = make_specified_string (target, -1, o - target, multibyte);
1324 result = ENCODE_FILE (result);
1325 dostounix_filename (SSDATA (result));
1326 result = DECODE_FILE (result);
1327#else /* !DOS_NT */
1328 result = make_specified_string (target, -1, o - target, multibyte);
1329#endif /* !DOS_NT */
1312 } 1330 }
1313 1331
1314 /* Again look to see if the file name has special constructs in it 1332 /* Again look to see if the file name has special constructs in it
@@ -1587,8 +1605,18 @@ those `/' is discarded. */)
1587 memcpy (nm, SDATA (filename), SBYTES (filename) + 1); 1605 memcpy (nm, SDATA (filename), SBYTES (filename) + 1);
1588 1606
1589#ifdef DOS_NT 1607#ifdef DOS_NT
1590 dostounix_filename (nm); 1608 {
1591 substituted = (strcmp (nm, SDATA (filename)) != 0); 1609 Lisp_Object encoded_filename = ENCODE_FILE (filename);
1610 Lisp_Object tem_fn;
1611
1612 dostounix_filename (SDATA (encoded_filename));
1613 tem_fn = DECODE_FILE (encoded_filename);
1614 nm = alloca (SBYTES (tem_fn) + 1);
1615 memcpy (nm, SDATA (tem_fn), SBYTES (tem_fn) + 1);
1616 substituted = (memcmp (nm, SDATA (filename), SBYTES (filename)) != 0);
1617 if (substituted)
1618 filename = tem_fn;
1619 }
1592#endif 1620#endif
1593 endp = nm + SBYTES (filename); 1621 endp = nm + SBYTES (filename);
1594 1622
diff --git a/src/frame.h b/src/frame.h
index 35cbc44becc..87c4fcb0555 100644
--- a/src/frame.h
+++ b/src/frame.h
@@ -933,6 +933,21 @@ typedef struct frame *FRAME_PTR;
933 && (frame_var = XCAR (list_var), 1)); \ 933 && (frame_var = XCAR (list_var), 1)); \
934 list_var = XCDR (list_var)) 934 list_var = XCDR (list_var))
935 935
936/* Reflect mouse movement when a complete frame update is performed. */
937
938#define FRAME_MOUSE_UPDATE(frame) \
939 do { \
940 Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (frame); \
941 if (frame == hlinfo->mouse_face_mouse_frame) \
942 { \
943 block_input (); \
944 if (hlinfo->mouse_face_mouse_frame) \
945 note_mouse_highlight (hlinfo->mouse_face_mouse_frame, \
946 hlinfo->mouse_face_mouse_x, \
947 hlinfo->mouse_face_mouse_y); \
948 unblock_input (); \
949 } \
950 } while (0)
936 951
937extern Lisp_Object Qframep, Qframe_live_p; 952extern Lisp_Object Qframep, Qframe_live_p;
938extern Lisp_Object Qtty, Qtty_type; 953extern Lisp_Object Qtty, Qtty_type;
diff --git a/src/lisp.h b/src/lisp.h
index 67ae28a488f..419176d06c8 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -1104,7 +1104,7 @@ struct Lisp_Symbol
1104 union Lisp_Fwd *fwd; 1104 union Lisp_Fwd *fwd;
1105 } val; 1105 } val;
1106 1106
1107 /* Function value of the symbol or Qunbound if not fboundp. */ 1107 /* Function value of the symbol or Qnil if not fboundp. */
1108 Lisp_Object function; 1108 Lisp_Object function;
1109 1109
1110 /* The symbol's property list. */ 1110 /* The symbol's property list. */
@@ -1649,10 +1649,6 @@ typedef struct {
1649 int mouse_face_face_id; 1649 int mouse_face_face_id;
1650 Lisp_Object mouse_face_overlay; 1650 Lisp_Object mouse_face_overlay;
1651 1651
1652 /* 1 if a mouse motion event came and we didn't handle it right away because
1653 gc was in progress. */
1654 int mouse_face_deferred_gc;
1655
1656 /* FRAME and X, Y position of mouse when last checked for 1652 /* FRAME and X, Y position of mouse when last checked for
1657 highlighting. X and Y can be negative or out of range for the frame. */ 1653 highlighting. X and Y can be negative or out of range for the frame. */
1658 struct frame *mouse_face_mouse_frame; 1654 struct frame *mouse_face_mouse_frame;
diff --git a/src/lread.c b/src/lread.c
index 5859a2f85a9..6d0ff9f780e 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -3957,12 +3957,13 @@ init_obarray (void)
3957 /* Fmake_symbol inits fields of new symbols with Qunbound and Qnil, 3957 /* Fmake_symbol inits fields of new symbols with Qunbound and Qnil,
3958 so those two need to be fixed manually. */ 3958 so those two need to be fixed manually. */
3959 SET_SYMBOL_VAL (XSYMBOL (Qunbound), Qunbound); 3959 SET_SYMBOL_VAL (XSYMBOL (Qunbound), Qunbound);
3960 set_symbol_function (Qunbound, Qunbound); 3960 set_symbol_function (Qunbound, Qnil);
3961 set_symbol_plist (Qunbound, Qnil); 3961 set_symbol_plist (Qunbound, Qnil);
3962 SET_SYMBOL_VAL (XSYMBOL (Qnil), Qnil); 3962 SET_SYMBOL_VAL (XSYMBOL (Qnil), Qnil);
3963 XSYMBOL (Qnil)->constant = 1; 3963 XSYMBOL (Qnil)->constant = 1;
3964 XSYMBOL (Qnil)->declared_special = 1; 3964 XSYMBOL (Qnil)->declared_special = 1;
3965 set_symbol_plist (Qnil, Qnil); 3965 set_symbol_plist (Qnil, Qnil);
3966 set_symbol_function (Qnil, Qnil);
3966 3967
3967 Qt = intern_c_string ("t"); 3968 Qt = intern_c_string ("t");
3968 SET_SYMBOL_VAL (XSYMBOL (Qt), Qt); 3969 SET_SYMBOL_VAL (XSYMBOL (Qt), Qt);
diff --git a/src/makefile.w32-in b/src/makefile.w32-in
index 9778e955677..a296f6eb393 100644
--- a/src/makefile.w32-in
+++ b/src/makefile.w32-in
@@ -229,12 +229,12 @@ SOME_MACHINE_OBJECTS = dosfns.o msdos.o \
229obj = $(GLOBAL_SOURCES:.c=.o) 229obj = $(GLOBAL_SOURCES:.c=.o)
230 230
231globals.h: gl-stamp 231globals.h: gl-stamp
232 @cmd /c rem true 232 @cmd $(SWITCHCHAR)c rem true
233 233
234gl-stamp: ../lib-src/$(BLD)/make-docfile.exe $(GLOBAL_SOURCES) 234gl-stamp: ../lib-src/$(BLD)/make-docfile.exe $(GLOBAL_SOURCES)
235 - $(DEL) gl-tmp 235 - $(DEL) gl-tmp
236 "$(THISDIR)/../lib-src/$(BLD)/make-docfile" -d . -g $(SOME_MACHINE_OBJECTS) $(obj) > gl-tmp 236 "$(THISDIR)/../lib-src/$(BLD)/make-docfile" -d . -g $(SOME_MACHINE_OBJECTS) $(obj) > gl-tmp
237 cmd /c "fc /b gl-tmp globals.h >nul 2>&1 || $(CP) gl-tmp globals.h" 237 fc.exe $(SWITCHCHAR)b gl-tmp globals.h >nul 2>&1 || $(CP) gl-tmp globals.h
238 - $(DEL) gl-tmp 238 - $(DEL) gl-tmp
239 echo timestamp > $@ 239 echo timestamp > $@
240 240
@@ -413,8 +413,6 @@ CONF_POST_H = $(SRC)/conf_post.h \
413 $(MS_W32_H) 413 $(MS_W32_H)
414CONFIG_H = $(SRC)/config.h \ 414CONFIG_H = $(SRC)/config.h \
415 $(CONF_POST_H) 415 $(CONF_POST_H)
416DIR_H = $(NT_INC)/sys/dir.h \
417 $(SRC)/ndir.h
418W32GUI_H = $(SRC)/w32gui.h \ 416W32GUI_H = $(SRC)/w32gui.h \
419 $(SYSTIME_H) 417 $(SYSTIME_H)
420DISPEXTERN_H = $(SRC)/dispextern.h \ 418DISPEXTERN_H = $(SRC)/dispextern.h \
@@ -714,6 +712,7 @@ $(BLD)/dired.$(O) : \
714 $(SRC)/blockinput.h \ 712 $(SRC)/blockinput.h \
715 $(SRC)/commands.h \ 713 $(SRC)/commands.h \
716 $(SRC)/regex.h \ 714 $(SRC)/regex.h \
715 $(NT_INC)/dirent.h \
717 $(NT_INC)/pwd.h \ 716 $(NT_INC)/pwd.h \
718 $(NT_INC)/sys/stat.h \ 717 $(NT_INC)/sys/stat.h \
719 $(NT_INC)/unistd.h \ 718 $(NT_INC)/unistd.h \
@@ -722,7 +721,6 @@ $(BLD)/dired.$(O) : \
722 $(CHARSET_H) \ 721 $(CHARSET_H) \
723 $(CODING_H) \ 722 $(CODING_H) \
724 $(CONFIG_H) \ 723 $(CONFIG_H) \
725 $(DIR_H) \
726 $(FILEMODE_H) \ 724 $(FILEMODE_H) \
727 $(GRP_H) \ 725 $(GRP_H) \
728 $(LISP_H) \ 726 $(LISP_H) \
@@ -1175,11 +1173,11 @@ $(BLD)/minibuf.$(O) : \
1175 1173
1176$(BLD)/w32.$(O) : \ 1174$(BLD)/w32.$(O) : \
1177 $(SRC)/w32.c \ 1175 $(SRC)/w32.c \
1178 $(SRC)/ndir.h \
1179 $(SRC)/w32.h \ 1176 $(SRC)/w32.h \
1180 $(SRC)/w32common.h \ 1177 $(SRC)/w32common.h \
1181 $(SRC)/w32heap.h \ 1178 $(SRC)/w32heap.h \
1182 $(SRC)/w32select.h \ 1179 $(SRC)/w32select.h \
1180 $(NT_INC)/dirent.h \
1183 $(NT_INC)/pwd.h \ 1181 $(NT_INC)/pwd.h \
1184 $(NT_INC)/sys/file.h \ 1182 $(NT_INC)/sys/file.h \
1185 $(NT_INC)/sys/time.h \ 1183 $(NT_INC)/sys/time.h \
diff --git a/src/msdos.c b/src/msdos.c
index dd05a8b2c5d..433bf1074d8 100644
--- a/src/msdos.c
+++ b/src/msdos.c
@@ -1275,7 +1275,6 @@ IT_update_begin (struct frame *f)
1275 hlinfo->mouse_face_beg_row = hlinfo->mouse_face_beg_col = -1; 1275 hlinfo->mouse_face_beg_row = hlinfo->mouse_face_beg_col = -1;
1276 hlinfo->mouse_face_end_row = hlinfo->mouse_face_end_col = -1; 1276 hlinfo->mouse_face_end_row = hlinfo->mouse_face_end_col = -1;
1277 hlinfo->mouse_face_window = Qnil; 1277 hlinfo->mouse_face_window = Qnil;
1278 hlinfo->mouse_face_deferred_gc = 0;
1279 hlinfo->mouse_face_mouse_frame = NULL; 1278 hlinfo->mouse_face_mouse_frame = NULL;
1280 } 1279 }
1281 1280
@@ -1295,21 +1294,10 @@ IT_update_end (struct frame *f)
1295static void 1294static void
1296IT_frame_up_to_date (struct frame *f) 1295IT_frame_up_to_date (struct frame *f)
1297{ 1296{
1298 Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (f);
1299 Lisp_Object new_cursor, frame_desired_cursor; 1297 Lisp_Object new_cursor, frame_desired_cursor;
1300 struct window *sw; 1298 struct window *sw;
1301 1299
1302 if (hlinfo->mouse_face_deferred_gc 1300 FRAME_MOUSE_UPDATE (f);
1303 || (f && f == hlinfo->mouse_face_mouse_frame))
1304 {
1305 block_input ();
1306 if (hlinfo->mouse_face_mouse_frame)
1307 note_mouse_highlight (hlinfo->mouse_face_mouse_frame,
1308 hlinfo->mouse_face_mouse_x,
1309 hlinfo->mouse_face_mouse_y);
1310 hlinfo->mouse_face_deferred_gc = 0;
1311 unblock_input ();
1312 }
1313 1301
1314 /* Set the cursor type to whatever they wanted. In a minibuffer 1302 /* Set the cursor type to whatever they wanted. In a minibuffer
1315 window, we want the cursor to appear only if we are reading input 1303 window, we want the cursor to appear only if we are reading input
@@ -1849,7 +1837,6 @@ internal_terminal_init (void)
1849 FRAME_BACKGROUND_PIXEL (SELECTED_FRAME ()) = colors[1]; 1837 FRAME_BACKGROUND_PIXEL (SELECTED_FRAME ()) = colors[1];
1850 } 1838 }
1851 the_only_display_info.mouse_highlight.mouse_face_mouse_frame = NULL; 1839 the_only_display_info.mouse_highlight.mouse_face_mouse_frame = NULL;
1852 the_only_display_info.mouse_highlight.mouse_face_deferred_gc = 0;
1853 the_only_display_info.mouse_highlight.mouse_face_beg_row = 1840 the_only_display_info.mouse_highlight.mouse_face_beg_row =
1854 the_only_display_info.mouse_highlight.mouse_face_beg_col = -1; 1841 the_only_display_info.mouse_highlight.mouse_face_beg_col = -1;
1855 the_only_display_info.mouse_highlight.mouse_face_end_row = 1842 the_only_display_info.mouse_highlight.mouse_face_end_row =
diff --git a/src/nsterm.m b/src/nsterm.m
index 57d32ee0528..25eb7ebc495 100644
--- a/src/nsterm.m
+++ b/src/nsterm.m
@@ -1186,7 +1186,6 @@ x_free_frame_resources (struct frame *f)
1186 hlinfo->mouse_face_beg_row = hlinfo->mouse_face_beg_col = -1; 1186 hlinfo->mouse_face_beg_row = hlinfo->mouse_face_beg_col = -1;
1187 hlinfo->mouse_face_end_row = hlinfo->mouse_face_end_col = -1; 1187 hlinfo->mouse_face_end_row = hlinfo->mouse_face_end_col = -1;
1188 hlinfo->mouse_face_window = Qnil; 1188 hlinfo->mouse_face_window = Qnil;
1189 hlinfo->mouse_face_deferred_gc = 0;
1190 hlinfo->mouse_face_mouse_frame = 0; 1189 hlinfo->mouse_face_mouse_frame = 0;
1191 } 1190 }
1192 1191
@@ -1887,8 +1886,7 @@ static void
1887ns_frame_up_to_date (struct frame *f) 1886ns_frame_up_to_date (struct frame *f)
1888/* -------------------------------------------------------------------------- 1887/* --------------------------------------------------------------------------
1889 External (hook): Fix up mouse highlighting right after a full update. 1888 External (hook): Fix up mouse highlighting right after a full update.
1890 Some highlighting was deferred if GC was happening during 1889 Can't use FRAME_MOUSE_UPDATE due to ns_frame_begin and ns_frame_end calls.
1891 note_mouse_highlight (), while other highlighting was deferred for update.
1892 -------------------------------------------------------------------------- */ 1890 -------------------------------------------------------------------------- */
1893{ 1891{
1894 NSTRACE (ns_frame_up_to_date); 1892 NSTRACE (ns_frame_up_to_date);
@@ -1896,19 +1894,17 @@ ns_frame_up_to_date (struct frame *f)
1896 if (FRAME_NS_P (f)) 1894 if (FRAME_NS_P (f))
1897 { 1895 {
1898 Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (f); 1896 Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (f);
1899 if ((hlinfo->mouse_face_deferred_gc || f ==hlinfo->mouse_face_mouse_frame) 1897 if (f == hlinfo->mouse_face_mouse_frame)
1900 /*&& hlinfo->mouse_face_mouse_frame*/) 1898 {
1901 { 1899 block_input ();
1902 block_input ();
1903 ns_update_begin(f); 1900 ns_update_begin(f);
1904 if (hlinfo->mouse_face_mouse_frame) 1901 if (hlinfo->mouse_face_mouse_frame)
1905 note_mouse_highlight (hlinfo->mouse_face_mouse_frame, 1902 note_mouse_highlight (hlinfo->mouse_face_mouse_frame,
1906 hlinfo->mouse_face_mouse_x, 1903 hlinfo->mouse_face_mouse_x,
1907 hlinfo->mouse_face_mouse_y); 1904 hlinfo->mouse_face_mouse_y);
1908 hlinfo->mouse_face_deferred_gc = 0;
1909 ns_update_end(f); 1905 ns_update_end(f);
1910 unblock_input (); 1906 unblock_input ();
1911 } 1907 }
1912 } 1908 }
1913} 1909}
1914 1910
@@ -3869,7 +3865,6 @@ ns_initialize_display_info (struct ns_display_info *dpyinfo)
3869 dpyinfo->root_window = 42; /* a placeholder.. */ 3865 dpyinfo->root_window = 42; /* a placeholder.. */
3870 3866
3871 hlinfo->mouse_face_mouse_frame = NULL; 3867 hlinfo->mouse_face_mouse_frame = NULL;
3872 hlinfo->mouse_face_deferred_gc = 0;
3873 hlinfo->mouse_face_beg_row = hlinfo->mouse_face_beg_col = -1; 3868 hlinfo->mouse_face_beg_row = hlinfo->mouse_face_beg_col = -1;
3874 hlinfo->mouse_face_end_row = hlinfo->mouse_face_end_col = -1; 3869 hlinfo->mouse_face_end_row = hlinfo->mouse_face_end_col = -1;
3875 hlinfo->mouse_face_face_id = DEFAULT_FACE_ID; 3870 hlinfo->mouse_face_face_id = DEFAULT_FACE_ID;
diff --git a/src/sysdep.c b/src/sysdep.c
index 7c5c144fa8c..bc4dc91509f 100644
--- a/src/sysdep.c
+++ b/src/sysdep.c
@@ -101,7 +101,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
101#define _P_WAIT 0 101#define _P_WAIT 0
102int _cdecl _spawnlp (int, const char *, const char *, ...); 102int _cdecl _spawnlp (int, const char *, const char *, ...);
103int _cdecl _getpid (void); 103int _cdecl _getpid (void);
104extern char *getwd (char *);
105#endif 104#endif
106 105
107#include "syssignal.h" 106#include "syssignal.h"
@@ -134,12 +133,12 @@ char*
134get_current_dir_name (void) 133get_current_dir_name (void)
135{ 134{
136 char *buf; 135 char *buf;
137 char *pwd; 136 char *pwd = getenv ("PWD");
138 struct stat dotstat, pwdstat; 137 struct stat dotstat, pwdstat;
139 /* If PWD is accurate, use it instead of calling getwd. PWD is 138 /* If PWD is accurate, use it instead of calling getcwd. PWD is
140 sometimes a nicer name, and using it may avoid a fatal error if a 139 sometimes a nicer name, and using it may avoid a fatal error if a
141 parent directory is searchable but not readable. */ 140 parent directory is searchable but not readable. */
142 if ((pwd = getenv ("PWD")) != 0 141 if (pwd
143 && (IS_DIRECTORY_SEP (*pwd) || (*pwd && IS_DEVICE_SEP (pwd[1]))) 142 && (IS_DIRECTORY_SEP (*pwd) || (*pwd && IS_DEVICE_SEP (pwd[1])))
144 && stat (pwd, &pwdstat) == 0 143 && stat (pwd, &pwdstat) == 0
145 && stat (".", &dotstat) == 0 144 && stat (".", &dotstat) == 0
@@ -155,7 +154,6 @@ get_current_dir_name (void)
155 return NULL; 154 return NULL;
156 strcpy (buf, pwd); 155 strcpy (buf, pwd);
157 } 156 }
158#ifdef HAVE_GETCWD
159 else 157 else
160 { 158 {
161 size_t buf_size = 1024; 159 size_t buf_size = 1024;
@@ -179,22 +177,6 @@ get_current_dir_name (void)
179 return NULL; 177 return NULL;
180 } 178 }
181 } 179 }
182#else
183 else
184 {
185 /* We need MAXPATHLEN here. */
186 buf = malloc (MAXPATHLEN + 1);
187 if (!buf)
188 return NULL;
189 if (getwd (buf) == NULL)
190 {
191 int tmp_errno = errno;
192 free (buf);
193 errno = tmp_errno;
194 return NULL;
195 }
196 }
197#endif
198 return buf; 180 return buf;
199} 181}
200#endif 182#endif
@@ -521,7 +503,7 @@ sys_subshell (void)
521 const char *sh = 0; 503 const char *sh = 0;
522 504
523#ifdef DOS_NT /* MW, Aug 1993 */ 505#ifdef DOS_NT /* MW, Aug 1993 */
524 getwd (oldwd); 506 getcwd (oldwd, sizeof oldwd);
525 if (sh == 0) 507 if (sh == 0)
526 sh = (char *) egetenv ("SUSPEND"); /* KFS, 1994-12-14 */ 508 sh = (char *) egetenv ("SUSPEND"); /* KFS, 1994-12-14 */
527#endif 509#endif
@@ -2238,82 +2220,6 @@ emacs_readlink (char const *filename, char initial_buf[READLINK_BUFSIZE])
2238 &emacs_norealloc_allocator, careadlinkatcwd); 2220 &emacs_norealloc_allocator, careadlinkatcwd);
2239} 2221}
2240 2222
2241#ifdef USG
2242/*
2243 * All of the following are for USG.
2244 *
2245 * On USG systems the system calls are INTERRUPTIBLE by signals
2246 * that the user program has elected to catch. Thus the system call
2247 * must be retried in these cases. To handle this without massive
2248 * changes in the source code, we remap the standard system call names
2249 * to names for our own functions in sysdep.c that do the system call
2250 * with retries. Actually, for portability reasons, it is good
2251 * programming practice, as this example shows, to limit all actual
2252 * system calls to a single occurrence in the source. Sure, this
2253 * adds an extra level of function call overhead but it is almost
2254 * always negligible. Fred Fish, Unisoft Systems Inc.
2255 */
2256
2257/*
2258 * Warning, this function may not duplicate 4.2 action properly
2259 * under error conditions.
2260 */
2261
2262#if !defined (HAVE_GETWD) || defined (BROKEN_GETWD)
2263
2264#ifndef MAXPATHLEN
2265/* In 4.1, param.h fails to define this. */
2266#define MAXPATHLEN 1024
2267#endif
2268
2269char *
2270getwd (char *pathname)
2271{
2272 char *npath, *spath;
2273 extern char *getcwd (char *, size_t);
2274
2275 block_input (); /* getcwd uses malloc */
2276 spath = npath = getcwd ((char *) 0, MAXPATHLEN);
2277 if (spath == 0)
2278 {
2279 unblock_input ();
2280 return spath;
2281 }
2282 /* On Altos 3068, getcwd can return @hostname/dir, so discard
2283 up to first slash. Should be harmless on other systems. */
2284 while (*npath && *npath != '/')
2285 npath++;
2286 strcpy (pathname, npath);
2287 free (spath); /* getcwd uses malloc */
2288 unblock_input ();
2289 return pathname;
2290}
2291
2292#endif /* !defined (HAVE_GETWD) || defined (BROKEN_GETWD) */
2293#endif /* USG */
2294
2295/* Directory routines for systems that don't have them. */
2296
2297#ifdef HAVE_DIRENT_H
2298
2299#include <dirent.h>
2300
2301#if !defined (HAVE_CLOSEDIR)
2302
2303int
2304closedir (DIR *dirp /* stream from opendir */)
2305{
2306 int rtnval;
2307
2308 rtnval = emacs_close (dirp->dd_fd);
2309 xfree (dirp);
2310
2311 return rtnval;
2312}
2313#endif /* not HAVE_CLOSEDIR */
2314#endif /* HAVE_DIRENT_H */
2315
2316
2317/* Return a struct timeval that is roughly equivalent to T. 2223/* Return a struct timeval that is roughly equivalent to T.
2318 Use the least timeval not less than T. 2224 Use the least timeval not less than T.
2319 Return an extremal value if the result would overflow. */ 2225 Return an extremal value if the result would overflow. */
diff --git a/src/w32.c b/src/w32.c
index 94cf472a4ae..c8e16dfaa94 100644
--- a/src/w32.c
+++ b/src/w32.c
@@ -119,9 +119,10 @@ typedef struct _PROCESS_MEMORY_COUNTERS_EX {
119#include <aclapi.h> 119#include <aclapi.h>
120 120
121#ifdef _MSC_VER 121#ifdef _MSC_VER
122/* MSVC doesn't provide the definition of REPARSE_DATA_BUFFER, except 122/* MSVC doesn't provide the definition of REPARSE_DATA_BUFFER and the
123 on ntifs.h, which cannot be included because it triggers conflicts 123 associated macros, except on ntifs.h, which cannot be included
124 with other Windows API headers. So we define it here by hand. */ 124 because it triggers conflicts with other Windows API headers. So
125 we define it here by hand. */
125 126
126typedef struct _REPARSE_DATA_BUFFER { 127typedef struct _REPARSE_DATA_BUFFER {
127 ULONG ReparseTag; 128 ULONG ReparseTag;
@@ -149,6 +150,12 @@ typedef struct _REPARSE_DATA_BUFFER {
149 } DUMMYUNIONNAME; 150 } DUMMYUNIONNAME;
150} REPARSE_DATA_BUFFER, *PREPARSE_DATA_BUFFER; 151} REPARSE_DATA_BUFFER, *PREPARSE_DATA_BUFFER;
151 152
153#define FILE_DEVICE_FILE_SYSTEM 9
154#define METHOD_BUFFERED 0
155#define FILE_ANY_ACCESS 0x00000000
156#define CTL_CODE(t,f,m,a) (((t)<<16)|((a)<<14)|((f)<<2)|(m))
157#define FSCTL_GET_REPARSE_POINT \
158 CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 42, METHOD_BUFFERED, FILE_ANY_ACCESS)
152#endif 159#endif
153 160
154/* TCP connection support. */ 161/* TCP connection support. */
@@ -172,7 +179,7 @@ typedef struct _REPARSE_DATA_BUFFER {
172#undef sendto 179#undef sendto
173 180
174#include "w32.h" 181#include "w32.h"
175#include "ndir.h" 182#include <dirent.h>
176#include "w32common.h" 183#include "w32common.h"
177#include "w32heap.h" 184#include "w32heap.h"
178#include "w32select.h" 185#include "w32select.h"
@@ -901,8 +908,18 @@ static char startup_dir[MAXPATHLEN];
901 908
902/* Get the current working directory. */ 909/* Get the current working directory. */
903char * 910char *
904getwd (char *dir) 911getcwd (char *dir, int dirsize)
905{ 912{
913 if (!dirsize)
914 {
915 errno = EINVAL;
916 return NULL;
917 }
918 if (dirsize <= strlen (startup_dir))
919 {
920 errno = ERANGE;
921 return NULL;
922 }
906#if 0 923#if 0
907 if (GetCurrentDirectory (MAXPATHLEN, dir) > 0) 924 if (GetCurrentDirectory (MAXPATHLEN, dir) > 0)
908 return dir; 925 return dir;
@@ -1818,7 +1835,7 @@ init_environment (char ** argv)
1818 memcpy (*envp, "COMSPEC=", 8); 1835 memcpy (*envp, "COMSPEC=", 8);
1819 } 1836 }
1820 1837
1821 /* Remember the initial working directory for getwd. */ 1838 /* Remember the initial working directory for getcwd. */
1822 /* FIXME: Do we need to resolve possible symlinks in startup_dir? 1839 /* FIXME: Do we need to resolve possible symlinks in startup_dir?
1823 Does it matter anywhere in Emacs? */ 1840 Does it matter anywhere in Emacs? */
1824 if (!GetCurrentDirectory (MAXPATHLEN, startup_dir)) 1841 if (!GetCurrentDirectory (MAXPATHLEN, startup_dir))
@@ -2431,7 +2448,7 @@ is_exec (const char * name)
2431 and readdir. We can't use the procedures supplied in sysdep.c, 2448 and readdir. We can't use the procedures supplied in sysdep.c,
2432 so we provide them here. */ 2449 so we provide them here. */
2433 2450
2434struct direct dir_static; /* simulated directory contents */ 2451struct dirent dir_static; /* simulated directory contents */
2435static HANDLE dir_find_handle = INVALID_HANDLE_VALUE; 2452static HANDLE dir_find_handle = INVALID_HANDLE_VALUE;
2436static int dir_is_fat; 2453static int dir_is_fat;
2437static char dir_pathname[MAXPATHLEN+1]; 2454static char dir_pathname[MAXPATHLEN+1];
@@ -2501,7 +2518,7 @@ closedir (DIR *dirp)
2501 xfree ((char *) dirp); 2518 xfree ((char *) dirp);
2502} 2519}
2503 2520
2504struct direct * 2521struct dirent *
2505readdir (DIR *dirp) 2522readdir (DIR *dirp)
2506{ 2523{
2507 int downcase = !NILP (Vw32_downcase_file_names); 2524 int downcase = !NILP (Vw32_downcase_file_names);
@@ -2555,7 +2572,7 @@ readdir (DIR *dirp)
2555 downcase = 1; /* 8+3 aliases are returned in all caps */ 2572 downcase = 1; /* 8+3 aliases are returned in all caps */
2556 } 2573 }
2557 dir_static.d_namlen = strlen (dir_static.d_name); 2574 dir_static.d_namlen = strlen (dir_static.d_name);
2558 dir_static.d_reclen = sizeof (struct direct) - MAXNAMLEN + 3 + 2575 dir_static.d_reclen = sizeof (struct dirent) - MAXNAMLEN + 3 +
2559 dir_static.d_namlen - dir_static.d_namlen % 4; 2576 dir_static.d_namlen - dir_static.d_namlen % 4;
2560 2577
2561 /* If the file name in cFileName[] includes `?' characters, it means 2578 /* If the file name in cFileName[] includes `?' characters, it means
diff --git a/src/w32.h b/src/w32.h
index 8309a3cc23d..23eda830268 100644
--- a/src/w32.h
+++ b/src/w32.h
@@ -163,7 +163,6 @@ extern int sys_spawnve (int, char *, char **, char **);
163extern void register_child (int, int); 163extern void register_child (int, int);
164 164
165extern void sys_sleep (int); 165extern void sys_sleep (int);
166extern char *getwd (char *);
167extern int sys_link (const char *, const char *); 166extern int sys_link (const char *, const char *);
168 167
169 168
@@ -181,4 +180,3 @@ extern ssize_t emacs_gnutls_push (gnutls_transport_ptr_t p,
181#endif /* HAVE_GNUTLS */ 180#endif /* HAVE_GNUTLS */
182 181
183#endif /* EMACS_W32_H */ 182#endif /* EMACS_W32_H */
184
diff --git a/src/w32fns.c b/src/w32fns.c
index ed5625e802c..90f5b1695ea 100644
--- a/src/w32fns.c
+++ b/src/w32fns.c
@@ -6167,9 +6167,9 @@ Otherwise, if ONLY-DIR-P is non-nil, the user can only select directories. */)
6167 filename = empty_unibyte_string; 6167 filename = empty_unibyte_string;
6168 6168
6169#ifdef CYGWIN 6169#ifdef CYGWIN
6170 dir = Fcygwin_convert_path_to_windows (dir, Qt); 6170 dir = Fcygwin_convert_file_name_to_windows (dir, Qt);
6171 if (SCHARS (filename) > 0) 6171 if (SCHARS (filename) > 0)
6172 filename = Fcygwin_convert_path_to_windows (filename, Qnil); 6172 filename = Fcygwin_convert_file_name_to_windows (filename, Qnil);
6173#endif 6173#endif
6174 6174
6175 CHECK_STRING (dir); 6175 CHECK_STRING (dir);
@@ -6270,7 +6270,7 @@ Otherwise, if ONLY-DIR-P is non-nil, the user can only select directories. */)
6270#endif /* NTGUI_UNICODE */ 6270#endif /* NTGUI_UNICODE */
6271 6271
6272#ifdef CYGWIN 6272#ifdef CYGWIN
6273 filename = Fcygwin_convert_path_from_windows (filename, Qt); 6273 filename = Fcygwin_convert_file_name_from_windows (filename, Qt);
6274#endif /* CYGWIN */ 6274#endif /* CYGWIN */
6275 6275
6276 /* Strip the dummy filename off the end of the string if we 6276 /* Strip the dummy filename off the end of the string if we
diff --git a/src/w32term.c b/src/w32term.c
index 032912c27f4..ab6afd32c75 100644
--- a/src/w32term.c
+++ b/src/w32term.c
@@ -723,21 +723,7 @@ static void
723w32_frame_up_to_date (struct frame *f) 723w32_frame_up_to_date (struct frame *f)
724{ 724{
725 if (FRAME_W32_P (f)) 725 if (FRAME_W32_P (f))
726 { 726 FRAME_MOUSE_UPDATE (f);
727 Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (f);
728
729 if (hlinfo->mouse_face_deferred_gc
730 || f == hlinfo->mouse_face_mouse_frame)
731 {
732 block_input ();
733 if (hlinfo->mouse_face_mouse_frame)
734 note_mouse_highlight (hlinfo->mouse_face_mouse_frame,
735 hlinfo->mouse_face_mouse_x,
736 hlinfo->mouse_face_mouse_y);
737 hlinfo->mouse_face_deferred_gc = 0;
738 unblock_input ();
739 }
740 }
741} 727}
742 728
743 729
@@ -5979,7 +5965,6 @@ x_free_frame_resources (struct frame *f)
5979 hlinfo->mouse_face_end_row 5965 hlinfo->mouse_face_end_row
5980 = hlinfo->mouse_face_end_col = -1; 5966 = hlinfo->mouse_face_end_col = -1;
5981 hlinfo->mouse_face_window = Qnil; 5967 hlinfo->mouse_face_window = Qnil;
5982 hlinfo->mouse_face_deferred_gc = 0;
5983 hlinfo->mouse_face_mouse_frame = 0; 5968 hlinfo->mouse_face_mouse_frame = 0;
5984 } 5969 }
5985 5970
diff --git a/src/w32term.h b/src/w32term.h
index 83535b8faa3..ce709c1231d 100644
--- a/src/w32term.h
+++ b/src/w32term.h
@@ -751,7 +751,7 @@ extern int w32_system_caret_y;
751typedef BOOL (CALLBACK *LOCALE_ENUMPROCA)(LPSTR); 751typedef BOOL (CALLBACK *LOCALE_ENUMPROCA)(LPSTR);
752typedef BOOL (CALLBACK *LOCALE_ENUMPROCW)(LPWSTR); 752typedef BOOL (CALLBACK *LOCALE_ENUMPROCW)(LPWSTR);
753BOOL WINAPI EnumSystemLocalesA(LOCALE_ENUMPROCA,DWORD); 753BOOL WINAPI EnumSystemLocalesA(LOCALE_ENUMPROCA,DWORD);
754BOOL WINAPI EnumSystemLocalesW(LOCALE_ENUMPROCW,DWORD) 754BOOL WINAPI EnumSystemLocalesW(LOCALE_ENUMPROCW,DWORD);
755#ifdef UNICODE 755#ifdef UNICODE
756#define EnumSystemLocales EnumSystemLocalesW 756#define EnumSystemLocales EnumSystemLocalesW
757#else 757#else
diff --git a/src/xdisp.c b/src/xdisp.c
index 27d9fff0b7d..5d260d851ef 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -515,9 +515,8 @@ Lisp_Object Qmenu_bar_update_hook;
515 515
516static int overlay_arrow_seen; 516static int overlay_arrow_seen;
517 517
518/* Number of windows showing the buffer of the selected window (or 518/* Number of windows showing the buffer of the selected
519 another buffer with the same base buffer). keyboard.c refers to 519 window (or another buffer with the same base buffer). */
520 this. */
521 520
522int buffer_shared; 521int buffer_shared;
523 522
@@ -9643,7 +9642,7 @@ message2_nolog (const char *m, ptrdiff_t nbytes, int multibyte)
9643 do_pending_window_change (0); 9642 do_pending_window_change (0);
9644 echo_area_display (1); 9643 echo_area_display (1);
9645 do_pending_window_change (0); 9644 do_pending_window_change (0);
9646 if (FRAME_TERMINAL (f)->frame_up_to_date_hook != 0 && ! gc_in_progress) 9645 if (FRAME_TERMINAL (f)->frame_up_to_date_hook)
9647 (*FRAME_TERMINAL (f)->frame_up_to_date_hook) (f); 9646 (*FRAME_TERMINAL (f)->frame_up_to_date_hook) (f);
9648 } 9647 }
9649} 9648}
@@ -9740,7 +9739,7 @@ message3_nolog (Lisp_Object m, ptrdiff_t nbytes, int multibyte)
9740 do_pending_window_change (0); 9739 do_pending_window_change (0);
9741 echo_area_display (1); 9740 echo_area_display (1);
9742 do_pending_window_change (0); 9741 do_pending_window_change (0);
9743 if (FRAME_TERMINAL (f)->frame_up_to_date_hook != 0 && ! gc_in_progress) 9742 if (FRAME_TERMINAL (f)->frame_up_to_date_hook)
9744 (*FRAME_TERMINAL (f)->frame_up_to_date_hook) (f); 9743 (*FRAME_TERMINAL (f)->frame_up_to_date_hook) (f);
9745 } 9744 }
9746} 9745}
@@ -10889,8 +10888,41 @@ echo_area_display (int update_frame_p)
10889 return window_height_changed_p; 10888 return window_height_changed_p;
10890} 10889}
10891 10890
10891/* Nonzero if the current buffer is shown in more than
10892 one window and was modified since last display. */
10893
10894static int
10895buffer_shared_and_changed (void)
10896{
10897 return (buffer_shared > 1 && UNCHANGED_MODIFIED < MODIFF);
10898}
10899
10900/* Nonzero if W doesn't reflect the actual state of
10901 current buffer due to its text or overlays change. */
10902
10903static int
10904window_outdated (struct window *w)
10905{
10906 eassert (XBUFFER (w->buffer) == current_buffer);
10907 return (w->last_modified < MODIFF
10908 || w->last_overlay_modified < OVERLAY_MODIFF);
10909}
10910
10911/* Nonzero if W's buffer was changed but not saved or Transient Mark mode
10912 is enabled and mark of W's buffer was changed since last W's update. */
10913
10914static int
10915window_buffer_changed (struct window *w)
10916{
10917 struct buffer *b = XBUFFER (w->buffer);
10918
10919 eassert (BUFFER_LIVE_P (b));
10920
10921 return (((BUF_SAVE_MODIFF (b) < BUF_MODIFF (b)) != w->last_had_star)
10922 || ((!NILP (Vtransient_mark_mode) && !NILP (BVAR (b, mark_active)))
10923 != !NILP (w->region_showing)));
10924}
10892 10925
10893
10894/*********************************************************************** 10926/***********************************************************************
10895 Mode Lines and Frame Titles 10927 Mode Lines and Frame Titles
10896 ***********************************************************************/ 10928 ***********************************************************************/
@@ -11196,7 +11228,7 @@ prepare_menu_bars (void)
11196 /* Update the menu bar item lists, if appropriate. This has to be 11228 /* Update the menu bar item lists, if appropriate. This has to be
11197 done before any actual redisplay or generation of display lines. */ 11229 done before any actual redisplay or generation of display lines. */
11198 all_windows = (update_mode_lines 11230 all_windows = (update_mode_lines
11199 || buffer_shared > 1 11231 || buffer_shared_and_changed ()
11200 || windows_or_buffers_changed); 11232 || windows_or_buffers_changed);
11201 if (all_windows) 11233 if (all_windows)
11202 { 11234 {
@@ -11310,12 +11342,7 @@ update_menu_bar (struct frame *f, int save_match_data, int hooks_run)
11310 /* This used to test w->update_mode_line, but we believe 11342 /* This used to test w->update_mode_line, but we believe
11311 there is no need to recompute the menu in that case. */ 11343 there is no need to recompute the menu in that case. */
11312 || update_mode_lines 11344 || update_mode_lines
11313 || ((BUF_SAVE_MODIFF (XBUFFER (w->buffer)) 11345 || window_buffer_changed (w))
11314 < BUF_MODIFF (XBUFFER (w->buffer)))
11315 != w->last_had_star)
11316 || ((!NILP (Vtransient_mark_mode)
11317 && !NILP (BVAR (XBUFFER (w->buffer), mark_active)))
11318 != !NILP (w->region_showing)))
11319 { 11346 {
11320 struct buffer *prev = current_buffer; 11347 struct buffer *prev = current_buffer;
11321 ptrdiff_t count = SPECPDL_INDEX (); 11348 ptrdiff_t count = SPECPDL_INDEX ();
@@ -11467,11 +11494,18 @@ FRAME_PTR last_mouse_frame;
11467 11494
11468int last_tool_bar_item; 11495int last_tool_bar_item;
11469 11496
11470 11497/* Select `frame' temporarily without running all the code in
11498 do_switch_frame.
11499 FIXME: Maybe do_switch_frame should be trimmed down similarly
11500 when `norecord' is set. */
11471static Lisp_Object 11501static Lisp_Object
11472update_tool_bar_unwind (Lisp_Object frame) 11502fast_set_selected_frame (Lisp_Object frame)
11473{ 11503{
11474 selected_frame = frame; 11504 if (!EQ (selected_frame, frame))
11505 {
11506 selected_frame = frame;
11507 selected_window = XFRAME (frame)->selected_window;
11508 }
11475 return Qnil; 11509 return Qnil;
11476} 11510}
11477 11511
@@ -11508,12 +11542,7 @@ update_tool_bar (struct frame *f, int save_match_data)
11508 if (windows_or_buffers_changed 11542 if (windows_or_buffers_changed
11509 || w->update_mode_line 11543 || w->update_mode_line
11510 || update_mode_lines 11544 || update_mode_lines
11511 || ((BUF_SAVE_MODIFF (XBUFFER (w->buffer)) 11545 || window_buffer_changed (w))
11512 < BUF_MODIFF (XBUFFER (w->buffer)))
11513 != w->last_had_star)
11514 || ((!NILP (Vtransient_mark_mode)
11515 && !NILP (BVAR (XBUFFER (w->buffer), mark_active)))
11516 != !NILP (w->region_showing)))
11517 { 11546 {
11518 struct buffer *prev = current_buffer; 11547 struct buffer *prev = current_buffer;
11519 ptrdiff_t count = SPECPDL_INDEX (); 11548 ptrdiff_t count = SPECPDL_INDEX ();
@@ -11543,9 +11572,13 @@ update_tool_bar (struct frame *f, int save_match_data)
11543 before calling tool_bar_items, because the calculation of 11572 before calling tool_bar_items, because the calculation of
11544 the tool-bar keymap uses the selected frame (see 11573 the tool-bar keymap uses the selected frame (see
11545 `tool-bar-make-keymap' in tool-bar.el). */ 11574 `tool-bar-make-keymap' in tool-bar.el). */
11546 record_unwind_protect (update_tool_bar_unwind, selected_frame); 11575 eassert (EQ (selected_window,
11576 /* Since we only explicitly preserve selected_frame,
11577 check that selected_window would be redundant. */
11578 XFRAME (selected_frame)->selected_window));
11579 record_unwind_protect (fast_set_selected_frame, selected_frame);
11547 XSETFRAME (frame, f); 11580 XSETFRAME (frame, f);
11548 selected_frame = frame; 11581 fast_set_selected_frame (frame);
11549 11582
11550 /* Build desired tool-bar items from keymaps. */ 11583 /* Build desired tool-bar items from keymaps. */
11551 new_tool_bar 11584 new_tool_bar
@@ -12616,8 +12649,7 @@ text_outside_line_unchanged_p (struct window *w,
12616 int unchanged_p = 1; 12649 int unchanged_p = 1;
12617 12650
12618 /* If text or overlays have changed, see where. */ 12651 /* If text or overlays have changed, see where. */
12619 if (w->last_modified < MODIFF 12652 if (window_outdated (w))
12620 || w->last_overlay_modified < OVERLAY_MODIFF)
12621 { 12653 {
12622 /* Gap in the line? */ 12654 /* Gap in the line? */
12623 if (GPT < start || Z - GPT < end) 12655 if (GPT < start || Z - GPT < end)
@@ -12961,7 +12993,7 @@ redisplay_internal (void)
12961 ptrdiff_t count, count1; 12993 ptrdiff_t count, count1;
12962 struct frame *sf; 12994 struct frame *sf;
12963 int polling_stopped_here = 0; 12995 int polling_stopped_here = 0;
12964 Lisp_Object old_frame = selected_frame; 12996 Lisp_Object tail, frame, old_frame = selected_frame;
12965 struct backtrace backtrace; 12997 struct backtrace backtrace;
12966 12998
12967 /* Non-zero means redisplay has to consider all windows on all 12999 /* Non-zero means redisplay has to consider all windows on all
@@ -13013,15 +13045,8 @@ redisplay_internal (void)
13013 backtrace.debug_on_exit = 0; 13045 backtrace.debug_on_exit = 0;
13014 backtrace_list = &backtrace; 13046 backtrace_list = &backtrace;
13015 13047
13016 { 13048 FOR_EACH_FRAME (tail, frame)
13017 Lisp_Object tail, frame; 13049 XFRAME (frame)->already_hscrolled_p = 0;
13018
13019 FOR_EACH_FRAME (tail, frame)
13020 {
13021 struct frame *f = XFRAME (frame);
13022 f->already_hscrolled_p = 0;
13023 }
13024 }
13025 13050
13026 retry: 13051 retry:
13027 /* Remember the currently selected window. */ 13052 /* Remember the currently selected window. */
@@ -13071,25 +13096,20 @@ redisplay_internal (void)
13071 FRAME_TTY (sf)->previous_frame = sf; 13096 FRAME_TTY (sf)->previous_frame = sf;
13072 } 13097 }
13073 13098
13074 /* Set the visible flags for all frames. Do this before checking 13099 /* Set the visible flags for all frames. Do this before checking for
13075 for resized or garbaged frames; they want to know if their frames 13100 resized or garbaged frames; they want to know if their frames are
13076 are visible. See the comment in frame.h for 13101 visible. See the comment in frame.h for FRAME_SAMPLE_VISIBILITY. */
13077 FRAME_SAMPLE_VISIBILITY. */ 13102 number_of_visible_frames = 0;
13078 {
13079 Lisp_Object tail, frame;
13080 13103
13081 number_of_visible_frames = 0; 13104 FOR_EACH_FRAME (tail, frame)
13082 13105 {
13083 FOR_EACH_FRAME (tail, frame) 13106 struct frame *f = XFRAME (frame);
13084 {
13085 struct frame *f = XFRAME (frame);
13086 13107
13087 FRAME_SAMPLE_VISIBILITY (f); 13108 FRAME_SAMPLE_VISIBILITY (f);
13088 if (FRAME_VISIBLE_P (f)) 13109 if (FRAME_VISIBLE_P (f))
13089 ++number_of_visible_frames; 13110 ++number_of_visible_frames;
13090 clear_desired_matrices (f); 13111 clear_desired_matrices (f);
13091 } 13112 }
13092 }
13093 13113
13094 /* Notice any pending interrupt request to change frame size. */ 13114 /* Notice any pending interrupt request to change frame size. */
13095 do_pending_window_change (1); 13115 do_pending_window_change (1);
@@ -13116,7 +13136,7 @@ redisplay_internal (void)
13116 if ((SAVE_MODIFF < MODIFF) != w->last_had_star) 13136 if ((SAVE_MODIFF < MODIFF) != w->last_had_star)
13117 { 13137 {
13118 w->update_mode_line = 1; 13138 w->update_mode_line = 1;
13119 if (buffer_shared > 1) 13139 if (buffer_shared_and_changed ())
13120 update_mode_lines++; 13140 update_mode_lines++;
13121 } 13141 }
13122 13142
@@ -13128,9 +13148,7 @@ redisplay_internal (void)
13128 if (!NILP (w->column_number_displayed) 13148 if (!NILP (w->column_number_displayed)
13129 /* This alternative quickly identifies a common case 13149 /* This alternative quickly identifies a common case
13130 where no change is needed. */ 13150 where no change is needed. */
13131 && !(PT == w->last_point 13151 && !(PT == w->last_point && !window_outdated (w))
13132 && w->last_modified >= MODIFF
13133 && w->last_overlay_modified >= OVERLAY_MODIFF)
13134 && (XFASTINT (w->column_number_displayed) != current_column ())) 13152 && (XFASTINT (w->column_number_displayed) != current_column ()))
13135 w->update_mode_line = 1; 13153 w->update_mode_line = 1;
13136 13154
@@ -13141,7 +13159,8 @@ redisplay_internal (void)
13141 /* The variable buffer_shared is set in redisplay_window and 13159 /* The variable buffer_shared is set in redisplay_window and
13142 indicates that we redisplay a buffer in different windows. See 13160 indicates that we redisplay a buffer in different windows. See
13143 there. */ 13161 there. */
13144 consider_all_windows_p = (update_mode_lines || buffer_shared > 1 13162 consider_all_windows_p = (update_mode_lines
13163 || buffer_shared_and_changed ()
13145 || cursor_type_changed); 13164 || cursor_type_changed);
13146 13165
13147 /* If specs for an arrow have changed, do thorough redisplay 13166 /* If specs for an arrow have changed, do thorough redisplay
@@ -13191,18 +13210,16 @@ redisplay_internal (void)
13191 } 13210 }
13192 } 13211 }
13193 else if (EQ (selected_window, minibuf_window) 13212 else if (EQ (selected_window, minibuf_window)
13194 && (current_buffer->clip_changed 13213 && (current_buffer->clip_changed || window_outdated (w))
13195 || w->last_modified < MODIFF
13196 || w->last_overlay_modified < OVERLAY_MODIFF)
13197 && resize_mini_window (w, 0)) 13214 && resize_mini_window (w, 0))
13198 { 13215 {
13199 /* Resized active mini-window to fit the size of what it is 13216 /* Resized active mini-window to fit the size of what it is
13200 showing if its contents might have changed. */ 13217 showing if its contents might have changed. */
13201 must_finish = 1; 13218 must_finish = 1;
13202/* FIXME: this causes all frames to be updated, which seems unnecessary 13219 /* FIXME: this causes all frames to be updated, which seems unnecessary
13203 since only the current frame needs to be considered. This function needs 13220 since only the current frame needs to be considered. This function
13204 to be rewritten with two variables, consider_all_windows and 13221 needs to be rewritten with two variables, consider_all_windows and
13205 consider_all_frames. */ 13222 consider_all_frames. */
13206 consider_all_windows_p = 1; 13223 consider_all_windows_p = 1;
13207 ++windows_or_buffers_changed; 13224 ++windows_or_buffers_changed;
13208 ++update_mode_lines; 13225 ++update_mode_lines;
@@ -13257,9 +13274,7 @@ redisplay_internal (void)
13257 || FETCH_BYTE (BYTEPOS (tlbufpos)) == '\n')) 13274 || FETCH_BYTE (BYTEPOS (tlbufpos)) == '\n'))
13258 /* Former continuation line has disappeared by becoming empty. */ 13275 /* Former continuation line has disappeared by becoming empty. */
13259 goto cancel; 13276 goto cancel;
13260 else if (w->last_modified < MODIFF 13277 else if (window_outdated (w) || MINI_WINDOW_P (w))
13261 || w->last_overlay_modified < OVERLAY_MODIFF
13262 || MINI_WINDOW_P (w))
13263 { 13278 {
13264 /* We have to handle the case of continuation around a 13279 /* We have to handle the case of continuation around a
13265 wide-column character (see the comment in indent.c around 13280 wide-column character (see the comment in indent.c around
@@ -13433,7 +13448,7 @@ redisplay_internal (void)
13433 } 13448 }
13434 13449
13435 CHARPOS (this_line_start_pos) = 0; 13450 CHARPOS (this_line_start_pos) = 0;
13436 consider_all_windows_p |= buffer_shared > 1; 13451 consider_all_windows_p |= buffer_shared_and_changed ();
13437 ++clear_face_cache_count; 13452 ++clear_face_cache_count;
13438#ifdef HAVE_WINDOW_SYSTEM 13453#ifdef HAVE_WINDOW_SYSTEM
13439 ++clear_image_cache_count; 13454 ++clear_image_cache_count;
@@ -13445,8 +13460,6 @@ redisplay_internal (void)
13445 13460
13446 if (consider_all_windows_p) 13461 if (consider_all_windows_p)
13447 { 13462 {
13448 Lisp_Object tail, frame;
13449
13450 FOR_EACH_FRAME (tail, frame) 13463 FOR_EACH_FRAME (tail, frame)
13451 XFRAME (frame)->updated_p = 0; 13464 XFRAME (frame)->updated_p = 0;
13452 13465
@@ -13656,7 +13669,6 @@ redisplay_internal (void)
13656 frames here explicitly. */ 13669 frames here explicitly. */
13657 if (!pending) 13670 if (!pending)
13658 { 13671 {
13659 Lisp_Object tail, frame;
13660 int new_count = 0; 13672 int new_count = 0;
13661 13673
13662 FOR_EACH_FRAME (tail, frame) 13674 FOR_EACH_FRAME (tail, frame)
@@ -15510,8 +15522,7 @@ redisplay_window (Lisp_Object window, int just_this_one_p)
15510 = (!NILP (w->window_end_valid) 15522 = (!NILP (w->window_end_valid)
15511 && !current_buffer->clip_changed 15523 && !current_buffer->clip_changed
15512 && !current_buffer->prevent_redisplay_optimizations_p 15524 && !current_buffer->prevent_redisplay_optimizations_p
15513 && w->last_modified >= MODIFF 15525 && !window_outdated (w));
15514 && w->last_overlay_modified >= OVERLAY_MODIFF);
15515 15526
15516 /* Run the window-bottom-change-functions 15527 /* Run the window-bottom-change-functions
15517 if it is possible that the text on the screen has changed 15528 if it is possible that the text on the screen has changed
@@ -15533,8 +15544,7 @@ redisplay_window (Lisp_Object window, int just_this_one_p)
15533 buffer_unchanged_p 15544 buffer_unchanged_p
15534 = (!NILP (w->window_end_valid) 15545 = (!NILP (w->window_end_valid)
15535 && !current_buffer->clip_changed 15546 && !current_buffer->clip_changed
15536 && w->last_modified >= MODIFF 15547 && !window_outdated (w));
15537 && w->last_overlay_modified >= OVERLAY_MODIFF);
15538 15548
15539 /* When windows_or_buffers_changed is non-zero, we can't rely on 15549 /* When windows_or_buffers_changed is non-zero, we can't rely on
15540 the window end being valid, so set it to nil there. */ 15550 the window end being valid, so set it to nil there. */
@@ -15559,9 +15569,7 @@ redisplay_window (Lisp_Object window, int just_this_one_p)
15559 if (!NILP (w->column_number_displayed) 15569 if (!NILP (w->column_number_displayed)
15560 /* This alternative quickly identifies a common case 15570 /* This alternative quickly identifies a common case
15561 where no change is needed. */ 15571 where no change is needed. */
15562 && !(PT == w->last_point 15572 && !(PT == w->last_point && !window_outdated (w))
15563 && w->last_modified >= MODIFF
15564 && w->last_overlay_modified >= OVERLAY_MODIFF)
15565 && (XFASTINT (w->column_number_displayed) != current_column ())) 15573 && (XFASTINT (w->column_number_displayed) != current_column ()))
15566 update_mode_line = 1; 15574 update_mode_line = 1;
15567 15575
@@ -15803,8 +15811,7 @@ redisplay_window (Lisp_Object window, int just_this_one_p)
15803 && (CHARPOS (startp) < ZV 15811 && (CHARPOS (startp) < ZV
15804 /* Avoid starting at end of buffer. */ 15812 /* Avoid starting at end of buffer. */
15805 || CHARPOS (startp) == BEGV 15813 || CHARPOS (startp) == BEGV
15806 || (w->last_modified >= MODIFF 15814 || !window_outdated (w)))
15807 && w->last_overlay_modified >= OVERLAY_MODIFF)))
15808 { 15815 {
15809 int d1, d2, d3, d4, d5, d6; 15816 int d1, d2, d3, d4, d5, d6;
15810 15817
@@ -27678,12 +27685,6 @@ note_mouse_highlight (struct frame *f, int x, int y)
27678 if (hlinfo->mouse_face_defer) 27685 if (hlinfo->mouse_face_defer)
27679 return; 27686 return;
27680 27687
27681 if (gc_in_progress)
27682 {
27683 hlinfo->mouse_face_deferred_gc = 1;
27684 return;
27685 }
27686
27687 /* Which window is that in? */ 27688 /* Which window is that in? */
27688 window = window_from_coordinates (f, x, y, &part, 1); 27689 window = window_from_coordinates (f, x, y, &part, 1);
27689 27690
diff --git a/src/xftfont.c b/src/xftfont.c
index 372ed87705f..181a1da9b38 100644
--- a/src/xftfont.c
+++ b/src/xftfont.c
@@ -369,7 +369,7 @@ xftfont_open (FRAME_PTR f, Lisp_Object entity, int pixel_size)
369 ASET (font_object, FONT_FORMAT_INDEX, 369 ASET (font_object, FONT_FORMAT_INDEX,
370 ftfont_font_format (xftfont->pattern, filename)); 370 ftfont_font_format (xftfont->pattern, filename));
371 font = XFONT_OBJECT (font_object); 371 font = XFONT_OBJECT (font_object);
372 font->pixel_size = pixel_size; 372 font->pixel_size = size;
373 font->driver = &xftfont_driver; 373 font->driver = &xftfont_driver;
374 font->encoding_charset = font->repertory_charset = -1; 374 font->encoding_charset = font->repertory_charset = -1;
375 375
@@ -387,8 +387,6 @@ xftfont_open (FRAME_PTR f, Lisp_Object entity, int pixel_size)
387 xftfont_info->matrix.xy = 0x10000L * matrix->xy; 387 xftfont_info->matrix.xy = 0x10000L * matrix->xy;
388 xftfont_info->matrix.yx = 0x10000L * matrix->yx; 388 xftfont_info->matrix.yx = 0x10000L * matrix->yx;
389 } 389 }
390 font->pixel_size = size;
391 font->driver = &xftfont_driver;
392 if (INTEGERP (AREF (entity, FONT_SPACING_INDEX))) 390 if (INTEGERP (AREF (entity, FONT_SPACING_INDEX)))
393 spacing = XINT (AREF (entity, FONT_SPACING_INDEX)); 391 spacing = XINT (AREF (entity, FONT_SPACING_INDEX));
394 else 392 else
diff --git a/src/xterm.c b/src/xterm.c
index 463d82b4ee2..61e942e10d2 100644
--- a/src/xterm.c
+++ b/src/xterm.c
@@ -669,21 +669,7 @@ static void
669XTframe_up_to_date (struct frame *f) 669XTframe_up_to_date (struct frame *f)
670{ 670{
671 if (FRAME_X_P (f)) 671 if (FRAME_X_P (f))
672 { 672 FRAME_MOUSE_UPDATE (f);
673 Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (f);
674
675 if (hlinfo->mouse_face_deferred_gc
676 || f == hlinfo->mouse_face_mouse_frame)
677 {
678 block_input ();
679 if (hlinfo->mouse_face_mouse_frame)
680 note_mouse_highlight (hlinfo->mouse_face_mouse_frame,
681 hlinfo->mouse_face_mouse_x,
682 hlinfo->mouse_face_mouse_y);
683 hlinfo->mouse_face_deferred_gc = 0;
684 unblock_input ();
685 }
686 }
687} 673}
688 674
689 675
@@ -9502,7 +9488,6 @@ x_free_frame_resources (struct frame *f)
9502 hlinfo->mouse_face_end_row 9488 hlinfo->mouse_face_end_row
9503 = hlinfo->mouse_face_end_col = -1; 9489 = hlinfo->mouse_face_end_col = -1;
9504 hlinfo->mouse_face_window = Qnil; 9490 hlinfo->mouse_face_window = Qnil;
9505 hlinfo->mouse_face_deferred_gc = 0;
9506 hlinfo->mouse_face_mouse_frame = 0; 9491 hlinfo->mouse_face_mouse_frame = 0;
9507 } 9492 }
9508 9493
@@ -10153,7 +10138,6 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name)
10153 dpyinfo->bitmaps_last = 0; 10138 dpyinfo->bitmaps_last = 0;
10154 dpyinfo->scratch_cursor_gc = 0; 10139 dpyinfo->scratch_cursor_gc = 0;
10155 hlinfo->mouse_face_mouse_frame = 0; 10140 hlinfo->mouse_face_mouse_frame = 0;
10156 hlinfo->mouse_face_deferred_gc = 0;
10157 hlinfo->mouse_face_beg_row = hlinfo->mouse_face_beg_col = -1; 10141 hlinfo->mouse_face_beg_row = hlinfo->mouse_face_beg_col = -1;
10158 hlinfo->mouse_face_end_row = hlinfo->mouse_face_end_col = -1; 10142 hlinfo->mouse_face_end_row = hlinfo->mouse_face_end_col = -1;
10159 hlinfo->mouse_face_face_id = DEFAULT_FACE_ID; 10143 hlinfo->mouse_face_face_id = DEFAULT_FACE_ID;
diff --git a/test/ChangeLog b/test/ChangeLog
index f11325d0318..b66c2925287 100644
--- a/test/ChangeLog
+++ b/test/ChangeLog
@@ -1,3 +1,14 @@
12012-11-20 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 * automated/advice-tests.el (advice-tests--data): Remove.
4 (advice-tests): Move the tests directly here instead.
5 Add called-interactively-p tests.
6
72012-11-19 Stefan Monnier <monnier@iro.umontreal.ca>
8
9 * automated/ert-x-tests.el: Use cl-lib.
10 * automated/ert-tests.el: Use lexical-binding and cl-lib.
11
12012-11-14 Dmitry Gutov <dgutov@yandex.ru> 122012-11-14 Dmitry Gutov <dgutov@yandex.ru>
2 13
3 * automated/ruby-mode-tests.el (ruby-indent-singleton-class): Pass. 14 * automated/ruby-mode-tests.el (ruby-indent-singleton-class): Pass.
@@ -5,8 +16,8 @@
5 (ruby-indent-inside-heredoc-after-space): New tests. 16 (ruby-indent-inside-heredoc-after-space): New tests.
6 Change direct font-lock face references to var references. 17 Change direct font-lock face references to var references.
7 (ruby-interpolation-suppresses-syntax-inside): New test. 18 (ruby-interpolation-suppresses-syntax-inside): New test.
8 (ruby-interpolation-inside-percent-literal-with-paren): New 19 (ruby-interpolation-inside-percent-literal-with-paren):
9 failing test. 20 New failing test.
10 21
112012-11-13 Dmitry Gutov <dgutov@yandex.ru> 222012-11-13 Dmitry Gutov <dgutov@yandex.ru>
12 23
diff --git a/test/automated/advice-tests.el b/test/automated/advice-tests.el
index 80321f8f3f9..94f69e77e43 100644
--- a/test/automated/advice-tests.el
+++ b/test/automated/advice-tests.el
@@ -21,81 +21,94 @@
21 21
22;;; Code: 22;;; Code:
23 23
24(defvar advice-tests--data 24(ert-deftest advice-tests ()
25 '(((defun sm-test1 (x) (+ x 4)) 25 "Test advice code."
26 (sm-test1 6) 10) 26 (with-temp-buffer
27 ((advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 5))) 27 (defun sm-test1 (x) (+ x 4))
28 (sm-test1 6) 50) 28 (should (equal (sm-test1 6) 10))
29 ((defun sm-test1 (x) (+ x 14)) 29 (advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 5)))
30 (sm-test1 6) 100) 30 (should (equal (sm-test1 6) 50))
31 ((null (get 'sm-test1 'defalias-fset-function)) nil) 31 (defun sm-test1 (x) (+ x 14))
32 ((advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5))) 32 (should (equal (sm-test1 6) 100))
33 (sm-test1 6) 20) 33 (should (equal (null (get 'sm-test1 'defalias-fset-function)) nil))
34 ((null (get 'sm-test1 'defalias-fset-function)) t) 34 (advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5)))
35 35 (should (equal (sm-test1 6) 20))
36 ((defun sm-test2 (x) (+ x 4)) 36 (should (equal (null (get 'sm-test1 'defalias-fset-function)) t))
37 (sm-test2 6) 10) 37
38 ((defadvice sm-test2 (around sm-test activate) 38 (defun sm-test2 (x) (+ x 4))
39 (should (equal (sm-test2 6) 10))
40 (defadvice sm-test2 (around sm-test activate)
39 ad-do-it (setq ad-return-value (* ad-return-value 5))) 41 ad-do-it (setq ad-return-value (* ad-return-value 5)))
40 (sm-test2 6) 50) 42 (should (equal (sm-test2 6) 50))
41 ((ad-deactivate 'sm-test2) 43 (ad-deactivate 'sm-test2)
42 (sm-test2 6) 10) 44 (should (equal (sm-test2 6) 10))
43 ((ad-activate 'sm-test2) 45 (ad-activate 'sm-test2)
44 (sm-test2 6) 50) 46 (should (equal (sm-test2 6) 50))
45 ((defun sm-test2 (x) (+ x 14)) 47 (defun sm-test2 (x) (+ x 14))
46 (sm-test2 6) 100) 48 (should (equal (sm-test2 6) 100))
47 ((null (get 'sm-test2 'defalias-fset-function)) nil) 49 (should (equal (null (get 'sm-test2 'defalias-fset-function)) nil))
48 ((ad-remove-advice 'sm-test2 'around 'sm-test) 50 (ad-remove-advice 'sm-test2 'around 'sm-test)
49 (sm-test2 6) 100) 51 (should (equal (sm-test2 6) 100))
50 ((ad-activate 'sm-test2) 52 (ad-activate 'sm-test2)
51 (sm-test2 6) 20) 53 (should (equal (sm-test2 6) 20))
52 ((null (get 'sm-test2 'defalias-fset-function)) t) 54 (should (equal (null (get 'sm-test2 'defalias-fset-function)) t))
53 55
54 ((advice-add 'sm-test3 :around 56 (advice-add 'sm-test3 :around
55 (lambda (f &rest args) `(toto ,(apply f args))) 57 (lambda (f &rest args) `(toto ,(apply f args)))
56 '((name . wrap-with-toto))) 58 '((name . wrap-with-toto)))
57 (defmacro sm-test3 (x) `(call-test3 ,x)) 59 (defmacro sm-test3 (x) `(call-test3 ,x))
58 (macroexpand '(sm-test3 56)) (toto (call-test3 56))) 60 (should (equal (macroexpand '(sm-test3 56)) '(toto (call-test3 56))))
59 61
60 ((defadvice sm-test4 (around wrap-with-toto activate) 62 (defadvice sm-test4 (around wrap-with-toto activate)
61 ad-do-it (setq ad-return-value `(toto ,ad-return-value))) 63 ad-do-it (setq ad-return-value `(toto ,ad-return-value)))
62 (defmacro sm-test4 (x) `(call-test4 ,x)) 64 (defmacro sm-test4 (x) `(call-test4 ,x))
63 (macroexpand '(sm-test4 56)) (toto (call-test4 56))) 65 (should (equal (macroexpand '(sm-test4 56)) '(toto (call-test4 56))))
64 ((defmacro sm-test4 (x) `(call-testq ,x)) 66 (defmacro sm-test4 (x) `(call-testq ,x))
65 (macroexpand '(sm-test4 56)) (toto (call-testq 56))) 67 (should (equal (macroexpand '(sm-test4 56)) '(toto (call-testq 56))))
66 68
67 ;; Combining old style and new style advices. 69 ;; Combining old style and new style advices.
68 ((defun sm-test5 (x) (+ x 4)) 70 (defun sm-test5 (x) (+ x 4))
69 (sm-test5 6) 10) 71 (should (equal (sm-test5 6) 10))
70 ((advice-add 'sm-test5 :around (lambda (f y) (* (funcall f y) 5))) 72 (advice-add 'sm-test5 :around (lambda (f y) (* (funcall f y) 5)))
71 (sm-test5 6) 50) 73 (should (equal (sm-test5 6) 50))
72 ((defadvice sm-test5 (around test activate) 74 (defadvice sm-test5 (around test activate)
73 ad-do-it (setq ad-return-value (+ ad-return-value 0.1))) 75 ad-do-it (setq ad-return-value (+ ad-return-value 0.1)))
74 (sm-test5 5) 45.1) 76 (should (equal (sm-test5 5) 45.1))
75 ((ad-deactivate 'sm-test5) 77 (ad-deactivate 'sm-test5)
76 (sm-test5 6) 50) 78 (should (equal (sm-test5 6) 50))
77 ((ad-activate 'sm-test5) 79 (ad-activate 'sm-test5)
78 (sm-test5 6) 50.1) 80 (should (equal (sm-test5 6) 50.1))
79 ((defun sm-test5 (x) (+ x 14)) 81 (defun sm-test5 (x) (+ x 14))
80 (sm-test5 6) 100.1) 82 (should (equal (sm-test5 6) 100.1))
81 ((advice-remove 'sm-test5 (lambda (f y) (* (funcall f y) 5))) 83 (advice-remove 'sm-test5 (lambda (f y) (* (funcall f y) 5)))
82 (sm-test5 6) 20.1) 84 (should (equal (sm-test5 6) 20.1))
83 85
84 ;; This used to signal an error (bug#12858). 86 ;; This used to signal an error (bug#12858).
85 ((autoload 'sm-test6 "foo") 87 (autoload 'sm-test6 "foo")
86 (defadvice sm-test6 (around test activate) 88 (defadvice sm-test6 (around test activate)
87 ad-do-it) 89 ad-do-it)
88 t t)
89 90
91 ;; Check interaction between advice and called-interactively-p.
92 (defun sm-test7 (&optional x) (interactive) (+ (or x 7) 4))
93 (advice-add 'sm-test7 :around
94 (lambda (f &rest args)
95 (list (cons 1 (called-interactively-p)) (apply f args))))
96 (should (equal (sm-test7) '((1 . nil) 11)))
97 (should (equal (call-interactively 'sm-test7) '((1 . t) 11)))
98 (let ((smi 7))
99 (advice-add 'sm-test7 :before
100 (lambda (&rest args)
101 (setq smi (called-interactively-p))))
102 (should (equal (list (sm-test7) smi)
103 '(((1 . nil) 11) nil)))
104 (should (equal (list (call-interactively 'sm-test7) smi)
105 '(((1 . t) 11) t))))
106 (advice-add 'sm-test7 :around
107 (lambda (f &rest args)
108 (cons (cons 2 (called-interactively-p)) (apply f args))))
109 (should (equal (call-interactively 'sm-test7) '((2 . t) (1 . t) 11)))
90 )) 110 ))
91 111
92(ert-deftest advice-tests ()
93 "Test advice code."
94 (with-temp-buffer
95 (dolist (test advice-tests--data)
96 (let ((res (eval `(progn ,@(butlast test)))))
97 (should (equal (car (last test)) res))))))
98
99;; Local Variables: 112;; Local Variables:
100;; no-byte-compile: t 113;; no-byte-compile: t
101;; End: 114;; End:
diff --git a/test/automated/ert-tests.el b/test/automated/ert-tests.el
index 1778afea802..1aef1921871 100644
--- a/test/automated/ert-tests.el
+++ b/test/automated/ert-tests.el
@@ -1,4 +1,4 @@
1;;; ert-tests.el --- ERT's self-tests 1;;; ert-tests.el --- ERT's self-tests -*- 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
@@ -27,7 +27,7 @@
27;;; Code: 27;;; Code:
28 28
29(eval-when-compile 29(eval-when-compile
30 (require 'cl)) 30 (require 'cl-lib))
31(require 'ert) 31(require 'ert)
32 32
33 33
@@ -45,7 +45,7 @@
45 ;; The buffer name chosen here should not compete with the default 45 ;; The buffer name chosen here should not compete with the default
46 ;; results buffer name for completion in `switch-to-buffer'. 46 ;; results buffer name for completion in `switch-to-buffer'.
47 (let ((stats (ert-run-tests-interactively "^ert-" " *ert self-tests*"))) 47 (let ((stats (ert-run-tests-interactively "^ert-" " *ert self-tests*")))
48 (assert ert--test-body-was-run) 48 (cl-assert ert--test-body-was-run)
49 (if (zerop (ert-stats-completed-unexpected stats)) 49 (if (zerop (ert-stats-completed-unexpected stats))
50 ;; Hide results window only when everything went well. 50 ;; Hide results window only when everything went well.
51 (set-window-configuration window-configuration) 51 (set-window-configuration window-configuration)
@@ -71,26 +71,26 @@ failed or if there was a problem."
71 71
72(ert-deftest ert-test-nested-test-body-runs () 72(ert-deftest ert-test-nested-test-body-runs ()
73 "Test that nested test bodies run." 73 "Test that nested test bodies run."
74 (lexical-let ((was-run nil)) 74 (let ((was-run nil))
75 (let ((test (make-ert-test :body (lambda () 75 (let ((test (make-ert-test :body (lambda ()
76 (setq was-run t))))) 76 (setq was-run t)))))
77 (assert (not was-run)) 77 (cl-assert (not was-run))
78 (ert-run-test test) 78 (ert-run-test test)
79 (assert was-run)))) 79 (cl-assert was-run))))
80 80
81 81
82;;; Test that pass/fail works. 82;;; Test that pass/fail works.
83(ert-deftest ert-test-pass () 83(ert-deftest ert-test-pass ()
84 (let ((test (make-ert-test :body (lambda ())))) 84 (let ((test (make-ert-test :body (lambda ()))))
85 (let ((result (ert-run-test test))) 85 (let ((result (ert-run-test test)))
86 (assert (ert-test-passed-p result))))) 86 (cl-assert (ert-test-passed-p result)))))
87 87
88(ert-deftest ert-test-fail () 88(ert-deftest ert-test-fail ()
89 (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) 89 (let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))))
90 (let ((result (let ((ert-debug-on-error nil)) 90 (let ((result (let ((ert-debug-on-error nil))
91 (ert-run-test test)))) 91 (ert-run-test test))))
92 (assert (ert-test-failed-p result) t) 92 (cl-assert (ert-test-failed-p result) t)
93 (assert (equal (ert-test-result-with-condition-condition result) 93 (cl-assert (equal (ert-test-result-with-condition-condition result)
94 '(ert-test-failed "failure message")) 94 '(ert-test-failed "failure message"))
95 t)))) 95 t))))
96 96
@@ -100,50 +100,50 @@ failed or if there was a problem."
100 (progn 100 (progn
101 (let ((ert-debug-on-error t)) 101 (let ((ert-debug-on-error t))
102 (ert-run-test test)) 102 (ert-run-test test))
103 (assert nil)) 103 (cl-assert nil))
104 ((error) 104 ((error)
105 (assert (equal condition '(ert-test-failed "failure message")) t))))) 105 (cl-assert (equal condition '(ert-test-failed "failure message")) t)))))
106 106
107(ert-deftest ert-test-fail-debug-with-debugger-1 () 107(ert-deftest ert-test-fail-debug-with-debugger-1 ()
108 (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) 108 (let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))))
109 (let ((debugger (lambda (&rest debugger-args) 109 (let ((debugger (lambda (&rest _args)
110 (assert nil)))) 110 (cl-assert nil))))
111 (let ((ert-debug-on-error nil)) 111 (let ((ert-debug-on-error nil))
112 (ert-run-test test))))) 112 (ert-run-test test)))))
113 113
114(ert-deftest ert-test-fail-debug-with-debugger-2 () 114(ert-deftest ert-test-fail-debug-with-debugger-2 ()
115 (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) 115 (let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))))
116 (block nil 116 (cl-block nil
117 (let ((debugger (lambda (&rest debugger-args) 117 (let ((debugger (lambda (&rest _args)
118 (return-from nil nil)))) 118 (cl-return-from nil nil))))
119 (let ((ert-debug-on-error t)) 119 (let ((ert-debug-on-error t))
120 (ert-run-test test)) 120 (ert-run-test test))
121 (assert nil))))) 121 (cl-assert nil)))))
122 122
123(ert-deftest ert-test-fail-debug-nested-with-debugger () 123(ert-deftest ert-test-fail-debug-nested-with-debugger ()
124 (let ((test (make-ert-test :body (lambda () 124 (let ((test (make-ert-test :body (lambda ()
125 (let ((ert-debug-on-error t)) 125 (let ((ert-debug-on-error t))
126 (ert-fail "failure message")))))) 126 (ert-fail "failure message"))))))
127 (let ((debugger (lambda (&rest debugger-args) 127 (let ((debugger (lambda (&rest _args)
128 (assert nil nil "Assertion a")))) 128 (cl-assert nil nil "Assertion a"))))
129 (let ((ert-debug-on-error nil)) 129 (let ((ert-debug-on-error nil))
130 (ert-run-test test)))) 130 (ert-run-test test))))
131 (let ((test (make-ert-test :body (lambda () 131 (let ((test (make-ert-test :body (lambda ()
132 (let ((ert-debug-on-error nil)) 132 (let ((ert-debug-on-error nil))
133 (ert-fail "failure message")))))) 133 (ert-fail "failure message"))))))
134 (block nil 134 (cl-block nil
135 (let ((debugger (lambda (&rest debugger-args) 135 (let ((debugger (lambda (&rest _args)
136 (return-from nil nil)))) 136 (cl-return-from nil nil))))
137 (let ((ert-debug-on-error t)) 137 (let ((ert-debug-on-error t))
138 (ert-run-test test)) 138 (ert-run-test test))
139 (assert nil nil "Assertion b"))))) 139 (cl-assert nil nil "Assertion b")))))
140 140
141(ert-deftest ert-test-error () 141(ert-deftest ert-test-error ()
142 (let ((test (make-ert-test :body (lambda () (error "Error message"))))) 142 (let ((test (make-ert-test :body (lambda () (error "Error message")))))
143 (let ((result (let ((ert-debug-on-error nil)) 143 (let ((result (let ((ert-debug-on-error nil))
144 (ert-run-test test)))) 144 (ert-run-test test))))
145 (assert (ert-test-failed-p result) t) 145 (cl-assert (ert-test-failed-p result) t)
146 (assert (equal (ert-test-result-with-condition-condition result) 146 (cl-assert (equal (ert-test-result-with-condition-condition result)
147 '(error "Error message")) 147 '(error "Error message"))
148 t)))) 148 t))))
149 149
@@ -153,9 +153,9 @@ failed or if there was a problem."
153 (progn 153 (progn
154 (let ((ert-debug-on-error t)) 154 (let ((ert-debug-on-error t))
155 (ert-run-test test)) 155 (ert-run-test test))
156 (assert nil)) 156 (cl-assert nil))
157 ((error) 157 ((error)
158 (assert (equal condition '(error "Error message")) t))))) 158 (cl-assert (equal condition '(error "Error message")) t)))))
159 159
160 160
161;;; Test that `should' works. 161;;; Test that `should' works.
@@ -163,13 +163,13 @@ failed or if there was a problem."
163 (let ((test (make-ert-test :body (lambda () (should nil))))) 163 (let ((test (make-ert-test :body (lambda () (should nil)))))
164 (let ((result (let ((ert-debug-on-error nil)) 164 (let ((result (let ((ert-debug-on-error nil))
165 (ert-run-test test)))) 165 (ert-run-test test))))
166 (assert (ert-test-failed-p result) t) 166 (cl-assert (ert-test-failed-p result) t)
167 (assert (equal (ert-test-result-with-condition-condition result) 167 (cl-assert (equal (ert-test-result-with-condition-condition result)
168 '(ert-test-failed ((should nil) :form nil :value nil))) 168 '(ert-test-failed ((should nil) :form nil :value nil)))
169 t))) 169 t)))
170 (let ((test (make-ert-test :body (lambda () (should t))))) 170 (let ((test (make-ert-test :body (lambda () (should t)))))
171 (let ((result (ert-run-test test))) 171 (let ((result (ert-run-test test)))
172 (assert (ert-test-passed-p result) t)))) 172 (cl-assert (ert-test-passed-p result) t))))
173 173
174(ert-deftest ert-test-should-value () 174(ert-deftest ert-test-should-value ()
175 (should (eql (should 'foo) 'foo)) 175 (should (eql (should 'foo) 'foo))
@@ -179,17 +179,18 @@ failed or if there was a problem."
179 (let ((test (make-ert-test :body (lambda () (should-not t))))) 179 (let ((test (make-ert-test :body (lambda () (should-not t)))))
180 (let ((result (let ((ert-debug-on-error nil)) 180 (let ((result (let ((ert-debug-on-error nil))
181 (ert-run-test test)))) 181 (ert-run-test test))))
182 (assert (ert-test-failed-p result) t) 182 (cl-assert (ert-test-failed-p result) t)
183 (assert (equal (ert-test-result-with-condition-condition result) 183 (cl-assert (equal (ert-test-result-with-condition-condition result)
184 '(ert-test-failed ((should-not t) :form t :value t))) 184 '(ert-test-failed ((should-not t) :form t :value t)))
185 t))) 185 t)))
186 (let ((test (make-ert-test :body (lambda () (should-not nil))))) 186 (let ((test (make-ert-test :body (lambda () (should-not nil)))))
187 (let ((result (ert-run-test test))) 187 (let ((result (ert-run-test test)))
188 (assert (ert-test-passed-p result))))) 188 (cl-assert (ert-test-passed-p result)))))
189
189 190
190(ert-deftest ert-test-should-with-macrolet () 191(ert-deftest ert-test-should-with-macrolet ()
191 (let ((test (make-ert-test :body (lambda () 192 (let ((test (make-ert-test :body (lambda ()
192 (macrolet ((foo () `(progn t nil))) 193 (cl-macrolet ((foo () `(progn t nil)))
193 (should (foo))))))) 194 (should (foo)))))))
194 (let ((result (let ((ert-debug-on-error nil)) 195 (let ((result (let ((ert-debug-on-error nil))
195 (ert-run-test test)))) 196 (ert-run-test test))))
@@ -303,32 +304,33 @@ This macro is used to test if macroexpansion in `should' works."
303 304
304(ert-deftest ert-test-should-failure-debugging () 305(ert-deftest ert-test-should-failure-debugging ()
305 "Test that `should' errors contain the information we expect them to." 306 "Test that `should' errors contain the information we expect them to."
306 (loop for (body expected-condition) in 307 (cl-loop
307 `((,(lambda () (let ((x nil)) (should x))) 308 for (body expected-condition) in
308 (ert-test-failed ((should x) :form x :value nil))) 309 `((,(lambda () (let ((x nil)) (should x)))
309 (,(lambda () (let ((x t)) (should-not x))) 310 (ert-test-failed ((should x) :form x :value nil)))
310 (ert-test-failed ((should-not x) :form x :value t))) 311 (,(lambda () (let ((x t)) (should-not x)))
311 (,(lambda () (let ((x t)) (should (not x)))) 312 (ert-test-failed ((should-not x) :form x :value t)))
312 (ert-test-failed ((should (not x)) :form (not t) :value nil))) 313 (,(lambda () (let ((x t)) (should (not x))))
313 (,(lambda () (let ((x nil)) (should-not (not x)))) 314 (ert-test-failed ((should (not x)) :form (not t) :value nil)))
314 (ert-test-failed ((should-not (not x)) :form (not nil) :value t))) 315 (,(lambda () (let ((x nil)) (should-not (not x))))
315 (,(lambda () (let ((x t) (y nil)) (should-not 316 (ert-test-failed ((should-not (not x)) :form (not nil) :value t)))
316 (ert--test-my-list x y)))) 317 (,(lambda () (let ((x t) (y nil)) (should-not
317 (ert-test-failed 318 (ert--test-my-list x y))))
318 ((should-not (ert--test-my-list x y)) 319 (ert-test-failed
319 :form (list t nil) 320 ((should-not (ert--test-my-list x y))
320 :value (t nil)))) 321 :form (list t nil)
321 (,(lambda () (let ((x t)) (should (error "Foo")))) 322 :value (t nil))))
322 (error "Foo"))) 323 (,(lambda () (let ((_x t)) (should (error "Foo"))))
323 do 324 (error "Foo")))
324 (let ((test (make-ert-test :body body))) 325 do
325 (condition-case actual-condition 326 (let ((test (make-ert-test :body body)))
326 (progn 327 (condition-case actual-condition
327 (let ((ert-debug-on-error t)) 328 (progn
328 (ert-run-test test)) 329 (let ((ert-debug-on-error t))
329 (assert nil)) 330 (ert-run-test test))
330 ((error) 331 (cl-assert nil))
331 (should (equal actual-condition expected-condition))))))) 332 ((error)
333 (should (equal actual-condition expected-condition)))))))
332 334
333(ert-deftest ert-test-deftest () 335(ert-deftest ert-test-deftest ()
334 (should (equal (macroexpand '(ert-deftest abc () "foo" :tags '(bar))) 336 (should (equal (macroexpand '(ert-deftest abc () "foo" :tags '(bar)))
@@ -520,7 +522,7 @@ This macro is used to test if macroexpansion in `should' works."
520 (setf (cdr (last a)) (cddr a)) 522 (setf (cdr (last a)) (cddr a))
521 (should (not (ert--proper-list-p a)))) 523 (should (not (ert--proper-list-p a))))
522 (let ((a (list 1 2 3 4))) 524 (let ((a (list 1 2 3 4)))
523 (setf (cdr (last a)) (cdddr a)) 525 (setf (cdr (last a)) (cl-cdddr a))
524 (should (not (ert--proper-list-p a))))) 526 (should (not (ert--proper-list-p a)))))
525 527
526(ert-deftest ert-test-parse-keys-and-body () 528(ert-deftest ert-test-parse-keys-and-body ()
@@ -657,14 +659,14 @@ This macro is used to test if macroexpansion in `should' works."
657 (i 0)) 659 (i 0))
658 (let ((result (ert--remove-if-not (lambda (x) 660 (let ((result (ert--remove-if-not (lambda (x)
659 (should (eql x (nth i list))) 661 (should (eql x (nth i list)))
660 (incf i) 662 (cl-incf i)
661 (member i '(2 3))) 663 (member i '(2 3)))
662 list))) 664 list)))
663 (should (equal i 4)) 665 (should (equal i 4))
664 (should (equal result '(b c))) 666 (should (equal result '(b c)))
665 (should (equal list '(a b c d))))) 667 (should (equal list '(a b c d)))))
666 (should (equal '() 668 (should (equal '()
667 (ert--remove-if-not (lambda (x) (should nil)) '())))) 669 (ert--remove-if-not (lambda (_x) (should nil)) '()))))
668 670
669(ert-deftest ert-test-remove* () 671(ert-deftest ert-test-remove* ()
670 (let ((list (list 'a 'b 'c 'd)) 672 (let ((list (list 'a 'b 'c 'd))
@@ -676,13 +678,13 @@ This macro is used to test if macroexpansion in `should' works."
676 (should (eql x (nth key-index list))) 678 (should (eql x (nth key-index list)))
677 (prog1 679 (prog1
678 (list key-index x) 680 (list key-index x)
679 (incf key-index))) 681 (cl-incf key-index)))
680 :test 682 :test
681 (lambda (a b) 683 (lambda (a b)
682 (should (eql a 'foo)) 684 (should (eql a 'foo))
683 (should (equal b (list test-index 685 (should (equal b (list test-index
684 (nth test-index list)))) 686 (nth test-index list))))
685 (incf test-index) 687 (cl-incf test-index)
686 (member test-index '(2 3)))))) 688 (member test-index '(2 3))))))
687 (should (equal key-index 4)) 689 (should (equal key-index 4))
688 (should (equal test-index 4)) 690 (should (equal test-index 4))
diff --git a/test/automated/ert-x-tests.el b/test/automated/ert-x-tests.el
index 520502bb307..e03c8475442 100644
--- a/test/automated/ert-x-tests.el
+++ b/test/automated/ert-x-tests.el
@@ -28,7 +28,7 @@
28;;; Code: 28;;; Code:
29 29
30(eval-when-compile 30(eval-when-compile
31 (require 'cl)) 31 (require 'cl-lib))
32(require 'ert) 32(require 'ert)
33(require 'ert-x) 33(require 'ert-x)
34 34
@@ -233,8 +233,8 @@ desired effect."
233 (should (equal (buffer-string) "")) 233 (should (equal (buffer-string) ""))
234 (let ((message-log-max 2)) 234 (let ((message-log-max 2))
235 (let ((message-log-max t)) 235 (let ((message-log-max t))
236 (loop for i below 4 do 236 (cl-loop for i below 4 do
237 (message "%s" i)) 237 (message "%s" i))
238 (should (equal (buffer-string) "0\n1\n2\n3\n"))) 238 (should (equal (buffer-string) "0\n1\n2\n3\n")))
239 (should (equal (buffer-string) "0\n1\n2\n3\n")) 239 (should (equal (buffer-string) "0\n1\n2\n3\n"))
240 (message "") 240 (message "")
@@ -244,28 +244,28 @@ desired effect."
244 244
245(ert-deftest ert-test-force-message-log-buffer-truncation () 245(ert-deftest ert-test-force-message-log-buffer-truncation ()
246 :tags '(:causes-redisplay) 246 :tags '(:causes-redisplay)
247 (labels ((body () 247 (cl-labels ((body ()
248 (loop for i below 3 do 248 (cl-loop for i below 3 do
249 (message "%s" i))) 249 (message "%s" i)))
250 ;; Uses the implicit messages buffer truncation implemented 250 ;; Uses the implicit messages buffer truncation implemented
251 ;; in Emacs' C core. 251 ;; in Emacs' C core.
252 (c (x) 252 (c (x)
253 (ert-with-buffer-renamed ("*Messages*") 253 (ert-with-buffer-renamed ("*Messages*")
254 (let ((message-log-max x)) 254 (let ((message-log-max x))
255 (body)) 255 (body))
256 (with-current-buffer "*Messages*" 256 (with-current-buffer "*Messages*"
257 (buffer-string)))) 257 (buffer-string))))
258 ;; Uses our lisp reimplementation. 258 ;; Uses our lisp reimplementation.
259 (lisp (x) 259 (lisp (x)
260 (ert-with-buffer-renamed ("*Messages*") 260 (ert-with-buffer-renamed ("*Messages*")
261 (let ((message-log-max t)) 261 (let ((message-log-max t))
262 (body)) 262 (body))
263 (let ((message-log-max x)) 263 (let ((message-log-max x))
264 (ert--force-message-log-buffer-truncation)) 264 (ert--force-message-log-buffer-truncation))
265 (with-current-buffer "*Messages*" 265 (with-current-buffer "*Messages*"
266 (buffer-string))))) 266 (buffer-string)))))
267 (loop for x in '(0 1 2 3 4 t) do 267 (cl-loop for x in '(0 1 2 3 4 t) do
268 (should (equal (c x) (lisp x)))))) 268 (should (equal (c x) (lisp x))))))
269 269
270 270
271(provide 'ert-x-tests) 271(provide 'ert-x-tests)