diff options
| author | Kenichi Handa <handa@gnu.org> | 2012-11-23 23:36:24 +0900 |
|---|---|---|
| committer | Kenichi Handa <handa@gnu.org> | 2012-11-23 23:36:24 +0900 |
| commit | 2aaec2d9be5cec44ea3b59cba476fd3e091f2fc9 (patch) | |
| tree | 3711b97807201b7eeaa066003b1c3a4ce929e5bb | |
| parent | e1d276cbf9e18f13101328f56bed1a1c0a66e63a (diff) | |
| parent | e7d0e5ee247a155a268ffbf80bedbe25e15b5032 (diff) | |
114 files changed, 2574 insertions, 1987 deletions
diff --git a/ChangeLog b/ChangeLog index 05e1a14d55d..03815e86ff8 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,25 @@ +2012-11-23 Paul Eggert <eggert@cs.ucla.edu> + + Assume POSIX 1003.1-1988 or later for dirent.h (Bug#12958). + * configure.ac: Do not check for dirent.h or closdir. + +2012-11-21 Paul Eggert <eggert@cs.ucla.edu> + + Assume POSIX 1003.1-1988 or later for unistd.h (Bug#12945). + * configure.ac: Do not check for getcwd or getwd. + +2012-11-21 Glenn Morris <rgm@gnu.org> + + * configure.ac (--enable-profiling): Doc fix. + +2012-11-20 Paul Eggert <eggert@cs.ucla.edu> + + Improve static checking of integer overflow and stack smashing. + * configure.ac (WARN_CFLAGS): Add -Wstack-protector + if using GCC 4.7.2 or later on a platform with + at least 64-bit long int. This improves static checking on these + platforms, when configured with --enable-gcc-warnings. + 2012-11-17 Paul Eggert <eggert@cs.ucla.edu> 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. AMPERSAND_FULL_NAME BROKEN_DATAGRAM_SOCKETS BROKEN_FIONREAD -BROKEN_GETWD BROKEN_GET_CURRENT_DIR_NAME BROKEN_NON_BLOCKING_CONNECT BROKEN_PTY_READ_AFTER_EAGAIN @@ -119,7 +118,6 @@ HAVE_CFMAKERAW HAVE_CFSETSPEED HAVE_CLOCK_GETTIME HAVE_CLOCK_SETTIME -HAVE_CLOSEDIR HAVE_COFF_H HAVE_COM_ERR_H HAVE_COPYSIGN @@ -144,7 +142,6 @@ HAVE_DES_H HAVE_DEV_PTMX HAVE_DIALOGS HAVE_DIFFTIME -HAVE_DIRENT_H HAVE_DUP2 HAVE_ENDGRENT HAVE_ENDPWENT @@ -161,7 +158,6 @@ HAVE_FUTIMESAT HAVE_GAI_STRERROR HAVE_GCONF HAVE_GETADDRINFO -HAVE_GETCWD HAVE_GETDELIM HAVE_GETGRENT HAVE_GETHOSTNAME @@ -178,7 +174,6 @@ HAVE_GETRLIMIT HAVE_GETRUSAGE HAVE_GETSOCKNAME HAVE_GETTIMEOFDAY -HAVE_GETWD HAVE_GET_CURRENT_DIR_NAME HAVE_GHOSTSCRIPT HAVE_GIF @@ -304,7 +299,6 @@ HAVE_SIGNED_SIG_ATOMIC_T HAVE_SIGNED_WCHAR_T HAVE_SIGNED_WINT_T HAVE_SIGSET_T -HAVE_SIZE_T HAVE_SNPRINTF HAVE_SOCKETS HAVE_SOUND @@ -369,7 +363,6 @@ HAVE_TM_ZONE HAVE_TOUCHLOCK HAVE_TZNAME HAVE_TZSET -HAVE_UNISTD_H HAVE_UNSIGNED_LONG_LONG_INT HAVE_UTIL_H HAVE_UTIMENSAT diff --git a/admin/ChangeLog b/admin/ChangeLog index 3d76f9dd2ba..fe75ae57a6d 100644 --- a/admin/ChangeLog +++ b/admin/ChangeLog @@ -1,3 +1,15 @@ +2012-11-23 Paul Eggert <eggert@cs.ucla.edu> + + Assume POSIX 1003.1-1988 or later for dirent.h (Bug#12958). + * CPP-DEFINES (HAVE_CLOSEDIR, HAVE_DIRENT_H): Remove. + * notes/copyright: Adjust to src/ndir.h -> nt/inc/dirent.h renaming. + +2012-11-21 Paul Eggert <eggert@cs.ucla.edu> + + Assume POSIX 1003.1-1988 or later for unistd.h (Bug#12945). + * CPP-DEFINES (BROKEN_GETWD, HAVE_GETCWD, HAVE_GETWD, HAVE_SIZE_T) + (HAVE_UNISTD_H): Remove. + 2012-11-17 Paul Eggert <eggert@cs.ucla.edu> 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. src/gmalloc.c - contains numerous copyrights from the GNU C library. Leave them alone. -src/ndir.h +nt/inc/dirent.h - see comments below. This file is OK to be released with Emacs 22, but we may want to revisit it afterwards. @@ -429,7 +429,7 @@ admin/check-doc-strings File says it's in the public domain, but that might not make it so. etc/e/eterm-color.ti -src/ndir.h +nt/inc/dirent.h On legal advice from Matt Norwood, the following comment was added to these files in Feb/Mar 2007: 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/>. */ /* Define to the number of bits in type 'wint_t'. */ #undef BITSIZEOF_WINT_T -/* Define if getwd should not be used. */ -#undef BROKEN_GETWD - /* Define if get_current_dir_name should not be used. */ #undef BROKEN_GET_CURRENT_DIR_NAME @@ -256,9 +253,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ /* Define to 1 if you have the `clock_settime' function. */ #undef HAVE_CLOCK_SETTIME -/* Define to 1 if you have the `closedir' function. */ -#undef HAVE_CLOSEDIR - /* Define to 1 if you have the <coff.h> header file. */ #undef HAVE_COFF_H @@ -342,9 +336,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ /* Define to 1 if you have the `difftime' function. */ #undef HAVE_DIFFTIME -/* Define to 1 if you have the <dirent.h> header file. */ -#undef HAVE_DIRENT_H - /* Define to 1 if you have the 'dup2' function. */ #undef HAVE_DUP2 @@ -402,9 +393,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ /* Define to 1 if you have the `getaddrinfo' function. */ #undef HAVE_GETADDRINFO -/* Define to 1 if you have the `getcwd' function. */ -#undef HAVE_GETCWD - /* Define to 1 if you have the `getdelim' function. */ #undef HAVE_GETDELIM @@ -453,9 +441,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ /* Define to 1 if you have the `gettimeofday' function. */ #undef HAVE_GETTIMEOFDAY -/* Define to 1 if you have the `getwd' function. */ -#undef HAVE_GETWD - /* Define to 1 if you have the `get_current_dir_name' function. */ #undef HAVE_GET_CURRENT_DIR_NAME diff --git a/autogen/configure b/autogen/configure index afcf9a73fa6..fbb2efbc860 100755 --- a/autogen/configure +++ b/autogen/configure @@ -2058,8 +2058,9 @@ Optional Features: enable compile time checks for the Lisp_Object data type. This is useful for development for catching certain types of bugs. - --enable-profiling build emacs with profiling support. This might not - work on all platforms + --enable-profiling build emacs with low-level, gprof profiling support. + Mainly useful for debugging Emacs itself. May not + work on all platforms. Stops profiler.el working. --enable-autodepend automatically generate dependencies to .h-files. Requires GNU Make and Gcc. Enabled if GNU Make and Gcc is found @@ -3213,7 +3214,6 @@ as_fn_append ac_header_list " sys/resource.h" as_fn_append ac_header_list " sys/utsname.h" as_fn_append ac_header_list " pwd.h" as_fn_append ac_header_list " utmp.h" -as_fn_append ac_header_list " dirent.h" as_fn_append ac_header_list " util.h" as_fn_append ac_header_list " sys/socket.h" as_fn_append ac_header_list " stdlib.h" @@ -7257,6 +7257,8 @@ fi nw="$nw -Wfloat-equal" # warns about high-quality code nw="$nw -Winline" # OK to ignore 'inline' nw="$nw -Wjump-misses-init" # We sometimes safely jump over init. + nw="$nw -Wstrict-overflow" # OK to optimize assuming that + # signed overflow has undefined behavior nw="$nw -Wsync-nand" # irrelevant here, and provokes ObjC warning nw="$nw -Wunsafe-loop-optimizations" # OK to suppress unsafe optimizations @@ -7264,11 +7266,38 @@ fi # <http://lists.gnu.org/archive/html/emacs-diffs/2011-11/msg00265.html>. nw="$nw -Wshadow" - # The following lines should be removable at some point. - nw="$nw -Wstack-protector" - nw="$nw -Wstrict-overflow" + # The following line should be removable at some point. nw="$nw -Wsuggest-attribute=pure" + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to use -Wstack-protector" >&5 +$as_echo_n "checking whether to use -Wstack-protector... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#if (1 <= __LONG_MAX__ >> 31 >> 31 \ + && 4 < __GNUC__ + (7 < __GNUC_MINOR__ + (2 <= __GNUC_PATCHLEVEL__))) + /* OK */ + #else + #error "Not GCC, or GCC before 4.7.2, or 'long int' has < 64 bits." + #endif + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + nw="$nw -Wstack-protector" +fi +rm -f conftest.err conftest.$ac_ext + if test -n "$GCC"; then @@ -8779,8 +8808,6 @@ done - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking if personality LINUX32 can be set" >&5 $as_echo_n "checking if personality LINUX32 can be set... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext @@ -13444,10 +13471,10 @@ esac for ac_func in gethostname \ -closedir getrusage get_current_dir_name \ +getrusage get_current_dir_name \ lrand48 \ select getpagesize setlocale \ -utimes getrlimit setrlimit getcwd shutdown getaddrinfo \ +utimes getrlimit setrlimit shutdown getaddrinfo \ strsignal setitimer \ sendto recvfrom getsockname getpeername getifaddrs freeifaddrs \ gai_strerror mkstemp getline getdelim fsync sync \ @@ -13468,24 +13495,6 @@ fi done -if test $opsys = unixware; then - -$as_echo "#define BROKEN_GETWD 1" >>confdefs.h - -else - for ac_func in getwd -do : - ac_fn_c_check_func "$LINENO" "getwd" "ac_cv_func_getwd" -if test "x$ac_cv_func_getwd" = x""yes; then : - cat >>confdefs.h <<_ACEOF -#define HAVE_GETWD 1 -_ACEOF - -fi -done - -fi - ## Eric Backus <ericb@lsid.hp.com> says, HP-UX 9.x on HP 700 machines ## has a broken `rint' in some library versions including math library ## 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 fi) +dnl The name of this option is unfortunate. It predates, and has no +dnl relation to, the "sampling-based elisp profiler" added in 24.3. +dnl Actually, it stops it working. +dnl http://lists.gnu.org/archive/html/emacs-devel/2012-11/msg00393.html AC_ARG_ENABLE(profiling, [AS_HELP_STRING([--enable-profiling], - [build emacs with profiling support. - This might not work on all platforms])], + [build emacs with low-level, gprof profiling support. + Mainly useful for debugging Emacs itself. May not work on + all platforms. Stops profiler.el working.])], [ac_enable_profiling="${enableval}"],[]) if test x$ac_enable_profiling != x ; then PROFILING_CFLAGS="-DPROFILING=1 -pg" @@ -710,6 +715,8 @@ else nw="$nw -Wfloat-equal" # warns about high-quality code nw="$nw -Winline" # OK to ignore 'inline' nw="$nw -Wjump-misses-init" # We sometimes safely jump over init. + nw="$nw -Wstrict-overflow" # OK to optimize assuming that + # signed overflow has undefined behavior nw="$nw -Wsync-nand" # irrelevant here, and provokes ObjC warning nw="$nw -Wunsafe-loop-optimizations" # OK to suppress unsafe optimizations @@ -717,11 +724,23 @@ else # <http://lists.gnu.org/archive/html/emacs-diffs/2011-11/msg00265.html>. nw="$nw -Wshadow" - # The following lines should be removable at some point. - nw="$nw -Wstack-protector" - nw="$nw -Wstrict-overflow" + # The following line should be removable at some point. nw="$nw -Wsuggest-attribute=pure" + AC_MSG_CHECKING([whether to use -Wstack-protector]) + AC_PREPROC_IFELSE( + [AC_LANG_PROGRAM( + [[#if (1 <= __LONG_MAX__ >> 31 >> 31 \ + && 4 < __GNUC__ + (7 < __GNUC_MINOR__ + (2 <= __GNUC_PATCHLEVEL__))) + /* OK */ + #else + #error "Not GCC, or GCC before 4.7.2, or 'long int' has < 64 bits." + #endif + ]])], + [AC_MSG_RESULT(yes)], + [AC_MSG_RESULT(no) + nw="$nw -Wstack-protector"]) + gl_MANYWARN_ALL_GCC([ws]) gl_MANYWARN_COMPLEMENT([ws], [$ws], [$nw]) for w in $ws; do @@ -1270,7 +1289,7 @@ AC_CHECK_HEADERS_ONCE( linux/version.h sys/systeminfo.h coff.h pty.h sys/vlimit.h sys/resource.h - sys/utsname.h pwd.h utmp.h dirent.h util.h) + sys/utsname.h pwd.h utmp.h util.h) AC_MSG_CHECKING(if personality LINUX32 can be set) AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <sys/personality.h>]], [[personality (PER_LINUX32)]])], @@ -2872,10 +2891,10 @@ AC_SUBST(BLESSMAIL_TARGET) AC_CHECK_FUNCS(gethostname \ -closedir getrusage get_current_dir_name \ +getrusage get_current_dir_name \ lrand48 \ select getpagesize setlocale \ -utimes getrlimit setrlimit getcwd shutdown getaddrinfo \ +utimes getrlimit setrlimit shutdown getaddrinfo \ strsignal setitimer \ sendto recvfrom getsockname getpeername getifaddrs freeifaddrs \ gai_strerror mkstemp getline getdelim fsync sync \ @@ -2884,14 +2903,6 @@ getpwent endpwent getgrent endgrent \ touchlock \ cfmakeraw cfsetspeed copysign __executable_start) -dnl getwd appears to be buggy on SVR4.2, so we don't use it. -if test $opsys = unixware; then - dnl In case some other test ends up checking for getwd. - AC_DEFINE(BROKEN_GETWD, 1, [Define if getwd should not be used.]) -else - AC_CHECK_FUNCS(getwd) -fi - ## Eric Backus <ericb@lsid.hp.com> says, HP-UX 9.x on HP 700 machines ## has a broken `rint' in some library versions including math library ## 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 @@ +2012-11-21 Dani Moncayo <dmoncayo@gmail.com> + + * display.texi (Auto Scrolling): Fix some inaccuracies, plus + clarifications (Bug#12865). + (Horizontal Scrolling): Clarifications. + 2012-11-18 Dani Moncayo <dmoncayo@gmail.com> * 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. @node Auto Scrolling @section Automatic Scrolling +@cindex automatic scrolling Emacs performs @dfn{automatic scrolling} when point moves out of the -visible portion of the text. +visible portion of the text. Normally, automatic scrolling centers +point vertically in the window, but there are several ways to alter +this behavior. @vindex scroll-conservatively - Normally, this centers point vertically within the window. However, -if you set @code{scroll-conservatively} to a small number @var{n}, -then if you move point just a little off the screen (less than @var{n} -lines), Emacs scrolls the text just far enough to bring point back on -screen. If doing so fails to make point visible, Emacs centers point -in the window. By default, @code{scroll-conservatively} is@tie{}0. -If you set @code{scroll-conservatively} to a large number (larger than -100), Emacs will never center point as result of scrolling, even if -point moves far away from the text previously displayed in the window. -With such a large value, Emacs will always scroll text just enough for -bringing point into view, so point will end up at the top or bottom of -the window, depending on the scroll direction. + If you set @code{scroll-conservatively} to a small number @var{n}, +then moving point just a little off the screen (no more than @var{n} +lines) causes Emacs to scroll just enough to bring point back on +screen; if doing so fails to make point visible, Emacs scrolls just +far enough to center point in the window. If you set +@code{scroll-conservatively} to a large number (larger than 100), +automatic scrolling never centers point, no matter how far point +moves; Emacs always scrolls text just enough to bring point into view, +either at the top or bottom of the window depending on the scroll +direction. By default, @code{scroll-conservatively} is@tie{}0, which +means to always center point in the window. @vindex scroll-step - An alternative way of controlling how Emacs scrolls text is by -customizing the variable @code{scroll-step}. Its value determines how -many lines to scroll the window when point moves off the screen. If -moving by that number of lines fails to bring point back into view, -point is centered instead. The default value is zero, which causes -point to always be centered after scrolling. - - Since both @code{scroll-conservatively} and @code{scroll-step} -control automatic scrolling in contradicting ways, you should set only -one of them. If you customize both, the value of -@code{scroll-conservatively} takes precedence. + Another way to control automatic scrolling is to customize the +variable @code{scroll-step}. Its value determines the number of lines +by which to automatically scroll, when point moves off the screen. If +scrolling by that number of lines fails to bring point back into view, +point is centered instead. The default value is zero, which (by +default) causes point to always be centered after scrolling. @cindex aggressive scrolling @vindex scroll-up-aggressively @vindex scroll-down-aggressively - When the window does scroll by a distance longer than -@code{scroll-step}, you can control how aggressively it scrolls by -setting the variables @code{scroll-up-aggressively} and -@code{scroll-down-aggressively}. The value of -@code{scroll-up-aggressively} should be either @code{nil}, or a -fraction @var{f} between 0 and 1. A fraction specifies where on the -screen to put point when scrolling upward, i.e.@: forward. When point -goes off the window end, the new start position is chosen to put point -@var{f} parts of the window height from the bottom margin. Thus, -larger @var{f} means more aggressive scrolling: more new text is -brought into view. The default value, @code{nil}, is equivalent to -0.5. + A third way to control automatic scrolling is to customize the +variables @code{scroll-up-aggressively} and +@code{scroll-down-aggressively}, which directly specify the vertical +position of point after scrolling. The value of +@code{scroll-up-aggressively} should be either @code{nil} (the +default), or a floating point number @var{f} between 0 and 1. The +latter means that when point goes below the bottom window edge (i.e.@: +scrolling forward), Emacs scrolls the window so that point is @var{f} +parts of the window height from the bottom window edge. Thus, larger +@var{f} means more aggressive scrolling: more new text is brought into +view. The default value, @code{nil}, is equivalent to 0.5. - Likewise, @code{scroll-down-aggressively} is used for scrolling -down, i.e.@: backward. The value specifies how far point should be -placed from the top margin of the window; thus, as with -@code{scroll-up-aggressively}, a larger value is more aggressive. + Likewise, @code{scroll-down-aggressively} is used when point goes +above the bottom window edge (i.e.@: scrolling backward). The value +specifies how far point should be from the top margin of the window +after scrolling. Thus, as with @code{scroll-up-aggressively}, a +larger value is more aggressive. - These two variables are ignored if either @code{scroll-step} or -@code{scroll-conservatively} are set to a non-zero value. + Note that the variables @code{scroll-conservatively}, +@code{scroll-step}, and @code{scroll-up-aggressively} / +@code{scroll-down-aggressively} control automatic scrolling in +contradictory ways. Therefore, you should pick no more than one of +these methods to customize automatic scrolling. In case you customize +multiple variables, the order of priority is: +@code{scroll-conservatively}, then @code{scroll-step}, and finally +@code{scroll-up-aggressively} / @code{scroll-down-aggressively}. @vindex scroll-margin The variable @code{scroll-margin} restricts how close point can come @@ -295,10 +298,10 @@ the cursor is left at the edge instead.) @vindex hscroll-margin The variable @code{hscroll-margin} controls how close point can get -to the window's edges before automatic scrolling occurs. It is -measured in columns. For example, if the value is 5, then moving -point within 5 columns of an edge causes horizontal scrolling away -from that edge. +to the window's left and right edges before automatic scrolling +occurs. It is measured in columns. For example, if the value is 5, +then moving point within 5 columns of an edge causes horizontal +scrolling away from that edge. @vindex hscroll-step 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 @@ +2012-11-21 Glenn Morris <rgm@gnu.org> + + * display.texi (Attribute Functions): + Update for set-face-* name changes. + Add new "inherit" argument for face-bold-p etc. + Move description of this argument to a common section, like "frame". + + * debugging.texi (Profiling): New section. + (Debugging): Mention profiling in the introduction. + * tips.texi (Compilation Tips): Move profiling to separate section. + * elisp.texi: Add Profiling to detailed menu. + +2012-11-21 Martin Rudalics <rudalics@gmx.at> + + * windows.texi (Display Action Functions): Fix recently added + example. Suggested by Michael Heerdegen. + +2012-11-21 Paul Eggert <eggert@cs.ucla.edu> + + Minor cleanup for times as lists of four integers. + * os.texi (Time Parsing): Time values can now be four integers. + 2012-11-18 Glenn Morris <rgm@gnu.org> * 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. @item You can use the ERT package to write regression tests for the program. @xref{Top,the ERT manual,, ERT, ERT: Emacs Lisp Regression Testing}. + +@item +You can profile the program to get hints about how to make it more efficient. @end itemize Other useful tools for debugging input and output problems are the @@ -43,6 +46,7 @@ function (@pxref{Terminal Output}). * Edebug:: A source-level Emacs Lisp debugger. * Syntax Errors:: How to find syntax errors. * Test Coverage:: Ensuring you have tested all branches in your code. +* Profiling:: Measuring the resources that your code uses. @end menu @node Debugger @@ -809,3 +813,63 @@ never return. If it ever does return, you get a run-time error. Edebug also has a coverage testing feature (@pxref{Coverage Testing}). These features partly duplicate each other, and it would be cleaner to combine them. + + +@node Profiling +@section Profiling +@cindex profiling +@cindex measuring resource usage +@cindex memory usage + +If your program is working correctly, but you want to make it run more +quickly or efficiently, the first thing to do is @dfn{profile} your +code so that you know how it is using resources. If you find that one +particular function is responsible for a significant portion of the +runtime, you can start looking for ways to optimize that piece. + +Emacs has built-in support for this. To begin profiling, type +@kbd{M-x profiler-start}. You can choose to profile by processor +usage, memory usage, or both. After doing some work, type +@kbd{M-x profiler-report} to display a summary buffer for each +resource that you chose to profile. The names of the report buffers +include the times at which the reports were generated, so you can +generate another report later on without erasing previous results. +When you have finished profiling, type @kbd{M-x profiler-stop} (there +is a small overhead associated with profiling). + +The profiler report buffer shows, on each line, a function that was +called, followed by how much resource (processor or memory) it used in +absolute and percentage times since profiling started. If a given +line has a @samp{+} symbol at the left-hand side, you can expand that +line by typing @key{RET}, in order to see the function(s) called by +the higher-level function. Pressing @key{RET} again will collapse +back to the original state. + +Press @kbd{j} or @kbd{mouse-2} to jump to the definition of a function. +Press @kbd{d} to view a function's documentation. +You can save a profile to a file using @kbd{C-x C-w}. +You can compare two profiles using @kbd{=}. + +@c FIXME reversed calltree? + +@cindex @file{elp.el} +@cindex timing programs +The @file{elp} library offers an alternative approach. See the file +@file{elp.el} for instructions. + +@cindex @file{benchmark.el} +@cindex benchmarking +You can check the speed of individual Emacs Lisp forms using the +@file{benchmark} library. See the functions @code{benchmark-run} and +@code{benchmark-run-compiled} in @file{benchmark.el}. + +@c Not worth putting in the printed manual. +@ifnottex +@cindex --enable-profiling option of configure +For low-level profiling of Emacs itself, you can build it using the +@option{--enable-profiling} option of @command{configure}. When Emacs +exits, it generates a file @file{gmon.out} that you can examine using +the @command{gprof} utility. This feature is mainly useful for +debugging Emacs. It actually stops the Lisp-level @kbd{M-x +profiler-@dots{}} commands described above from working. +@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 This sets the @code{:font} attribute of @var{face} to @var{font}. @end deffn -@defun set-face-bold-p face bold-p &optional frame +@defun set-face-bold face bold-p &optional frame This sets the @code{:weight} attribute of @var{face} to @var{normal} if @var{bold-p} is @code{nil}, and to @var{bold} otherwise. @end defun -@defun set-face-italic-p face italic-p &optional frame +@defun set-face-italic face italic-p &optional frame This sets the @code{:slant} attribute of @var{face} to @var{normal} if @var{italic-p} is @code{nil}, and to @var{italic} otherwise. @end defun @@ -2440,7 +2440,7 @@ This sets the @code{:underline} attribute of @var{face} to @var{underline}. @end defun -@defun set-face-inverse-video-p face inverse-video-p &optional frame +@defun set-face-inverse-video face inverse-video-p &optional frame This sets the @code{:inverse-video} attribute of @var{face} to @var{inverse-video-p}. @end defun @@ -2453,59 +2453,48 @@ This swaps the foreground and background colors of face @var{face}. don't specify @var{frame}, they refer to the selected frame; @code{t} refers to the default data for new frames. They return the symbol @code{unspecified} if the face doesn't define any value for that -attribute. +attribute. If @var{inherit} is @code{nil}, only an attribute directly +defined by the face is returned. If @var{inherit} is non-@code{nil}, +any faces specified by its @code{:inherit} attribute are considered as +well, and if @var{inherit} is a face or a list of faces, then they are +also considered, until a specified attribute is found. To ensure that +the return value is always specified, use a value of @code{default} for +@var{inherit}. + +@defun face-font face &optional frame +This function returns the name of the font of face @var{face}. +@end defun @defun face-foreground face &optional frame inherit @defunx face-background face &optional frame inherit These functions return the foreground color (or background color, respectively) of face @var{face}, as a string. - -If @var{inherit} is @code{nil}, only a color directly defined by the face is -returned. If @var{inherit} is non-@code{nil}, any faces specified by its -@code{:inherit} attribute are considered as well, and if @var{inherit} -is a face or a list of faces, then they are also considered, until a -specified color is found. To ensure that the return value is always -specified, use a value of @code{default} for @var{inherit}. @end defun @defun face-stipple face &optional frame inherit This function returns the name of the background stipple pattern of face @var{face}, or @code{nil} if it doesn't have one. - -If @var{inherit} is @code{nil}, only a stipple directly defined by the -face is returned. If @var{inherit} is non-@code{nil}, any faces -specified by its @code{:inherit} attribute are considered as well, and -if @var{inherit} is a face or a list of faces, then they are also -considered, until a specified stipple is found. To ensure that the -return value is always specified, use a value of @code{default} for -@var{inherit}. -@end defun - -@defun face-font face &optional frame -This function returns the name of the font of face @var{face}. @end defun -@defun face-bold-p face &optional frame +@defun face-bold-p face &optional frame inherit This function returns a non-@code{nil} value if the @code{:weight} attribute of @var{face} is bolder than normal (i.e., one of @code{semi-bold}, @code{bold}, @code{extra-bold}, or @code{ultra-bold}). Otherwise, it returns @code{nil}. @end defun -@defun face-italic-p face &optional frame +@defun face-italic-p face &optional frame inherit This function returns a non-@code{nil} value if the @code{:slant} attribute of @var{face} is @code{italic} or @code{oblique}, and @code{nil} otherwise. @end defun -@c Note the weasel words. A face that inherits from an underlined -@c face but does not specify :underline will return nil. -@defun face-underline-p face &optional frame +@defun face-underline-p face &optional frame inherit This function returns non-@code{nil} if face @var{face} specifies a non-@code{nil} @code{:underline} attribute. @end defun -@defun face-inverse-video-p face &optional frame +@defun face-inverse-video-p face &optional frame inherit This function returns non-@code{nil} if face @var{face} specifies a non-@code{nil} @code{:inverse-video} attribute. @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 * Edebug:: A source-level Emacs Lisp debugger. * Syntax Errors:: How to find syntax errors. * Test Coverage:: Ensuring you have tested all branches in your code. +* Profiling:: Measuring the resources that your code uses. The Lisp Debugger 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. @node Time Parsing @section Parsing and Formatting Times - These functions convert time values (lists of two or three integers) -to text in a string, and vice versa. + These functions convert time values to text in a string, and vice versa. +Time values are lists of two to four integers (@pxref{Time of Day}). @defun date-to-time string This 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. @itemize @bullet @item -@cindex profiling -@cindex timing programs -@cindex @file{elp.el} -Profile your program with the @file{elp} library. See the file -@file{elp.el} for instructions. - -@item -@cindex @file{benchmark.el} -@cindex benchmarking -Check the speed of individual Emacs Lisp forms using the -@file{benchmark} library. See the functions @code{benchmark-run} and -@code{benchmark-run-compiled} in @file{benchmark.el}. +Profile your program, to find out where the time is being spent. +@xref{Profiling}. @item Use 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 follows: If `*foo*' already appears on a visible or iconified frame, it will reuse its window. Otherwise, it will try to pop up a new window or, if that is impossible, a new frame. If all these steps fail, it -will try to use some existing window. +will proceed using whatever @code{display-buffer-base-action} and +@code{display-buffer-fallback-action} prescribe. Furthermore, @code{display-buffer} will try to adjust a reused window (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 @@ +2012-11-22 Paul Eggert <eggert@cs.ucla.edu> + + * calc.texi: Fix TeX issues with capitals followed by ".", "?", "!". + (Date Forms): Correct off-by-one error in explanation of + Julian day numbers. Give Gregorian equivalent of its origin. + +2012-11-22 Jay Belanger <jay.p.belanger@gmail.com> + + * doc/misc/calc.texi (Date Forms): Mention the customizable + Gregorian-Julian switch. + (Customizing Calc): Mention the variable `calc-gregorian-switch'. + 2012-11-17 Paul Eggert <eggert@cs.ucla.edu> - Calc now uses the Gregorian calendar for all dates, - and uses January 1, 1 AD as its day number 1. + Calc now uses the Gregorian calendar for all dates (Bug#12633). + It also uses January 1, 1 AD as its day number 1. * calc.texi (Date Forms): Document this. 2012-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 fair to give the user direct access to it, which in turn made it practical to support fractions as well as floats. All these features inspired me to look around for other data types that might be worth -having. +having. Around this time, my friend Rick Koshi showed me his nifty new HP-28 calculator. 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. Friday the 13th? @xref{Types Answer 5, 5}. (@bullet{}) (@bullet{}) @strong{Exercise 6.} How many leap years will there be -between now and the year 10001 A.D.? @xref{Types Answer 6, 6}. (@bullet{}) +between now and the year 10001 AD@? @xref{Types Answer 6, 6}. (@bullet{}) @cindex Slope and angle of a line @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 rearranged. (This one is rather tricky; the solution at the end of this chapter uses 6 rewrite rules. Hint: The @samp{constant(x)} condition tests whether @samp{x} is a number.) @xref{Rewrites Answer -6, 6}. (@bullet{}) +6, 6}. (@bullet{}) Just for kicks, try adding the rule @code{2+3 := 6} to @code{EvalRules}. What 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}. @smallexample @group ___ -1: V 2 +1: V 2 . 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 apply to any product-of-sum it encounters---this rule may surprise you if you put it into @code{EvalRules}! -In the second rule, the sum of two O's is changed to the smaller O. +In the second rule, the sum of two O's is changed to the smaller O@. The optional constant coefficients are there mostly so that @samp{O(x^2) - O(x^3)} and @samp{O(x^3) - O(x^2)} are handled as 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 notations for dates and times. @xref{Date Formats}. Date forms are stored internally as numbers, specifically the number -of days since midnight on the morning of January 1 of the year 1 AD. +of days since midnight on the morning of December 31 of the year 1 BC@. If the internal number is an integer, the form represents a date only; if the internal number is a fraction or float, the form represents -a date and time. For example, @samp{<6:00am Wed Jan 9, 1991>} +a date and time. For example, @samp{<6:00am Thu Jan 10, 1991>} is represented by the number 726842.25. The standard precision of 12 decimal digits is enough to ensure that a (reasonable) date and time can be stored without roundoff error. @@ -11010,55 +11010,70 @@ You can use the @kbd{v p} (@code{calc-pack}) and @kbd{v u} of a date form. @xref{Packing and Unpacking}. Date forms can go arbitrarily far into the future or past. Negative -year numbers represent years BC. There is no ``year 0''; the day +year numbers represent years BC@. There is no ``year 0''; the day before @samp{<Mon Jan 1, +1>} is @samp{<Sun Dec 31, -1>}. These are days 1 and 0 respectively in Calc's internal numbering scheme. The Gregorian calendar is used for all dates, including dates before the -Gregorian calendar was invented. Thus Calc's use of the day number -@mathit{-10000} to represent August 15, 28 BC should be taken with a -grain of salt. +Gregorian calendar was invented (although that can be configured; see +below). Thus Calc's use of the day number @mathit{-10000} to +represent August 15, 28 BC should be taken with a grain of salt. @cindex Julian calendar @cindex Gregorian calendar Some historical background: The Julian calendar was created by Julius Caesar in the year 46 BC as an attempt to fix the confusion caused by the irregular Roman calendar that was used before that time. -The Julian calendar introduced an extra day in -all years divisible by four. After some initial confusion, the -calendar was adopted around the year we call 8 AD, although the years were -numbered differently and did not necessarily begin on January 1. Some centuries -later it became apparent that the Julian year of 365.25 days was -itself not quite right. In 1582 Pope Gregory XIII introduced the -Gregorian calendar, which added the new rule that years divisible -by 100, but not by 400, were not to be considered leap years -despite being divisible by four. Many countries delayed adoption -of the Gregorian calendar because of religious differences, and -used differing year numbers and start-of-year for other reasons; -for example, in early 1752 England changed the start of its year from -March 25 to January 1, and in September it switched to the Gregorian -calendar: in England, the day after December 31, 1750 was January 1, -1750 and the day after March 24, 1750 was March 25, 1751, but the day -after December 31, 1751 was January 1, 1752 and the day after -September 2, 1752 was September 14, 1752. To take another example, -Russia switched both year numbering and start-of-year in 1700, but did -not adopt the Gregorian calendar until 1918. Calc's reckoning -therefore matches English practice starting in 1752 and Russian -practice starting in 1918, but disagrees with earlier dates in both -countries. +The Julian calendar introduced an extra day in all years divisible by +four. After some initial confusion, the calendar was adopted around +the year we call 8 AD@. Some centuries later it became +apparent that the Julian year of 365.25 days was itself not quite +right. In 1582 Pope Gregory XIII introduced the Gregorian calendar, +which added the new rule that years divisible by 100, but not by 400, +were not to be considered leap years despite being divisible by four. +Many countries delayed adoption of the Gregorian calendar +because of religious differences. For example, Great Britain and the +British colonies switched to the Gregorian calendar in September +1752, when the Julian calendar was eleven days behind the +Gregorian calendar. That year in Britain, the day after September 2 +was September 14. To take another example, Russia did not adopt the +Gregorian calendar until 1918, and that year in Russia the day after +January 31 was February 14. Calc's reckoning therefore matches English +practice starting in 1752 and Russian practice starting in 1918, but +disagrees with earlier dates in both countries. -Today's timekeepers introduce an occasional ``leap second'' as -well, but Calc does not take these minor effects into account. -(If it did, it would have to report a non-integer number of days -between, say, @samp{<12:00am Mon Jan 1, 1900>} and +When the Julian calendar was introduced, it had January 1 as the first +day of the year. By the Middle Ages, many European countries +had changed the beginning of a new year to a different date, often to +a religious festival. Almost all countries reverted to using January 1 +as the beginning of the year by the time they adopted the Gregorian +calendar. + +Some calendars attempt to mimic the historical situation by using the +Gregorian calendar for recent dates and the Julian calendar for older +dates. The @code{cal} program in most Unix implementations does this, +for example. While January 1 wasn't always the beginning of a calendar +year, these hybrid calendars still use January 1 as the beginning of +the year even for older dates. The customizable variable +@code{calc-gregorian-switch} (@pxref{Customizing Calc}) can be set to +have Calc's date forms switch from the Julian to Gregorian calendar at +any specified date. + +Today's timekeepers introduce an occasional ``leap second''. +These do not occur regularly and Calc does not take these minor +effects into account. (If it did, it would have to report a +non-integer number of days between, say, +@samp{<12:00am Mon Jan 1, 1900>} and @samp{<12:00am Sat Jan 1, 2000>}.) @cindex Julian day counting Another day counting system in common use is, confusingly, also called -``Julian.'' The Julian day number is the numbers of days since -12:00 noon (GMT) on Jan 1, 4713 BC, which in Calc's scheme (in GMT) -is @mathit{-1721423.5} (recall that Calc starts at midnight instead -of noon). Thus to convert a Calc date code obtained by unpacking a -date form into a Julian day number, simply add 1721423.5 after +``Julian.'' Julian days go from noon to noon. The Julian day number +is the numbers of days since 12:00 noon (GMT) on November 24, 4714 BC +in the Gregorian calendar (i.e., January 1, 4713 BC in the Julian +calendar). In Calc's scheme (in GMT) the Julian day origin is +@mathit{-1721422.5}, because Calc starts at midnight instead of noon. +Thus to convert a Calc date code obtained by unpacking a +date form into a Julian day number, simply add 1721422.5 after compensating for the time zone difference. The built-in @kbd{t J} command performs this conversion for you. @@ -11090,7 +11105,7 @@ the Julian cycle as an astronomical dating system; this idea was taken up by other astronomers. (At the time, noon was the start of the astronomical day. Herschel originally suggested counting the days since Jan 1, 4713 BC at noon Alexandria time; this was later amended to -noon GMT.) Julian day numbering is largely used in astronomy. +noon GMT@.) Julian day numbering is largely used in astronomy. @cindex Unix time format The Unix operating system measures time as an integer number of @@ -12638,7 +12653,7 @@ are simplified with their unit definitions in mind. A common technique is to set the simplification mode down to the lowest amount of simplification you will allow to be applied automatically, then use manual commands like @kbd{a s} and @kbd{c c} (@code{calc-clean}) to -perform higher types of simplifications on demand. +perform higher types of simplifications on demand. @node Declarations, Display Modes, Simplification Modes, Mode Settings @section Declarations @@ -12989,7 +13004,7 @@ The @code{dneg} function checks for negative reals. The @code{dnonneg} function checks for nonnegative reals, i.e., reals greater than or equal to zero. Note that Calc's algebraic simplifications, which are effectively applied to all conditions in rewrite rules, can simplify -an expression like @expr{x > 0} to 1 or 0 using @code{dpos}. +an expression like @expr{x > 0} to 1 or 0 using @code{dpos}. So the actual functions @code{dpos}, @code{dneg}, and @code{dnonneg} are rarely necessary. @@ -13424,7 +13439,7 @@ the time part. The punctuation characters (including spaces) must match exactly; letter fields must correspond to suitable text in the input. If this doesn't work, Calc checks if the input is a simple number; if so, the number is interpreted as a number of days -since Jan 1, 1 AD. Otherwise, Calc tries a much more relaxed and +since Jan 1, 1 AD@. Otherwise, Calc tries a much more relaxed and flexible algorithm which is described in the next section. Weekday names are ignored during reading. @@ -14653,7 +14668,7 @@ Subscripts use double square brackets: @samp{a[[i]]}. The @kbd{d W} (@code{calc-maple-language}) command selects the conventions of Maple. -Maple's language is much like C. Underscores are allowed in symbol +Maple's language is much like C@. Underscores are allowed in symbol names; square brackets are used for subscripts; explicit @samp{*}s for multiplications are required. Use either @samp{^} or @samp{**} to denote powers. @@ -16714,7 +16729,7 @@ number (i.e., pervasively). If the simplification mode is set below basic simplification, it is raised for the purposes of this command. Thus, @kbd{c c} applies the basic simplifications even if their automatic application is disabled. -@xref{Simplification Modes}. +@xref{Simplification Modes}. @cindex Roundoff errors, correcting A numeric prefix argument to @kbd{c c} sets the floating-point precision @@ -16791,7 +16806,7 @@ additional argument from the top of the stack. @pindex calc-date @tindex date The @kbd{t D} (@code{calc-date}) [@code{date}] command converts a -date form into a number, measured in days since Jan 1, 1 AD. The +date form into a number, measured in days since Jan 1, 1 AD@. The result will be an integer if @var{date} is a pure date form, or a fraction or float if @var{date} is a date/time form. Or, if its argument is a number, it converts this number into a date form. @@ -16829,7 +16844,7 @@ The last two arguments default to zero if omitted. @cindex Julian day counts, conversions The @kbd{t J} (@code{calc-julian}) [@code{julian}] command converts a date form into a Julian day count, which is the number of days -since noon (GMT) on Jan 1, 4713 BC. A pure date is converted to an +since noon (GMT) on Jan 1, 4713 BC@. A pure date is converted to an integer Julian count representing noon of that day. A date/time form is converted to an exact floating-point Julian count, adjusted to interpret 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 ten, however, the numbers should be completely unbiased. The Gaussian random numbers generated by @samp{random(0.0)} use the -``polar'' method described in Knuth section 3.4.1C. This method +``polar'' method described in Knuth section 3.4.1C@. This method generates a pair of Gaussian random numbers at a time, so only every other call to @samp{random(0.0)} will require significant calculations. @@ -22175,7 +22190,7 @@ Use @kbd{a v} if you want the variables to ignore their stored values. If you give a numeric prefix argument of 2 to @kbd{a v}, it simplifies using Calc's algebraic simplifications; @pxref{Simplifying Formulas}. If you give a numeric prefix of 3 or more, it uses Extended -Simplification mode (@kbd{a e}). +Simplification mode (@kbd{a e}). If you give a negative prefix argument @mathit{-1}, @mathit{-2}, or @mathit{-3}, it 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{>}) are mapped, the direction of the second inequality is reversed to match the first: Using @kbd{a M +} on @samp{a < b} and @samp{a > 2} reverses the latter to get @samp{2 < a}, which then allows the -combination @samp{a + 2 < b + a}, which the algebraic simplifications +combination @samp{a + 2 < b + a}, which the algebraic simplifications can reduce to @samp{2 < b}. Using @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 @kbd{Q} [@code{sqrt}], the arguments are simply popped from the stack and collected into a suitable function call, which is then simplified (the arguments being simplified first as part of the process, as -described above). +described above). Even the basic set of simplifications are too numerous to describe completely 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 mode. If you have switched to a different simplification mode, you can switch back with the @kbd{m A} command. Even in other simplification modes, the @kbd{a s} command will use these algebraic simplifications to -simplify the formula. +simplify the formula. There is a variable, @code{AlgSimpRules}, in which you can put rewrites to be applied. Its use is analogous to @code{EvalRules}, @@ -22738,7 +22753,7 @@ This allows easier comparison of products; for example, the basic simplifications will not change @expr{x y + y x} to @expr{2 x y}, but the algebraic simplifications; it first rewrites the sum to @expr{x y + x y} which can then be recognized as a sum of identical -terms. +terms. The canonical ordering used to sort terms of products has the property that real-valued numbers, interval forms and infinities @@ -22781,10 +22796,10 @@ factor in the numerator and denominator, it is canceled out; for example, @expr{(4 x + 6) / 8 x} simplifies to @expr{(2 x + 3) / 4 x}. Non-constant common factors are not found even by algebraic -simplifications. To cancel the factor @expr{a} in +simplifications. To cancel the factor @expr{a} in @expr{(a x + a) / a^2} you could first use @kbd{j M} on the product @expr{a x} to Merge the numerator to @expr{a (1+x)}, which can then be -simplified successfully. +simplified successfully. @tex \bigskip @@ -22937,7 +22952,7 @@ as is @expr{x^2 >= 0} if @expr{x} is known to be real. @tindex esimplify Calc is capable of performing some simplifications which may sometimes be desired but which are not ``safe'' in all cases. The @kbd{a e} -(@code{calc-simplify-extended}) [@code{esimplify}] command +(@code{calc-simplify-extended}) [@code{esimplify}] command applies the algebraic simplifications as well as these extended, or ``unsafe'', simplifications. Use this only if you know the values in your formula lie in the restricted ranges for which these @@ -23581,10 +23596,10 @@ forever!) @vindex IntegSimpRules Another set of rules, stored in @code{IntegSimpRules}, are applied every time the integrator uses algebraic simplifications to simplify an -intermediate result. For example, putting the rule +intermediate result. For example, putting the rule @samp{twice(x) := 2 x} into @code{IntegSimpRules} would tell Calc to convert the @code{twice} function into a form it knows whenever -integration is attempted. +integration is attempted. One more way to influence the integrator is to define a function with the @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 been matched to something else the two values must be equal; if the meta-variable is new then it is bound to the result of the expression. This variable can then appear in later conditions, and on the righthand -side of the rule. +side of the rule. In fact, @expr{v} may be any pattern in which case the result of evaluating @expr{x} is matched to that pattern, binding any meta-variables that appear in that pattern. Note that @code{let} @@ -27503,7 +27518,7 @@ but only when algebraic simplifications are used to simplify the formula. The variable @code{AlgSimpRules} holds rules for this purpose. The @kbd{a s} command will apply @code{EvalRules} and @code{AlgSimpRules} to the formula, as well as all of its built-in -simplifications. +simplifications. Most of the special limitations for @code{EvalRules} don't apply to @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 simplifications. It then applies its own built-in simplifications throughout the formula, and then repeats these two steps (along with applying the default simplifications) until no further changes are -possible. +possible. @cindex @code{ExtSimpRules} variable @cindex @code{UnitSimpRules} variable @@ -28946,9 +28961,9 @@ to select the lefthand side, execute your commands, then type All current modes apply when an @samp{=>} operator is computed, including the current simplification mode. Recall that the formula @samp{arcsin(sin(x))} will not be handled by Calc's algebraic -simplifications, but Calc's unsafe simplifications will reduce it to +simplifications, but Calc's unsafe simplifications will reduce it to @samp{x}. If you enter @samp{arcsin(sin(x)) =>} normally, the result -will be @samp{arcsin(sin(x)) => arcsin(sin(x))}. If you change to +will be @samp{arcsin(sin(x)) => arcsin(sin(x))}. If you change to Extended Simplification mode, the result will be @samp{arcsin(sin(x)) => x}. However, just pressing @kbd{a e} once will have no effect on @samp{arcsin(sin(x)) => arcsin(sin(x))}, @@ -29566,7 +29581,7 @@ plot on any text-only printer. @kindex g O @pindex calc-graph-output The @kbd{g O} (@code{calc-graph-output}) command sets the name of the -output file used by GNUPLOT. For some devices, notably @code{x11} and +output file used by GNUPLOT@. For some devices, notably @code{x11} and @code{windows}, there is no output file and this information is not used. Many other ``devices'' are really file formats like @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 effect if the current device is @code{windows}. The buffer called @samp{*Gnuplot Trail*} holds a transcript of the -session with GNUPLOT. This shows the commands Calc has ``typed'' to +session with GNUPLOT@. This shows the commands Calc has ``typed'' to GNUPLOT and the responses it has received. Calc tries to notice when an error message has appeared here and display the buffer for you when this happens. You can check this buffer yourself if you suspect @@ -33249,7 +33264,7 @@ in the range @samp{[0 ..@: 60)}. Date forms are stored as @samp{(date @var{n})}, where @var{n} is a real number that counts days since midnight on the morning of -January 1, 1 AD. If @var{n} is an integer, this is a pure date +January 1, 1 AD@. If @var{n} is an integer, this is a pure date form. If @var{n} is a fraction or float, this is a date/time form. Modulo 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} function is used by the @kbd{V S} vector-sorting command, and also by Calc's algebraic simplifications to put the terms of a product into canonical order: This allows @samp{x y + y x} to be simplified easily to -@samp{2 x y}. +@samp{2 x y}. @end defun @defun equal x y @@ -35590,6 +35605,20 @@ number of undo steps that will be preserved; if be preserved. The default value of @code{calc-undo-length} is @expr{100}. @end defvar +@defvar calc-gregorian-switch +See @ref{Date Forms}.@* +The variable @code{calc-gregorian-switch} is either a list of integers +@code{(@var{YEAR} @var{MONTH} @var{DAY})} or @code{nil}. +If it is @code{nil}, then Calc's date forms always represent Gregorian dates. +Otherwise, @code{calc-gregorian-switch} represents the date that the +calendar switches from Julian dates to Gregorian dates; +@code{(@var{YEAR} @var{MONTH} @var{DAY})} will be the first Gregorian +date. The customization buffer will offer several standard dates to +choose from, or the user can enter their own date. + +The default value of @code{calc-gregorian-switch} is @code{nil}. +@end defvar + @node Reporting Bugs, Summary, Customizing Calc, Top @appendix Reporting Bugs diff --git a/etc/ChangeLog b/etc/ChangeLog index 60d4a7aa271..11dc42b7f45 100644 --- a/etc/ChangeLog +++ b/etc/ChangeLog @@ -1,3 +1,7 @@ +2012-11-22 Paul Eggert <eggert@cs.ucla.edu> + + * NEWS: Document Calc changes for Gregorian calendar (Bug#12633). + 2012-10-26 Nicolas Goaziou <n.goaziou@gmail.com> * refcards/orgcard.tex: Fix keybindings about @@ -29,9 +29,32 @@ so we will look at it and add it to the manual. * Changes in Specialized Modes and Packages in Emacs 24.4 +** Calc + +*** Calc by default now uses the Gregorian calendar for all dates, and +uses January 1, 1 AD as its day number 1. Previously Calc used the +Julian calendar for dates before September 14, 1752, and it used +December 31, 1 BC as its day number 1; the new scheme is more +consistent with Calendar's calendrical system and day numbering. + +*** The new variable `calc-gregorian-switch' lets you configure the +date when Calc switches from the Julian to the Gregorian calendar. +Nil, the default value, means to always use the Gregorian calendar. +The value (YEAR MONTH DAY) means to start using the Gregorian calendar +on the given date. + +++ ** New function `ses-rename-cell' to give SES cells arbitrary names. +** trace-function was largely rewritten. +New features include: +- no prompting for the destination buffer, unless a prefix-arg was used. +- additionally to prompting for a destination buffer, when a prefix-arg is + used, the user can enter a "context", i.e. Lisp expression whose value at the + time the function is entered/exited will be printed along with the function + name and arguments. Useful to trace the value of (current-buffer) or + (point) when the function is invoked. + * New Modes and Packages in Emacs 24.4 ** New nadvice.el package offering lighter-weight advice facilities. @@ -43,6 +66,10 @@ It is layered as: * Incompatible Lisp Changes in Emacs 24.4 +** nil and "unbound" are indistinguishable in symbol-function. +`symbol-function' never signals `void-function' any more. +`fboundp' returns non-nil if the symbol was `fset' to nil. + ** `defadvice' does not honor the `freeze' flag and cannot advise special-forms any more. @@ -52,6 +79,7 @@ spurious warnings about an unused var. * Lisp changes in Emacs 24.4 +** time-to-seconds is not obsolete any more. ** New function special-form-p. ** Docstrings can be made dynamic by adding a `dynamic-docstring-function' text-property on the first char. @@ -833,7 +861,7 @@ are deprecated and will be removed eventually. ** New sampling-based Elisp profiler. Try M-x profiler-start, do some work, and then call M-x profiler-report. When finished, use M-x profiler-stop. The sampling rate can be based on -CPU time (only supported on some systems) or memory allocations. +CPU time or memory allocations. +++ ** 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). Pass --with-w32 to configure. The default remains the X11 interface. ** Two new functions are available in Cygwin builds: -`cygwin-convert-path-from-windows' and `cygwin-convert-path-to-windows'. -These functions allow Lisp code to access the Cygwin file-name mapping -machinery to convert between Cygwin and Windows-native file names. +`cygwin-convert-file-name-from-windows' and +`cygwin-convert-file-name-to-windows'. These functions allow Lisp +code to access the Cygwin file-name mapping machinery to convert +between Cygwin and Windows-native file and directory names. ** When invoked with the -nw switch to run on the Windows text-mode terminal, Emacs 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 @@ +2012-11-23 Paul Eggert <eggert@cs.ucla.edu> + + movemail: treat EACCES etc. failures as permanent + * movemail.c (main): Treat any link failure other than EEXIST as a + permanent failure, not just EPERM. EACCES, for example. + +2012-11-21 Paul Eggert <eggert@cs.ucla.edu> + + Assume POSIX 1003.1-1988 or later for unistd.h (Bug#12945). + * emacsclient.c (getcwd): Remove decl. + (get_current_dir_name): Assume getcwd exists. + * etags.c (HAVE_GETCWD): Remove. + (getcwd): Remove decl. + (NO_LONG_OPTIONS): Remove this. All uses removed. + Emacs always has GNU getopt. + (etags_getcwd): Assume getcwd exists. + * movemail.c (F_OK, X_OK, W_OK, R_OK): Remove. + +2012-11-20 Paul Eggert <eggert@cs.ucla.edu> + + * emacsclient.c (handle_sigcont, handle_sigtstp): Use raise (sig) + rather than kill (getpid (), sig), as it's simpler and safer. + 2012-11-17 Juanma Barranquero <lekktu@gmail.com> * 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 *); -char *getenv (const char *), *getwd (char *); -#ifdef HAVE_GETCWD -char *(getcwd) (char *, size_t); -#endif +char *getenv (const char *); #ifndef VERSION #define VERSION "unspecified" @@ -223,7 +220,7 @@ get_current_dir_name (void) char *buf; const char *pwd; struct stat dotstat, pwdstat; - /* If PWD is accurate, use it instead of calling getwd. PWD is + /* If PWD is accurate, use it instead of calling getcwd. PWD is sometimes a nicer name, and using it may avoid a fatal error if a parent directory is searchable but not readable. */ if ((pwd = egetenv ("PWD")) != 0 @@ -240,7 +237,6 @@ get_current_dir_name (void) buf = (char *) xmalloc (strlen (pwd) + 1); strcpy (buf, pwd); } -#ifdef HAVE_GETCWD else { size_t buf_size = 1024; @@ -267,20 +263,6 @@ get_current_dir_name (void) } } } -#else - else - { - /* We need MAXPATHLEN here. */ - buf = (char *) xmalloc (MAXPATHLEN + 1); - if (getwd (buf) == NULL) - { - int tmp_errno = errno; - free (buf); - errno = tmp_errno; - return NULL; - } - } -#endif return buf; } #endif @@ -1138,7 +1120,7 @@ handle_sigcont (int signalnum) else { /* We are in the background; cancel the continue. */ - kill (getpid (), SIGSTOP); + raise (SIGSTOP); } signal (signalnum, handle_sigcont); @@ -1165,7 +1147,7 @@ handle_sigtstp (int signalnum) sigprocmask (SIG_BLOCK, NULL, &set); sigdelset (&set, signalnum); signal (signalnum, SIG_DFL); - kill (getpid (), signalnum); + raise (signalnum); sigprocmask (SIG_SETMASK, &set, NULL); /* Let's the above signal through. */ signal (signalnum, handle_sigtstp); @@ -1592,7 +1574,6 @@ main (int argc, char **argv) cwd = get_current_dir_name (); if (cwd == 0) { - /* getwd puts message in STRING if it fails. */ message (TRUE, "%s: %s\n", progname, "Cannot get current working directory"); 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"; # undef HAVE_NTGUI # undef DOS_NT # define DOS_NT -# ifndef HAVE_GETCWD -# define HAVE_GETCWD -# endif /* undef HAVE_GETCWD */ -#else /* not WINDOWSNT */ -#endif /* !WINDOWSNT */ +#endif /* WINDOWSNT */ #include <unistd.h> -#ifndef HAVE_UNISTD_H -# if defined (HAVE_GETCWD) && !defined (WINDOWSNT) - extern char *getcwd (char *buf, size_t size); -# endif -#endif /* HAVE_UNISTD_H */ - #include <stdarg.h> #include <stdlib.h> #include <string.h> @@ -152,16 +142,7 @@ char pot_etags_version[] = "@(#) pot revision number is 17.38.1.4"; # define assert(x) ((void) 0) #endif -#ifdef NO_LONG_OPTIONS /* define this if you don't have GNU getopt */ -# define NO_LONG_OPTIONS TRUE -# define getopt_long(argc,argv,optstr,lopts,lind) getopt (argc, argv, optstr) - extern char *optarg; - extern int optind, opterr; -#else -# define NO_LONG_OPTIONS FALSE -# include <getopt.h> -#endif /* NO_LONG_OPTIONS */ - +#include <getopt.h> #include <regex.h> /* Define CTAGS to make the program "ctags" compatible with the usual one. @@ -869,11 +850,7 @@ print_help (argument *argbuffer) printf ("Usage: %s [options] [[regex-option ...] file-name] ...\n\ \n\ These are the options accepted by %s.\n", progname, progname); - if (NO_LONG_OPTIONS) - puts ("WARNING: long option names do not work with this executable,\n\ -as it is not linked with GNU getopt."); - else - puts ("You may use unambiguous abbreviations for the long option names."); + puts ("You may use unambiguous abbreviations for the long option names."); puts (" A - as file name means read names from stdin (one per line).\n\ Absolute names are stored in the output file as they are.\n\ Relative ones are stored relative to the output file's directory.\n"); @@ -1065,9 +1042,9 @@ main (int argc, char **argv) /* When the optstring begins with a '-' getopt_long does not rearrange the non-options arguments to be at the end, but leaves them alone. */ - optstring = concat (NO_LONG_OPTIONS ? "" : "-", - "ac:Cf:Il:o:r:RSVhH", - (CTAGS) ? "BxdtTuvw" : "Di:"); + optstring = concat ("-ac:Cf:Il:o:r:RSVhH", + (CTAGS) ? "BxdtTuvw" : "Di:", + ""); while ((opt = getopt_long (argc, argv, optstring, longopts, NULL)) != EOF) switch (opt) @@ -6333,8 +6310,8 @@ pfatal (const char *s1) static void suggest_asking_for_help (void) { - fprintf (stderr, "\tTry `%s %s' for a complete list of options.\n", - progname, NO_LONG_OPTIONS ? "-h" : "--help"); + fprintf (stderr, "\tTry `%s --help' for a complete list of options.\n", + progname); exit (EXIT_FAILURE); } @@ -6372,7 +6349,6 @@ concat (const char *s1, const char *s2, const char *s3) static char * etags_getcwd (void) { -#ifdef HAVE_GETCWD int bufsize = 200; char *path = xnew (bufsize, char); @@ -6387,34 +6363,6 @@ etags_getcwd (void) canonicalize_filename (path); return path; - -#else /* not HAVE_GETCWD */ -#if MSDOS - - char *p, path[MAXPATHLEN + 1]; /* Fixed size is safe on MSDOS. */ - - getwd (path); - - for (p = path; *p != '\0'; p++) - if (*p == '\\') - *p = '/'; - else - *p = lowcase (*p); - - return strdup (path); -#else /* not MSDOS */ - linebuffer path; - FILE *pipe; - - linebuffer_init (&path); - pipe = (FILE *) popen ("pwd 2>/dev/null", "r"); - if (pipe == NULL || readline_internal (&path, pipe) == 0) - pfatal ("pwd"); - pclose (pipe); - - return path.buffer; -#endif /* not MSDOS */ -#endif /* not HAVE_GETCWD */ } /* 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/>. */ #include <fcntl.h> #endif /* WINDOWSNT */ -#ifndef F_OK -#define F_OK 0 -#define X_OK 1 -#define W_OK 2 -#define R_OK 4 -#endif - #ifdef WINDOWSNT #include <sys/locking.h> #endif @@ -335,11 +328,8 @@ main (int argc, char **argv) tem = link (tempname, lockname); -#ifdef EPERM - if (tem < 0 && errno == EPERM) - fatal ("Unable to create hard link between %s and %s", - tempname, lockname); -#endif + if (tem < 0 && errno != EEXIST) + pfatal_with_name (lockname); unlink (tempname); 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 @@ +2012-11-23 Chong Yidong <cyd@gnu.org> + + * find-cmd.el (find-constituents): Add executable, ipath, + readable, samefile, writable, daystart, regextype (Bug#12856). + +2012-11-23 Stefan Monnier <monnier@iro.umontreal.ca> + + * emacs-lisp/ert.el, emacs-lisp/ert-x.el: Use cl-lib and lexical-binding. + +2012-11-22 Paul Eggert <eggert@cs.ucla.edu> + + * calc/calc.el (calc-gregorian-switch): Move to after calc-refresh + definition. This fixes a bootstrap failure. + (calc-gregorian-switch): In menu, put dates before regions. + This is easier to follow, lines up better in the menu, and lets us + coalesce regions that switch at the same time. Give country + names, not "Vatican", as that's better for non-expert users. + Use names that are stable between the date of switch and now, e.g., + Bohemia and Moravia (which existed then and now) and not + Czechoslovakia (which didn't exist then and doesn't exist now). + What is now the U.S. mostly did not switch at the same time as + Britain, so omit the U.S. Correct spelling of "Britain". + Catholic Switzerland was too much of a mess, so omit it. + +2012-11-22 Jay Belanger <jay.p.belanger@gmail.com> + + * calc/calc.el (calc-gregorian-switch): Refresh the Calc buffer + after the variable is changed. + +2012-11-21 Daniel Colascione <dancol@dancol.org> + + * progmodes/sql.el (sql-mode-font-lock-object-name): Support IF NOT EXISTS + in SQL declarations for font-lock. + (sql-imenu-generic-expression): Teach imenu about IF NOT EXISTS. + +2012-11-21 Glenn Morris <rgm@gnu.org> + + * faces.el (face-underline-p, face-inverse-video-p, face-bold-p) + (face-italic-p): Add optional argument "inherit". + + * faces.el (set-face-inverse-video, set-face-bold, set-face-italic): + Remove -p suffix from names, for consistency with other set-face-*. + (set-face-inverse-video): Fix interactive spec. + * play/gamegrid.el (gamegrid-make-mono-tty-face): + * textmodes/table.el (table--update-cell-face): + Use set-face-inverse-video rather than now obsolete alias. + +2012-11-21 Eli Zaretskii <eliz@gnu.org> + + * simple.el (line-move): Don't call line-move-partial if + scroll-conservatively is in effect. (Bug#12927) + +2012-11-21 Stefan Monnier <monnier@iro.umontreal.ca> + + * eshell/em-cmpl.el (eshell-pcomplete): Refine fix for bug#12838: + Fallback on completion-at-point rather than + pcomplete-expand-and-complete, and only if pcomplete actually failed. + (eshell-cmpl-initialize): Setup completion-at-point. + + * pcomplete.el (pcomplete--entries): Obey pcomplete-ignore-case. + + * emacs-lisp/ert.el (ert--expand-should-1): Adapt to cl-lib. + +2012-11-21 Michael Albinus <michael.albinus@gmx.de> + + * net/tramp-sh.el (tramp-do-copy-or-rename-file): If both files + are remote, check out-of-band property for both. + +2012-11-21 Stefan Monnier <monnier@iro.umontreal.ca> + + * window.el (switch-to-buffer): Re-add the warning that was lost in the + code rewrite. + +2012-11-21 Paul Eggert <eggert@cs.ucla.edu> + + More minor time fixes. + * calendar/time-date.el: Commentary fix. + * net/tramp-sh.el (tramp-do-file-attributes-with-ls): Undo last change; + too much other code depends on (0 0) time stamps. + * net/tramp.el (tramp-time-less-p, tramp-time-subtract): + Add a couple of FIXME comments. + + Minor cleanup for times as lists of four integers. + * files.el (dir-locals-directory-cache): + * ps-bdf.el (bdf-file-mod-time, bdf-read-font-info): + Doc fixes. + * net/tramp-sh.el (tramp-do-file-attributes-with-ls): + * ps-bdf.el (bdf-file-newer-than-time): + Process four-integers time stamps, not two. Doc fixes. + +2012-11-20 Stefan Monnier <monnier@iro.umontreal.ca> + + * uniquify.el (uniquify-managed): Use defvar-local. + (rename-buffer, create-file-buffer): Advise with advice-add. + (uniquify-unload-function): Unadvise accordingly. + + * emacs-lisp/trace.el: Rewrite, use nadvice and lexical-binding. + (trace-buffer): Don't purecopy. + (trace-entry-message, trace-exit-message): Add `context' arg. + (trace--timer): New var. + (trace-make-advice): Adjust for use in nadvice. + Add `context' argument. Delay `display-buffer' via a timer. + (trace-function-internal): Use advice-add. + (trace--read-args): New function. + (trace-function-foreground, trace-function-background): Use it. + (trace-function): Rename to trace-function-foreground and redefine as + an alias to that new name. + (untrace-function, untrace-all): Adjust to the use of nadvice. + + * emacs-lisp/bytecomp.el (byte-compile): Fix handling of closures. + + * emacs-lisp/byte-run.el (defun-declarations-alist): Fix last change. + + * subr.el (called-interactively-p-functions): New var. + (internal--called-interactively-p--get-frame): New macro. + (called-interactively-p, interactive-p): Rewrite in Lisp. + * emacs-lisp/nadvice.el (advice--called-interactively-skip): New fun. + (called-interactively-p-functions): Use it. + * emacs-lisp/edebug.el (edebug--called-interactively-skip): New fun. + (called-interactively-p-functions): Use it. + * allout.el (allout-called-interactively-p): Don't assume + called-interactively-p is a subr. + +2012-11-20 Glenn Morris <rgm@gnu.org> + + * profiler.el (profiler-report-mode-map): Add a menu. + No need to bind `q' because we derive from special-mode. + (profiler-report-find-entry): Handle calls from the menu-bar. + +2012-11-19 Stefan Monnier <monnier@iro.umontreal.ca> + + * emacs-lisp/byte-run.el (defun-declarations-alist): + Allow a compiler-macro to be a lambda expression. + + * progmodes/python.el: Use cl-lib. Move var declarations outside of + eval-when-compile. + (python-syntax-context): Add compiler-macro. + (python-font-lock-keywords): Simplify with De Morgan. + + * vc/diff-mode.el (diff-hunk): Don't make useless timers. + + * files.el (load-file): Require match in minibuffer selection, as was + the case in Emacs-20 before we changed the spec to allow .elc files + (bug#12935). + + * json.el: Don't require cl since we don't use it. + * color.el: Don't require cl. + (color-complement): `caddr' -> `nth 2'. + + * calendar/time-date.el (time-to-seconds): De-obsolete. + +2012-11-19 Jay Belanger <jay.p.belanger@gmail.com> + + * calc/calc-forms.el (math-leap-year-p): Fix formula for negative + year numbers. + (math-date-to-julian-dt): Adjust the initial approximation for the + year to deal with the new definition of the DATE. + +2012-11-19 Daniel Colascione <dancol@dancol.org> + + * term/w32-win.el (cygwin-convert-path-from-windows): + Accomodate rename of cygwin_convert_path* to cygwin_convert_file_name*. + 2012-11-18 Chong Yidong <cyd@gnu.org> * filecache.el (file-cache--read-list): New function. @@ -47,8 +210,10 @@ 2012-11-17 Paul Eggert <eggert@cs.ucla.edu> + Calc by default uses the Gregorian calendar for all dates (Bug#12633). + It also uses January 1, 1 AD as its day number 1. * calc/calc-forms.el (math-julian-date-beginning) - (math-julian-date-beginning-int): Implement [new date numbering]. + (math-julian-date-beginning-int): Implement this. 2012-11-17 Juanma Barranquero <lekktu@gmail.com> 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." (defmacro allout-called-interactively-p () "A version of `called-interactively-p' independent of Emacs version." ;; ... to ease maintenance of allout without betraying deprecation. - (if (equal (subr-arity (symbol-function 'called-interactively-p)) - '(0 . 0)) - '(called-interactively-p) - '(called-interactively-p 'interactive))) + (if (ignore-errors (called-interactively-p 'interactive) t) + '(called-interactively-p 'interactive) + '(called-interactively-p))) ;;;_ = allout-inhibit-aberrance-doublecheck nil ;; In some exceptional moments, disparate topic depths need to be allowed ;; 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. Summary of changes to "Calc" ------- -- ------- -- ---- +Emacs 24.4 + +* The date forms use the Gregorian calendar for all dates. + (Previously they were a combination of Julian and Gregorian + dates.) This can be configured with the customizable variable + `calc-gregorian-switch'. + Emacs 24.3 -Algebraic simplification mode is now the default. -To restrict to the limited simplifications given by the former -default simplification mode, use `m I'. +* Algebraic simplification mode is now the default. + To restrict to the limited simplifications given by the former + default simplification mode, use `m I'. Emacs 24.1 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 @@ ;;; These versions are rewritten to use arbitrary-size integers. ;;; A numerical date is the number of days since midnight on -;;; the morning of December 31, 1 B.C. Emacs's calendar refers to such -;;; a date as an absolute date, some function names also use that -;;; terminology. If the date is a non-integer, it represents a specific date and time. +;;; the morning of December 31, 1 B.C. (Gregorian) or January 2, 1 A.D. (Julian). +;;; Emacs's calendar refers to such a date as an absolute date, some Calc function +;;; names also use that terminology. If the date is a non-integer, it represents +;;; a specific date and time. ;;; A "dt" is a list of the form, (year month day), corresponding to ;;; an integer code, or (year month day hour minute second), corresponding ;;; to a non-integer code. @@ -408,8 +409,8 @@ DATE is the number of days since December 31, -1 in the Gregorian calendar." (let* ((month 1) day (year (math-quotient (math-add date (if (Math-lessp date 711859) - 365 ; for speed, we take - -108)) ; >1950 as a special case + 367 ; for speed, we take + -106)) ; >1950 as a special case (if (math-negp date) 366 365))) ; this result may be an overestimate temp) @@ -494,6 +495,8 @@ Gregorian calendar." (if (math-negp year) (= (math-imod (math-neg year) 4) 1) (= (math-imod year 4) 0)) + (if (math-negp year) + (setq year (math-sub -1 year))) (setq year (math-imod year 400)) (or (and (= (% year 4) 0) (/= (% year 100) 0)) (= 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." (defvar math-format-date-cache) ; calc-forms.el -;; Dates that are built-in options for `calc-gregorian-switch' should be -;; (YEAR MONTH DAY math-date-from-gregorian-dt(YEAR MONTH DAY)) for speed. -(defcustom calc-gregorian-switch nil - "The first day the Gregorian calendar is used by Calc's date forms. -This is `nil' (the default) if the Gregorian calendar is the only one used. -Otherwise, it should be a list `(YEAR MONTH DAY)' when Calc begins to use -the Gregorian calendar; Calc will use the Julian calendar for earlier dates. -The dates in which different regions of the world began to use the -Gregorian calendar vary quite a bit, even within a single country. -If you want Calc's date forms to switch between the Julian and -Gregorian calendar, you can specify the date or choose from several -common choices. Some of these choices should be taken with a grain -of salt; for example different parts of France changed calendars at -different times, and Sweden's change to the Gregorian calendar was -complicated. Also, the boundaries of the countries were different at -the times of the calendar changes than they are now. -The Vatican decided that the Gregorian calendar should take effect -on 15 October 1582 (Gregorian), and many Catholic countries made -the change then. Great Britian and its colonies had the Gregorian -calendar take effect on 14 September 1752 (Gregorian); this includes -the United States." - :group 'calc - :version "24.4" - :type '(choice (const :tag "Always use the Gregorian calendar" nil) - (const :tag "Great Britian and the US (1752 9 14)" (1752 9 14 639797)) - (const :tag "Vatican (1582 10 15)" (1582 10 15 577736)) - (const :tag "Czechoslovakia (1584 1 17)" (1584 1 17 578195)) - (const :tag "Denmark (1700 3 1)" (1700 3 1 620607)) - (const :tag "France (1582 12 20)" (1582 12 20 577802)) - (const :tag "Hungary (1587 11 1)" (1587 11 1 579579)) - (const :tag "Luxemburg (1582 12 25)" (1582 12 25 577807)) - (const :tag "Romania (1919 4 14)" (1919 4 14 700638)) - (const :tag "Russia (1918 2 14)" (1918 2 14 700214)) - (const :tag "Sweden (1753 3 1)" (1753 3 1 639965)) - (const :tag "Switzerland (Catholic) (1584 1 22)" (1584 1 22 578200)) - (const :tag "Switzerland (Protestant) (1701 1 12)" (1701 1 12 620924)) - (list :tag "(YEAR MONTH DAY)" - (integer :tag "Year") - (integer :tag "Month (integer)") - (integer :tag "Day"))) - :set (lambda (symbol value) - (set-default symbol value) - (setq math-format-date-cache nil))) - (defface calc-nonselected-face '((t :inherit shadow :slant italic)) @@ -2066,6 +2022,50 @@ See calc-keypad for details." (calc-refresh align))) (setq calc-refresh-count (1+ calc-refresh-count))) +;; Dates that are built-in options for `calc-gregorian-switch' should be +;; (YEAR MONTH DAY math-date-from-gregorian-dt(YEAR MONTH DAY)) for speed. +(defcustom calc-gregorian-switch nil + "The first day the Gregorian calendar is used by Calc's date forms. +This is `nil' (the default) if the Gregorian calendar is the only one used. +Otherwise, it should be a list `(YEAR MONTH DAY)' when Calc begins to use +the Gregorian calendar; Calc will use the Julian calendar for earlier dates. +The dates in which different regions of the world began to use the +Gregorian calendar vary quite a bit, even within a single country. +If you want Calc's date forms to switch between the Julian and +Gregorian calendar, you can specify the date or choose from several +common choices. Some of these choices should be taken with a grain +of salt; for example different parts of France changed calendars at +different times, and Sweden's change to the Gregorian calendar was +complicated. Also, the boundaries of the countries were different at +the times of the calendar changes than they are now. +The Vatican decided that the Gregorian calendar should take effect +on 15 October 1582 (Gregorian), and many Catholic countries made +the change then. Great Britain and its colonies had the Gregorian +calendar take effect on 14 September 1752 (Gregorian); this includes +the United States." + :group 'calc + :version "24.4" + :type '(choice (const :tag "Always use the Gregorian calendar" nil) + (const :tag "1582-10-15 - Italy, Poland, Portugal, Spain" (1582 10 15 577736)) + (const :tag "1582-12-20 - France" (1582 12 20 577802)) + (const :tag "1582-12-25 - Luxemburg" (1582 12 25 577807)) + (const :tag "1584-01-17 - Bohemia and Moravia" (1584 1 17 578195)) + (const :tag "1587-11-01 - Hungary" (1587 11 1 579579)) + (const :tag "1700-03-01 - Denmark" (1700 3 1 620607)) + (const :tag "1701-01-12 - Protestant Switzerland" (1701 1 12 620924)) + (const :tag "1752-09-14 - Great Britain and dominions" (1752 9 14 639797)) + (const :tag "1753-03-01 - Sweden" (1753 3 1 639965)) + (const :tag "1918-02-14 - Russia" (1918 2 14 700214)) + (const :tag "1919-04-14 - Romania" (1919 4 14 700638)) + (list :tag "(YEAR MONTH DAY)" + (integer :tag "Year") + (integer :tag "Month (integer)") + (integer :tag "Day"))) + :set (lambda (symbol value) + (set-default symbol value) + (setq math-format-date-cache nil) + (calc-refresh))) + ;;;; The Calc Trail buffer. (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 @@ ;; value equal to HIGH * 2^16 + LOW + USEC * 10^-6 + PSEC * 10^-12 ;; seconds, where missing components are treated as zero. HIGH can be ;; negative, either because the value is a time difference, or because -;; the machine supports negative time stamps that fall before the -;; epoch. The macro `with-decoded-time-value' and the -;; function `encode-time-value' make it easier to deal with these -;; three formats. See `time-subtract' for an example of how to use -;; them. +;; the machine supports negative time stamps that fall before the epoch. +;; The macro `with-decoded-time-value' and the function +;; `encode-time-value' make it easier to deal with these formats. +;; See `time-subtract' for an example of how to use them. ;;; Code: @@ -134,9 +133,7 @@ If DATE lacks timezone information, GMT is assumed." ;;;###autoload(if (or (featurep 'emacs) ;;;###autoload (and (fboundp 'float-time) ;;;###autoload (subrp (symbol-function 'float-time)))) -;;;###autoload (progn -;;;###autoload (defalias 'time-to-seconds 'float-time) -;;;###autoload (make-obsolete 'time-to-seconds 'float-time "21.1")) +;;;###autoload (defalias 'time-to-seconds 'float-time) ;;;###autoload (autoload 'time-to-seconds "time-date")) (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 @@ +2012-11-19 Stefan Monnier <monnier@iro.umontreal.ca> + + * semantic/fw.el (semantic-make-local-hook, semantic-mode-line-update): + Simplify via CSE. + 2012-11-16 David Engster <deng@randomsample.de> - * semantic/symref/list.el (semantic-symref-symbol): Use - `semantic-complete-read-tag-project' instead of + * semantic/symref/list.el (semantic-symref-symbol): + Use `semantic-complete-read-tag-project' instead of `semantic-complete-read-tag-buffer-deep', since the latter is not working correctly. - * semantic/symref.el (semantic-symref-result-get-tags): Use - `find-buffer-visiting' to follow symbolic links. + * semantic/symref.el (semantic-symref-result-get-tags): + Use `find-buffer-visiting' to follow symbolic links. * semantic/fw.el (semantic-find-file-noselect): Always set `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 @@ ) - (if (and (not (featurep 'xemacs)) - (>= emacs-major-version 21)) - (defalias 'semantic-make-local-hook 'identity) - (defalias 'semantic-make-local-hook 'make-local-hook) - ) + (defalias 'semantic-make-local-hook + (if (and (not (featurep 'xemacs)) + (>= emacs-major-version 21)) + #'identity #'make-local-hook)) - (if (featurep 'xemacs) - (defalias 'semantic-mode-line-update 'redraw-modeline) - (defalias 'semantic-mode-line-update 'force-mode-line-update)) + (defalias 'semantic-mode-line-update + (if (featurep 'xemacs) #'redraw-modeline #'force-mode-line-update)) ;; Since Emacs 22 major mode functions should use `run-mode-hooks' to ;; 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 @@ ;;; Code: -(eval-when-compile - (require 'cl)) - ;; Emacs < 23.3 (eval-and-compile (unless (boundp 'float-pi) @@ -69,9 +66,9 @@ RED, GREEN, and BLUE should be numbers between 0.0 and 1.0, inclusive." COLOR-NAME should be a string naming a color (e.g. \"white\"), or a string specifying a color's RGB components (e.g. \"#ff12ec\")." (let ((color (color-name-to-rgb color-name))) - (list (- 1.0 (car color)) - (- 1.0 (cadr color)) - (- 1.0 (caddr color))))) + (list (- 1.0 (nth 0 color)) + (- 1.0 (nth 1 color)) + (- 1.0 (nth 2 color))))) (defun color-gradient (start stop step-number) "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." #'(lambda (f _args new-name when) `(make-obsolete ',f ',new-name ,when))) (list 'compiler-macro - #'(lambda (f _args compiler-function) - `(put ',f 'compiler-macro #',compiler-function))) + #'(lambda (f args compiler-function) + ;; FIXME: Make it possible to just reuse `args'. + `(eval-and-compile + (put ',f 'compiler-macro + ,(if (eq (car-safe compiler-function) 'lambda) + `(lambda ,(append (cadr compiler-function) args) + ,@(cddr compiler-function)) + `#',compiler-function))))) (list 'doc-string #'(lambda (f _args pos) (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." (when (symbolp form) (unless (memq (car-safe fun) '(closure lambda)) (error "Don't know how to compile %S" fun)) - (setq fun (byte-compile--reify-function fun)) - (setq lexical-binding (eq (car fun) 'closure))) + (setq lexical-binding (eq (car fun) 'closure)) + (setq fun (byte-compile--reify-function fun))) (unless (eq (car-safe fun) 'lambda) (error "Don't know how to compile %S" fun)) ;; 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." ;;; Finalize Loading +;; When edebugging a function, some of the sub-expressions are +;; wrapped in (edebug-enter (lambda () ..)), so we need to teach +;; called-interactively-p that calls within the inner lambda should refer to +;; the outside function. +(add-hook 'called-interactively-p-functions + #'edebug--called-interactively-skip) +(defun edebug--called-interactively-skip (i frame1 frame2) + (when (and (eq (car-safe (nth 1 frame1)) 'lambda) + (eq (nth 1 (nth 1 frame1)) '()) + (eq (nth 1 frame2) 'edebug-enter)) + ;; `edebug-enter' calls itself on its first invocation. + (if (eq (nth 1 (internal--called-interactively-p--get-frame i)) + 'edebug-enter) + 2 1))) + ;; Finally, hook edebug into the rest of Emacs. ;; There are probably some other things that could go here. 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 @@ -;;; ert-x.el --- Staging area for experimental extensions to ERT +;;; ert-x.el --- Staging area for experimental extensions to ERT -*- lexical-binding: t -*- ;; Copyright (C) 2008, 2010-2012 Free Software Foundation, Inc. @@ -28,8 +28,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'ert) @@ -90,8 +89,8 @@ ERT--THUNK with that buffer as current." (kill-buffer ert--buffer) (remhash ert--buffer ert--test-buffers)))) -(defmacro* ert-with-test-buffer ((&key ((:name name-form))) - &body body) +(cl-defmacro ert-with-test-buffer ((&key ((:name name-form))) + &body body) "Create a test buffer and run BODY in that buffer. To 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." "Kill all test buffers that are still live." (interactive) (let ((count 0)) - (maphash (lambda (buffer dummy) + (maphash (lambda (buffer _dummy) (when (or (not (buffer-live-p buffer)) (kill-buffer buffer)) - (incf count))) + (cl-incf count))) ert--test-buffers) (message "%s out of %s test buffers killed" count (hash-table-count ert--test-buffers))) @@ -149,9 +148,9 @@ the rest are arguments to the command. NOTE: Since the command is not called by `call-interactively' test for `called-interactively' in the command will fail." - (assert (listp command) t) - (assert (commandp (car command)) t) - (assert (not unread-command-events) t) + (cl-assert (listp command) t) + (cl-assert (commandp (car command)) t) + (cl-assert (not unread-command-events) t) (let (return-value) ;; For the order of things here see command_loop_1 in keyboard.c. ;; @@ -175,7 +174,7 @@ test for `called-interactively' in the command will fail." (when (boundp 'last-repeatable-command) (setq last-repeatable-command real-last-command)) (when (and deactivate-mark transient-mark-mode) (deactivate-mark)) - (assert (not unread-command-events) t) + (cl-assert (not unread-command-events) t) return-value)) (defun ert-run-idle-timers () @@ -198,7 +197,7 @@ rather than the entire match." (with-temp-buffer (insert s) (dolist (x regexps) - (destructuring-bind (regexp subexp) (if (listp x) x `(,x nil)) + (cl-destructuring-bind (regexp subexp) (if (listp x) x `(,x nil)) (goto-char (point-min)) (while (re-search-forward regexp nil t) (replace-match "" t t nil subexp)))) @@ -224,15 +223,15 @@ would return the string \"foo bar baz quux\" where the substring None of the ARGS are modified, but the return value may share structure with the plists in ARGS." (with-temp-buffer - (loop with current-plist = nil - for x in args do - (etypecase x - (string (let ((begin (point))) - (insert x) - (set-text-properties begin (point) current-plist))) - (list (unless (zerop (mod (length x) 2)) - (error "Odd number of args in plist: %S" x)) - (setq current-plist x)))) + (cl-loop with current-plist = nil + for x in args do + (cl-etypecase x + (string (let ((begin (point))) + (insert x) + (set-text-properties begin (point) current-plist))) + (list (unless (zerop (mod (length x) 2)) + (error "Odd number of args in plist: %S" x)) + (setq current-plist x)))) (buffer-string))) @@ -245,8 +244,8 @@ buffer, and renames the original buffer back to BUFFER-NAME. This is useful if THUNK has undesirable side-effects on an Emacs buffer with a fixed name such as *Messages*." - (lexical-let ((new-buffer-name (generate-new-buffer-name - (format "%s orig buffer" buffer-name)))) + (let ((new-buffer-name (generate-new-buffer-name + (format "%s orig buffer" buffer-name)))) (with-current-buffer (get-buffer-create buffer-name) (rename-buffer new-buffer-name)) (unwind-protect @@ -258,7 +257,7 @@ buffer with a fixed name such as *Messages*." (with-current-buffer new-buffer-name (rename-buffer buffer-name))))) -(defmacro* ert-with-buffer-renamed ((buffer-name-form) &body body) +(cl-defmacro ert-with-buffer-renamed ((buffer-name-form) &body body) "Protect the buffer named BUFFER-NAME from side-effects and run BODY. See `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 @@ -;;; ert.el --- Emacs Lisp Regression Testing +;;; ert.el --- Emacs Lisp Regression Testing -*- lexical-binding: t -*- ;; Copyright (C) 2007-2008, 2010-2012 Free Software Foundation, Inc. @@ -54,8 +54,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'button) (require 'debug) (require 'easymenu) @@ -105,33 +104,33 @@ "A reimplementation of `remove-if-not'. ERT-PRED is a predicate, ERT-LIST is the input list." - (loop for ert-x in ert-list - if (funcall ert-pred ert-x) - collect ert-x)) + (cl-loop for ert-x in ert-list + if (funcall ert-pred ert-x) + collect ert-x)) (defun ert--intersection (a b) "A reimplementation of `intersection'. Intersect the sets A and B. Elements are compared using `eql'." - (loop for x in a - if (memql x b) - collect x)) + (cl-loop for x in a + if (memql x b) + collect x)) (defun ert--set-difference (a b) "A reimplementation of `set-difference'. Subtract the set B from the set A. Elements are compared using `eql'." - (loop for x in a - unless (memql x b) - collect x)) + (cl-loop for x in a + unless (memql x b) + collect x)) (defun ert--set-difference-eq (a b) "A reimplementation of `set-difference'. Subtract the set B from the set A. Elements are compared using `eq'." - (loop for x in a - unless (memq x b) - collect x)) + (cl-loop for x in a + unless (memq x b) + collect x)) (defun ert--union (a b) "A reimplementation of `union'. Compute the union of the sets A and B. @@ -149,7 +148,7 @@ Elements are compared using `eql'." (make-symbol (format "%s%s" prefix (prog1 ert--gensym-counter - (incf ert--gensym-counter)))))) + (cl-incf ert--gensym-counter)))))) (defun ert--coerce-to-vector (x) "Coerce X to a vector." @@ -158,19 +157,19 @@ Elements are compared using `eql'." x (vconcat x))) -(defun* ert--remove* (x list &key key test) +(cl-defun ert--remove* (x list &key key test) "Does not support all the keywords of remove*." (unless key (setq key #'identity)) (unless test (setq test #'eql)) - (loop for y in list - unless (funcall test x (funcall key y)) - collect y)) + (cl-loop for y in list + unless (funcall test x (funcall key y)) + collect y)) (defun ert--string-position (c s) "Return the position of the first occurrence of C in S, or nil if none." - (loop for i from 0 - for x across s - when (eql x c) return i)) + (cl-loop for i from 0 + for x across s + when (eql x c) return i)) (defun ert--mismatch (a b) "Return index of first element that differs between A and B. @@ -184,29 +183,30 @@ Like `mismatch'. Uses `equal' for comparison." (t (let ((la (length a)) (lb (length b))) - (assert (arrayp a) t) - (assert (arrayp b) t) - (assert (<= la lb) t) - (loop for i below la - when (not (equal (aref a i) (aref b i))) return i - finally (return (if (/= la lb) - la - (assert (equal a b) t) - nil))))))) + (cl-assert (arrayp a) t) + (cl-assert (arrayp b) t) + (cl-assert (<= la lb) t) + (cl-loop for i below la + when (not (equal (aref a i) (aref b i))) return i + finally (cl-return (if (/= la lb) + la + (cl-assert (equal a b) t) + nil))))))) (defun ert--subseq (seq start &optional end) "Return a subsequence of SEQ from START to END." (when (char-table-p seq) (error "Not supported")) (let ((vector (substring (ert--coerce-to-vector seq) start end))) - (etypecase seq + (cl-etypecase seq (vector vector) (string (concat vector)) (list (append vector nil)) - (bool-vector (loop with result = (make-bool-vector (length vector) nil) - for i below (length vector) do - (setf (aref result i) (aref vector i)) - finally (return result))) - (char-table (assert nil))))) + (bool-vector (cl-loop with result + = (make-bool-vector (length vector) nil) + for i below (length vector) do + (setf (aref result i) (aref vector i)) + finally (cl-return result))) + (char-table (cl-assert nil))))) (defun ert-equal-including-properties (a b) "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'." ;;; Defining and locating tests. ;; The data structure that represents a test case. -(defstruct ert-test +(cl-defstruct ert-test (name nil) (documentation nil) - (body (assert nil)) + (body (cl-assert nil)) (most-recent-result nil) (expected-result-type ':passed) (tags '())) @@ -273,7 +273,7 @@ Returns a two-element list containing the keys-and-values plist and the body." (let ((extracted-key-accu '()) (remaining keys-and-body)) - (while (and (consp remaining) (keywordp (first remaining))) + (while (keywordp (car-safe remaining)) (let ((keyword (pop remaining))) (unless (consp remaining) (error "Value expected after keyword %S in %S" @@ -283,13 +283,13 @@ and the body." keys-and-body)) (push (cons keyword (pop remaining)) extracted-key-accu))) (setq extracted-key-accu (nreverse extracted-key-accu)) - (list (loop for (key . value) in extracted-key-accu - collect key - collect value) + (list (cl-loop for (key . value) in extracted-key-accu + collect key + collect value) remaining))) ;;;###autoload -(defmacro* ert-deftest (name () &body docstring-keys-and-body) +(cl-defmacro ert-deftest (name () &body docstring-keys-and-body) "Define NAME (a symbol) as a test. BODY is evaluated as a `progn' when the test is run. It should @@ -313,12 +313,13 @@ description of valid values for RESULT-TYPE. (indent 2)) (let ((documentation nil) (documentation-supplied-p nil)) - (when (stringp (first docstring-keys-and-body)) + (when (stringp (car docstring-keys-and-body)) (setq documentation (pop docstring-keys-and-body) documentation-supplied-p t)) - (destructuring-bind ((&key (expected-result nil expected-result-supplied-p) - (tags nil tags-supplied-p)) - body) + (cl-destructuring-bind + ((&key (expected-result nil expected-result-supplied-p) + (tags nil tags-supplied-p)) + body) (ert--parse-keys-and-body docstring-keys-and-body) `(progn (ert-set-test ',name @@ -388,16 +389,11 @@ DATA is displayed to the user and should state the reason of the failure." (defun ert--expand-should-1 (whole form inner-expander) "Helper function for the `should' macro and its variants." (let ((form - ;; If `cl-macroexpand' isn't bound, the code that we're - ;; compiling doesn't depend on cl and thus doesn't need an - ;; environment arg for `macroexpand'. - (if (fboundp 'cl-macroexpand) - ;; Suppress warning about run-time call to cl function: we - ;; only call it if it's fboundp. - (with-no-warnings - (cl-macroexpand form (and (boundp 'cl-macro-environment) - cl-macro-environment))) - (macroexpand form)))) + (macroexpand form (cond + ((boundp 'macroexpand-all-environment) + macroexpand-all-environment) + ((boundp 'cl-macro-environment) + cl-macro-environment))))) (cond ((or (atom form) (ert--special-operator-p (car form))) (let ((value (ert--gensym "value-"))) @@ -410,10 +406,10 @@ DATA is displayed to the user and should state the reason of the failure." (t (let ((fn-name (car form)) (arg-forms (cdr form))) - (assert (or (symbolp fn-name) - (and (consp fn-name) - (eql (car fn-name) 'lambda) - (listp (cdr fn-name))))) + (cl-assert (or (symbolp fn-name) + (and (consp fn-name) + (eql (car fn-name) 'lambda) + (listp (cdr fn-name))))) (let ((fn (ert--gensym "fn-")) (args (ert--gensym "args-")) (value (ert--gensym "value-")) @@ -451,35 +447,34 @@ should return code that calls INNER-FORM and performs the checks and error signaling specific to the particular variant of `should'. The code that INNER-EXPANDER returns must not call FORM-DESCRIPTION-FORM before it has called INNER-FORM." - (lexical-let ((inner-expander inner-expander)) - (ert--expand-should-1 - whole form - (lambda (inner-form form-description-form value-var) - (let ((form-description (ert--gensym "form-description-"))) - `(let (,form-description) - ,(funcall inner-expander - `(unwind-protect - ,inner-form - (setq ,form-description ,form-description-form) - (ert--signal-should-execution ,form-description)) - `,form-description - value-var))))))) + (ert--expand-should-1 + whole form + (lambda (inner-form form-description-form value-var) + (let ((form-description (ert--gensym "form-description-"))) + `(let (,form-description) + ,(funcall inner-expander + `(unwind-protect + ,inner-form + (setq ,form-description ,form-description-form) + (ert--signal-should-execution ,form-description)) + `,form-description + value-var)))))) -(defmacro* should (form) +(cl-defmacro should (form) "Evaluate FORM. If it returns nil, abort the current test as failed. Returns the value of FORM." (ert--expand-should `(should ,form) form - (lambda (inner-form form-description-form value-var) + (lambda (inner-form form-description-form _value-var) `(unless ,inner-form (ert-fail ,form-description-form))))) -(defmacro* should-not (form) +(cl-defmacro should-not (form) "Evaluate FORM. If it returns non-nil, abort the current test as failed. Returns nil." (ert--expand-should `(should-not ,form) form - (lambda (inner-form form-description-form value-var) + (lambda (inner-form form-description-form _value-var) `(unless (not ,inner-form) (ert-fail ,form-description-form))))) @@ -490,10 +485,10 @@ Returns nil." Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES, and aborts the current test as failed if it doesn't." (let ((signaled-conditions (get (car condition) 'error-conditions)) - (handled-conditions (etypecase type + (handled-conditions (cl-etypecase type (list type) (symbol (list type))))) - (assert signaled-conditions) + (cl-assert signaled-conditions) (unless (ert--intersection signaled-conditions handled-conditions) (ert-fail (append (funcall form-description-fn) @@ -512,7 +507,7 @@ and aborts the current test as failed if it doesn't." ;; FIXME: The expansion will evaluate the keyword args (if any) in ;; nonstandard order. -(defmacro* should-error (form &rest keys &key type exclude-subtypes) +(cl-defmacro should-error (form &rest keys &key type exclude-subtypes) "Evaluate FORM and check that it signals an error. The error signaled needs to match TYPE. TYPE should be a list @@ -560,19 +555,19 @@ failed." (defun ert--proper-list-p (x) "Return non-nil if X is a proper list, nil otherwise." - (loop + (cl-loop for firstp = t then nil for fast = x then (cddr fast) for slow = x then (cdr slow) do - (when (null fast) (return t)) - (when (not (consp fast)) (return nil)) - (when (null (cdr fast)) (return t)) - (when (not (consp (cdr fast))) (return nil)) - (when (and (not firstp) (eq fast slow)) (return nil)))) + (when (null fast) (cl-return t)) + (when (not (consp fast)) (cl-return nil)) + (when (null (cdr fast)) (cl-return t)) + (when (not (consp (cdr fast))) (cl-return nil)) + (when (and (not firstp) (eq fast slow)) (cl-return nil)))) (defun ert--explain-format-atom (x) "Format the atom X for `ert--explain-equal'." - (typecase x + (cl-typecase x (fixnum (list x (format "#x%x" x) (format "?%c" x))) (t x))) @@ -581,7 +576,7 @@ failed." Returns nil if they are." (if (not (equal (type-of a) (type-of b))) `(different-types ,a ,b) - (etypecase a + (cl-etypecase a (cons (let ((a-proper-p (ert--proper-list-p a)) (b-proper-p (ert--proper-list-p b))) @@ -593,19 +588,19 @@ Returns nil if they are." ,a ,b first-mismatch-at ,(ert--mismatch a b)) - (loop for i from 0 - for ai in a - for bi in b - for xi = (ert--explain-equal-rec ai bi) - do (when xi (return `(list-elt ,i ,xi))) - finally (assert (equal a b) t))) + (cl-loop for i from 0 + for ai in a + for bi in b + for xi = (ert--explain-equal-rec ai bi) + do (when xi (cl-return `(list-elt ,i ,xi))) + finally (cl-assert (equal a b) t))) (let ((car-x (ert--explain-equal-rec (car a) (car b)))) (if car-x `(car ,car-x) (let ((cdr-x (ert--explain-equal-rec (cdr a) (cdr b)))) (if cdr-x `(cdr ,cdr-x) - (assert (equal a b) t) + (cl-assert (equal a b) t) nil)))))))) (array (if (not (equal (length a) (length b))) `(arrays-of-different-length ,(length a) ,(length b) @@ -613,12 +608,12 @@ Returns nil if they are." ,@(unless (char-table-p a) `(first-mismatch-at ,(ert--mismatch a b)))) - (loop for i from 0 - for ai across a - for bi across b - for xi = (ert--explain-equal-rec ai bi) - do (when xi (return `(array-elt ,i ,xi))) - finally (assert (equal a b) t)))) + (cl-loop for i from 0 + for ai across a + for bi across b + for xi = (ert--explain-equal-rec ai bi) + do (when xi (cl-return `(array-elt ,i ,xi))) + finally (cl-assert (equal a b) t)))) (atom (if (not (equal a b)) (if (and (symbolp a) (symbolp b) (string= a b)) `(different-symbols-with-the-same-name ,a ,b) @@ -637,10 +632,10 @@ Returns nil if they are." (defun ert--significant-plist-keys (plist) "Return the keys of PLIST that have non-null values, in order." - (assert (zerop (mod (length plist) 2)) t) - (loop for (key value . rest) on plist by #'cddr - unless (or (null value) (memq key accu)) collect key into accu - finally (return accu))) + (cl-assert (zerop (mod (length plist) 2)) t) + (cl-loop for (key value . rest) on plist by #'cddr + unless (or (null value) (memq key accu)) collect key into accu + finally (cl-return accu))) (defun ert--plist-difference-explanation (a b) "Return a programmer-readable explanation of why A and B are different plists. @@ -648,8 +643,8 @@ Returns nil if they are." Returns nil if they are equivalent, i.e., have the same value for each key, where absent values are treated as nil. The order of key/value pairs in each list does not matter." - (assert (zerop (mod (length a) 2)) t) - (assert (zerop (mod (length b) 2)) t) + (cl-assert (zerop (mod (length a) 2)) t) + (cl-assert (zerop (mod (length b) 2)) t) ;; Normalizing the plists would be another way to do this but it ;; requires a total ordering on all lisp objects (since any object ;; is valid as a text property key). Perhaps defining such an @@ -659,21 +654,21 @@ key/value pairs in each list does not matter." (keys-b (ert--significant-plist-keys b)) (keys-in-a-not-in-b (ert--set-difference-eq keys-a keys-b)) (keys-in-b-not-in-a (ert--set-difference-eq keys-b keys-a))) - (flet ((explain-with-key (key) - (let ((value-a (plist-get a key)) - (value-b (plist-get b key))) - (assert (not (equal value-a value-b)) t) - `(different-properties-for-key - ,key ,(ert--explain-equal-including-properties value-a - value-b))))) + (cl-flet ((explain-with-key (key) + (let ((value-a (plist-get a key)) + (value-b (plist-get b key))) + (cl-assert (not (equal value-a value-b)) t) + `(different-properties-for-key + ,key ,(ert--explain-equal-including-properties value-a + value-b))))) (cond (keys-in-a-not-in-b - (explain-with-key (first keys-in-a-not-in-b))) + (explain-with-key (car keys-in-a-not-in-b))) (keys-in-b-not-in-a - (explain-with-key (first keys-in-b-not-in-a))) + (explain-with-key (car keys-in-b-not-in-a))) (t - (loop for key in keys-a - when (not (equal (plist-get a key) (plist-get b key))) - return (explain-with-key key))))))) + (cl-loop for key in keys-a + when (not (equal (plist-get a key) (plist-get b key))) + return (explain-with-key key))))))) (defun ert--abbreviate-string (s len suffixp) "Shorten string S to at most LEN chars. @@ -697,29 +692,30 @@ Returns a programmer-readable explanation of why A and B are not `ert-equal-including-properties', or nil if they are." (if (not (equal a b)) (ert--explain-equal a b) - (assert (stringp a) t) - (assert (stringp b) t) - (assert (eql (length a) (length b)) t) - (loop for i from 0 to (length a) - for props-a = (text-properties-at i a) - for props-b = (text-properties-at i b) - for difference = (ert--plist-difference-explanation props-a props-b) - do (when difference - (return `(char ,i ,(substring-no-properties a i (1+ i)) - ,difference - context-before - ,(ert--abbreviate-string - (substring-no-properties a 0 i) - 10 t) - context-after - ,(ert--abbreviate-string - (substring-no-properties a (1+ i)) - 10 nil)))) - ;; TODO(ohler): Get `equal-including-properties' fixed in - ;; Emacs, delete `ert-equal-including-properties', and - ;; re-enable this assertion. - ;;finally (assert (equal-including-properties a b) t) - ))) + (cl-assert (stringp a) t) + (cl-assert (stringp b) t) + (cl-assert (eql (length a) (length b)) t) + (cl-loop for i from 0 to (length a) + for props-a = (text-properties-at i a) + for props-b = (text-properties-at i b) + for difference = (ert--plist-difference-explanation + props-a props-b) + do (when difference + (cl-return `(char ,i ,(substring-no-properties a i (1+ i)) + ,difference + context-before + ,(ert--abbreviate-string + (substring-no-properties a 0 i) + 10 t) + context-after + ,(ert--abbreviate-string + (substring-no-properties a (1+ i)) + 10 nil)))) + ;; TODO(ohler): Get `equal-including-properties' fixed in + ;; Emacs, delete `ert-equal-including-properties', and + ;; re-enable this assertion. + ;;finally (cl-assert (equal-including-properties a b) t) + ))) (put 'ert-equal-including-properties 'ert-explainer 'ert--explain-equal-including-properties) @@ -734,8 +730,8 @@ Returns a programmer-readable explanation of why A and B are not Bound dynamically. This is a list of (PREFIX . MESSAGE) pairs.") -(defmacro* ert-info ((message-form &key ((:prefix prefix-form) "Info: ")) - &body body) +(cl-defmacro ert-info ((message-form &key ((:prefix prefix-form) "Info: ")) + &body body) "Evaluate MESSAGE-FORM and BODY, and report the message if BODY fails. To be used within ERT tests. MESSAGE-FORM should evaluate to a @@ -755,18 +751,19 @@ and is displayed in front of the value of MESSAGE-FORM." "Non-nil means enter debugger when a test fails or terminates with an error.") ;; The data structures that represent the result of running a test. -(defstruct ert-test-result +(cl-defstruct ert-test-result (messages nil) (should-forms nil) ) -(defstruct (ert-test-passed (:include ert-test-result))) -(defstruct (ert-test-result-with-condition (:include ert-test-result)) - (condition (assert nil)) - (backtrace (assert nil)) - (infos (assert nil))) -(defstruct (ert-test-quit (:include ert-test-result-with-condition))) -(defstruct (ert-test-failed (:include ert-test-result-with-condition))) -(defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result))) +(cl-defstruct (ert-test-passed (:include ert-test-result))) +(cl-defstruct (ert-test-result-with-condition (:include ert-test-result)) + (condition (cl-assert nil)) + (backtrace (cl-assert nil)) + (infos (cl-assert nil))) +(cl-defstruct (ert-test-quit (:include ert-test-result-with-condition))) +(cl-defstruct (ert-test-failed (:include ert-test-result-with-condition))) +(cl-defstruct (ert-test-aborted-with-non-local-exit + (:include ert-test-result))) (defun ert--record-backtrace () @@ -779,7 +776,7 @@ and is displayed in front of the value of MESSAGE-FORM." ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we ;; already have `ert-results-rerun-test-debugging-errors-at-point'. ;; For batch use, however, printing the backtrace may be useful. - (loop + (cl-loop ;; 6 is the number of frames our own debugger adds (when ;; compiled; more when interpreted). FIXME: Need to describe a ;; procedure for determining this constant. @@ -796,33 +793,33 @@ and is displayed in front of the value of MESSAGE-FORM." (print-level 8) (print-length 50)) (dolist (frame backtrace) - (ecase (first frame) + (cl-ecase (car frame) ((nil) ;; Special operator. - (destructuring-bind (special-operator &rest arg-forms) + (cl-destructuring-bind (special-operator &rest arg-forms) (cdr frame) (insert - (format " %S\n" (list* special-operator arg-forms))))) + (format " %S\n" (cons special-operator arg-forms))))) ((t) ;; Function call. - (destructuring-bind (fn &rest args) (cdr frame) + (cl-destructuring-bind (fn &rest args) (cdr frame) (insert (format " %S(" fn)) - (loop for firstp = t then nil - for arg in args do - (unless firstp - (insert " ")) - (insert (format "%S" arg))) + (cl-loop for firstp = t then nil + for arg in args do + (unless firstp + (insert " ")) + (insert (format "%S" arg))) (insert ")\n"))))))) ;; A container for the state of the execution of a single test and ;; environment data needed during its execution. -(defstruct ert--test-execution-info - (test (assert nil)) - (result (assert nil)) +(cl-defstruct ert--test-execution-info + (test (cl-assert nil)) + (result (cl-assert nil)) ;; A thunk that may be called when RESULT has been set to its final ;; value and test execution should be terminated. Should not ;; return. - (exit-continuation (assert nil)) + (exit-continuation (cl-assert nil)) ;; The binding of `debugger' outside of the execution of the test. next-debugger ;; The binding of `ert-debug-on-error' that is in effect for the @@ -831,7 +828,7 @@ and is displayed in front of the value of MESSAGE-FORM." ;; don't remember whether this feature is important.) ert-debug-on-error) -(defun ert--run-test-debugger (info debugger-args) +(defun ert--run-test-debugger (info args) "During a test run, `debugger' is bound to a closure that calls this function. This function records failures and errors and either terminates @@ -839,21 +836,21 @@ the test silently or calls the interactive debugger, as appropriate. INFO is the ert--test-execution-info corresponding to this test -run. DEBUGGER-ARGS are the arguments to `debugger'." - (destructuring-bind (first-debugger-arg &rest more-debugger-args) - debugger-args - (ecase first-debugger-arg +run. ARGS are the arguments to `debugger'." + (cl-destructuring-bind (first-debugger-arg &rest more-debugger-args) + args + (cl-ecase first-debugger-arg ((lambda debug t exit nil) - (apply (ert--test-execution-info-next-debugger info) debugger-args)) + (apply (ert--test-execution-info-next-debugger info) args)) (error - (let* ((condition (first more-debugger-args)) - (type (case (car condition) + (let* ((condition (car more-debugger-args)) + (type (cl-case (car condition) ((quit) 'quit) (otherwise 'failed))) (backtrace (ert--record-backtrace)) (infos (reverse ert--infos))) (setf (ert--test-execution-info-result info) - (ecase type + (cl-ecase type (quit (make-ert-test-quit :condition condition :backtrace backtrace @@ -864,39 +861,42 @@ run. DEBUGGER-ARGS are the arguments to `debugger'." :infos infos)))) ;; Work around Emacs's heuristic (in eval.c) for detecting ;; errors in the debugger. - (incf num-nonmacro-input-events) + (cl-incf num-nonmacro-input-events) ;; FIXME: We should probably implement more fine-grained ;; control a la non-t `debug-on-error' here. (cond ((ert--test-execution-info-ert-debug-on-error info) - (apply (ert--test-execution-info-next-debugger info) debugger-args)) + (apply (ert--test-execution-info-next-debugger info) args)) (t)) (funcall (ert--test-execution-info-exit-continuation info))))))) -(defun ert--run-test-internal (ert-test-execution-info) - "Low-level function to run a test according to ERT-TEST-EXECUTION-INFO. +(defun ert--run-test-internal (test-execution-info) + "Low-level function to run a test according to TEST-EXECUTION-INFO. This mainly sets up debugger-related bindings." - (lexical-let ((info ert-test-execution-info)) - (setf (ert--test-execution-info-next-debugger info) debugger - (ert--test-execution-info-ert-debug-on-error info) ert-debug-on-error) - (catch 'ert--pass - ;; For now, each test gets its own temp buffer and its own - ;; window excursion, just to be safe. If this turns out to be - ;; too expensive, we can remove it. - (with-temp-buffer - (save-window-excursion - (let ((debugger (lambda (&rest debugger-args) - (ert--run-test-debugger info debugger-args))) - (debug-on-error t) - (debug-on-quit t) - ;; FIXME: Do we need to store the old binding of this - ;; and consider it in `ert--run-test-debugger'? - (debug-ignored-errors nil) - (ert--infos '())) - (funcall (ert-test-body (ert--test-execution-info-test info)))))) - (ert-pass)) - (setf (ert--test-execution-info-result info) (make-ert-test-passed))) + (setf (ert--test-execution-info-next-debugger test-execution-info) debugger + (ert--test-execution-info-ert-debug-on-error test-execution-info) + ert-debug-on-error) + (catch 'ert--pass + ;; For now, each test gets its own temp buffer and its own + ;; window excursion, just to be safe. If this turns out to be + ;; too expensive, we can remove it. + (with-temp-buffer + (save-window-excursion + (let ((debugger (lambda (&rest args) + (ert--run-test-debugger test-execution-info + args))) + (debug-on-error t) + (debug-on-quit t) + ;; FIXME: Do we need to store the old binding of this + ;; and consider it in `ert--run-test-debugger'? + (debug-ignored-errors nil) + (ert--infos '())) + (funcall (ert-test-body (ert--test-execution-info-test + test-execution-info)))))) + (ert-pass)) + (setf (ert--test-execution-info-result test-execution-info) + (make-ert-test-passed)) nil) (defun ert--force-message-log-buffer-truncation () @@ -934,18 +934,18 @@ The elements are of type `ert-test'.") Returns the result and stores it in ERT-TEST's `most-recent-result' slot." (setf (ert-test-most-recent-result ert-test) nil) - (block error - (lexical-let ((begin-marker - (with-current-buffer (get-buffer-create "*Messages*") - (set-marker (make-marker) (point-max))))) + (cl-block error + (let ((begin-marker + (with-current-buffer (get-buffer-create "*Messages*") + (set-marker (make-marker) (point-max))))) (unwind-protect - (lexical-let ((info (make-ert--test-execution-info - :test ert-test - :result - (make-ert-test-aborted-with-non-local-exit) - :exit-continuation (lambda () - (return-from error nil)))) - (should-form-accu (list))) + (let ((info (make-ert--test-execution-info + :test ert-test + :result + (make-ert-test-aborted-with-non-local-exit) + :exit-continuation (lambda () + (cl-return-from error nil)))) + (should-form-accu (list))) (unwind-protect (let ((ert--should-execution-observer (lambda (form-description) @@ -987,32 +987,32 @@ t -- Always matches. RESULT." ;; It would be easy to add `member' and `eql' types etc., but I ;; haven't bothered yet. - (etypecase result-type + (cl-etypecase result-type ((member nil) nil) ((member t) t) ((member :failed) (ert-test-failed-p result)) ((member :passed) (ert-test-passed-p result)) (cons - (destructuring-bind (operator &rest operands) result-type - (ecase operator + (cl-destructuring-bind (operator &rest operands) result-type + (cl-ecase operator (and - (case (length operands) + (cl-case (length operands) (0 t) (t - (and (ert-test-result-type-p result (first operands)) - (ert-test-result-type-p result `(and ,@(rest operands))))))) + (and (ert-test-result-type-p result (car operands)) + (ert-test-result-type-p result `(and ,@(cdr operands))))))) (or - (case (length operands) + (cl-case (length operands) (0 nil) (t - (or (ert-test-result-type-p result (first operands)) - (ert-test-result-type-p result `(or ,@(rest operands))))))) + (or (ert-test-result-type-p result (car operands)) + (ert-test-result-type-p result `(or ,@(cdr operands))))))) (not - (assert (eql (length operands) 1)) - (not (ert-test-result-type-p result (first operands)))) + (cl-assert (eql (length operands) 1)) + (not (ert-test-result-type-p result (car operands)))) (satisfies - (assert (eql (length operands) 1)) - (funcall (first operands) result))))))) + (cl-assert (eql (length operands) 1)) + (funcall (car operands) result))))))) (defun ert-test-result-expected-p (test result) "Return non-nil if TEST's expected result type matches RESULT." @@ -1053,9 +1053,9 @@ set implied by them without checking whether it is really contained in UNIVERSE." ;; This code needs to match the etypecase in ;; `ert-insert-human-readable-selector'. - (etypecase selector + (cl-etypecase selector ((member nil) nil) - ((member t) (etypecase universe + ((member t) (cl-etypecase universe (list universe) ((member t) (ert-select-tests "" universe)))) ((member :new) (ert-select-tests @@ -1083,7 +1083,7 @@ contained in UNIVERSE." universe)) ((member :unexpected) (ert-select-tests `(not :expected) universe)) (string - (etypecase universe + (cl-etypecase universe ((member t) (mapcar #'ert-get-test (apropos-internal selector #'ert-test-boundp))) (list (ert--remove-if-not (lambda (test) @@ -1093,51 +1093,51 @@ contained in UNIVERSE." universe)))) (ert-test (list selector)) (symbol - (assert (ert-test-boundp selector)) + (cl-assert (ert-test-boundp selector)) (list (ert-get-test selector))) (cons - (destructuring-bind (operator &rest operands) selector - (ecase operator + (cl-destructuring-bind (operator &rest operands) selector + (cl-ecase operator (member (mapcar (lambda (purported-test) - (etypecase purported-test - (symbol (assert (ert-test-boundp purported-test)) + (cl-etypecase purported-test + (symbol (cl-assert (ert-test-boundp purported-test)) (ert-get-test purported-test)) (ert-test purported-test))) operands)) (eql - (assert (eql (length operands) 1)) + (cl-assert (eql (length operands) 1)) (ert-select-tests `(member ,@operands) universe)) (and ;; Do these definitions of AND, NOT and OR satisfy de ;; Morgan's laws? Should they? - (case (length operands) + (cl-case (length operands) (0 (ert-select-tests 't universe)) - (t (ert-select-tests `(and ,@(rest operands)) - (ert-select-tests (first operands) + (t (ert-select-tests `(and ,@(cdr operands)) + (ert-select-tests (car operands) universe))))) (not - (assert (eql (length operands) 1)) + (cl-assert (eql (length operands) 1)) (let ((all-tests (ert-select-tests 't universe))) (ert--set-difference all-tests - (ert-select-tests (first operands) + (ert-select-tests (car operands) all-tests)))) (or - (case (length operands) + (cl-case (length operands) (0 (ert-select-tests 'nil universe)) - (t (ert--union (ert-select-tests (first operands) universe) - (ert-select-tests `(or ,@(rest operands)) + (t (ert--union (ert-select-tests (car operands) universe) + (ert-select-tests `(or ,@(cdr operands)) universe))))) (tag - (assert (eql (length operands) 1)) - (let ((tag (first operands))) + (cl-assert (eql (length operands) 1)) + (let ((tag (car operands))) (ert-select-tests `(satisfies ,(lambda (test) (member tag (ert-test-tags test)))) universe))) (satisfies - (assert (eql (length operands) 1)) - (ert--remove-if-not (first operands) + (cl-assert (eql (length operands) 1)) + (ert--remove-if-not (car operands) (ert-select-tests 't universe)))))))) (defun ert--insert-human-readable-selector (selector) @@ -1146,26 +1146,27 @@ contained in UNIVERSE." ;; `backtrace' slot of the result objects in the ;; `most-recent-result' slots of test case objects in (eql ...) or ;; (member ...) selectors. - (labels ((rec (selector) - ;; This code needs to match the etypecase in `ert-select-tests'. - (etypecase selector - ((or (member nil t - :new :failed :passed - :expected :unexpected) - string - symbol) - selector) - (ert-test - (if (ert-test-name selector) - (make-symbol (format "<%S>" (ert-test-name selector))) - (make-symbol "<unnamed test>"))) - (cons - (destructuring-bind (operator &rest operands) selector - (ecase operator - ((member eql and not or) - `(,operator ,@(mapcar #'rec operands))) - ((member tag satisfies) - selector))))))) + (cl-labels ((rec (selector) + ;; This code needs to match the etypecase in + ;; `ert-select-tests'. + (cl-etypecase selector + ((or (member nil t + :new :failed :passed + :expected :unexpected) + string + symbol) + selector) + (ert-test + (if (ert-test-name selector) + (make-symbol (format "<%S>" (ert-test-name selector))) + (make-symbol "<unnamed test>"))) + (cons + (cl-destructuring-bind (operator &rest operands) selector + (cl-ecase operator + ((member eql and not or) + `(,operator ,@(mapcar #'rec operands))) + ((member tag satisfies) + selector))))))) (insert (format "%S" (rec selector))))) @@ -1182,21 +1183,21 @@ contained in UNIVERSE." ;; that corresponds to this run in order to be able to update the ;; statistics correctly when a test is re-run interactively and has a ;; different result than before. -(defstruct ert--stats - (selector (assert nil)) +(cl-defstruct ert--stats + (selector (cl-assert nil)) ;; The tests, in order. - (tests (assert nil) :type vector) + (tests (cl-assert nil) :type vector) ;; A map of test names (or the test objects themselves for unnamed ;; tests) to indices into the `tests' vector. - (test-map (assert nil) :type hash-table) + (test-map (cl-assert nil) :type hash-table) ;; The results of the tests during this run, in order. - (test-results (assert nil) :type vector) + (test-results (cl-assert nil) :type vector) ;; The start times of the tests, in order, as reported by ;; `current-time'. - (test-start-times (assert nil) :type vector) + (test-start-times (cl-assert nil) :type vector) ;; The end times of the tests, in order, as reported by ;; `current-time'. - (test-end-times (assert nil) :type vector) + (test-end-times (cl-assert nil) :type vector) (passed-expected 0) (passed-unexpected 0) (failed-expected 0) @@ -1246,21 +1247,25 @@ Also changes the counters in STATS to match." (results (ert--stats-test-results stats)) (old-test (aref tests pos)) (map (ert--stats-test-map stats))) - (flet ((update (d) - (if (ert-test-result-expected-p (aref tests pos) - (aref results pos)) - (etypecase (aref results pos) - (ert-test-passed (incf (ert--stats-passed-expected stats) d)) - (ert-test-failed (incf (ert--stats-failed-expected stats) d)) - (null) - (ert-test-aborted-with-non-local-exit) - (ert-test-quit)) - (etypecase (aref results pos) - (ert-test-passed (incf (ert--stats-passed-unexpected stats) d)) - (ert-test-failed (incf (ert--stats-failed-unexpected stats) d)) - (null) - (ert-test-aborted-with-non-local-exit) - (ert-test-quit))))) + (cl-flet ((update (d) + (if (ert-test-result-expected-p (aref tests pos) + (aref results pos)) + (cl-etypecase (aref results pos) + (ert-test-passed + (cl-incf (ert--stats-passed-expected stats) d)) + (ert-test-failed + (cl-incf (ert--stats-failed-expected stats) d)) + (null) + (ert-test-aborted-with-non-local-exit) + (ert-test-quit)) + (cl-etypecase (aref results pos) + (ert-test-passed + (cl-incf (ert--stats-passed-unexpected stats) d)) + (ert-test-failed + (cl-incf (ert--stats-failed-unexpected stats) d)) + (null) + (ert-test-aborted-with-non-local-exit) + (ert-test-quit))))) ;; Adjust counters to remove the result that is currently in stats. (update -1) ;; Put new test and result into stats. @@ -1278,11 +1283,11 @@ Also changes the counters in STATS to match." SELECTOR is the selector that was used to select TESTS." (setq tests (ert--coerce-to-vector tests)) (let ((map (make-hash-table :size (length tests)))) - (loop for i from 0 - for test across tests - for key = (ert--stats-test-key test) do - (assert (not (gethash key map))) - (setf (gethash key map) i)) + (cl-loop for i from 0 + for test across tests + for key = (ert--stats-test-key test) do + (cl-assert (not (gethash key map))) + (setf (gethash key map) i)) (make-ert--stats :selector selector :tests tests :test-map map @@ -1324,8 +1329,8 @@ SELECTOR is the selector that was used to select TESTS." (force-mode-line-update) (unwind-protect (progn - (loop for test in tests do - (ert-run-or-rerun-test stats test listener)) + (cl-loop for test in tests do + (ert-run-or-rerun-test stats test listener)) (setq abortedp nil)) (setf (ert--stats-aborted-p stats) abortedp) (setf (ert--stats-end-time stats) (current-time)) @@ -1349,7 +1354,7 @@ SELECTOR is the selector that was used to select TESTS." "Return a character that represents the test result RESULT. EXPECTEDP specifies whether the result was expected." - (let ((s (etypecase result + (let ((s (cl-etypecase result (ert-test-passed ".P") (ert-test-failed "fF") (null "--") @@ -1361,7 +1366,7 @@ EXPECTEDP specifies whether the result was expected." "Return a string that represents the test result RESULT. EXPECTEDP specifies whether the result was expected." - (let ((s (etypecase result + (let ((s (cl-etypecase result (ert-test-passed '("passed" "PASSED")) (ert-test-failed '("failed" "FAILED")) (null '("unknown" "UNKNOWN")) @@ -1383,9 +1388,9 @@ Ensures a final newline is inserted." "Insert `ert-info' infos from RESULT into current buffer. RESULT must be an `ert-test-result-with-condition'." - (check-type result ert-test-result-with-condition) + (cl-check-type result ert-test-result-with-condition) (dolist (info (ert-test-result-with-condition-infos result)) - (destructuring-bind (prefix . message) info + (cl-destructuring-bind (prefix . message) info (let ((begin (point)) (indentation (make-string (+ (length prefix) 4) ?\s)) (end nil)) @@ -1421,14 +1426,14 @@ Returns the stats object." (ert-run-tests selector (lambda (event-type &rest event-args) - (ecase event-type + (cl-ecase event-type (run-started - (destructuring-bind (stats) event-args + (cl-destructuring-bind (stats) event-args (message "Running %s tests (%s)" (length (ert--stats-tests stats)) (ert--format-time-iso8601 (ert--stats-start-time stats))))) (run-ended - (destructuring-bind (stats abortedp) event-args + (cl-destructuring-bind (stats abortedp) event-args (let ((unexpected (ert-stats-completed-unexpected stats)) (expected-failures (ert--stats-failed-expected stats))) (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n" @@ -1446,19 +1451,19 @@ Returns the stats object." (format "\n%s expected failures" expected-failures))) (unless (zerop unexpected) (message "%s unexpected results:" unexpected) - (loop for test across (ert--stats-tests stats) - for result = (ert-test-most-recent-result test) do - (when (not (ert-test-result-expected-p test result)) - (message "%9s %S" - (ert-string-for-test-result result nil) - (ert-test-name test)))) + (cl-loop for test across (ert--stats-tests stats) + for result = (ert-test-most-recent-result test) do + (when (not (ert-test-result-expected-p test result)) + (message "%9s %S" + (ert-string-for-test-result result nil) + (ert-test-name test)))) (message "%s" ""))))) (test-started ) (test-ended - (destructuring-bind (stats test result) event-args + (cl-destructuring-bind (stats test result) event-args (unless (ert-test-result-expected-p test result) - (etypecase result + (cl-etypecase result (ert-test-passed (message "Test %S passed unexpectedly" (ert-test-name test))) (ert-test-result-with-condition @@ -1484,7 +1489,7 @@ Returns the stats object." (ert--pp-with-indentation-and-newline (ert-test-result-with-condition-condition result))) (goto-char (1- (point-max))) - (assert (looking-at "\n")) + (cl-assert (looking-at "\n")) (delete-char 1) (message "Test %S condition:" (ert-test-name test)) (message "%s" (buffer-string)))) @@ -1532,7 +1537,7 @@ the tests)." (1 font-lock-keyword-face nil t) (2 font-lock-function-name-face nil t))))) -(defun* ert--remove-from-list (list-var element &key key test) +(cl-defun ert--remove-from-list (list-var element &key key test) "Remove ELEMENT from the value of LIST-VAR if present. This can be used as an inverse of `add-to-list'." @@ -1557,7 +1562,7 @@ If ADD-DEFAULT-TO-PROMPT is non-nil, PROMPT will be modified to include the default, if any. Signals an error if no test name was read." - (etypecase default + (cl-etypecase default (string (let ((symbol (intern-soft default))) (unless (and symbol (ert-test-boundp symbol)) (setq default nil)))) @@ -1614,11 +1619,11 @@ Nothing more than an interactive interface to `ert-make-test-unbound'." ;;; Display of test progress and results. ;; An entry in the results buffer ewoc. There is one entry per test. -(defstruct ert--ewoc-entry - (test (assert nil)) +(cl-defstruct ert--ewoc-entry + (test (cl-assert nil)) ;; If the result of this test was expected, its ewoc entry is hidden ;; initially. - (hidden-p (assert nil)) + (hidden-p (cl-assert nil)) ;; An ewoc entry may be collapsed to hide details such as the error ;; condition. ;; @@ -1694,7 +1699,7 @@ Also sets `ert--results-progress-bar-button-begin'." ((ert--stats-current-test stats) 'running) ((ert--stats-end-time stats) 'finished) (t 'preparing)))) - (ecase state + (cl-ecase state (preparing (insert "")) (aborted @@ -1705,12 +1710,12 @@ Also sets `ert--results-progress-bar-button-begin'." (t (insert "Aborted.")))) (running - (assert (ert--stats-current-test stats)) + (cl-assert (ert--stats-current-test stats)) (insert "Running test: ") (ert-insert-test-name-button (ert-test-name (ert--stats-current-test stats)))) (finished - (assert (not (ert--stats-current-test stats))) + (cl-assert (not (ert--stats-current-test stats))) (insert "Finished."))) (insert "\n") (if (ert--stats-end-time stats) @@ -1813,7 +1818,7 @@ non-nil, returns the face for expected results.." (defun ert-face-for-stats (stats) "Return a face that represents STATS." (cond ((ert--stats-aborted-p stats) 'nil) - ((plusp (ert-stats-completed-unexpected stats)) + ((cl-plusp (ert-stats-completed-unexpected stats)) (ert-face-for-test-result nil)) ((eql (ert-stats-completed-expected stats) (ert-stats-total stats)) (ert-face-for-test-result t)) @@ -1824,7 +1829,7 @@ non-nil, returns the face for expected results.." (let* ((test (ert--ewoc-entry-test entry)) (stats ert--results-stats) (result (let ((pos (ert--stats-test-pos stats test))) - (assert pos) + (cl-assert pos) (aref (ert--stats-test-results stats) pos))) (hiddenp (ert--ewoc-entry-hidden-p entry)) (expandedp (ert--ewoc-entry-expanded-p entry)) @@ -1850,7 +1855,7 @@ non-nil, returns the face for expected results.." (ert--string-first-line (ert-test-documentation test)) 'font-lock-face 'font-lock-doc-face) "\n")) - (etypecase result + (cl-etypecase result (ert-test-passed (if (ert-test-result-expected-p test result) (insert " passed\n") @@ -1908,9 +1913,10 @@ BUFFER-NAME, if non-nil, is the buffer name to use." (make-string (ert-stats-total stats) (ert-char-for-test-result nil t))) (set (make-local-variable 'ert--results-listener) listener) - (loop for test across (ert--stats-tests stats) do - (ewoc-enter-last ewoc - (make-ert--ewoc-entry :test test :hidden-p t))) + (cl-loop for test across (ert--stats-tests stats) do + (ewoc-enter-last ewoc + (make-ert--ewoc-entry :test test + :hidden-p t))) (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) (goto-char (1- (point-max))) buffer))))) @@ -1945,21 +1951,21 @@ and how to display message." default nil)) nil)) (unless message-fn (setq message-fn 'message)) - (lexical-let ((output-buffer-name output-buffer-name) - buffer - listener - (message-fn message-fn)) + (let ((output-buffer-name output-buffer-name) + buffer + listener + (message-fn message-fn)) (setq listener (lambda (event-type &rest event-args) - (ecase event-type + (cl-ecase event-type (run-started - (destructuring-bind (stats) event-args + (cl-destructuring-bind (stats) event-args (setq buffer (ert--setup-results-buffer stats listener output-buffer-name)) (pop-to-buffer buffer))) (run-ended - (destructuring-bind (stats abortedp) event-args + (cl-destructuring-bind (stats abortedp) event-args (funcall message-fn "%sRan %s tests, %s results were as expected%s" (if (not abortedp) @@ -1976,19 +1982,19 @@ and how to display message." ert--results-ewoc) stats))) (test-started - (destructuring-bind (stats test) event-args + (cl-destructuring-bind (stats test) event-args (with-current-buffer buffer (let* ((ewoc ert--results-ewoc) (pos (ert--stats-test-pos stats test)) (node (ewoc-nth ewoc pos))) - (assert node) + (cl-assert node) (setf (ert--ewoc-entry-test (ewoc-data node)) test) (aset ert--results-progress-bar-string pos (ert-char-for-test-result nil t)) (ert--results-update-stats-display-maybe ewoc stats) (ewoc-invalidate ewoc node))))) (test-ended - (destructuring-bind (stats test result) event-args + (cl-destructuring-bind (stats test result) event-args (with-current-buffer buffer (let* ((ewoc ert--results-ewoc) (pos (ert--stats-test-pos stats test)) @@ -2020,28 +2026,28 @@ and how to display message." (define-derived-mode ert-results-mode special-mode "ERT-Results" "Major mode for viewing results of ERT test runs.") -(loop for (key binding) in - '(;; Stuff that's not in the menu. - ("\t" forward-button) - ([backtab] backward-button) - ("j" ert-results-jump-between-summary-and-result) - ("L" ert-results-toggle-printer-limits-for-test-at-point) - ("n" ert-results-next-test) - ("p" ert-results-previous-test) - ;; Stuff that is in the menu. - ("R" ert-results-rerun-all-tests) - ("r" ert-results-rerun-test-at-point) - ("d" ert-results-rerun-test-at-point-debugging-errors) - ("." ert-results-find-test-at-point-other-window) - ("b" ert-results-pop-to-backtrace-for-test-at-point) - ("m" ert-results-pop-to-messages-for-test-at-point) - ("l" ert-results-pop-to-should-forms-for-test-at-point) - ("h" ert-results-describe-test-at-point) - ("D" ert-delete-test) - ("T" ert-results-pop-to-timings) - ) - do - (define-key ert-results-mode-map key binding)) +(cl-loop for (key binding) in + '( ;; Stuff that's not in the menu. + ("\t" forward-button) + ([backtab] backward-button) + ("j" ert-results-jump-between-summary-and-result) + ("L" ert-results-toggle-printer-limits-for-test-at-point) + ("n" ert-results-next-test) + ("p" ert-results-previous-test) + ;; Stuff that is in the menu. + ("R" ert-results-rerun-all-tests) + ("r" ert-results-rerun-test-at-point) + ("d" ert-results-rerun-test-at-point-debugging-errors) + ("." ert-results-find-test-at-point-other-window) + ("b" ert-results-pop-to-backtrace-for-test-at-point) + ("m" ert-results-pop-to-messages-for-test-at-point) + ("l" ert-results-pop-to-should-forms-for-test-at-point) + ("h" ert-results-describe-test-at-point) + ("D" ert-delete-test) + ("T" ert-results-pop-to-timings) + ) + do + (define-key ert-results-mode-map key binding)) (easy-menu-define ert-results-mode-menu ert-results-mode-map "Menu for `ert-results-mode'." @@ -2121,15 +2127,15 @@ To be used in the ERT results buffer." EWOC-FN specifies the direction and should be either `ewoc-prev' or `ewoc-next'. If there are no more nodes in that direction, an error is signaled with the message ERROR-MESSAGE." - (loop + (cl-loop (setq node (funcall ewoc-fn ert--results-ewoc node)) (when (null node) (error "%s" error-message)) (unless (ert--ewoc-entry-hidden-p (ewoc-data node)) (goto-char (ewoc-location node)) - (return)))) + (cl-return)))) -(defun ert--results-expand-collapse-button-action (button) +(defun ert--results-expand-collapse-button-action (_button) "Expand or collapse the test node BUTTON belongs to." (let* ((ewoc ert--results-ewoc) (node (save-excursion @@ -2158,11 +2164,11 @@ To be used in the ERT results buffer." (defun ert--ewoc-position (ewoc node) ;; checkdoc-order: nil "Return the position of NODE in EWOC, or nil if NODE is not in EWOC." - (loop for i from 0 - for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here) - do (when (eql node node-here) - (return i)) - finally (return nil))) + (cl-loop for i from 0 + for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here) + do (when (eql node node-here) + (cl-return i)) + finally (cl-return nil))) (defun ert-results-jump-between-summary-and-result () "Jump back and forth between the test run summary and individual test results. @@ -2210,7 +2216,7 @@ To be used in the ERT results buffer." "Return the test at point, or nil. To be used in the ERT results buffer." - (assert (eql major-mode 'ert-results-mode)) + (cl-assert (eql major-mode 'ert-results-mode)) (if (ert--results-test-node-or-null-at-point) (let* ((node (ert--results-test-node-at-point)) (test (ert--ewoc-entry-test (ewoc-data node)))) @@ -2282,9 +2288,9 @@ definition." (point)) ((eventp last-command-event) (posn-point (event-start last-command-event))) - (t (assert nil)))) + (t (cl-assert nil)))) -(defun ert--results-progress-bar-button-action (button) +(defun ert--results-progress-bar-button-action (_button) "Jump to details for the test represented by the character clicked in BUTTON." (goto-char (ert--button-action-position)) (ert-results-jump-between-summary-and-result)) @@ -2294,7 +2300,7 @@ definition." To be used in the ERT results buffer." (interactive) - (assert (eql major-mode 'ert-results-mode)) + (cl-assert (eql major-mode 'ert-results-mode)) (let ((selector (ert--stats-selector ert--results-stats))) (ert-run-tests-interactively selector (buffer-name)))) @@ -2303,13 +2309,13 @@ To be used in the ERT results buffer." To be used in the ERT results buffer." (interactive) - (destructuring-bind (test redefinition-state) + (cl-destructuring-bind (test redefinition-state) (ert--results-test-at-point-allow-redefinition) (when (null test) (error "No test at point")) (let* ((stats ert--results-stats) (progress-message (format "Running %stest %S" - (ecase redefinition-state + (cl-ecase redefinition-state ((nil) "") (redefined "new definition of ") (deleted "deleted ")) @@ -2350,7 +2356,7 @@ To be used in the ERT results buffer." (stats ert--results-stats) (pos (ert--stats-test-pos stats test)) (result (aref (ert--stats-test-results stats) pos))) - (etypecase result + (cl-etypecase result (ert-test-passed (error "Test passed, no backtrace available")) (ert-test-result-with-condition (let ((backtrace (ert-test-result-with-condition-backtrace result)) @@ -2408,13 +2414,14 @@ To be used in the ERT results buffer." (ert-simple-view-mode) (if (null (ert-test-result-should-forms result)) (insert "\n(No should forms during this test.)\n") - (loop for form-description in (ert-test-result-should-forms result) - for i from 1 do - (insert "\n") - (insert (format "%s: " i)) - (let ((begin (point))) - (ert--pp-with-indentation-and-newline form-description) - (ert--make-xrefs-region begin (point))))) + (cl-loop for form-description + in (ert-test-result-should-forms result) + for i from 1 do + (insert "\n") + (insert (format "%s: " i)) + (let ((begin (point))) + (ert--pp-with-indentation-and-newline form-description) + (ert--make-xrefs-region begin (point))))) (goto-char (point-min)) (insert "`should' forms executed during test `") (ert-insert-test-name-button (ert-test-name test)) @@ -2443,17 +2450,16 @@ To be used in the ERT results buffer." To be used in the ERT results buffer." (interactive) (let* ((stats ert--results-stats) - (start-times (ert--stats-test-start-times stats)) - (end-times (ert--stats-test-end-times stats)) (buffer (get-buffer-create "*ERT timings*")) - (data (loop for test across (ert--stats-tests stats) - for start-time across (ert--stats-test-start-times stats) - for end-time across (ert--stats-test-end-times stats) - collect (list test - (float-time (subtract-time end-time - start-time)))))) + (data (cl-loop for test across (ert--stats-tests stats) + for start-time across (ert--stats-test-start-times + stats) + for end-time across (ert--stats-test-end-times stats) + collect (list test + (float-time (subtract-time + end-time start-time)))))) (setq data (sort data (lambda (a b) - (> (second a) (second b))))) + (> (cl-second a) (cl-second b))))) (pop-to-buffer buffer) (let ((inhibit-read-only t)) (buffer-disable-undo) @@ -2462,13 +2468,13 @@ To be used in the ERT results buffer." (if (null data) (insert "(No data)\n") (insert (format "%-3s %8s %8s\n" "" "time" "cumul")) - (loop for (test time) in data - for cumul-time = time then (+ cumul-time time) - for i from 1 do - (let ((begin (point))) - (insert (format "%3s: %8.3f %8.3f " i time cumul-time)) - (ert-insert-test-name-button (ert-test-name test)) - (insert "\n")))) + (cl-loop for (test time) in data + for cumul-time = time then (+ cumul-time time) + for i from 1 do + (progn + (insert (format "%3s: %8.3f %8.3f " i time cumul-time)) + (ert-insert-test-name-button (ert-test-name test)) + (insert "\n")))) (goto-char (point-min)) (insert "Tests by run time (seconds):\n\n") (forward-line 1)))) @@ -2481,7 +2487,7 @@ To be used in the ERT results buffer." (error "Requires Emacs 24")) (let (test-name test-definition) - (etypecase test-or-test-name + (cl-etypecase test-or-test-name (symbol (setq test-name test-or-test-name test-definition (ert-get-test test-or-test-name))) (ert-test (setq test-name (ert-test-name test-or-test-name) 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." (if (fboundp function-name) (symbol-function function-name)))))) +;; When code is advised, called-interactively-p needs to be taught to skip +;; the advising frames. +;; FIXME: This Major Ugly Hack won't handle calls to called-interactively-p +;; done from the advised function if the deepest advice is an around advice! +;; In other cases (calls from an advice or calls from the advised function when +;; the deepest advice is not an around advice), it should hopefully get +;; it right. +(add-hook 'called-interactively-p-functions + #'advice--called-interactively-skip) +(defun advice--called-interactively-skip (origi frame1 frame2) + (let* ((i origi) + (get-next-frame + (lambda () + (setq frame1 frame2) + (setq frame2 (internal--called-interactively-p--get-frame i)) + ;; (message "Advice Frame %d = %S" i frame2) + (setq i (1+ i))))) + (when (and (eq (nth 1 frame2) 'apply) + (progn + (funcall get-next-frame) + (advice--p (indirect-function (nth 1 frame2))))) + (funcall get-next-frame) + ;; If we now have the symbol, this was the head advice and + ;; we're done. + (while (advice--p (nth 1 frame1)) + ;; This was an inner advice called from some earlier advice. + ;; The stack frames look different depending on the particular + ;; kind of the earlier advice. + (let ((inneradvice (nth 1 frame1))) + (if (and (eq (nth 1 frame2) 'apply) + (progn + (funcall get-next-frame) + (advice--p (indirect-function + (nth 1 frame2))))) + ;; The earlier advice was something like a before/after + ;; advice where the "next" code is called directly by the + ;; advice--p object. + (funcall get-next-frame) + ;; It's apparently an around advice, where the "next" is + ;; called by the body of the advice in any way it sees fit, + ;; so we need to skip the frames of that body. + (while + (progn + (funcall get-next-frame) + (not (and (eq (nth 1 frame2) 'apply) + (eq (nth 3 frame2) inneradvice))))) + (funcall get-next-frame) + (funcall get-next-frame)))) + (- i origi 1)))) + (provide 'nadvice) ;;; 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 @@ -;;; trace.el --- tracing facility for Emacs Lisp functions +;;; trace.el --- tracing facility for Emacs Lisp functions -*- lexical-binding: t -*- ;; Copyright (C) 1993, 1998, 2000-2012 Free Software Foundation, Inc. @@ -151,18 +151,15 @@ ;;; Code: -(require 'advice) - (defgroup trace nil "Tracing facility for Emacs Lisp functions." :prefix "trace-" :group 'lisp) ;;;###autoload -(defcustom trace-buffer (purecopy "*trace-output*") +(defcustom trace-buffer "*trace-output*" "Trace output will by default go to that buffer." - :type 'string - :group 'trace) + :type 'string) ;; Current level of traced function invocation: (defvar trace-level 0) @@ -176,78 +173,109 @@ (defvar inhibit-trace nil "If non-nil, all tracing is temporarily inhibited.") -(defun trace-entry-message (function level argument-bindings) - ;; Generates a string that describes that FUNCTION has been entered at - ;; trace LEVEL with ARGUMENT-BINDINGS. - (format "%s%s%d -> %s: %s\n" - (mapconcat 'char-to-string (make-string (1- level) ?|) " ") - (if (> level 1) " " "") - level - function - (let ((print-circle t)) - (mapconcat (lambda (binding) - (concat - (symbol-name (ad-arg-binding-field binding 'name)) - "=" - ;; do this so we'll see strings: - (prin1-to-string - (ad-arg-binding-field binding 'value)))) - argument-bindings - " ")))) +(defun trace-entry-message (function level args context) + "Generate a string that describes that FUNCTION has been entered. +LEVEL is the trace level, ARGS is the list of arguments passed to FUNCTION, +and CONTEXT is a string describing the dynamic context (e.g. values of +some global variables)." + (let ((print-circle t)) + (format "%s%s%d -> %S%s\n" + (mapconcat 'char-to-string (make-string (1- level) ?|) " ") + (if (> level 1) " " "") + level + (cons function args) + context))) + +(defun trace-exit-message (function level value context) + "Generate a string that describes that FUNCTION has exited. +LEVEL is the trace level, VALUE value returned by FUNCTION, +and CONTEXT is a string describing the dynamic context (e.g. values of +some global variables)." + (let ((print-circle t)) + (format "%s%s%d <- %s: %S%s\n" + (mapconcat 'char-to-string (make-string (1- level) ?|) " ") + (if (> level 1) " " "") + level + function + ;; Do this so we'll see strings: + value + context))) -(defun trace-exit-message (function level value) - ;; Generates a string that describes that FUNCTION has been exited at - ;; trace LEVEL and that it returned VALUE. - (format "%s%s%d <- %s: %s\n" - (mapconcat 'char-to-string (make-string (1- level) ?|) " ") - (if (> level 1) " " "") - level - function - ;; do this so we'll see strings: - (let ((print-circle t)) (prin1-to-string value)))) +(defvar trace--timer nil) -(defun trace-make-advice (function buffer background) - ;; Builds the piece of advice to be added to FUNCTION's advice info - ;; so that it will generate the proper trace output in BUFFER - ;; (quietly if BACKGROUND is t). - (ad-make-advice - trace-advice-name nil t - `(advice - lambda () - (let ((trace-level (1+ trace-level)) - (trace-buffer (get-buffer-create ,buffer))) - (unless inhibit-trace - (with-current-buffer trace-buffer - (set (make-local-variable 'window-point-insertion-type) t) - ,(unless background '(display-buffer trace-buffer)) - (goto-char (point-max)) - ;; Insert a separator from previous trace output: - (if (= trace-level 1) (insert trace-separator)) - (insert - (trace-entry-message - ',function trace-level ad-arg-bindings)))) - ad-do-it - (unless inhibit-trace - (with-current-buffer trace-buffer - ,(unless background '(display-buffer trace-buffer)) - (goto-char (point-max)) - (insert - (trace-exit-message - ',function trace-level ad-return-value)))))))) +(defun trace-make-advice (function buffer background context) + "Build the piece of advice to be added to trace FUNCTION. +FUNCTION is the name of the traced function. +BUFFER is the buffer where the trace should be printed. +BACKGROUND if nil means to display BUFFER. +CONTEXT if non-nil should be a function that returns extra info that should +be printed along with the arguments in the trace." + (lambda (body &rest args) + (let ((trace-level (1+ trace-level)) + (trace-buffer (get-buffer-create buffer)) + (ctx (funcall context))) + (unless inhibit-trace + (with-current-buffer trace-buffer + (set (make-local-variable 'window-point-insertion-type) t) + (unless (or background trace--timer + (get-buffer-window trace-buffer 'visible)) + (setq trace--timer + ;; Postpone the display to some later time, in case we + ;; can't actually do it now. + (run-with-timer 0 nil + (lambda () + (setq trace--timer nil) + (display-buffer trace-buffer))))) + (goto-char (point-max)) + ;; Insert a separator from previous trace output: + (if (= trace-level 1) (insert trace-separator)) + (insert + (trace-entry-message + function trace-level args ctx)))) + (let ((result)) + (unwind-protect + (setq result (list (apply body args))) + (unless inhibit-trace + (let ((ctx (funcall context))) + (with-current-buffer trace-buffer + (unless background (display-buffer trace-buffer)) + (goto-char (point-max)) + (insert + (trace-exit-message + function + trace-level + (if result (car result) '\!non-local\ exit\!) + ctx)))))) + (car result))))) -(defun trace-function-internal (function buffer background) - ;; Adds trace advice for FUNCTION and activates it. - (ad-add-advice - function - (trace-make-advice function (or buffer trace-buffer) background) - 'around 'last) - (ad-activate function nil)) +(defun trace-function-internal (function buffer background context) + "Add trace advice for FUNCTION." + (advice-add + function :around + (trace-make-advice function (or buffer trace-buffer) background + (or context (lambda () ""))) + `((name . ,trace-advice-name)))) (defun trace-is-traced (function) - (ad-find-advice function 'around trace-advice-name)) + (advice-member-p trace-advice-name function)) + +(defun trace--read-args (prompt) + (cons + (intern (completing-read prompt obarray 'fboundp t)) + (when current-prefix-arg + (list + (read-buffer "Output to buffer: " trace-buffer) + (let ((exp + (let ((minibuffer-completing-symbol t)) + (read-from-minibuffer "Context expression: " + nil read-expression-map t + 'read-expression-history)))) + `(lambda () + (let ((print-circle t)) + (concat " [" (prin1-to-string ,exp) "]")))))))) ;;;###autoload -(defun trace-function (function &optional buffer) +(defun trace-function-foreground (function &optional buffer context) "Traces FUNCTION with trace output going to BUFFER. For every call of FUNCTION Lisp-style trace messages that display argument and 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 there might be!! The trace BUFFER will popup whenever FUNCTION is called. Do not use this to trace functions that switch buffers or do any other display oriented stuff, use `trace-function-background' instead." - (interactive - (list - (intern (completing-read "Trace function: " obarray 'fboundp t)) - (read-buffer "Output to buffer: " trace-buffer))) - (trace-function-internal function buffer nil)) + (interactive (trace--read-args "Trace function: ")) + (trace-function-internal function buffer nil context)) ;;;###autoload -(defun trace-function-background (function &optional buffer) +(defun trace-function-background (function &optional buffer context) "Traces FUNCTION with trace output going quietly to BUFFER. When this tracing is enabled, every call to FUNCTION writes a Lisp-style trace message (showing the arguments and return value) @@ -272,12 +297,11 @@ The trace output goes to BUFFER quietly, without changing the window or buffer configuration. BUFFER defaults to `trace-buffer'." - (interactive - (list - (intern - (completing-read "Trace function in background: " obarray 'fboundp t)) - (read-buffer "Output to buffer: " trace-buffer))) - (trace-function-internal function buffer t)) + (interactive (trace--read-args "Trace function in background: ")) + (trace-function-internal function buffer t context)) + +;;;###autoload +(defalias 'trace-function 'trace-function-foreground) (defun untrace-function (function) "Untraces FUNCTION and possibly activates all remaining advice. @@ -285,16 +309,14 @@ Activation is performed with `ad-update', hence remaining advice will get activated only if the advice of FUNCTION is currently active. If FUNCTION was not traced this is a noop." (interactive - (list (ad-read-advised-function "Untrace function" 'trace-is-traced))) - (when (trace-is-traced function) - (ad-remove-advice function 'around trace-advice-name) - (ad-update function))) + (list (intern (completing-read "Untrace function: " + obarray #'trace-is-traced t)))) + (advice-remove function trace-advice-name)) (defun untrace-all () "Untraces all currently traced functions." (interactive) - (ad-do-advised-functions (function) - (untrace-function function))) + (mapatoms #'untrace-function)) (provide 'trace) 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 @@ +2012-11-19 Stefan Monnier <monnier@iro.umontreal.ca> + + Use cl-lib instead of cl, and interactive-p => called-interactively-p. + * erc-track.el, erc-networks.el, erc-netsplit.el, erc-dcc.el: + * erc-backend.el: Use cl-lib, nth, pcase, and called-interactively-p + instead of cl. + * erc-speedbar.el, erc-services.el, erc-pcomplete.el, erc-notify.el: + * erc-match.el, erc-log.el, erc-join.el, erc-ezbounce.el: + * erc-capab.el: Don't require cl since we don't use it. + * erc.el: Use cl-lib, nth, pcase, and called-interactively-p i.s.o cl. + (erc-lurker-ignore-chars, erc-common-server-suffixes): + Move before first use. + 2012-11-16 Glenn Morris <rgm@gnu.org> * 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 @@ ;;; Code: (require 'erc-compat) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;; There's a fairly strong mutual dependency between erc.el and erc-backend.el. ;; Luckily, erc.el does not need erc-backend.el for macroexpansion whereas the ;; reverse is true: @@ -109,7 +109,7 @@ (defvar erc-server-responses (make-hash-table :test #'equal) "Hashtable mapping server responses to their handler hooks.") -(defstruct (erc-response (:conc-name erc-response.)) +(cl-defstruct (erc-response (:conc-name erc-response.)) (unparsed "" :type string) (sender "" :type string) (command "" :type string) @@ -950,7 +950,7 @@ PROCs `process-buffer' is `current-buffer' when this function is called." (push str (erc-response.command-args msg)))) (setf (erc-response.contents msg) - (first (erc-response.command-args msg))) + (car (erc-response.command-args msg))) (setf (erc-response.command-args msg) (nreverse (erc-response.command-args msg))) @@ -1045,7 +1045,7 @@ Finds hooks by looking in the `erc-server-responses' hashtable." (name &rest name) &optional sexp sexp def-body)) -(defmacro* define-erc-response-handler ((name &rest aliases) +(cl-defmacro define-erc-response-handler ((name &rest aliases) &optional extra-fn-doc extra-var-doc &rest fn-body) "Define an ERC handler hook/function pair. @@ -1154,11 +1154,11 @@ add things to `%s' instead." "") name hook-name)) (fn-alternates - (loop for alias in aliases - collect (intern (format "erc-server-%s" alias)))) + (cl-loop for alias in aliases + collect (intern (format "erc-server-%s" alias)))) (var-alternates - (loop for alias in aliases - collect (intern (format "erc-server-%s-functions" alias))))) + (cl-loop for alias in aliases + collect (intern (format "erc-server-%s-functions" alias))))) `(prog2 ;; Normal hook variable. (defvar ,hook-name ',fn-name ,(format hook-doc name)) @@ -1172,19 +1172,19 @@ add things to `%s' instead." (put ',hook-name 'definition-name ',name) ;; Hashtable map of responses to hook variables - ,@(loop for response in (cons name aliases) - for var in (cons hook-name var-alternates) - collect `(puthash ,(format "%s" response) ',var - erc-server-responses)) + ,@(cl-loop for response in (cons name aliases) + for var in (cons hook-name var-alternates) + collect `(puthash ,(format "%s" response) ',var + erc-server-responses)) ;; Alternates. ;; Functions are defaliased, hook variables are defvared so we ;; can add hooks to one alias, but not another. - ,@(loop for fn in fn-alternates - for var in var-alternates - for a in aliases - nconc (list `(defalias ',fn ',fn-name) - `(defvar ,var ',fn-name ,(format hook-doc a)) - `(put ',var 'definition-name ',hook-name)))))) + ,@(cl-loop for fn in fn-alternates + for var in var-alternates + for a in aliases + nconc (list `(defalias ',fn ',fn-name) + `(defvar ,var ',fn-name ,(format hook-doc a)) + `(put ',var 'definition-name ',hook-name)))))) (define-erc-response-handler (ERROR) "Handle an ERROR command from the server." nil @@ -1196,10 +1196,10 @@ add things to `%s' instead." (define-erc-response-handler (INVITE) "Handle invitation messages." nil - (let ((target (first (erc-response.command-args parsed))) + (let ((target (car (erc-response.command-args parsed))) (chnl (erc-response.contents parsed))) - (multiple-value-bind (nick login host) - (values-list (erc-parse-user (erc-response.sender parsed))) + (pcase-let ((`(,nick ,login ,host) + (erc-parse-user (erc-response.sender parsed)))) (setq erc-invitation chnl) (when (string= target (erc-current-nick)) (erc-display-message @@ -1212,8 +1212,8 @@ add things to `%s' instead." nil (let ((chnl (erc-response.contents parsed)) (buffer nil)) - (multiple-value-bind (nick login host) - (values-list (erc-parse-user (erc-response.sender parsed))) + (pcase-let ((`(,nick ,login ,host) + (erc-parse-user (erc-response.sender parsed)))) ;; strip the stupid combined JOIN facility (IRC 2.9) (if (string-match "^\\(.*\\)?\^g.*$" chnl) (setq chnl (match-string 1 chnl))) @@ -1249,12 +1249,12 @@ add things to `%s' instead." (define-erc-response-handler (KICK) "Handle kick messages received from the server." nil - (let* ((ch (first (erc-response.command-args parsed))) - (tgt (second (erc-response.command-args parsed))) + (let* ((ch (nth 0 (erc-response.command-args parsed))) + (tgt (nth 1 (erc-response.command-args parsed))) (reason (erc-trim-string (erc-response.contents parsed))) (buffer (erc-get-buffer ch proc))) - (multiple-value-bind (nick login host) - (values-list (erc-parse-user (erc-response.sender parsed))) + (pcase-let ((`(,nick ,login ,host) + (erc-parse-user (erc-response.sender parsed)))) (erc-remove-channel-member buffer tgt) (cond ((string= tgt (erc-current-nick)) @@ -1277,11 +1277,11 @@ add things to `%s' instead." (define-erc-response-handler (MODE) "Handle server mode changes." nil - (let ((tgt (first (erc-response.command-args parsed))) + (let ((tgt (car (erc-response.command-args parsed))) (mode (mapconcat 'identity (cdr (erc-response.command-args parsed)) " "))) - (multiple-value-bind (nick login host) - (values-list (erc-parse-user (erc-response.sender parsed))) + (pcase-let ((`(,nick ,login ,host) + (erc-parse-user (erc-response.sender parsed)))) (erc-log (format "MODE: %s -> %s: %s" nick tgt mode)) ;; dirty hack (let ((buf (cond ((erc-channel-p tgt) @@ -1305,8 +1305,8 @@ add things to `%s' instead." "Handle nick change messages." nil (let ((nn (erc-response.contents parsed)) bufs) - (multiple-value-bind (nick login host) - (values-list (erc-parse-user (erc-response.sender parsed))) + (pcase-let ((`(,nick ,login ,host) + (erc-parse-user (erc-response.sender parsed)))) (setq bufs (erc-buffer-list-with-nick nick proc)) (erc-log (format "NICK: %s -> %s" nick nn)) ;; if we had a query with this user, make sure future messages will be @@ -1340,11 +1340,11 @@ add things to `%s' instead." (define-erc-response-handler (PART) "Handle part messages." nil - (let* ((chnl (first (erc-response.command-args parsed))) + (let* ((chnl (car (erc-response.command-args parsed))) (reason (erc-trim-string (erc-response.contents parsed))) (buffer (erc-get-buffer chnl proc))) - (multiple-value-bind (nick login host) - (values-list (erc-parse-user (erc-response.sender parsed))) + (pcase-let ((`(,nick ,login ,host) + (erc-parse-user (erc-response.sender parsed)))) (erc-remove-channel-member buffer nick) (erc-display-message parsed 'notice buffer 'PART ?n nick ?u login @@ -1361,7 +1361,7 @@ add things to `%s' instead." (define-erc-response-handler (PING) "Handle ping messages." nil - (let ((pinger (first (erc-response.command-args parsed)))) + (let ((pinger (car (erc-response.command-args parsed)))) (erc-log (format "PING: %s" pinger)) ;; ping response to the server MUST be forced, or you can lose big (erc-server-send (format "PONG :%s" pinger) t) @@ -1379,7 +1379,7 @@ add things to `%s' instead." (when erc-verbose-server-ping (erc-display-message parsed 'notice proc 'PONG - ?h (first (erc-response.command-args parsed)) ?i erc-server-lag + ?h (car (erc-response.command-args parsed)) ?i erc-server-lag ?s (if (/= erc-server-lag 1) "s" ""))) (erc-update-mode-line)))) @@ -1451,8 +1451,8 @@ add things to `%s' instead." "Another user has quit IRC." nil (let ((reason (erc-response.contents parsed)) bufs) - (multiple-value-bind (nick login host) - (values-list (erc-parse-user (erc-response.sender parsed))) + (pcase-let ((`(,nick ,login ,host) + (erc-parse-user (erc-response.sender parsed)))) (setq bufs (erc-buffer-list-with-nick nick proc)) (erc-remove-user nick) (setq reason (erc-wash-quit-reason reason nick login host)) @@ -1462,12 +1462,12 @@ add things to `%s' instead." (define-erc-response-handler (TOPIC) "The channel topic has changed." nil - (let* ((ch (first (erc-response.command-args parsed))) + (let* ((ch (car (erc-response.command-args parsed))) (topic (erc-trim-string (erc-response.contents parsed))) (time (format-time-string erc-server-timestamp-format (current-time)))) - (multiple-value-bind (nick login host) - (values-list (erc-parse-user (erc-response.sender parsed))) + (pcase-let ((`(,nick ,login ,host) + (erc-parse-user (erc-response.sender parsed)))) (erc-update-channel-member ch nick nick nil nil nil host login) (erc-update-channel-topic ch (format "%s\C-o (%s, %s)" topic nick time)) (erc-display-message parsed 'notice (erc-get-buffer ch proc) @@ -1477,8 +1477,8 @@ add things to `%s' instead." (define-erc-response-handler (WALLOPS) "Display a WALLOPS message." nil (let ((message (erc-response.contents parsed))) - (multiple-value-bind (nick login host) - (values-list (erc-parse-user (erc-response.sender parsed))) + (pcase-let ((`(,nick ,login ,host) + (erc-parse-user (erc-response.sender parsed)))) (erc-display-message parsed 'notice nil 'WALLOPS ?n nick ?m message)))) @@ -1486,7 +1486,7 @@ add things to `%s' instead." (define-erc-response-handler (001) "Set `erc-server-current-nick' to reflect server settings and display the welcome message." nil - (erc-set-current-nick (first (erc-response.command-args parsed))) + (erc-set-current-nick (car (erc-response.command-args parsed))) (erc-update-mode-line) ; needed here? (setq erc-nick-change-attempt-count 0) (setq erc-default-nicks (if (consp erc-nick) erc-nick (list erc-nick))) @@ -1507,16 +1507,16 @@ add things to `%s' instead." (define-erc-response-handler (004) "Display the server's identification." nil - (multiple-value-bind (server-name server-version) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,server-name ,server-version) + (cdr (erc-response.command-args parsed)))) (setq erc-server-version server-version) (setq erc-server-announced-name server-name) (erc-update-mode-line-buffer (process-buffer proc)) (erc-display-message parsed 'notice proc 's004 ?s server-name ?v server-version - ?U (fourth (erc-response.command-args parsed)) - ?C (fifth (erc-response.command-args parsed))))) + ?U (nth 3 (erc-response.command-args parsed)) + ?C (nth 4 (erc-response.command-args parsed))))) (define-erc-response-handler (005) "Set the variable `erc-server-parameters' and display the received message. @@ -1547,7 +1547,7 @@ A server may send more than one 005 message." (define-erc-response-handler (221) "Display the current user modes." nil - (let* ((nick (first (erc-response.command-args parsed))) + (let* ((nick (car (erc-response.command-args parsed))) (modes (mapconcat 'identity (cdr (erc-response.command-args parsed)) " "))) (erc-set-modes nick modes) @@ -1576,8 +1576,8 @@ See `erc-display-server-message'." nil (define-erc-response-handler (275) "Display secure connection message." nil - (multiple-value-bind (nick user message) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,nick ,user ,message) + (cdr (erc-response.command-args parsed)))) (erc-display-message parsed 'notice 'active 's275 ?n nick @@ -1612,8 +1612,8 @@ See `erc-display-server-message'." nil (define-erc-response-handler (307) "Display nick-identified message." nil - (multiple-value-bind (nick user message) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,nick ,user ,message) + (cdr (erc-response.command-args parsed)))) (erc-display-message parsed 'notice 'active 's307 ?n nick @@ -1624,8 +1624,8 @@ See `erc-display-server-message'." nil "WHOIS/WHOWAS notices." nil (let ((fname (erc-response.contents parsed)) (catalog-entry (intern (format "s%s" (erc-response.command parsed))))) - (multiple-value-bind (nick user host) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,nick ,user ,host) + (cdr (erc-response.command-args parsed)))) (erc-update-user-nick nick nick host nil fname user) (erc-display-message parsed 'notice 'active catalog-entry @@ -1633,8 +1633,8 @@ See `erc-display-server-message'." nil (define-erc-response-handler (312) "Server name response in WHOIS." nil - (multiple-value-bind (nick server-host) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,nick ,server-host)) + (cdr (erc-response.command-args parsed))) (erc-display-message parsed 'notice 'active 's312 ?n nick ?s server-host ?c (erc-response.contents parsed)))) @@ -1655,8 +1655,8 @@ See `erc-display-server-message'." nil (define-erc-response-handler (317) "IDLE notice." nil - (multiple-value-bind (nick seconds-idle on-since time) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,nick ,seconds-idle ,on-since ,time) + (cdr (erc-response.command-args parsed)))) (setq time (when on-since (format-time-string erc-server-timestamp-format (erc-string-to-emacs-time on-since)))) @@ -1696,16 +1696,16 @@ See `erc-display-server-message'." nil (define-erc-response-handler (322) "LIST notice." nil (let ((topic (erc-response.contents parsed))) - (multiple-value-bind (channel num-users) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,channel ,num-users) + (cdr (erc-response.command-args parsed)))) (add-to-list 'erc-channel-list (list channel)) (erc-update-channel-topic channel topic)))) (defun erc-server-322-message (proc parsed) "Display a message for the 322 event." (let ((topic (erc-response.contents parsed))) - (multiple-value-bind (channel num-users) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,channel ,num-users) + (cdr (erc-response.command-args parsed)))) (erc-display-message parsed 'notice proc 's322 ?c channel ?u num-users ?t (or topic ""))))) @@ -1732,7 +1732,7 @@ See `erc-display-server-message'." nil "Channel creation date." nil (let ((channel (second (erc-response.command-args parsed))) (time (erc-string-to-emacs-time - (third (erc-response.command-args parsed))))) + (nth 2 (erc-response.command-args parsed))))) (erc-display-message parsed 'notice (erc-get-buffer channel proc) 's329 ?c channel ?t (format-time-string erc-server-timestamp-format @@ -1749,7 +1749,7 @@ See `erc-display-server-message'." nil ;; authmsg == (aref parsed 5) ;; The guesses below are, well, just that. -- Lawrence 2004/05/10 (let ((nick (second (erc-response.command-args parsed))) - (authaccount (third (erc-response.command-args parsed))) + (authaccount (nth 2 (erc-response.command-args parsed))) (authmsg (erc-response.contents parsed))) (erc-display-message parsed 'notice 'active 's330 ?n nick ?a authmsg ?i authaccount))) @@ -1771,8 +1771,8 @@ See `erc-display-server-message'." nil (define-erc-response-handler (333) "Who set the topic, and when." nil - (multiple-value-bind (channel nick time) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,channel ,nick ,time) + (cdr (erc-response.command-args parsed)))) (setq time (format-time-string erc-server-timestamp-format (erc-string-to-emacs-time time))) (erc-update-channel-topic channel @@ -1784,15 +1784,15 @@ See `erc-display-server-message'." nil (define-erc-response-handler (341) "Let user know when an INVITE attempt has been sent successfully." nil - (multiple-value-bind (nick channel) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,nick ,channel) + (cdr (erc-response.command-args parsed)))) (erc-display-message parsed 'notice (erc-get-buffer channel proc) 's341 ?n nick ?c channel))) (define-erc-response-handler (352) "WHO notice." nil - (multiple-value-bind (channel user host server nick away-flag) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,channel ,user ,host ,server ,nick ,away-flag) + (cdr (erc-response.command-args parsed)))) (let ((full-name (erc-response.contents parsed)) hopcount) (when (string-match "\\(^[0-9]+ \\)\\(.*\\)$" full-name) @@ -1806,7 +1806,7 @@ See `erc-display-server-message'." nil (define-erc-response-handler (353) "NAMES notice." nil - (let ((channel (third (erc-response.command-args parsed))) + (let ((channel (nth 2 (erc-response.command-args parsed))) (users (erc-response.contents parsed))) (erc-display-message parsed 'notice (or (erc-get-buffer channel proc) 'active) @@ -1821,8 +1821,8 @@ See `erc-display-server-message'." nil (define-erc-response-handler (367) "Channel ban list entries." nil - (multiple-value-bind (channel banmask setter time) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,channel ,banmask ,setter ,time) + (cdr (erc-response.command-args parsed)))) ;; setter and time are not standard (if setter (erc-display-message parsed 'notice 'active 's367-set-by @@ -1845,8 +1845,8 @@ See `erc-display-server-message'." nil ;; FIXME: Yet more magic numbers in original code, I'm guessing this ;; command takes two arguments, and doesn't have any "contents". -- ;; Lawrence 2004/05/10 - (multiple-value-bind (from to) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,from ,to) + (cdr (erc-response.command-args parsed)))) (erc-display-message parsed 'notice 'active 's379 ?c from ?f to))) @@ -1855,7 +1855,7 @@ See `erc-display-server-message'." nil (erc-display-message parsed 'notice 'active 's391 ?s (second (erc-response.command-args parsed)) - ?t (third (erc-response.command-args parsed)))) + ?t (nth 2 (erc-response.command-args parsed)))) (define-erc-response-handler (401) "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 @@ ;;; Code: (require 'erc) -(eval-when-compile (require 'cl)) ;;; Customization: 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 @@ ;;; Code: (require 'erc) -(eval-when-compile - (require 'cl) - (require 'pcomplete)) +(eval-when-compile (require 'pcomplete)) ;;;###autoload (autoload 'erc-dcc-mode "erc-dcc") (define-erc-module dcc nil @@ -277,7 +275,7 @@ Argument IP is the address as a string. The result is also a string." (* (nth 1 ips) 65536.0) (* (nth 2 ips) 256.0) (nth 3 ips)))) - (if (interactive-p) + (if (called-interactively-p 'interactive) (message "%s is %.0f" ip res) (format "%.0f" res))))) @@ -380,8 +378,8 @@ created subprocess, or nil." (with-no-warnings ; obsolete since 23.1 (set-process-filter-multibyte process nil))))) (file-error - (unless (and (string= "Cannot bind server socket" (cadr err)) - (string= "address already in use" (caddr err))) + (unless (and (string= "Cannot bind server socket" (nth 1 err)) + (string= "address already in use" (nth 2 err))) (signal (car err) (cdr err))) (setq port (1+ port)) (unless (< port upper) @@ -434,38 +432,38 @@ where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc." (pcomplete-here (append '("chat" "close" "get" "list") (when (fboundp 'make-network-process) '("send")))) (pcomplete-here - (case (intern (downcase (pcomplete-arg 1))) - (chat (mapcar (lambda (elt) (plist-get elt :nick)) + (pcase (intern (downcase (pcomplete-arg 1))) + (`chat (mapcar (lambda (elt) (plist-get elt :nick)) + (erc-remove-if-not + #'(lambda (elt) + (eq (plist-get elt :type) 'CHAT)) + erc-dcc-list))) + (`close (erc-delete-dups + (mapcar (lambda (elt) (symbol-name (plist-get elt :type))) + erc-dcc-list))) + (`get (mapcar #'erc-dcc-nick (erc-remove-if-not #'(lambda (elt) - (eq (plist-get elt :type) 'CHAT)) + (eq (plist-get elt :type) 'GET)) erc-dcc-list))) - (close (erc-delete-dups - (mapcar (lambda (elt) (symbol-name (plist-get elt :type))) - erc-dcc-list))) - (get (mapcar #'erc-dcc-nick - (erc-remove-if-not - #'(lambda (elt) - (eq (plist-get elt :type) 'GET)) - erc-dcc-list))) - (send (pcomplete-erc-all-nicks)))) + (`send (pcomplete-erc-all-nicks)))) (pcomplete-here - (case (intern (downcase (pcomplete-arg 2))) - (get (mapcar (lambda (elt) (plist-get elt :file)) - (erc-remove-if-not - #'(lambda (elt) - (and (eq (plist-get elt :type) 'GET) - (erc-nick-equal-p (erc-extract-nick - (plist-get elt :nick)) - (pcomplete-arg 1)))) - erc-dcc-list))) - (close (mapcar #'erc-dcc-nick - (erc-remove-if-not - #'(lambda (elt) - (eq (plist-get elt :type) - (intern (upcase (pcomplete-arg 1))))) - erc-dcc-list))) - (send (pcomplete-entries))))) + (pcase (intern (downcase (pcomplete-arg 2))) + (`get (mapcar (lambda (elt) (plist-get elt :file)) + (erc-remove-if-not + #'(lambda (elt) + (and (eq (plist-get elt :type) 'GET) + (erc-nick-equal-p (erc-extract-nick + (plist-get elt :nick)) + (pcomplete-arg 1)))) + erc-dcc-list))) + (`close (mapcar #'erc-dcc-nick + (erc-remove-if-not + #'(lambda (elt) + (eq (plist-get elt :type) + (intern (upcase (pcomplete-arg 1))))) + erc-dcc-list))) + (`send (pcomplete-entries))))) (defun erc-dcc-do-CHAT-command (proc &optional nick) (when nick @@ -1248,7 +1246,7 @@ other client." (defun erc-dcc-no-such-nick (proc parsed) "Detect and handle no-such-nick replies from the IRC server." - (let* ((elt (erc-dcc-member :nick (second (erc-response.command-args parsed)) + (let* ((elt (erc-dcc-member :nick (nth 1 (erc-response.command-args parsed)) :parent proc)) (peer (plist-get elt :peer))) (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 @@ ;;; Code: (require 'erc) -(eval-when-compile (require 'cl)) (defgroup erc-ezbounce nil "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 @@ (require 'erc) (require 'auth-source) -(eval-when-compile (require 'cl)) (defgroup erc-autojoin nil "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 @@ ;;; Code: (require 'erc) -(eval-when-compile - (require 'erc-networks) - (require 'cl)) +(eval-when-compile (require 'erc-networks)) (defgroup erc-log nil "Logging facilities for ERC." @@ -429,7 +427,8 @@ You can save every individual message by putting this function on file t 'nomessage)))) (let ((coding-system-for-write coding-system)) (write-region start end file t 'nomessage)))) - (if (and erc-truncate-buffer-on-save (interactive-p)) + (if (and erc-truncate-buffer-on-save + (called-interactively-p 'interactive)) (progn (let ((inhibit-read-only t)) (erase-buffer)) (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 @@ ;;; Code: (require 'erc) -(eval-when-compile (require 'cl)) ;; Customization: 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 @@ ;;; Code: (require 'erc) -(eval-when-compile (require 'cl)) (defgroup erc-netsplit nil "Netsplit detection tries to automatically figure when a @@ -107,7 +106,7 @@ join from that split has been detected or not.") (dolist (elt erc-netsplit-list) (if (member nick (nthcdr 3 elt)) (progn - (if (not (caddr elt)) + (if (not (nth 2 elt)) (progn (erc-display-message parsed 'notice (process-buffer proc) @@ -149,7 +148,7 @@ join from that split has been detected or not.") ;; element for this netsplit exists already (progn (setcdr (nthcdr 2 ass) (cons nick (nthcdr 3 ass))) - (when (caddr ass) + (when (nth 2 ass) ;; There was already a netjoin for this netsplit, it ;; seems like the old one didn't get finished... (erc-display-message @@ -194,7 +193,7 @@ join from that split has been detected or not.") nil 'notice 'active 'netsplit-wholeft ?s (car elt) ?n (mapconcat 'erc-extract-nick (nthcdr 3 elt) " ") - ?t (if (caddr elt) + ?t (if (nth 2 elt) "(joining)" ""))))) 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 @@ ;;; Code: (require 'erc) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;; Variables @@ -729,10 +729,10 @@ search for a match in `erc-networks-alist'." (or ;; Loop through `erc-networks-alist' looking for a match. (let ((server (or erc-server-announced-name erc-session-server))) - (loop for (name matcher) in erc-networks-alist - when (and matcher - (string-match (concat matcher "\\'") server)) - do (return name))) + (cl-loop for (name matcher) in erc-networks-alist + when (and matcher + (string-match (concat matcher "\\'") server)) + do (cl-return name))) 'Unknown))) (defun erc-network () @@ -789,8 +789,8 @@ As an example: (cond ((numberp p) (push p result)) ((listp p) - (setq result (nconc (loop for i from (cadr p) downto (car p) - collect i) + (setq result (nconc (cl-loop for i from (cadr p) downto (car p) + collect i) result))))) (nreverse result))) 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 @@ (require 'erc) (require 'erc-networks) -(eval-when-compile - (require 'cl) - (require 'pcomplete)) +(eval-when-compile (require 'pcomplete)) ;;;; Customizable variables 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 @@ (require 'erc) (require 'erc-compat) (require 'time-date) -(eval-when-compile (require 'cl)) (defgroup erc-pcomplete nil "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 @@ (require 'erc) (require 'erc-networks) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;; Customization: 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 @@ (require 'erc) (require 'speedbar) (condition-case nil (require 'dframe) (error nil)) -(eval-when-compile (require 'cl)) ;;; Customization: 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 @@ ;; * Add extensibility so that custom functions can track ;; custom modification types. -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'erc) (require 'erc-compat) (require 'erc-match) @@ -484,7 +484,7 @@ START is the minimum length of the name used." ;;; Test: -(assert +(cl-assert (and ;; verify examples from the doc strings (equal (let ((erc-track-shorten-aggressively nil)) @@ -869,7 +869,7 @@ Use `erc-make-mode-line-buffer-name' to create buttons." (setq erc-modified-channels-alist (delete (assq buffer erc-modified-channels-alist) erc-modified-channels-alist)) - (when (interactive-p) + (when (called-interactively-p 'interactive) (erc-modified-channels-display))) (defun erc-track-find-face (faces) @@ -980,7 +980,7 @@ is in `erc-mode'." (add-to-list 'faces cur))) faces)) -(assert +(cl-assert (let ((str "is bold")) (put-text-property 3 (length str) 'face '(bold erc-current-nick-face) @@ -1030,17 +1030,17 @@ relative to `erc-track-switch-direction'" (let ((dir erc-track-switch-direction) offset) (when (< arg 0) - (setq dir (case dir - (oldest 'newest) - (newest 'oldest) - (mostactive 'leastactive) - (leastactive 'mostactive) - (importance 'oldest))) + (setq dir (pcase dir + (`oldest 'newest) + (`newest 'oldest) + (`mostactive 'leastactive) + (`leastactive 'mostactive) + (`importance 'oldest))) (setq arg (- arg))) - (setq offset (case dir - ((oldest leastactive) + (setq offset (pcase dir + ((or `oldest `leastactive) (- (length erc-modified-channels-alist) arg)) - (t (1- arg)))) + (_ (1- arg)))) ;; normalize out of range user input (cond ((>= offset (length erc-modified-channels-alist)) (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 @@ (defconst erc-version-string "Version 5.3" "ERC version. This is used by function `erc-version'.") -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'font-lock) (require 'pp) (require 'thingatpt) @@ -369,7 +369,7 @@ If no server buffer exists, return nil." (with-current-buffer ,buffer ,@body))))) -(defstruct (erc-server-user (:type vector) :named) +(cl-defstruct (erc-server-user (:type vector) :named) ;; User data nickname host login full-name info ;; Buffers @@ -379,7 +379,7 @@ If no server buffer exists, return nil." (buffers nil) ) -(defstruct (erc-channel-user (:type vector) :named) +(cl-defstruct (erc-channel-user (:type vector) :named) op voice ;; Last message time (in the form of the return value of ;; (current-time) @@ -1386,7 +1386,7 @@ If BUFFER is nil, the current buffer is used." t)) (erc-server-send (format "ISON %s" nick)) (while (eq erc-online-p 'unknown) (accept-process-output)) - (if (interactive-p) + (if (called-interactively-p 'interactive) (message "%s is %sonline" (or erc-online-p nick) (if erc-online-p "" "not ")) @@ -2157,11 +2157,11 @@ functions in here get called with the parameters SERVER and NICK." (list :server server :port port :nick nick :password passwd))) ;;;###autoload -(defun* erc (&key (server (erc-compute-server)) - (port (erc-compute-port)) - (nick (erc-compute-nick)) - password - (full-name (erc-compute-full-name))) +(cl-defun erc (&key (server (erc-compute-server)) + (port (erc-compute-port)) + (nick (erc-compute-nick)) + password + (full-name (erc-compute-full-name))) "ERC is a powerful, modular, and extensible IRC client. This function is the main entry point for ERC. @@ -2383,24 +2383,24 @@ If STRING is nil, the function does nothing." (while list (setq elt (car list)) (cond ((integerp elt) ; POSITION - (incf (car list) shift)) + (cl-incf (car list) shift)) ((or (atom elt) ; nil, EXTENT ;; (eq t (car elt)) ; (t . TIME) (markerp (car elt))) ; (MARKER . DISTANCE) nil) ((integerp (car elt)) ; (BEGIN . END) - (incf (car elt) shift) - (incf (cdr elt) shift)) + (cl-incf (car elt) shift) + (cl-incf (cdr elt) shift)) ((stringp (car elt)) ; (TEXT . POSITION) - (incf (cdr elt) (* (if (natnump (cdr elt)) 1 -1) shift))) + (cl-incf (cdr elt) (* (if (natnump (cdr elt)) 1 -1) shift))) ((null (car elt)) ; (nil PROPERTY VALUE BEG . END) (let ((cons (nthcdr 3 elt))) - (incf (car cons) shift) - (incf (cdr cons) shift))) + (cl-incf (car cons) shift) + (cl-incf (cdr cons) shift))) ((and (featurep 'xemacs) (extentp (car elt))) ; (EXTENT START END) - (incf (nth 1 elt) shift) - (incf (nth 2 elt) shift))) + (cl-incf (nth 1 elt) shift) + (cl-incf (nth 2 elt) shift))) (setq list (cdr list)))))) (defvar erc-valid-nick-regexp "[]a-zA-Z^[;\\`_{}|][]^[;\\`_{}|a-zA-Z0-9-]*" @@ -2477,6 +2477,13 @@ purposes." :group 'erc-lurker :type 'boolean) +(defcustom erc-lurker-ignore-chars "`_" + "Characters at the end of a nick to strip for activity tracking purposes. + +See also `erc-lurker-trim-nicks'." + :group 'erc-lurker + :type 'string) + (defun erc-lurker-maybe-trim (nick) "Maybe trim trailing `erc-lurker-ignore-chars' from NICK. @@ -2491,13 +2498,6 @@ non-nil." "" nick) nick)) -(defcustom erc-lurker-ignore-chars "`_" - "Characters at the end of a nick to strip for activity tracking purposes. - -See also `erc-lurker-trim-nicks'." - :group 'erc-lurker - :type 'string) - (defcustom erc-lurker-hide-list nil "List of IRC type messages to hide when sent by lurkers. @@ -2580,7 +2580,8 @@ updates of `erc-lurker-state'." (server (erc-canonicalize-server-name erc-server-announced-name))) (when (equal command "PRIVMSG") - (when (>= (incf erc-lurker-cleanup-count) erc-lurker-cleanup-interval) + (when (>= (cl-incf erc-lurker-cleanup-count) + erc-lurker-cleanup-interval) (setq erc-lurker-cleanup-count 0) (erc-lurker-cleanup)) (unless (gethash server erc-lurker-state) @@ -2605,6 +2606,17 @@ server within `erc-lurker-threshold-time'. See also (time-subtract (current-time) last-PRIVMSG-time)) erc-lurker-threshold-time)))) +(defcustom erc-common-server-suffixes + '(("openprojects.net$" . "OPN") + ("freenode.net$" . "freenode") + ("oftc.net$" . "OFTC")) + "Alist of common server name suffixes. +This variable is used in mode-line display to save screen +real estate. Set it to nil if you want to avoid changing +displayed hostnames." + :group 'erc-mode-line-and-header + :type 'alist) + (defun erc-canonicalize-server-name (server) "Returns the canonical network name for SERVER if any, otherwise `erc-server-announced-name'. SERVER is matched against @@ -3115,37 +3127,37 @@ If SERVER is non-nil, use that, rather than the current server." (add-to-list 'symlist (cons (erc-once-with-server-event 311 `(string= ,nick - (second + (nth 1 (erc-response.command-args parsed)))) 'erc-server-311-functions)) (add-to-list 'symlist (cons (erc-once-with-server-event 312 `(string= ,nick - (second + (nth 1 (erc-response.command-args parsed)))) 'erc-server-312-functions)) (add-to-list 'symlist (cons (erc-once-with-server-event 318 `(string= ,nick - (second + (nth 1 (erc-response.command-args parsed)))) 'erc-server-318-functions)) (add-to-list 'symlist (cons (erc-once-with-server-event 319 `(string= ,nick - (second + (nth 1 (erc-response.command-args parsed)))) 'erc-server-319-functions)) (add-to-list 'symlist (cons (erc-once-with-server-event 320 `(string= ,nick - (second + (nth 1 (erc-response.command-args parsed)))) 'erc-server-320-functions)) (add-to-list 'symlist (cons (erc-once-with-server-event 330 `(string= ,nick - (second + (nth 1 (erc-response.command-args parsed)))) 'erc-server-330-functions)) (add-to-list 'symlist @@ -4328,8 +4340,8 @@ See also: `erc-echo-notice-in-user-buffers', (defun erc-banlist-store (proc parsed) "Record ban entries for a channel." - (multiple-value-bind (channel mask whoset) - (values-list (cdr (erc-response.command-args parsed))) + (pcase-let ((`(,channel ,mask ,whoset) + (cdr (erc-response.command-args parsed)))) ;; Determine to which buffer the message corresponds (let ((buffer (erc-get-buffer channel proc))) (with-current-buffer buffer @@ -4340,7 +4352,7 @@ See also: `erc-echo-notice-in-user-buffers', (defun erc-banlist-finished (proc parsed) "Record that we have received the banlist." - (let* ((channel (second (erc-response.command-args parsed))) + (let* ((channel (nth 1 (erc-response.command-args parsed))) (buffer (erc-get-buffer channel proc))) (with-current-buffer buffer (put 'erc-channel-banlist 'received-from-server t))) @@ -4349,7 +4361,7 @@ See also: `erc-echo-notice-in-user-buffers', (defun erc-banlist-update (proc parsed) "Check MODE commands for bans and update the banlist appropriately." ;; FIXME: Possibly incorrect. -- Lawrence 2004-05-11 - (let* ((tgt (first (erc-response.command-args parsed))) + (let* ((tgt (car (erc-response.command-args parsed))) (mode (erc-response.contents parsed)) (whoset (erc-response.sender parsed)) (buffer (erc-get-buffer tgt proc))) @@ -6000,7 +6012,7 @@ entry of `channel-members'." (if cuser (setq op (erc-channel-user-op cuser) voice (erc-channel-user-voice cuser))) - (if (interactive-p) + (if (called-interactively-p 'interactive) (message "%s is %s@%s%s%s" nick login host (if full-name (format " (%s)" full-name) "") @@ -6088,17 +6100,6 @@ Otherwise, use the `erc-header-line' face." :group 'erc-paranoia :type 'boolean) -(defcustom erc-common-server-suffixes - '(("openprojects.net$" . "OPN") - ("freenode.net$" . "freenode") - ("oftc.net$" . "OFTC")) - "Alist of common server name suffixes. -This variable is used in mode-line display to save screen -real estate. Set it to nil if you want to avoid changing -displayed hostnames." - :group 'erc-mode-line-and-header - :type 'alist) - (defcustom erc-mode-line-away-status-format "(AWAY since %a %b %d %H:%M) " "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." (format "ERC %s (GNU Emacs %s)" erc-version-string emacs-version))) (if here (insert version-string) - (if (interactive-p) + (if (called-interactively-p 'interactive) (message "%s" version-string) version-string)))) @@ -6322,7 +6323,7 @@ If optional argument HERE is non-nil, insert version number at point." ", "))) (if here (insert string) - (if (interactive-p) + (if (called-interactively-p 'interactive) (message "%s" string) string)))) 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." (define-key eshell-command-map [? ] 'pcomplete-expand) (define-key eshell-mode-map [tab] 'eshell-pcomplete) (define-key eshell-mode-map [(control ?i)] 'eshell-pcomplete) + (add-hook 'completion-at-point-functions + #'pcomplete-completions-at-point nil t) ;; jww (1999-10-19): Will this work on anything but X? (if (featurep 'xemacs) (define-key eshell-mode-map [iso-left-tab] 'pcomplete-reverse) @@ -452,9 +454,9 @@ to writing a completion function." (defun eshell-pcomplete () "Eshell wrapper for `pcomplete'." (interactive) - (if eshell-cmpl-ignore-case - (pcomplete-expand-and-complete) ; hack workaround for bug#12838 - (pcomplete))) + (condition-case nil + (pcomplete) + (text-read-only (completion-at-point)))) ; Workaround for bug#12838. (provide 'em-cmpl) 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)." (defalias 'face-background-pixmap 'face-stipple) -;; FIXME all of these -p functions ignore inheritance (cf face-stipple). -;; Ie, a face that inherits from an underlined face but does not -;; specify :underline will return nil. -;; So these functions don't actually tell you anything about how the -;; face will _appear_. So not very useful IMO. -(defun face-underline-p (face &optional frame) +(defun face-underline-p (face &optional frame inherit) "Return non-nil if FACE specifies a non-nil underlining. If the optional argument FRAME is given, report on face FACE in that frame. If FRAME is t, report on the defaults for face FACE (for new frames). -If FRAME is omitted or nil, use the selected frame." - (face-attribute-specified-or (face-attribute face :underline frame) nil)) +If FRAME is omitted or nil, use the selected frame. +Optional argument INHERIT is passed to `face-attribute'." + (face-attribute-specified-or + (face-attribute face :underline frame inherit) nil)) -(defun face-inverse-video-p (face &optional frame) +(defun face-inverse-video-p (face &optional frame inherit) "Return non-nil if FACE specifies a non-nil inverse-video. If the optional argument FRAME is given, report on face FACE in that frame. If FRAME is t, report on the defaults for face FACE (for new frames). -If FRAME is omitted or nil, use the selected frame." - (eq (face-attribute face :inverse-video frame) t)) +If FRAME is omitted or nil, use the selected frame. +Optional argument INHERIT is passed to `face-attribute'." + (eq (face-attribute face :inverse-video frame inherit) t)) -(defun face-bold-p (face &optional frame) +(defun face-bold-p (face &optional frame inherit) "Return non-nil if the font of FACE is bold on FRAME. If the optional argument FRAME is given, report on face FACE in that frame. If FRAME is t, report on the defaults for face FACE (for new frames). If FRAME is omitted or nil, use the selected frame. +Optional argument INHERIT is passed to `face-attribute'. Use `face-attribute' for finer control." - (let ((bold (face-attribute face :weight frame))) + (let ((bold (face-attribute face :weight frame inherit))) (memq bold '(semi-bold bold extra-bold ultra-bold)))) -(defun face-italic-p (face &optional frame) +(defun face-italic-p (face &optional frame inherit) "Return non-nil if the font of FACE is italic on FRAME. If the optional argument FRAME is given, report on face FACE in that frame. If FRAME is t, report on the defaults for face FACE (for new frames). If FRAME is omitted or nil, use the selected frame. +Optional argument INHERIT is passed to `face-attribute'. Use `face-attribute' for finer control." - (let ((italic (face-attribute face :slant frame))) + (let ((italic (face-attribute face :slant frame inherit))) (memq italic '(italic oblique)))) @@ -862,7 +862,7 @@ Use `set-face-attribute' to ``unspecify'' underlining." 'set-face-underline "24.3") -(defun set-face-inverse-video-p (face inverse-video-p &optional frame) +(defun set-face-inverse-video (face inverse-video-p &optional frame) "Specify whether face FACE is in inverse video. INVERSE-VIDEO-P non-nil means FACE displays explicitly in inverse video. INVERSE-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. Use `set-face-attribute' to ``unspecify'' the inverse video attribute." (interactive (let ((list (read-face-and-attribute :inverse-video))) - (list (car list) (eq (car (cdr list)) t)))) + (list (car list) (if (cadr list) t)))) (set-face-attribute face frame :inverse-video inverse-video-p)) +(define-obsolete-function-alias 'set-face-inverse-video-p + 'set-face-inverse-video "24.4") -;; The -p suffix is a hostage to fortune. What if we want to extend -;; this to allow more than boolean options? Exactly this happened -;; to set-face-underline-p. -(defun set-face-bold-p (face bold-p &optional frame) +(defun set-face-bold (face bold-p &optional frame) "Specify whether face FACE is bold. BOLD-P non-nil means FACE should explicitly display bold. BOLD-P nil means FACE should explicitly display non-bold. @@ -887,8 +886,10 @@ Use `set-face-attribute' or `modify-face' for finer control." (make-face-unbold face frame) (make-face-bold face frame))) +(define-obsolete-function-alias 'set-face-bold-p 'set-face-bold "24.4") + -(defun set-face-italic-p (face italic-p &optional frame) +(defun set-face-italic (face italic-p &optional frame) "Specify whether face FACE is italic. ITALIC-P non-nil means FACE should explicitly display italic. ITALIC-P nil means FACE should explicitly display non-italic. @@ -898,6 +899,8 @@ Use `set-face-attribute' or `modify-face' for finer control." (make-face-unitalic face frame) (make-face-italic face frame))) +(define-obsolete-function-alias 'set-face-italic-p 'set-face-italic "24.4") + (defalias 'set-face-background-pixmap 'set-face-stipple) 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." ;; This is a case where .elc makes a lot of sense. (interactive (list (let ((completion-ignored-extensions (remove ".elc" completion-ignored-extensions))) - (read-file-name "Load file: ")))) + (read-file-name "Load file: " nil nil 'lambda)))) (load (expand-file-name file) nil nil t)) (defun locate-file (filename path &optional suffixes predicate) @@ -3433,7 +3433,7 @@ DIR is the name of the directory. CLASS is the name of a variable class (a symbol). MTIME is the recorded modification time of the directory-local variables file associated with this entry. This time is a list -of two integers (the same format as `file-attributes'), and is +of integers (the same format as `file-attributes'), and is used to test whether the cache entry is still valid. Alternatively, MTIME can be nil, which means the entry is always considered 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 @@ (cnewer . (1)) (ctime . (1)) (empty . (0)) + (executable . (0)) (false . (0)) (fstype . (1)) (gid . (1)) @@ -70,37 +71,43 @@ (ilname . (1)) (iname . (1)) (inum . (1)) - (iwholename . (1)) + (ipath . (1)) (iregex . (1)) + (iwholename . (1)) (links . (1)) (lname . (1)) (mmin . (1)) (mtime . (1)) (name . (1)) (newer . (1)) - (nouser . (0)) (nogroup . (0)) + (nouser . (0)) (path . (1)) (perm . (0)) + (readable . (0)) (regex . (1)) - (wholename . (1)) + (samefile . (1)) (size . (1)) (true . (0)) (type . (1)) (uid . (1)) (used . (1)) (user . (1)) + (wholename . (1)) + (writable . (0)) (xtype . (nil)) ;; normal options (always true) + (daystart . (0)) (depth . (0)) (maxdepth . (1)) (mindepth . (1)) (mount . (0)) (noleaf . (0)) - (xdev . (0)) (ignore_readdir_race . (0)) (noignore_readdir_race . (0)) + (regextype . (1)) + (xdev . (0)) ;; actions (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 @@ +2012-11-19 Katsumi Yamaoka <yamaoka@jpl.org> + + * message.el (message-get-reply-headers): + Make sure the reply goes to the author if it is a wide reply. + 2012-11-16 Jan Tatarik <jan.tatarik@gmail.com> * 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 ..." ", ")) mct (message-fetch-field "mail-copies-to") author (or (message-fetch-field "mail-reply-to") - (message-fetch-field "reply-to") - (message-fetch-field "from") - "") + (message-fetch-field "reply-to")) mft (and message-use-mail-followup-to - (message-fetch-field "mail-followup-to")))) + (message-fetch-field "mail-followup-to"))) + ;; Make sure this message goes to the author if this is a wide + ;; reply, since Reply-To address may be a list address a mailing + ;; list server added. + (when (and wide author) + (setq cc (concat author ", " cc))) + (when (or wide (not author)) + (setq author (or (message-fetch-field "from") "")))) ;; Handle special values of Mail-Copies-To. (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 @@ ;;; Code: -(eval-when-compile (require 'cl)) ;; Compatibility code 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." res-uid ;; 3. File gid. res-gid - ;; 4. Last access time, as a list of two integers. First - ;; integer has high-order 16 bits of time, second has low 16 - ;; bits. + ;; 4. Last access time, as a list of integers. Normally this + ;; would be in the same format as `current-time', but the + ;; subseconds part is not currently implemented, and (0 0) + ;; denotes an unknown time. ;; 5. Last modification time, likewise. ;; 6. Last status change time, likewise. '(0 0) '(0 0) '(0 0) ;CCC how to find out? @@ -1980,6 +1981,7 @@ file names." (error "Unknown operation `%s', must be `copy' or `rename'" op)) (let ((t1 (tramp-tramp-file-p filename)) (t2 (tramp-tramp-file-p newname)) + (length (nth 7 (file-attributes (file-truename filename)))) (context (and preserve-selinux-context (apply 'file-selinux-context (list filename)))) pr tm) @@ -2009,8 +2011,9 @@ file names." ok-if-already-exists keep-date preserve-uid-gid)) ;; Try out-of-band operation. - ((tramp-method-out-of-band-p - v1 (nth 7 (file-attributes (file-truename filename)))) + ((and + (tramp-method-out-of-band-p v1 length) + (tramp-method-out-of-band-p v2 length)) (tramp-do-copy-or-rename-file-out-of-band op filename newname keep-date)) @@ -2038,8 +2041,7 @@ file names." ;; If the Tramp file has an out-of-band method, the ;; corresponding copy-program can be invoked. - ((tramp-method-out-of-band-p - v (nth 7 (file-attributes (file-truename filename)))) + ((tramp-method-out-of-band-p v length) (tramp-do-copy-or-rename-file-out-of-band op filename newname keep-date)) 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." ("oct" . 10) ("nov" . 11) ("dec" . 12)) "Alist mapping month names to integers.") +;; FIXME: Shouldn't this also look at any subseconds parts of T1 and T2? ;;;###tramp-autoload (defun tramp-time-less-p (t1 t2) "Say whether time value T1 is less than time value T2." @@ -3776,6 +3777,7 @@ Invokes `password-read' if available, `read-passwd' else." (and (= (car t1) (car t2)) (< (nth 1 t1) (nth 1 t2))))) +;; FIXME: Shouldn't this also look at any subseconds parts of T1 and T2? (defun tramp-time-subtract (t1 t2) "Subtract two time values. Return 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'." . ,(lambda (comps) (sort comps pcomplete-compare-entry-function))) ,@(cdr (completion-file-name-table s p a))) - (let ((completion-ignored-extensions nil)) + (let ((completion-ignored-extensions nil) + (completion-ignore-case pcomplete-ignore-case)) (completion-table-with-predicate #'comint-completion-file-name-table pred 'strict s p a)))))) 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[] = { (defun gamegrid-make-mono-tty-face () (let ((face (make-face 'gamegrid-mono-tty-face))) - (set-face-inverse-video-p face t) + (set-face-inverse-video face t) face)) (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")) (defvar profiler-report-mode-map (let ((map (make-sparse-keymap))) - ;; FIXME: Add menu. (define-key map "n" 'profiler-report-next-entry) (define-key map "p" 'profiler-report-previous-entry) ;; I find it annoying more than helpful to not be able to navigate @@ -424,8 +423,43 @@ RET: expand or collapse")) (define-key map "D" 'profiler-report-descending-sort) (define-key map "=" 'profiler-report-compare-profile) (define-key map (kbd "C-x C-w") 'profiler-report-write-profile) - (define-key map "q" 'quit-window) - map)) + (easy-menu-define profiler-report-menu map "Menu for Profiler Report mode." + '("Profiler" + ["Next Entry" profiler-report-next-entry :active t + :help "Move to next entry"] + ["Previous Entry" profiler-report-previous-entry :active t + :help "Move to previous entry"] + "--" + ["Toggle Entry" profiler-report-toggle-entry + :active (profiler-report-calltree-at-point) + :help "Expand or collapse the current entry"] + ["Find Entry" profiler-report-find-entry + ;; FIXME should deactivate if not on a known function. + :active (profiler-report-calltree-at-point) + :help "Find the definition of the current entry"] + ["Describe Entry" profiler-report-describe-entry + :active (profiler-report-calltree-at-point) + :help "Show the documentation of the current entry"] + "--" + ["Show Calltree" profiler-report-render-calltree + :active profiler-report-reversed + :help "Show calltree view"] + ["Show Reversed Calltree" profiler-report-render-reversed-calltree + :active (not profiler-report-reversed) + :help "Show reversed calltree view"] + ["Sort Ascending" profiler-report-ascending-sort + :active (not (eq profiler-report-order 'ascending)) + :help "Sort calltree view in ascending order"] + ["Sort Descending" profiler-report-descending-sort + :active (not (eq profiler-report-order 'descending)) + :help "Sort calltree view in descending order"] + "--" + ["Compare Profile..." profiler-report-compare-profile :active t + :help "Compare current profile with another"] + ["Write Profile..." profiler-report-write-profile :active t + :help "Write current profile to a file"])) + map) + "Keymap for `profiler-report-mode'.") (defun profiler-report-make-buffer-name (profile) (format "*%s-Profiler-Report %s*" @@ -529,11 +563,15 @@ otherwise collapse." (defun profiler-report-find-entry (&optional event) "Find entry at point." (interactive (list last-nonmenu-event)) - (if event (posn-set-point (event-end event))) - (let ((tree (profiler-report-calltree-at-point))) - (when tree - (let ((entry (profiler-calltree-entry tree))) - (find-function entry))))) + (with-current-buffer + (if event (window-buffer (posn-window (event-start event))) + (current-buffer)) + (and event (setq event (event-end event)) + (posn-set-point event)) + (let ((tree (profiler-report-calltree-at-point))) + (when tree + (let ((entry (profiler-calltree-entry tree))) + (find-function entry)))))) (defun profiler-report-describe-entry () "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 @@ (require 'ansi-color) (require 'comint) +(eval-when-compile (require 'cl-lib)) -(eval-when-compile - (require 'cl) - ;; Avoid compiler warnings - (defvar view-return-to-alist) - (defvar compilation-error-regexp-alist) - (defvar outline-heading-end-regexp)) +;; Avoid compiler warnings +(defvar view-return-to-alist) +(defvar compilation-error-regexp-alist) +(defvar outline-heading-end-regexp) (autoload 'comint-mode "comint") @@ -364,12 +363,24 @@ This variant of `rx' supports common python named REGEXPS." "Return non-nil if point is on TYPE using SYNTAX-PPSS. TYPE can be `comment', `string' or `paren'. It returns the start character address of the specified TYPE." + (declare (compiler-macro + (lambda (form) + (pcase type + (`'comment + `(let ((ppss (or ,syntax-ppss (syntax-ppss)))) + (and (nth 4 ppss) (nth 8 ppss)))) + (`'string + `(let ((ppss (or ,syntax-ppss (syntax-ppss)))) + (and (nth 3 ppss) (nth 8 ppss)))) + (`'paren + `(nth 1 (or ,syntax-ppss (syntax-ppss)))) + (_ form))))) (let ((ppss (or syntax-ppss (syntax-ppss)))) - (case type - (comment (and (nth 4 ppss) (nth 8 ppss))) - (string (and (not (nth 4 ppss)) (nth 8 ppss))) - (paren (nth 1 ppss)) - (t nil)))) + (pcase type + (`comment (and (nth 4 ppss) (nth 8 ppss))) + (`string (and (nth 3 ppss) (nth 8 ppss))) + (`paren (nth 1 ppss)) + (_ nil)))) (defun python-syntax-context-type (&optional syntax-ppss) "Return the context type using SYNTAX-PPSS. @@ -481,8 +492,8 @@ The type returned can be `comment', `string' or `paren'." (when (re-search-forward re limit t) (while (and (python-syntax-context 'paren) (re-search-forward re limit t))) - (if (and (not (python-syntax-context 'paren)) - (not (equal (char-after (point-marker)) ?=))) + (if (not (or (python-syntax-context 'paren) + (equal (char-after (point-marker)) ?=))) t (set-match-data nil))))) (1 font-lock-variable-name-face nil nil)) @@ -516,7 +527,7 @@ is used to limit the scan." (while (and (< i 3) (or (not limit) (< (+ point i) limit)) (eq (char-after (+ point i)) quote-char)) - (incf i)) + (cl-incf i)) i)) (defun python-syntax-stringify () @@ -723,17 +734,17 @@ START is the buffer position where the sexp starts." (save-restriction (widen) (save-excursion - (case context-status - ('no-indent 0) + (pcase context-status + (`no-indent 0) ;; When point is after beginning of block just add one level ;; of indentation relative to the context-start - ('after-beginning-of-block + (`after-beginning-of-block (goto-char context-start) (+ (current-indentation) python-indent-offset)) ;; When after a simple line just use previous line ;; indentation, in the case current line starts with a ;; `python-indent-dedenters' de-indent one level. - ('after-line + (`after-line (- (save-excursion (goto-char context-start) @@ -746,11 +757,11 @@ START is the buffer position where the sexp starts." ;; When inside of a string, do nothing. just use the current ;; indentation. XXX: perhaps it would be a good idea to ;; invoke standard text indentation here - ('inside-string + (`inside-string (goto-char context-start) (current-indentation)) ;; After backslash we have several possibilities. - ('after-backslash + (`after-backslash (cond ;; Check if current line is a dot continuation. For this ;; the current line must start with a dot and previous @@ -816,7 +827,7 @@ START is the buffer position where the sexp starts." (+ (current-indentation) python-indent-offset))))) ;; When inside a paren there's a need to handle nesting ;; correctly - ('inside-paren + (`inside-paren (cond ;; If current line closes the outermost open paren use the ;; current indentation of the context-start line. @@ -2164,11 +2175,11 @@ INPUT." 'default) (t nil))) (completion-code - (case completion-context - (pdb python-shell-completion-pdb-string-code) - (import python-shell-completion-module-string-code) - (default python-shell-completion-string-code) - (t nil))) + (pcase completion-context + (`pdb python-shell-completion-pdb-string-code) + (`import python-shell-completion-module-string-code) + (`default python-shell-completion-string-code) + (_ nil))) (input (if (eq completion-context 'import) (replace-regexp-in-string "^[ \t]+" "" line) @@ -2492,17 +2503,17 @@ JUSTIFY should be used (if applicable) as in `fill-paragraph'." ;; Docstring styles may vary for oneliners and multi-liners. (> (count-matches "\n" str-start-pos str-end-pos) 0)) (delimiters-style - (case python-fill-docstring-style + (pcase python-fill-docstring-style ;; delimiters-style is a cons cell with the form ;; (START-NEWLINES . END-NEWLINES). When any of the sexps ;; is NIL means to not add any newlines for start or end ;; of docstring. See `python-fill-docstring-style' for a ;; graphic idea of each style. - (django (cons 1 1)) - (onetwo (and multi-line-p (cons 1 2))) - (pep-257 (and multi-line-p (cons nil 2))) - (pep-257-nn (and multi-line-p (cons nil 1))) - (symmetric (and multi-line-p (cons 1 1))))) + (`django (cons 1 1)) + (`onetwo (and multi-line-p (cons 1 2))) + (`pep-257 (and multi-line-p (cons nil 2))) + (`pep-257-nn (and multi-line-p (cons nil 1))) + (`symmetric (and multi-line-p (cons 1 1))))) (docstring-p (save-excursion ;; Consider docstrings those strings which ;; start on a line by themselves. @@ -2703,7 +2714,7 @@ The skeleton will be bound to python-skeleton-NAME." (easy-menu-add-item nil '("Python" "Skeletons") `[,(format - "Insert %s" (caddr (split-string (symbol-name skeleton) "-"))) + "Insert %s" (nth 2 (split-string (symbol-name skeleton) "-"))) ,skeleton t])))) ;;; 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 (defvar sql-imenu-generic-expression ;; Items are in reverse order because they are rendered in reverse. - '(("Rules/Defaults" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*\\(rule\\|default\\)\\s-+\\(\\w+\\)" 3) - ("Sequences" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*sequence\\s-+\\(\\w+\\)" 2) - ("Triggers" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*trigger\\s-+\\(\\w+\\)" 2) - ("Functions" "^\\s-*\\(create\\s-+\\(\\w+\\s-+\\)*\\)?function\\s-+\\(\\w+\\)" 3) - ("Procedures" "^\\s-*\\(create\\s-+\\(\\w+\\s-+\\)*\\)?proc\\(edure\\)?\\s-+\\(\\w+\\)" 4) - ("Packages" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*package\\s-+\\(body\\s-+\\)?\\(\\w+\\)" 3) - ("Types" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*type\\s-+\\(body\\s-+\\)?\\(\\w+\\)" 3) - ("Indexes" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*index\\s-+\\(\\w+\\)" 2) - ("Tables/Views" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*\\(table\\|view\\)\\s-+\\(\\w+\\)" 3)) + '(("Rules/Defaults" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*\\(?:rule\\|default\\)\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\s-+\\(\\w+\\)" 1) + ("Sequences" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*sequence\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) + ("Triggers" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*trigger\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) + ("Functions" "^\\s-*\\(?:create\\s-+\\(?:\\w+\\s-+\\)*\\)?function\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) + ("Procedures" "^\\s-*\\(?:create\\s-+\\(?:\\w+\\s-+\\)*\\)?proc\\(?:edure\\)?\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) + ("Packages" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*package\\s-+\\(?:body\\s-+\\)?\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) + ("Types" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*type\\s-+\\(?:body\\s-+\\)?\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) + ("Indexes" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*index\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1) + ("Tables/Views" "^\\s-*create\\s-+\\(?:\\w+\\s-+\\)*\\(?:table\\|view\\)\\s-+\\(?:if\\s-+not\\s-+exists\\s-+\\)?\\(\\w+\\)" 1)) "Define interesting points in the SQL buffer for `imenu'. This is used to set `imenu-generic-expression' when SQL mode is @@ -1339,6 +1339,7 @@ Based on `comint-mode-map'.") "\\(?:\\w+\\s-+\\)*" ;; optional intervening keywords "\\(?:table\\|view\\|\\(?:package\\|type\\)\\(?:\\s-+body\\)?\\|proc\\(?:edure\\)?" "\\|function\\|trigger\\|sequence\\|rule\\|default\\)\\s-+" + "\\(?:if\\s-+not\\s-+exists\\s-+\\)?" ;; IF NOT EXISTS "\\(\\w+\\)") 1 'font-lock-function-name-face)) 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." (defsubst bdf-file-mod-time (filename) "Return modification time of FILENAME. -The value is a list of two integers, the first integer has high-order -16 bits, the second has low 16 bits." +The value is a list of integers in the same format as `current-time'." (nth 5 (file-attributes filename))) (defun bdf-file-newer-than-time (filename mod-time) "Return non-nil if and only if FILENAME is newer than MOD-TIME. -MOD-TIME is a modification time as a list of two integers, the first -integer has high-order 16 bits, the second has low 16 bits." - (let* ((new-mod-time (bdf-file-mod-time filename)) - (new-time (car new-mod-time)) - (time (car mod-time))) - (or (> new-time time) - (and (= new-time time) - (> (nth 1 new-mod-time) (nth 1 mod-time)))))) +MOD-TIME is a modification time as a list of integers in the same +format as `current-time'." + (let ((new-mod-time (bdf-file-mod-time filename))) + (time-less-p mod-time new-mod-time))) (defun bdf-find-file (bdfname) "Return a buffer visiting a bdf file BDFNAME. @@ -178,8 +173,8 @@ FONT-INFO is a list of the following format: (BDFFILE MOD-TIME FONT-BOUNDING-BOX RELATIVE-COMPOSE BASELINE-OFFSET CODE-RANGE MAXLEN OFFSET-VECTOR) -MOD-TIME is last modification time as a list of two integers, the -first integer has high-order 16 bits, the second has low 16 bits. +MOD-TIME is last modification time as a list of integers in the +same format as `current-time'. SIZE is a size of the font on 72 dpi device. This value is got from 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." (unless (and auto-window-vscroll try-vscroll ;; Only vscroll for single line moves (= (abs arg) 1) + ;; Under scroll-conservatively, the display engine + ;; does this better. + (zerop scroll-conservatively) ;; But don't vscroll in a keyboard macro. (not defining-kbd-macro) (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." (make-obsolete 'unfocus-frame "it does nothing." "22.1") (make-obsolete 'make-variable-frame-local "explicitly check for a frame-parameter instead." "22.2") -(make-obsolete 'interactive-p 'called-interactively-p "23.2") -(set-advertised-calling-convention 'called-interactively-p '(kind) "23.1") (set-advertised-calling-convention 'all-completions '(string collection &optional predicate) "23.1") (set-advertised-calling-convention 'unintern '(name obarray) "23.3") @@ -3963,6 +3961,152 @@ The properties used on SYMBOL are `composefunc', `sendfunc', (put symbol 'abortfunc (or abortfunc 'kill-buffer)) (put symbol 'hookvar (or hookvar 'mail-send-hook))) +(defvar called-interactively-p-functions nil + "Special hook called to skip special frames in `called-interactively-p'. +The functions are called with 3 arguments: (I FRAME1 FRAME2), +where FRAME1 is a \"current frame\", FRAME2 is the next frame, +I is the index of the frame after FRAME2. It should return nil +if those frames don't seem special and otherwise, it should return +the number of frames to skip (minus 1).") + +(defmacro internal--called-interactively-p--get-frame (n) + ;; `sym' will hold a global variable, which will be used kind of like C's + ;; "static" variables. + (let ((sym (make-symbol "base-index"))) + `(progn + (defvar ,sym + (let ((i 1)) + (while (not (eq (nth 1 (backtrace-frame i)) + 'called-interactively-p)) + (setq i (1+ i))) + i)) + ;; (unless (eq (nth 1 (backtrace-frame ,sym)) 'called-interactively-p) + ;; (error "called-interactively-p: %s is out-of-sync!" ,sym)) + (backtrace-frame (+ ,sym ,n))))) + +(defun called-interactively-p (&optional kind) + "Return t if the containing function was called by `call-interactively'. +If KIND is `interactive', then only return t if the call was made +interactively by the user, i.e. not in `noninteractive' mode nor +when `executing-kbd-macro'. +If KIND is `any', on the other hand, it will return t for any kind of +interactive call, including being called as the binding of a key or +from a keyboard macro, even in `noninteractive' mode. + +This function is very brittle, it may fail to return the intended result when +the code is debugged, advised, or instrumented in some form. Some macros and +special forms (such as `condition-case') may also sometimes wrap their bodies +in a `lambda', so any call to `called-interactively-p' from those bodies will +indicate whether that lambda (rather than the surrounding function) was called +interactively. + +Instead of using this function, it is cleaner and more reliable to give your +function an extra optional argument whose `interactive' spec specifies +non-nil unconditionally (\"p\" is a good way to do this), or via +\(not (or executing-kbd-macro noninteractive)). + +The only known proper use of `interactive' for KIND is in deciding +whether to display a helpful message, or how to display it. If you're +thinking of using it for any other purpose, it is quite likely that +you're making a mistake. Think: what do you want to do when the +command is called from a keyboard macro?" + (declare (advertised-calling-convention (kind) "23.1")) + (when (not (and (eq kind 'interactive) + (or executing-kbd-macro noninteractive))) + (let* ((i 1) ;; 0 is the called-interactively-p frame. + frame nextframe + (get-next-frame + (lambda () + (setq frame nextframe) + (setq nextframe (internal--called-interactively-p--get-frame i)) + ;; (message "Frame %d = %S" i nextframe) + (setq i (1+ i))))) + (funcall get-next-frame) ;; Get the first frame. + (while + ;; FIXME: The edebug and advice handling should be made modular and + ;; provided directly by edebug.el and nadvice.el. + (progn + ;; frame =(backtrace-frame i-2) + ;; nextframe=(backtrace-frame i-1) + (funcall get-next-frame) + ;; `pcase' would be a fairly good fit here, but it sometimes moves + ;; branches within local functions, which then messes up the + ;; `backtrace-frame' data we get, + (or + ;; Skip special forms (from non-compiled code). + (and frame (null (car frame))) + ;; Skip also `interactive-p' (because we don't want to know if + ;; interactive-p was called interactively but if it's caller was) + ;; and `byte-code' (idem; this appears in subexpressions of things + ;; like condition-case, which are wrapped in a separate bytecode + ;; chunk). + ;; FIXME: For lexical-binding code, this is much worse, + ;; because the frames look like "byte-code -> funcall -> #[...]", + ;; which is not a reliable signature. + (memq (nth 1 frame) '(interactive-p 'byte-code)) + ;; Skip package-specific stack-frames. + (let ((skip (run-hook-with-args-until-success + 'called-interactively-p-functions + i frame nextframe))) + (pcase skip + (`nil nil) + (`0 t) + (_ (setq i (+ i skip -1)) (funcall get-next-frame))))))) + ;; Now `frame' should be "the function from which we were called". + (pcase (cons frame nextframe) + ;; No subr calls `interactive-p', so we can rule that out. + (`((,_ ,(pred (lambda (f) (subrp (indirect-function f)))) . ,_) . ,_) nil) + ;; Somehow, I sometimes got `command-execute' rather than + ;; `call-interactively' on my stacktrace !? + ;;(`(,_ . (t command-execute . ,_)) t) + (`(,_ . (t call-interactively . ,_)) t))))) + +(defun interactive-p () + "Return t if the containing function was run directly by user input. +This means that the function was called with `call-interactively' +\(which includes being called as the binding of a key) +and input is currently coming from the keyboard (not a keyboard macro), +and Emacs is not running in batch mode (`noninteractive' is nil). + +The only known proper use of `interactive-p' is in deciding whether to +display a helpful message, or how to display it. If you're thinking +of using it for any other purpose, it is quite likely that you're +making a mistake. Think: what do you want to do when the command is +called from a keyboard macro or in batch mode? + +To test whether your function was called with `call-interactively', +either (i) add an extra optional argument and give it an `interactive' +spec that specifies non-nil unconditionally (such as \"p\"); or (ii) +use `called-interactively-p'." + (declare (obsolete called-interactively-p "23.2")) + (called-interactively-p 'interactive)) + +(defun function-arity (f &optional num) + "Return the (MIN . MAX) arity of F. +If the maximum arity is infinite, MAX is `many'. +F can be a function or a macro. +If NUM is non-nil, return non-nil iff F can be called with NUM args." + (if (symbolp f) (setq f (indirect-function f))) + (if (eq (car-safe f) 'macro) (setq f (cdr f))) + (let ((res + (if (subrp f) + (let ((x (subr-arity f))) + (if (eq (cdr x) 'unevalled) (cons (car x) 'many))) + (let* ((args (if (consp f) (cadr f) (aref f 0))) + (max (length args)) + (opt (memq '&optional args)) + (rest (memq '&rest args)) + (min (- max (length opt)))) + (if opt + (cons min (if rest 'many (1- max))) + (if rest + (cons (- max (length rest)) 'many) + (cons min max))))))) + (if (not num) + res + (and (>= num (car res)) + (or (eq 'many (cdr res)) (<= num (cdr res))))))) + (defun set-temporary-overlay-map (map &optional keep-pred) "Set MAP as a temporary keymap taking precedence over most other keymaps. Note 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 @@ (declare-function w32-send-sys-command "w32fns.c") (declare-function set-message-beep "w32fns.c") -(declare-function cygwin-convert-path-from-windows "cygw32.c" +(declare-function cygwin-convert-file-name-from-windows "cygw32.c" (path &optional absolute_p)) ;; Conditional on new-fontset so bootstrapping works on non-GUI compiles @@ -108,7 +108,7 @@ (defun w32-handle-dropped-file (window file-name) (let ((f (if (eq system-type 'cygwin) - (cygwin-convert-path-from-windows file-name t) + (cygwin-convert-file-name-from-windows file-name t) (subst-char-in-string ?\\ ?/ file-name))) (coding (or file-name-coding-system 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." "Update cell face according to the current mode." (if (featurep 'xemacs) (set-face-property 'table-cell 'underline table-fixed-width-mode) - (set-face-inverse-video-p 'table-cell table-fixed-width-mode))) + (set-face-inverse-video 'table-cell table-fixed-width-mode))) (table--update-cell-face) 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.") ;; Internal variables used free (defvar uniquify-possibly-resolvable nil) -(defvar uniquify-managed nil +(defvar-local uniquify-managed nil "Non-nil if the name of this buffer is managed by uniquify. It actually holds the list of `uniquify-item's corresponding to the conflict.") -(make-variable-buffer-local 'uniquify-managed) (put 'uniquify-managed 'permanent-local t) ;; Used in desktop.el to save the non-uniquified buffer name @@ -464,27 +463,34 @@ For use on `kill-buffer-hook'." ;; rename-buffer and create-file-buffer. (Setting find-file-hook isn't ;; sufficient.) -(defadvice rename-buffer (after rename-buffer-uniquify activate) +(advice-add 'rename-buffer :around #'uniquify--rename-buffer-advice) +(defun uniquify--rename-buffer-advice (rb-fun newname &optional unique &rest args) "Uniquify buffer names with parts of directory name." + (let ((retval (apply rb-fun newname unique args))) (uniquify-maybe-rerationalize-w/o-cb) - (if (null (ad-get-arg 1)) ; no UNIQUE argument. + (if (null unique) ;; Mark this buffer so it won't be renamed by uniquify. (setq uniquify-managed nil) (when uniquify-buffer-name-style ;; Rerationalize w.r.t the new name. (uniquify-rationalize-file-buffer-names - (ad-get-arg 0) + newname (uniquify-buffer-file-name (current-buffer)) (current-buffer)) - (setq ad-return-value (buffer-name (current-buffer)))))) + (setq retval (buffer-name (current-buffer))))) + retval)) -(defadvice create-file-buffer (after create-file-buffer-uniquify activate) + +(advice-add 'create-file-buffer :around #'uniquify--create-file-buffer-advice) +(defun uniquify--create-file-buffer-advice (cfb-fun filename &rest args) "Uniquify buffer names with parts of directory name." + (let ((retval (apply cfb-fun filename args))) (if uniquify-buffer-name-style - (let ((filename (expand-file-name (directory-file-name (ad-get-arg 0))))) + (let ((filename (expand-file-name (directory-file-name filename)))) (uniquify-rationalize-file-buffer-names (file-name-nondirectory filename) - (file-name-directory filename) ad-return-value)))) + (file-name-directory filename) retval))) + retval)) ;;; The End @@ -496,9 +502,8 @@ For use on `kill-buffer-hook'." (set-buffer buf) (when uniquify-managed (push (cons buf (uniquify-item-base (car uniquify-managed))) buffers))) - (dolist (fun '(rename-buffer create-file-buffer)) - (ad-remove-advice fun 'after (intern (concat (symbol-name fun) "-uniquify"))) - (ad-update fun)) + (advice-remove 'rename-buffer #'uniquify--rename-buffer-advice) + (advice-remove 'create-file-buffer #'uniquify--create-file-buffer-advice) (dolist (buf buffers) (set-buffer (car buf)) (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." (easy-mmode-define-navigation diff-hunk diff-hunk-header-re "hunk" diff-end-of-hunk diff-restrict-view (when diff-auto-refine-mode - (setq diff--auto-refine-data (cons (current-buffer) (point-marker))) - (run-at-time 0.0 nil - (lambda () - (when diff--auto-refine-data - (let ((buffer (car diff--auto-refine-data)) - (point (cdr diff--auto-refine-data))) - (setq diff--auto-refine-data nil) - (with-local-quit - (when (buffer-live-p buffer) - (with-current-buffer buffer - (save-excursion - (goto-char point) - (diff-refine-hunk))))))))))) + (unless (prog1 diff--auto-refine-data + (setq diff--auto-refine-data + (cons (current-buffer) (point-marker)))) + (run-at-time 0.0 nil + (lambda () + (when diff--auto-refine-data + (let ((buffer (car diff--auto-refine-data)) + (point (cdr diff--auto-refine-data))) + (setq diff--auto-refine-data nil) + (with-local-quit + (when (buffer-live-p buffer) + (with-current-buffer buffer + (save-excursion + (goto-char point) + (diff-refine-hunk)))))))))))) (easy-mmode-define-navigation 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 :version "24.3") (defun switch-to-buffer (buffer-or-name &optional norecord force-same-window) - "Switch to buffer BUFFER-OR-NAME in the selected window. + "Display buffer BUFFER-OR-NAME in the selected window. + +WARNING: This is NOT the way to work on another buffer temporarily +within a Lisp program! Use `set-buffer' instead. That avoids +messing with the window-buffer correspondences. + If the selected window cannot display the specified buffer (e.g. if it is a minibuffer window or strongly dedicated to 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 @@ +2012-11-23 Eli Zaretskii <eliz@gnu.org> + + * gmake.defs (SWITCHCHAR): Define to // under MSYS, / otherwise. + (Bug#12955) + + * nmake.defs (SWITCHCHAR): Define to /. + +2012-11-23 Paul Eggert <eggert@cs.ucla.edu> + + Assume POSIX 1003.1-1988 or later for dirent.h (Bug#12958). + * inc/dirent.h: Rename from ../src/ndir.h, with these changes: + (struct dirent): Rename from struct direct. All uses changed. + * inc/sys/dir.h: Remove. + +2012-11-21 Paul Eggert <eggert@cs.ucla.edu> + + Assume POSIX 1003.1-1988 or later for unistd.h (Bug#12945). + * config.nt (HAVE_GETCWD): Remove. + +2012-11-21 Eli Zaretskii <eliz@gnu.org> + + * nmake.defs: Use !if, not !ifdef. For the details, see + http://lists.gnu.org/archive/html/help-emacs-windows/2012-11/msg00027.html + + * inc/stdint.h (INTPTR_MIN): + (PTRDIFF_MIN) [!__GNUC__]: Define for MSVC. + +2012-11-18 Eli Zaretskii <eliz@gnu.org> + + * inc/unistd.h: Don't include fcntl.h and don't define O_RDWR. + 2012-11-17 Juanma Barranquero <lekktu@gmail.com> * 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/>. */ /* Define to 1 if you have the `getaddrinfo' function. */ #undef HAVE_GETADDRINFO -/* Define to 1 if you have the `getcwd' function. - If you think about defining HAVE_GETCWD, don't: the alternative - getwd is redefined on w32.c, and does not really return the current - directory, to get the desired results elsewhere in Emacs. */ -#undef HAVE_GETCWD - /* Define to 1 if you have the `getdelim' function. */ #undef HAVE_GETDELIM 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) ifeq "$(findstring ECHO, $(sh_output))" "ECHO" THE_SHELL = $(COMSPEC)$(ComSpec) SHELLTYPE=CMD +SWITCHCHAR=/ else USING_SH = 1 THE_SHELL = $(SHELL) SHELLTYPE=SH +# MSYS needs to double the slash in cmd-style switches to avoid +# interpreting /x as a Posix style file name reference +ifneq ($(MSYSTEM),) +SWITCHCHAR=// +else +SWITCHCHAR=/ +endif endif MAKETYPE=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 @@ /* - <dir.h> -- definitions for 4.2BSD-compatible directory access - - last edit: 09-Jul-1983 D A Gwyn + <dirent.h> -- definitions for POSIX-compatible directory access * The code here is forced by the interface, and is not subject to * copyright, constituting the only possible expression of the @@ -16,7 +14,7 @@ #endif /* not WINDOWSNT */ /* NOTE: MAXNAMLEN must be one less than a multiple of 4 */ -struct direct /* data from readdir() */ +struct dirent /* data from readdir() */ { long d_ino; /* inode number of entry */ unsigned short d_reclen; /* length of this record */ @@ -33,9 +31,8 @@ typedef struct } DIR; /* stream data from opendir() */ extern DIR *opendir (char *); -extern struct direct *readdir (DIR *); +extern struct dirent *readdir (DIR *); extern void seekdir (DIR *, long); extern void closedir (DIR *); #define rewinddir( dirp ) seekdir( dirp, 0L ) - 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; #define INT64_MAX 9223372036854775807i64 #define INT64_MIN (~INT64_MAX) #define INTPTR_MAX INT64_MAX +#define INTPTR_MIN INT64_MIN #define UINTMAX_MAX UINT64_MAX #define UINTMAX_MIN UINT64_MIN #define INTMAX_MAX INT64_MAX @@ -51,6 +52,7 @@ typedef unsigned int uint32_t; #define INT32_MAX 2147483647 #define INT32_MIN (~INT32_MAX) #define INTPTR_MAX INT32_MAX +#define INTPTR_MIN INT32_MIN #define UINTMAX_MAX UINT32_MAX #define UINTMAX_MIN UINT32_MIN #define INTMAX_MAX INT32_MAX @@ -60,6 +62,7 @@ typedef unsigned int uint32_t; #endif #define PTRDIFF_MAX INTPTR_MAX +#define PTRDIFF_MIN INTPTR_MIN #endif /* !__GNUC__ */ 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 @@ -/* - * map sys\dir.h to ..\..\..\src\ndir.h - */ - -#include "..\..\..\src\ndir.h" - 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); #define AT_EACCESS 4 #define AT_SYMLINK_NOFOLLOW 4096 -/* Here are some more fcntl.h macros that default to gnulib-compatible - values. Include <fcntl.h> first, to make sure we don't override - its values if any. FIXME: If we know <fcntl.h> does not define - O_NOCTTY and O_RDWR, this can be replaced with a simple "#define - O_NOCTTY 0" and "#define O_RDWR 2". */ -#include <fcntl.h> -#ifndef O_NOCTTY #define O_NOCTTY 0 -#endif -#ifndef O_RDWR -#define O_RDWR 2 -#endif #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: THE_SHELL = $(COMSPEC)
SHELLTYPE=CMD
+SWITCHCHAR=/
MAKETYPE=nmake
@@ -116,7 +117,7 @@ RC_INCLUDE = -i USE_CRT_DLL = 1
-!ifdef USE_CRT_DLL
+!if USE_CRT_DLL
libc = msvcrt$(D).lib
EMACS_EXTRA_C_FLAGS= -D_DLL -D_MT -DUSE_CRT_DLL=1
!else
diff --git a/src/ChangeLog b/src/ChangeLog index 6dcddea2e63..c230b4bef24 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -8,6 +8,140 @@ * font.c (font_unparse_xlfd): Exclude special characters from the generating XLFD name. +2012-11-23 Eli Zaretskii <eliz@gnu.org> + + * makefile.w32-in (globals.h, gl-stamp): Use $(SWITCHCHAR) instead + of a literal "/". (Bug#12955) + (gl-stamp): Invoke fc.exe directly, not through cmd. + +2012-11-23 Paul Eggert <eggert@cs.ucla.edu> + + Assume POSIX 1003.1-1988 or later for dirent.h (Bug#12958). + * dired.c: Assume HAVE_DIRENT_H. + (NAMLEN): Remove, replacing with ... + (dirent_namelen): New function. All uses changed. Use the GNU macro + _D_EXACT_NAMELEN if available, as it's faster than strlen. + (DIRENTRY): Remove, replacing all uses with 'struct dirent'. + (DIRENTRY_NONEMPTY): Remove. All callers now assume it's nonzero. + * makefile.w32-in (DIR_H): Remove. All uses replaced with + $(NT_INC)/dirent.h. + ($(BLD)/w32.$(O)): Do not depend on $(SRC)/ndir.h. + * ndir.h: Rename to ../nt/inc/dirent.h. + * sysdep.h (closedir) [!HAVE_CLOSEDIR]: Remove. + Do not include <dirent.h>; no longer needed. + * w32.c: Include <dirent.h> rather than "ndir.h". + +2012-11-23 Chong Yidong <cyd@gnu.org> + + * xftfont.c (xftfont_open): Remove duplicate assignment. + +2012-11-22 Dmitry Antipov <dmantipov@yandex.ru> + + * alloc.c (Fgarbage_collect): Unblock input after clearing + gc_in_progress to avoid note_mouse_highlight glitch with GC. + * frame.h (FRAME_MOUSE_UPDATE): New macro. + * msdos.c (IT_frame_up_to_date): Use it here... + * w32term.c (w32_frame_up_to_date): ...here... + * xterm.c (XTframe_up_to_date): ...and here... + * nsterm.m (ns_frame_up_to_date): ...but not here. + * lisp.h (Mouse_HLInfo): Remove mouse_face_deferred_gc member. + Adjust users. + * xdisp.c (message2_nolog, message3_nolog, note_mouse_highlight): + Do not check whether GC is in progress. + +2012-11-22 Dmitry Antipov <dmantipov@yandex.ru> + + * xdisp.c (window_buffer_changed): New function. + (update_menu_bar, update_tool_bar): Use it to + simplify large 'if' statements. + (redisplay_internal): Generalize commonly used + 'tail' and 'frame' local variables. + +2012-11-22 Eli Zaretskii <eliz@gnu.org> + + * w32.c (getcwd): Fix the 2nd argument type, to prevent conflicts + with Windows system header. + +2012-11-21 Paul Eggert <eggert@cs.ucla.edu> + + Assume POSIX 1003.1-1988 or later for unistd.h (Bug#12945). + * alloc.c: Assume unistd.h exists. + * fileio.c (Fexpand_file_name) [DOS_NT]: Use getcwd, not getwd. + * sysdep.c (get_current_dir_name): Assume getcwd exists. + (getwd) [USG]: Remove; no longer needed. + (sys_subshell) [DOS_NT]: Use getcwd, not getwd. + * w32.c (getcwd): Rename from getwd, and switch to getcwd's API. + * w32.h (getcwd): Remove decl. + +2012-11-21 Stefan Monnier <monnier@iro.umontreal.ca> + + * xdisp.c (fast_set_selected_frame): Rename from update_tool_bar_unwind. + Make it set selected_window as well. + (update_tool_bar): Use it. + +2012-11-21 Ken Brown <kbrown@cornell.edu> + + * emacs.c (main): Set the G_SLICE environment variable for all + Cygwin builds, not just GTK builds. See + https://lists.gnu.org/archive/html/emacs-devel/2012-11/msg00368.html. + +2012-11-21 Eli Zaretskii <eliz@gnu.org> + + * w32.c (FILE_DEVICE_FILE_SYSTEM, METHOD_BUFFERED) + (FILE_ANY_ACCESS, CTL_CODE, FSCTL_GET_REPARSE_POINT) [_MSC_VER]: + Define for the MSVC compiler. + + * w32term.h (EnumSystemLocalesW) [_MSC_VER]: Add a missing semi-colon. + + * fileio.c (Fsubstitute_in_file_name, Ffile_name_directory) + (Fexpand_file_name) [DOS_NT]: Pass encoded file name to + dostounix_filename. Prevents crashes down the road, because + dostounix_filename assumes it gets a unibyte string. Reported by + Michel de Ruiter <michel@sentient.nl>, see + http://lists.gnu.org/archive/html/help-emacs-windows/2012-11/msg00017.html + +2012-11-20 Stefan Monnier <monnier@iro.umontreal.ca> + + Conflate Qnil and Qunbound for `symbol-function'. + * alloc.c (Fmake_symbol): Initialize `function' to Qnil. + * lread.c (init_obarray): Set `function' fields to Qnil. + * eval.c (Fcommandp): Ignore Qunbound. + (Fautoload, eval_sub, Fapply, Ffuncall, Fmacroexpand): + * data.c (Ffset, Ffboundp, indirect_function, Findirect_function): + Test NILP rather than Qunbound. + (Ffmakunbound): Set to Qnil. + (Fsymbol_function): Never signal an error. + (Finteractive_form): Ignore Qunbound. + +2012-11-20 Paul Eggert <eggert@cs.ucla.edu> + + * eval.c (interactive_p): Remove no-longer-used decl. + +2012-11-20 Dmitry Antipov <dmantipov@yandex.ru> + + * xdisp.c (buffer_shared): Adjust comment. + (buffer_shared_and_changed): New function. + (prepare_menu_bars, redisplay_internal): Use it to + decide whether all windows or frames should be updated. + (window_outdated): New function. + (text_outside_line_unchanged_p, redisplay_window): Use it. + (redisplay_internal): Likewise. Fix indentation. + +2012-11-20 Stefan Monnier <monnier@iro.umontreal.ca> + + * eval.c (Finteractive_p, Fcalled_interactively_p, interactive_p): Remove. + (syms_of_eval): Remove corresponding defsubr. + * bytecode.c (exec_byte_code): `interactive-p' is now a Lisp function. + +2012-11-19 Daniel Colascione <dancol@dancol.org> + + * w32fns.c (Fx_file_dialog): + (Fx_file_dialog): Accomodate rename of cygwin_convert_path* to + cygwin_convert_file_name*. + + * cygw32.c (Fcygwin_convert_path_to_windows, syms_of_cygw32): + Rename cygwin_convert_path* to cygwin_convert_file_name*. + 2012-11-18 Paul Eggert <eggert@cs.ucla.edu> * nsterm.m (ns_select): Send SIGIO only to self, not to process group. @@ -18,10 +152,10 @@ windows.h gets included before w32term.h uses some of its features, see below. - * w32term.h (LOCALE_ENUMPROCA, LOCALE_ENUMPROCW) [_MSC_VER]: New - typedefs. - (EnumSystemLocalesA, EnumSystemLocalesW) [_MSC_VER]: New - prototypes. + * w32term.h (LOCALE_ENUMPROCA, LOCALE_ENUMPROCW) [_MSC_VER]: + New typedefs. + (EnumSystemLocalesA, EnumSystemLocalesW) [_MSC_VER]: + New prototypes. (EnumSystemLocales) [_MSC_VER]: Define if undefined. (Bug#12878) 2012-11-18 Jan Djärv <jan.h.d@swipnet.se> @@ -313,8 +447,8 @@ * xdisp.c (try_scrolling): Fix correction of aggressive-scroll amount when the scroll margins are too large. When scrolling backwards in the buffer, give up if cannot reach point or the - scroll margin within a reasonable number of screen lines. Fixes - point position in window under scroll-up/down-aggressively when + scroll margin within a reasonable number of screen lines. + Fixes point position in window under scroll-up/down-aggressively when point is positioned many lines beyond the window top/bottom. (Bug#12811) 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/>. */ #endif #include <unistd.h> -#ifndef HAVE_UNISTD_H -extern void *sbrk (); -#endif - #include <fcntl.h> #ifdef USE_GTK @@ -3212,7 +3208,7 @@ static struct Lisp_Symbol *symbol_free_list; DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0, doc: /* Return a newly allocated uninterned symbol whose name is NAME. -Its value and function definition are void, and its property list is nil. */) +Its value is void, and its function definition and property list are nil. */) (Lisp_Object name) { register Lisp_Object val; @@ -3249,7 +3245,7 @@ Its value and function definition are void, and its property list is nil. */) set_symbol_plist (val, Qnil); p->redirect = SYMBOL_PLAINVAL; SET_SYMBOL_VAL (p, Qunbound); - set_symbol_function (val, Qunbound); + set_symbol_function (val, Qnil); set_symbol_next (val, NULL); p->gcmarkbit = 0; p->interned = SYMBOL_UNINTERNED; @@ -5335,12 +5331,12 @@ See Info node `(elisp)Garbage Collection'. */) dump_zombies (); #endif - unblock_input (); - check_cons_list (); gc_in_progress = 0; + unblock_input (); + consing_since_gc = 0; if (gc_cons_threshold < GC_DEFAULT_THRESHOLD / 10) 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, NEXT; CASE (Binteractive_p): /* Obsolete since 24.1. */ - PUSH (Finteractive_p ()); + BEFORE_POTENTIAL_GC (); + PUSH (call0 (intern ("interactive-p"))); + AFTER_POTENTIAL_GC (); NEXT; 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) return unbind_to (count, DECODE_FILE (converted)); } -DEFUN ("cygwin-convert-path-to-windows", - Fcygwin_convert_path_to_windows, Scygwin_convert_path_to_windows, +DEFUN ("cygwin-convert-file-name-to-windows", + Fcygwin_convert_file_name_to_windows, + Scygwin_convert_file_name_to_windows, 1, 2, 0, - doc: /* Convert PATH to a Windows path. If ABSOLUTE-P if - non-nil, return an absolute path.*/) + doc: /* Convert PATH to a Windows path. If ABSOLUTE-P is +non-nil, return an absolute path.*/) (Lisp_Object path, Lisp_Object absolute_p) { return from_unicode ( conv_filename_to_w32_unicode (path, EQ (absolute_p, Qnil) ? 0 : 1)); } -DEFUN ("cygwin-convert-path-from-windows", - Fcygwin_convert_path_from_windows, Scygwin_convert_path_from_windows, +DEFUN ("cygwin-convert-file-name-from-windows", + Fcygwin_convert_file_name_from_windows, + Scygwin_convert_file_name_from_windows, 1, 2, 0, doc: /* Convert a Windows path to a Cygwin path. If ABSOLUTE-P - if non-nil, return an absolute path.*/) +is non-nil, return an absolute path.*/) (Lisp_Object path, Lisp_Object absolute_p) { return conv_filename_from_w32_unicode (to_unicode (path, &path), @@ -131,6 +133,6 @@ DEFUN ("cygwin-convert-path-from-windows", void syms_of_cygw32 (void) { - defsubr (&Scygwin_convert_path_from_windows); - defsubr (&Scygwin_convert_path_to_windows); + defsubr (&Scygwin_convert_file_name_from_windows); + defsubr (&Scygwin_convert_file_name_to_windows); } 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, return (EQ (valcontents, Qunbound) ? Qnil : Qt); } +/* FIXME: Make it an alias for function-symbol! */ DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0, doc: /* Return t if SYMBOL's function definition is not void. */) (register Lisp_Object symbol) { CHECK_SYMBOL (symbol); - return EQ (XSYMBOL (symbol)->function, Qunbound) ? Qnil : Qt; + return NILP (XSYMBOL (symbol)->function) ? Qnil : Qt; } DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0, @@ -564,14 +565,14 @@ Return SYMBOL. */) } DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0, - doc: /* Make SYMBOL's function definition be void. + doc: /* Make SYMBOL's function definition be nil. Return SYMBOL. */) (register Lisp_Object symbol) { CHECK_SYMBOL (symbol); if (NILP (symbol) || EQ (symbol, Qt)) xsignal1 (Qsetting_constant, symbol); - set_symbol_function (symbol, Qunbound); + set_symbol_function (symbol, Qnil); return symbol; } @@ -580,9 +581,7 @@ DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0, (register Lisp_Object symbol) { CHECK_SYMBOL (symbol); - if (!EQ (XSYMBOL (symbol)->function, Qunbound)) return XSYMBOL (symbol)->function; - xsignal1 (Qvoid_function, symbol); } DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0, @@ -613,7 +612,7 @@ DEFUN ("fset", Ffset, Sfset, 2, 2, 0, function = XSYMBOL (symbol)->function; - if (!NILP (Vautoload_queue) && !EQ (function, Qunbound)) + if (!NILP (Vautoload_queue) && !NILP (function)) Vautoload_queue = Fcons (Fcons (symbol, function), Vautoload_queue); if (AUTOLOADP (function)) @@ -714,7 +713,7 @@ Value, if non-nil, is a list \(interactive SPEC). */) { Lisp_Object fun = indirect_function (cmd); /* Check cycles. */ - if (NILP (fun) || EQ (fun, Qunbound)) + if (NILP (fun)) return Qnil; /* Use an `interactive-form' property if present, analogous to the @@ -2008,10 +2007,10 @@ indirect_function (register Lisp_Object object) for (;;) { - if (!SYMBOLP (hare) || EQ (hare, Qunbound)) + if (!SYMBOLP (hare) || NILP (hare)) break; hare = XSYMBOL (hare)->function; - if (!SYMBOLP (hare) || EQ (hare, Qunbound)) + if (!SYMBOLP (hare) || NILP (hare)) break; hare = XSYMBOL (hare)->function; @@ -2038,10 +2037,10 @@ function chain of symbols. */) /* Optimize for no indirection. */ result = object; - if (SYMBOLP (result) && !EQ (result, Qunbound) + if (SYMBOLP (result) && !NILP (result) && (result = XSYMBOL (result)->function, SYMBOLP (result))) result = indirect_function (result); - if (!EQ (result, Qunbound)) + if (!NILP (result)) return result; 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/>. */ #include <errno.h> #include <unistd.h> -/* The d_nameln member of a struct dirent includes the '\0' character - on some systems, but not on others. What's worse, you can't tell - at compile-time which one it will be, since it really depends on - the sort of system providing the filesystem you're reading from, - not the system you are running on. Paul Eggert - <eggert@bi.twinsun.com> says this occurs when Emacs is running on a - SunOS 4.1.2 host, reading a directory that is remote-mounted from a - Solaris 2.1 host and is in a native Solaris 2.1 filesystem. - - Since applying strlen to the name always works, we'll just do that. */ -#define NAMLEN(p) strlen (p->d_name) - -#ifdef HAVE_DIRENT_H - #include <dirent.h> -#define DIRENTRY struct dirent - -#else /* not HAVE_DIRENT_H */ - -#include <sys/dir.h> -#include <sys/stat.h> - -#define DIRENTRY struct direct - -extern DIR *opendir (char *); -extern struct direct *readdir (DIR *); - -#endif /* HAVE_DIRENT_H */ - #include <filemode.h> #include <stat-time.h> -#ifdef MSDOS -#define DIRENTRY_NONEMPTY(p) ((p)->d_name[0] != 0) -#else -#define DIRENTRY_NONEMPTY(p) ((p)->d_ino) -#endif - #include "lisp.h" #include "systime.h" #include "character.h" @@ -88,6 +54,17 @@ static Lisp_Object Qfile_attributes_lessp; static ptrdiff_t scmp (const char *, const char *, ptrdiff_t); +/* Return the number of bytes in DP's name. */ +static ptrdiff_t +dirent_namelen (struct dirent *dp) +{ +#ifdef _D_EXACT_NAMLEN + return _D_EXACT_NAMLEN (dp); +#else + return strlen (dp->d_name); +#endif +} + #ifdef WINDOWSNT Lisp_Object directory_files_internal_w32_unwind (Lisp_Object arg) @@ -124,7 +101,7 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full, bool needsep = 0; ptrdiff_t count = SPECPDL_INDEX (); struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; - DIRENTRY *dp; + struct dirent *dp; #ifdef WINDOWSNT Lisp_Object w32_save = Qnil; #endif @@ -209,6 +186,11 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full, /* Loop reading blocks until EOF or error. */ for (;;) { + ptrdiff_t len; + bool wanted = 0; + Lisp_Object name, finalname; + struct gcpro gcpro1, gcpro2; + errno = 0; dp = readdir (d); @@ -225,89 +207,81 @@ directory_files_internal (Lisp_Object directory, Lisp_Object full, if (dp == NULL) break; - if (DIRENTRY_NONEMPTY (dp)) - { - ptrdiff_t len; - bool wanted = 0; - Lisp_Object name, finalname; - struct gcpro gcpro1, gcpro2; - - len = NAMLEN (dp); - name = finalname = make_unibyte_string (dp->d_name, len); - GCPRO2 (finalname, name); + len = dirent_namelen (dp); + name = finalname = make_unibyte_string (dp->d_name, len); + GCPRO2 (finalname, name); - /* Note: DECODE_FILE can GC; it should protect its argument, - though. */ - name = DECODE_FILE (name); - len = SBYTES (name); + /* Note: DECODE_FILE can GC; it should protect its argument, + though. */ + name = DECODE_FILE (name); + len = SBYTES (name); - /* Now that we have unwind_protect in place, we might as well - allow matching to be interrupted. */ - immediate_quit = 1; - QUIT; + /* Now that we have unwind_protect in place, we might as well + allow matching to be interrupted. */ + immediate_quit = 1; + QUIT; - if (NILP (match) - || (0 <= re_search (bufp, SSDATA (name), len, 0, len, 0))) - wanted = 1; + if (NILP (match) + || (0 <= re_search (bufp, SSDATA (name), len, 0, len, 0))) + wanted = 1; - immediate_quit = 0; + immediate_quit = 0; - if (wanted) + if (wanted) + { + if (!NILP (full)) { - if (!NILP (full)) - { - Lisp_Object fullname; - ptrdiff_t nbytes = len + directory_nbytes + needsep; - ptrdiff_t nchars; + Lisp_Object fullname; + ptrdiff_t nbytes = len + directory_nbytes + needsep; + ptrdiff_t nchars; - fullname = make_uninit_multibyte_string (nbytes, nbytes); - memcpy (SDATA (fullname), SDATA (directory), - directory_nbytes); + fullname = make_uninit_multibyte_string (nbytes, nbytes); + memcpy (SDATA (fullname), SDATA (directory), + directory_nbytes); - if (needsep) - SSET (fullname, directory_nbytes, DIRECTORY_SEP); + if (needsep) + SSET (fullname, directory_nbytes, DIRECTORY_SEP); - memcpy (SDATA (fullname) + directory_nbytes + needsep, - SDATA (name), len); + memcpy (SDATA (fullname) + directory_nbytes + needsep, + SDATA (name), len); - nchars = chars_in_text (SDATA (fullname), nbytes); + nchars = chars_in_text (SDATA (fullname), nbytes); - /* Some bug somewhere. */ - if (nchars > nbytes) - emacs_abort (); + /* Some bug somewhere. */ + if (nchars > nbytes) + emacs_abort (); - STRING_SET_CHARS (fullname, nchars); - if (nchars == nbytes) - STRING_SET_UNIBYTE (fullname); + STRING_SET_CHARS (fullname, nchars); + if (nchars == nbytes) + STRING_SET_UNIBYTE (fullname); - finalname = fullname; - } - else - finalname = name; + finalname = fullname; + } + else + finalname = name; - if (attrs) - { - /* Construct an expanded filename for the directory entry. - Use the decoded names for input to Ffile_attributes. */ - Lisp_Object decoded_fullname, fileattrs; - struct gcpro gcpro1, gcpro2; + if (attrs) + { + /* Construct an expanded filename for the directory entry. + Use the decoded names for input to Ffile_attributes. */ + Lisp_Object decoded_fullname, fileattrs; + struct gcpro gcpro1, gcpro2; - decoded_fullname = fileattrs = Qnil; - GCPRO2 (decoded_fullname, fileattrs); + decoded_fullname = fileattrs = Qnil; + GCPRO2 (decoded_fullname, fileattrs); - /* Both Fexpand_file_name and Ffile_attributes can GC. */ - decoded_fullname = Fexpand_file_name (name, directory); - fileattrs = Ffile_attributes (decoded_fullname, id_format); + /* Both Fexpand_file_name and Ffile_attributes can GC. */ + decoded_fullname = Fexpand_file_name (name, directory); + fileattrs = Ffile_attributes (decoded_fullname, id_format); - list = Fcons (Fcons (finalname, fileattrs), list); - UNGCPRO; - } - else - list = Fcons (finalname, list); + list = Fcons (Fcons (finalname, fileattrs), list); + UNGCPRO; } - - UNGCPRO; + else + list = Fcons (finalname, list); } + + UNGCPRO; } block_input (); @@ -442,7 +416,8 @@ These are all file names in directory DIRECTORY which begin with FILE. */) return file_name_completion (file, directory, 1, Qnil); } -static int file_name_completion_stat (Lisp_Object dirname, DIRENTRY *dp, struct stat *st_addr); +static int file_name_completion_stat (Lisp_Object dirname, struct dirent *dp, + struct stat *st_addr); static Lisp_Object Qdefault_directory; static Lisp_Object @@ -499,7 +474,7 @@ file_name_completion (Lisp_Object file, Lisp_Object dirname, bool all_flag, /* (att3b compiler bug requires do a null comparison this way) */ while (1) { - DIRENTRY *dp; + struct dirent *dp; ptrdiff_t len; bool canexclude = 0; @@ -517,11 +492,10 @@ file_name_completion (Lisp_Object file, Lisp_Object dirname, bool all_flag, if (!dp) break; - len = NAMLEN (dp); + len = dirent_namelen (dp); QUIT; - if (! DIRENTRY_NONEMPTY (dp) - || len < SCHARS (encoded_file) + if (len < SCHARS (encoded_file) || 0 <= scmp (dp->d_name, SSDATA (encoded_file), SCHARS (encoded_file))) continue; @@ -806,9 +780,10 @@ scmp (const char *s1, const char *s2, ptrdiff_t len) } static int -file_name_completion_stat (Lisp_Object dirname, DIRENTRY *dp, struct stat *st_addr) +file_name_completion_stat (Lisp_Object dirname, struct dirent *dp, + struct stat *st_addr) { - ptrdiff_t len = NAMLEN (dp); + ptrdiff_t len = dirent_namelen (dp); ptrdiff_t pos = SCHARS (dirname); int value; 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) stack_base = &dummy; #endif -#if defined (USE_GTK) && defined (G_SLICE_ALWAYS_MALLOC) +#ifdef G_SLICE_ALWAYS_MALLOC /* This is used by the Cygwin build. */ setenv ("G_SLICE", "always-malloc", 1); #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; Lisp_Object inhibit_lisp_code; static Lisp_Object funcall_lambda (Lisp_Object, ptrdiff_t, Lisp_Object *); -static bool interactive_p (void); static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args); /* Functions to set Lisp_Object slots of struct specbinding. */ @@ -489,102 +488,6 @@ usage: (function ARG) */) } -DEFUN ("interactive-p", Finteractive_p, Sinteractive_p, 0, 0, 0, - doc: /* Return t if the containing function was run directly by user input. -This means that the function was called with `call-interactively' -\(which includes being called as the binding of a key) -and input is currently coming from the keyboard (not a keyboard macro), -and Emacs is not running in batch mode (`noninteractive' is nil). - -The only known proper use of `interactive-p' is in deciding whether to -display a helpful message, or how to display it. If you're thinking -of using it for any other purpose, it is quite likely that you're -making a mistake. Think: what do you want to do when the command is -called from a keyboard macro? - -To test whether your function was called with `call-interactively', -either (i) add an extra optional argument and give it an `interactive' -spec that specifies non-nil unconditionally (such as \"p\"); or (ii) -use `called-interactively-p'. */) - (void) -{ - return (INTERACTIVE && interactive_p ()) ? Qt : Qnil; -} - - -DEFUN ("called-interactively-p", Fcalled_interactively_p, Scalled_interactively_p, 0, 1, 0, - doc: /* Return t if the containing function was called by `call-interactively'. -If KIND is `interactive', then only return t if the call was made -interactively by the user, i.e. not in `noninteractive' mode nor -when `executing-kbd-macro'. -If KIND is `any', on the other hand, it will return t for any kind of -interactive call, including being called as the binding of a key, or -from a keyboard macro, or in `noninteractive' mode. - -The only known proper use of `interactive' for KIND is in deciding -whether to display a helpful message, or how to display it. If you're -thinking of using it for any other purpose, it is quite likely that -you're making a mistake. Think: what do you want to do when the -command is called from a keyboard macro? - -Instead of using this function, it is sometimes cleaner to give your -function an extra optional argument whose `interactive' spec specifies -non-nil unconditionally (\"p\" is a good way to do this), or via -\(not (or executing-kbd-macro noninteractive)). */) - (Lisp_Object kind) -{ - return (((INTERACTIVE || !EQ (kind, intern ("interactive"))) - && interactive_p ()) - ? Qt : Qnil); -} - - -/* Return true if function in which this appears was called using - call-interactively and is not a built-in. */ - -static bool -interactive_p (void) -{ - struct backtrace *btp; - Lisp_Object fun; - - btp = backtrace_list; - - /* If this isn't a byte-compiled function, there may be a frame at - the top for Finteractive_p. If so, skip it. */ - fun = Findirect_function (btp->function, Qnil); - if (SUBRP (fun) && (XSUBR (fun) == &Sinteractive_p - || XSUBR (fun) == &Scalled_interactively_p)) - btp = btp->next; - - /* If we're running an Emacs 18-style byte-compiled function, there - may be a frame for Fbytecode at the top level. In any version of - Emacs there can be Fbytecode frames for subexpressions evaluated - inside catch and condition-case. Skip past them. - - If this isn't a byte-compiled function, then we may now be - looking at several frames for special forms. Skip past them. */ - while (btp - && (EQ (btp->function, Qbytecode) - || btp->nargs == UNEVALLED)) - btp = btp->next; - - /* `btp' now points at the frame of the innermost function that isn't - a special form, ignoring frames for Finteractive_p and/or - Fbytecode at the top. If this frame is for a built-in function - (such as load or eval-region) return false. */ - fun = Findirect_function (btp->function, Qnil); - if (SUBRP (fun)) - return 0; - - /* `btp' points to the frame of a Lisp function that called interactive-p. - Return t if that function was called interactively. */ - if (btp && btp->next && EQ (btp->next->function, Qcall_interactively)) - return 1; - return 0; -} - - DEFUN ("defvaralias", Fdefvaralias, Sdefvaralias, 2, 3, 0, doc: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE. Aliased variables always have the same value; setting one sets the other. @@ -696,8 +599,9 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */) if (EQ ((--pdl)->symbol, sym) && !pdl->func && EQ (pdl->old_value, Qunbound)) { - message_with_string ("Warning: defvar ignored because %s is let-bound", - SYMBOL_NAME (sym), 1); + message_with_string + ("Warning: defvar ignored because %s is let-bound", + SYMBOL_NAME (sym), 1); break; } } @@ -717,8 +621,8 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */) /* A simple (defvar foo) with lexical scoping does "nothing" except declare that var to be dynamically scoped *locally* (i.e. within the current file or let-block). */ - Vinternal_interpreter_environment = - Fcons (sym, Vinternal_interpreter_environment); + Vinternal_interpreter_environment + = Fcons (sym, Vinternal_interpreter_environment); else { /* 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. */) if (NILP (tem)) { def = XSYMBOL (sym)->function; - if (!EQ (def, Qunbound)) + if (!NILP (def)) continue; } break; @@ -986,7 +890,7 @@ definitions to shadow the loaded ones for use in file byte-compilation. */) GCPRO1 (form); def = Fautoload_do_load (def, sym, Qmacro); UNGCPRO; - if (EQ (def, Qunbound) || !CONSP (def)) + if (!CONSP (def)) /* Not defined or definition not suitable. */ break; if (!EQ (XCAR (def), Qmacro)) @@ -1811,12 +1715,12 @@ then strings and vectors are not accepted. */) fun = function; - fun = indirect_function (fun); /* Check cycles. */ - if (NILP (fun) || EQ (fun, Qunbound)) + fun = indirect_function (fun); /* Check cycles. */ + if (NILP (fun)) return Qnil; /* Check an `interactive-form' property if present, analogous to the - function-documentation property. */ + function-documentation property. */ fun = function; while (SYMBOLP (fun)) { @@ -1876,7 +1780,7 @@ this does nothing and returns nil. */) CHECK_STRING (file); /* If function is defined and not as an autoload, don't override. */ - if (!EQ (XSYMBOL (function)->function, Qunbound) + if (!NILP (XSYMBOL (function)->function) && !AUTOLOADP (XSYMBOL (function)->function)) return Qnil; @@ -2055,7 +1959,7 @@ eval_sub (Lisp_Object form) /* Optimize for no indirection. */ fun = original_fun; - if (SYMBOLP (fun) && !EQ (fun, Qunbound) + if (SYMBOLP (fun) && !NILP (fun) && (fun = XSYMBOL (fun)->function, SYMBOLP (fun))) fun = indirect_function (fun); @@ -2177,7 +2081,7 @@ eval_sub (Lisp_Object form) val = apply_lambda (fun, original_args); else { - if (EQ (fun, Qunbound)) + if (NILP (fun)) xsignal1 (Qvoid_function, original_fun); if (!CONSP (fun)) xsignal1 (Qinvalid_function, original_fun); @@ -2251,10 +2155,10 @@ usage: (apply FUNCTION &rest ARGUMENTS) */) numargs += nargs - 2; /* Optimize for no indirection. */ - if (SYMBOLP (fun) && !EQ (fun, Qunbound) + if (SYMBOLP (fun) && !NILP (fun) && (fun = XSYMBOL (fun)->function, SYMBOLP (fun))) fun = indirect_function (fun); - if (EQ (fun, Qunbound)) + if (NILP (fun)) { /* Let funcall get the error. */ fun = args[0]; @@ -2728,7 +2632,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) /* Optimize for no indirection. */ fun = original_fun; - if (SYMBOLP (fun) && !EQ (fun, Qunbound) + if (SYMBOLP (fun) && !NILP (fun) && (fun = XSYMBOL (fun)->function, SYMBOLP (fun))) fun = indirect_function (fun); @@ -2816,7 +2720,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) val = funcall_lambda (fun, numargs, args + 1); else { - if (EQ (fun, Qunbound)) + if (NILP (fun)) xsignal1 (Qvoid_function, original_fun); if (!CONSP (fun)) xsignal1 (Qinvalid_function, original_fun); @@ -3551,8 +3455,6 @@ alist of active lexical bindings. */); defsubr (&Sunwind_protect); defsubr (&Scondition_case); defsubr (&Ssignal); - defsubr (&Sinteractive_p); - defsubr (&Scalled_interactively_p); defsubr (&Scommandp); defsubr (&Sautoload); 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. */) register const char *beg; #else register char *beg; + Lisp_Object tem_fn; #endif register const char *p; Lisp_Object handler; @@ -374,10 +375,13 @@ Given a Unix syntax file name, returns a string ending in slash. */) p = beg + strlen (beg); } } - dostounix_filename (beg); -#endif /* DOS_NT */ - + tem_fn = ENCODE_FILE (make_specified_string (beg, -1, p - beg, + STRING_MULTIBYTE (filename))); + dostounix_filename (SSDATA (tem_fn)); + return DECODE_FILE (tem_fn); +#else /* DOS_NT */ return make_specified_string (beg, -1, p - beg, STRING_MULTIBYTE (filename)); +#endif /* DOS_NT */ } DEFUN ("file-name-nondirectory", Ffile_name_nondirectory, @@ -951,7 +955,18 @@ filesystem tree, not (expand-file-name ".." dirname). */) #ifdef DOS_NT /* Make sure directories are all separated with /, but avoid allocation of a new string when not required. */ - dostounix_filename (nm); + if (multibyte) + { + Lisp_Object tem_name = make_specified_string (nm, -1, strlen (nm), + multibyte); + + tem_name = ENCODE_FILE (tem_name); + dostounix_filename (SSDATA (tem_name)); + tem_name = DECODE_FILE (tem_name); + memcpy (nm, SSDATA (tem_name), SBYTES (tem_name) + 1); + } + else + dostounix_filename (nm); #ifdef WINDOWSNT if (IS_DIRECTORY_SEP (nm[1])) { @@ -1133,7 +1148,7 @@ filesystem tree, not (expand-file-name ".." dirname). */) newdir = "/"; } else - getwd (adir); + getcwd (adir, MAXPATHLEN + 1); newdir = adir; } @@ -1305,10 +1320,13 @@ filesystem tree, not (expand-file-name ".." dirname). */) target[0] = '/'; target[1] = ':'; } - dostounix_filename (target); -#endif /* DOS_NT */ - result = make_specified_string (target, -1, o - target, multibyte); + result = ENCODE_FILE (result); + dostounix_filename (SSDATA (result)); + result = DECODE_FILE (result); +#else /* !DOS_NT */ + result = make_specified_string (target, -1, o - target, multibyte); +#endif /* !DOS_NT */ } /* Again look to see if the file name has special constructs in it @@ -1587,8 +1605,18 @@ those `/' is discarded. */) memcpy (nm, SDATA (filename), SBYTES (filename) + 1); #ifdef DOS_NT - dostounix_filename (nm); - substituted = (strcmp (nm, SDATA (filename)) != 0); + { + Lisp_Object encoded_filename = ENCODE_FILE (filename); + Lisp_Object tem_fn; + + dostounix_filename (SDATA (encoded_filename)); + tem_fn = DECODE_FILE (encoded_filename); + nm = alloca (SBYTES (tem_fn) + 1); + memcpy (nm, SDATA (tem_fn), SBYTES (tem_fn) + 1); + substituted = (memcmp (nm, SDATA (filename), SBYTES (filename)) != 0); + if (substituted) + filename = tem_fn; + } #endif endp = nm + SBYTES (filename); 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; && (frame_var = XCAR (list_var), 1)); \ list_var = XCDR (list_var)) +/* Reflect mouse movement when a complete frame update is performed. */ + +#define FRAME_MOUSE_UPDATE(frame) \ + do { \ + Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (frame); \ + if (frame == hlinfo->mouse_face_mouse_frame) \ + { \ + block_input (); \ + if (hlinfo->mouse_face_mouse_frame) \ + note_mouse_highlight (hlinfo->mouse_face_mouse_frame, \ + hlinfo->mouse_face_mouse_x, \ + hlinfo->mouse_face_mouse_y); \ + unblock_input (); \ + } \ + } while (0) extern Lisp_Object Qframep, Qframe_live_p; extern 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 union Lisp_Fwd *fwd; } val; - /* Function value of the symbol or Qunbound if not fboundp. */ + /* Function value of the symbol or Qnil if not fboundp. */ Lisp_Object function; /* The symbol's property list. */ @@ -1649,10 +1649,6 @@ typedef struct { int mouse_face_face_id; Lisp_Object mouse_face_overlay; - /* 1 if a mouse motion event came and we didn't handle it right away because - gc was in progress. */ - int mouse_face_deferred_gc; - /* FRAME and X, Y position of mouse when last checked for highlighting. X and Y can be negative or out of range for the frame. */ 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) /* Fmake_symbol inits fields of new symbols with Qunbound and Qnil, so those two need to be fixed manually. */ SET_SYMBOL_VAL (XSYMBOL (Qunbound), Qunbound); - set_symbol_function (Qunbound, Qunbound); + set_symbol_function (Qunbound, Qnil); set_symbol_plist (Qunbound, Qnil); SET_SYMBOL_VAL (XSYMBOL (Qnil), Qnil); XSYMBOL (Qnil)->constant = 1; XSYMBOL (Qnil)->declared_special = 1; set_symbol_plist (Qnil, Qnil); + set_symbol_function (Qnil, Qnil); Qt = intern_c_string ("t"); 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 \ obj = $(GLOBAL_SOURCES:.c=.o) globals.h: gl-stamp - @cmd /c rem true + @cmd $(SWITCHCHAR)c rem true gl-stamp: ../lib-src/$(BLD)/make-docfile.exe $(GLOBAL_SOURCES) - $(DEL) gl-tmp "$(THISDIR)/../lib-src/$(BLD)/make-docfile" -d . -g $(SOME_MACHINE_OBJECTS) $(obj) > gl-tmp - cmd /c "fc /b gl-tmp globals.h >nul 2>&1 || $(CP) gl-tmp globals.h" + fc.exe $(SWITCHCHAR)b gl-tmp globals.h >nul 2>&1 || $(CP) gl-tmp globals.h - $(DEL) gl-tmp echo timestamp > $@ @@ -413,8 +413,6 @@ CONF_POST_H = $(SRC)/conf_post.h \ $(MS_W32_H) CONFIG_H = $(SRC)/config.h \ $(CONF_POST_H) -DIR_H = $(NT_INC)/sys/dir.h \ - $(SRC)/ndir.h W32GUI_H = $(SRC)/w32gui.h \ $(SYSTIME_H) DISPEXTERN_H = $(SRC)/dispextern.h \ @@ -714,6 +712,7 @@ $(BLD)/dired.$(O) : \ $(SRC)/blockinput.h \ $(SRC)/commands.h \ $(SRC)/regex.h \ + $(NT_INC)/dirent.h \ $(NT_INC)/pwd.h \ $(NT_INC)/sys/stat.h \ $(NT_INC)/unistd.h \ @@ -722,7 +721,6 @@ $(BLD)/dired.$(O) : \ $(CHARSET_H) \ $(CODING_H) \ $(CONFIG_H) \ - $(DIR_H) \ $(FILEMODE_H) \ $(GRP_H) \ $(LISP_H) \ @@ -1175,11 +1173,11 @@ $(BLD)/minibuf.$(O) : \ $(BLD)/w32.$(O) : \ $(SRC)/w32.c \ - $(SRC)/ndir.h \ $(SRC)/w32.h \ $(SRC)/w32common.h \ $(SRC)/w32heap.h \ $(SRC)/w32select.h \ + $(NT_INC)/dirent.h \ $(NT_INC)/pwd.h \ $(NT_INC)/sys/file.h \ $(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) hlinfo->mouse_face_beg_row = hlinfo->mouse_face_beg_col = -1; hlinfo->mouse_face_end_row = hlinfo->mouse_face_end_col = -1; hlinfo->mouse_face_window = Qnil; - hlinfo->mouse_face_deferred_gc = 0; hlinfo->mouse_face_mouse_frame = NULL; } @@ -1295,21 +1294,10 @@ IT_update_end (struct frame *f) static void IT_frame_up_to_date (struct frame *f) { - Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (f); Lisp_Object new_cursor, frame_desired_cursor; struct window *sw; - if (hlinfo->mouse_face_deferred_gc - || (f && f == hlinfo->mouse_face_mouse_frame)) - { - block_input (); - if (hlinfo->mouse_face_mouse_frame) - note_mouse_highlight (hlinfo->mouse_face_mouse_frame, - hlinfo->mouse_face_mouse_x, - hlinfo->mouse_face_mouse_y); - hlinfo->mouse_face_deferred_gc = 0; - unblock_input (); - } + FRAME_MOUSE_UPDATE (f); /* Set the cursor type to whatever they wanted. In a minibuffer window, we want the cursor to appear only if we are reading input @@ -1849,7 +1837,6 @@ internal_terminal_init (void) FRAME_BACKGROUND_PIXEL (SELECTED_FRAME ()) = colors[1]; } the_only_display_info.mouse_highlight.mouse_face_mouse_frame = NULL; - the_only_display_info.mouse_highlight.mouse_face_deferred_gc = 0; the_only_display_info.mouse_highlight.mouse_face_beg_row = the_only_display_info.mouse_highlight.mouse_face_beg_col = -1; 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) hlinfo->mouse_face_beg_row = hlinfo->mouse_face_beg_col = -1; hlinfo->mouse_face_end_row = hlinfo->mouse_face_end_col = -1; hlinfo->mouse_face_window = Qnil; - hlinfo->mouse_face_deferred_gc = 0; hlinfo->mouse_face_mouse_frame = 0; } @@ -1887,8 +1886,7 @@ static void ns_frame_up_to_date (struct frame *f) /* -------------------------------------------------------------------------- External (hook): Fix up mouse highlighting right after a full update. - Some highlighting was deferred if GC was happening during - note_mouse_highlight (), while other highlighting was deferred for update. + Can't use FRAME_MOUSE_UPDATE due to ns_frame_begin and ns_frame_end calls. -------------------------------------------------------------------------- */ { NSTRACE (ns_frame_up_to_date); @@ -1896,19 +1894,17 @@ ns_frame_up_to_date (struct frame *f) if (FRAME_NS_P (f)) { Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (f); - if ((hlinfo->mouse_face_deferred_gc || f ==hlinfo->mouse_face_mouse_frame) - /*&& hlinfo->mouse_face_mouse_frame*/) - { - block_input (); + if (f == hlinfo->mouse_face_mouse_frame) + { + block_input (); ns_update_begin(f); - if (hlinfo->mouse_face_mouse_frame) - note_mouse_highlight (hlinfo->mouse_face_mouse_frame, - hlinfo->mouse_face_mouse_x, - hlinfo->mouse_face_mouse_y); - hlinfo->mouse_face_deferred_gc = 0; + if (hlinfo->mouse_face_mouse_frame) + note_mouse_highlight (hlinfo->mouse_face_mouse_frame, + hlinfo->mouse_face_mouse_x, + hlinfo->mouse_face_mouse_y); ns_update_end(f); - unblock_input (); - } + unblock_input (); + } } } @@ -3869,7 +3865,6 @@ ns_initialize_display_info (struct ns_display_info *dpyinfo) dpyinfo->root_window = 42; /* a placeholder.. */ hlinfo->mouse_face_mouse_frame = NULL; - hlinfo->mouse_face_deferred_gc = 0; hlinfo->mouse_face_beg_row = hlinfo->mouse_face_beg_col = -1; hlinfo->mouse_face_end_row = hlinfo->mouse_face_end_col = -1; 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/>. */ #define _P_WAIT 0 int _cdecl _spawnlp (int, const char *, const char *, ...); int _cdecl _getpid (void); -extern char *getwd (char *); #endif #include "syssignal.h" @@ -134,12 +133,12 @@ char* get_current_dir_name (void) { char *buf; - char *pwd; + char *pwd = getenv ("PWD"); struct stat dotstat, pwdstat; - /* If PWD is accurate, use it instead of calling getwd. PWD is + /* If PWD is accurate, use it instead of calling getcwd. PWD is sometimes a nicer name, and using it may avoid a fatal error if a parent directory is searchable but not readable. */ - if ((pwd = getenv ("PWD")) != 0 + if (pwd && (IS_DIRECTORY_SEP (*pwd) || (*pwd && IS_DEVICE_SEP (pwd[1]))) && stat (pwd, &pwdstat) == 0 && stat (".", &dotstat) == 0 @@ -155,7 +154,6 @@ get_current_dir_name (void) return NULL; strcpy (buf, pwd); } -#ifdef HAVE_GETCWD else { size_t buf_size = 1024; @@ -179,22 +177,6 @@ get_current_dir_name (void) return NULL; } } -#else - else - { - /* We need MAXPATHLEN here. */ - buf = malloc (MAXPATHLEN + 1); - if (!buf) - return NULL; - if (getwd (buf) == NULL) - { - int tmp_errno = errno; - free (buf); - errno = tmp_errno; - return NULL; - } - } -#endif return buf; } #endif @@ -521,7 +503,7 @@ sys_subshell (void) const char *sh = 0; #ifdef DOS_NT /* MW, Aug 1993 */ - getwd (oldwd); + getcwd (oldwd, sizeof oldwd); if (sh == 0) sh = (char *) egetenv ("SUSPEND"); /* KFS, 1994-12-14 */ #endif @@ -2238,82 +2220,6 @@ emacs_readlink (char const *filename, char initial_buf[READLINK_BUFSIZE]) &emacs_norealloc_allocator, careadlinkatcwd); } -#ifdef USG -/* - * All of the following are for USG. - * - * On USG systems the system calls are INTERRUPTIBLE by signals - * that the user program has elected to catch. Thus the system call - * must be retried in these cases. To handle this without massive - * changes in the source code, we remap the standard system call names - * to names for our own functions in sysdep.c that do the system call - * with retries. Actually, for portability reasons, it is good - * programming practice, as this example shows, to limit all actual - * system calls to a single occurrence in the source. Sure, this - * adds an extra level of function call overhead but it is almost - * always negligible. Fred Fish, Unisoft Systems Inc. - */ - -/* - * Warning, this function may not duplicate 4.2 action properly - * under error conditions. - */ - -#if !defined (HAVE_GETWD) || defined (BROKEN_GETWD) - -#ifndef MAXPATHLEN -/* In 4.1, param.h fails to define this. */ -#define MAXPATHLEN 1024 -#endif - -char * -getwd (char *pathname) -{ - char *npath, *spath; - extern char *getcwd (char *, size_t); - - block_input (); /* getcwd uses malloc */ - spath = npath = getcwd ((char *) 0, MAXPATHLEN); - if (spath == 0) - { - unblock_input (); - return spath; - } - /* On Altos 3068, getcwd can return @hostname/dir, so discard - up to first slash. Should be harmless on other systems. */ - while (*npath && *npath != '/') - npath++; - strcpy (pathname, npath); - free (spath); /* getcwd uses malloc */ - unblock_input (); - return pathname; -} - -#endif /* !defined (HAVE_GETWD) || defined (BROKEN_GETWD) */ -#endif /* USG */ - -/* Directory routines for systems that don't have them. */ - -#ifdef HAVE_DIRENT_H - -#include <dirent.h> - -#if !defined (HAVE_CLOSEDIR) - -int -closedir (DIR *dirp /* stream from opendir */) -{ - int rtnval; - - rtnval = emacs_close (dirp->dd_fd); - xfree (dirp); - - return rtnval; -} -#endif /* not HAVE_CLOSEDIR */ -#endif /* HAVE_DIRENT_H */ - - /* Return a struct timeval that is roughly equivalent to T. Use the least timeval not less than T. 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 { #include <aclapi.h> #ifdef _MSC_VER -/* MSVC doesn't provide the definition of REPARSE_DATA_BUFFER, except - on ntifs.h, which cannot be included because it triggers conflicts - with other Windows API headers. So we define it here by hand. */ +/* MSVC doesn't provide the definition of REPARSE_DATA_BUFFER and the + associated macros, except on ntifs.h, which cannot be included + because it triggers conflicts with other Windows API headers. So + we define it here by hand. */ typedef struct _REPARSE_DATA_BUFFER { ULONG ReparseTag; @@ -149,6 +150,12 @@ typedef struct _REPARSE_DATA_BUFFER { } DUMMYUNIONNAME; } REPARSE_DATA_BUFFER, *PREPARSE_DATA_BUFFER; +#define FILE_DEVICE_FILE_SYSTEM 9 +#define METHOD_BUFFERED 0 +#define FILE_ANY_ACCESS 0x00000000 +#define CTL_CODE(t,f,m,a) (((t)<<16)|((a)<<14)|((f)<<2)|(m)) +#define FSCTL_GET_REPARSE_POINT \ + CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 42, METHOD_BUFFERED, FILE_ANY_ACCESS) #endif /* TCP connection support. */ @@ -172,7 +179,7 @@ typedef struct _REPARSE_DATA_BUFFER { #undef sendto #include "w32.h" -#include "ndir.h" +#include <dirent.h> #include "w32common.h" #include "w32heap.h" #include "w32select.h" @@ -901,8 +908,18 @@ static char startup_dir[MAXPATHLEN]; /* Get the current working directory. */ char * -getwd (char *dir) +getcwd (char *dir, int dirsize) { + if (!dirsize) + { + errno = EINVAL; + return NULL; + } + if (dirsize <= strlen (startup_dir)) + { + errno = ERANGE; + return NULL; + } #if 0 if (GetCurrentDirectory (MAXPATHLEN, dir) > 0) return dir; @@ -1818,7 +1835,7 @@ init_environment (char ** argv) memcpy (*envp, "COMSPEC=", 8); } - /* Remember the initial working directory for getwd. */ + /* Remember the initial working directory for getcwd. */ /* FIXME: Do we need to resolve possible symlinks in startup_dir? Does it matter anywhere in Emacs? */ if (!GetCurrentDirectory (MAXPATHLEN, startup_dir)) @@ -2431,7 +2448,7 @@ is_exec (const char * name) and readdir. We can't use the procedures supplied in sysdep.c, so we provide them here. */ -struct direct dir_static; /* simulated directory contents */ +struct dirent dir_static; /* simulated directory contents */ static HANDLE dir_find_handle = INVALID_HANDLE_VALUE; static int dir_is_fat; static char dir_pathname[MAXPATHLEN+1]; @@ -2501,7 +2518,7 @@ closedir (DIR *dirp) xfree ((char *) dirp); } -struct direct * +struct dirent * readdir (DIR *dirp) { int downcase = !NILP (Vw32_downcase_file_names); @@ -2555,7 +2572,7 @@ readdir (DIR *dirp) downcase = 1; /* 8+3 aliases are returned in all caps */ } dir_static.d_namlen = strlen (dir_static.d_name); - dir_static.d_reclen = sizeof (struct direct) - MAXNAMLEN + 3 + + dir_static.d_reclen = sizeof (struct dirent) - MAXNAMLEN + 3 + dir_static.d_namlen - dir_static.d_namlen % 4; /* 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 **); extern void register_child (int, int); extern void sys_sleep (int); -extern char *getwd (char *); extern int sys_link (const char *, const char *); @@ -181,4 +180,3 @@ extern ssize_t emacs_gnutls_push (gnutls_transport_ptr_t p, #endif /* HAVE_GNUTLS */ #endif /* EMACS_W32_H */ - 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. */) filename = empty_unibyte_string; #ifdef CYGWIN - dir = Fcygwin_convert_path_to_windows (dir, Qt); + dir = Fcygwin_convert_file_name_to_windows (dir, Qt); if (SCHARS (filename) > 0) - filename = Fcygwin_convert_path_to_windows (filename, Qnil); + filename = Fcygwin_convert_file_name_to_windows (filename, Qnil); #endif CHECK_STRING (dir); @@ -6270,7 +6270,7 @@ Otherwise, if ONLY-DIR-P is non-nil, the user can only select directories. */) #endif /* NTGUI_UNICODE */ #ifdef CYGWIN - filename = Fcygwin_convert_path_from_windows (filename, Qt); + filename = Fcygwin_convert_file_name_from_windows (filename, Qt); #endif /* CYGWIN */ /* 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 w32_frame_up_to_date (struct frame *f) { if (FRAME_W32_P (f)) - { - Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (f); - - if (hlinfo->mouse_face_deferred_gc - || f == hlinfo->mouse_face_mouse_frame) - { - block_input (); - if (hlinfo->mouse_face_mouse_frame) - note_mouse_highlight (hlinfo->mouse_face_mouse_frame, - hlinfo->mouse_face_mouse_x, - hlinfo->mouse_face_mouse_y); - hlinfo->mouse_face_deferred_gc = 0; - unblock_input (); - } - } + FRAME_MOUSE_UPDATE (f); } @@ -5979,7 +5965,6 @@ x_free_frame_resources (struct frame *f) hlinfo->mouse_face_end_row = hlinfo->mouse_face_end_col = -1; hlinfo->mouse_face_window = Qnil; - hlinfo->mouse_face_deferred_gc = 0; hlinfo->mouse_face_mouse_frame = 0; } 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; typedef BOOL (CALLBACK *LOCALE_ENUMPROCA)(LPSTR); typedef BOOL (CALLBACK *LOCALE_ENUMPROCW)(LPWSTR); BOOL WINAPI EnumSystemLocalesA(LOCALE_ENUMPROCA,DWORD); -BOOL WINAPI EnumSystemLocalesW(LOCALE_ENUMPROCW,DWORD) +BOOL WINAPI EnumSystemLocalesW(LOCALE_ENUMPROCW,DWORD); #ifdef UNICODE #define EnumSystemLocales EnumSystemLocalesW #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; static int overlay_arrow_seen; -/* Number of windows showing the buffer of the selected window (or - another buffer with the same base buffer). keyboard.c refers to - this. */ +/* Number of windows showing the buffer of the selected + window (or another buffer with the same base buffer). */ int buffer_shared; @@ -9643,7 +9642,7 @@ message2_nolog (const char *m, ptrdiff_t nbytes, int multibyte) do_pending_window_change (0); echo_area_display (1); do_pending_window_change (0); - if (FRAME_TERMINAL (f)->frame_up_to_date_hook != 0 && ! gc_in_progress) + if (FRAME_TERMINAL (f)->frame_up_to_date_hook) (*FRAME_TERMINAL (f)->frame_up_to_date_hook) (f); } } @@ -9740,7 +9739,7 @@ message3_nolog (Lisp_Object m, ptrdiff_t nbytes, int multibyte) do_pending_window_change (0); echo_area_display (1); do_pending_window_change (0); - if (FRAME_TERMINAL (f)->frame_up_to_date_hook != 0 && ! gc_in_progress) + if (FRAME_TERMINAL (f)->frame_up_to_date_hook) (*FRAME_TERMINAL (f)->frame_up_to_date_hook) (f); } } @@ -10889,8 +10888,41 @@ echo_area_display (int update_frame_p) return window_height_changed_p; } +/* Nonzero if the current buffer is shown in more than + one window and was modified since last display. */ + +static int +buffer_shared_and_changed (void) +{ + return (buffer_shared > 1 && UNCHANGED_MODIFIED < MODIFF); +} + +/* Nonzero if W doesn't reflect the actual state of + current buffer due to its text or overlays change. */ + +static int +window_outdated (struct window *w) +{ + eassert (XBUFFER (w->buffer) == current_buffer); + return (w->last_modified < MODIFF + || w->last_overlay_modified < OVERLAY_MODIFF); +} + +/* Nonzero if W's buffer was changed but not saved or Transient Mark mode + is enabled and mark of W's buffer was changed since last W's update. */ + +static int +window_buffer_changed (struct window *w) +{ + struct buffer *b = XBUFFER (w->buffer); + + eassert (BUFFER_LIVE_P (b)); + + return (((BUF_SAVE_MODIFF (b) < BUF_MODIFF (b)) != w->last_had_star) + || ((!NILP (Vtransient_mark_mode) && !NILP (BVAR (b, mark_active))) + != !NILP (w->region_showing))); +} - /*********************************************************************** Mode Lines and Frame Titles ***********************************************************************/ @@ -11196,7 +11228,7 @@ prepare_menu_bars (void) /* Update the menu bar item lists, if appropriate. This has to be done before any actual redisplay or generation of display lines. */ all_windows = (update_mode_lines - || buffer_shared > 1 + || buffer_shared_and_changed () || windows_or_buffers_changed); if (all_windows) { @@ -11310,12 +11342,7 @@ update_menu_bar (struct frame *f, int save_match_data, int hooks_run) /* This used to test w->update_mode_line, but we believe there is no need to recompute the menu in that case. */ || update_mode_lines - || ((BUF_SAVE_MODIFF (XBUFFER (w->buffer)) - < BUF_MODIFF (XBUFFER (w->buffer))) - != w->last_had_star) - || ((!NILP (Vtransient_mark_mode) - && !NILP (BVAR (XBUFFER (w->buffer), mark_active))) - != !NILP (w->region_showing))) + || window_buffer_changed (w)) { struct buffer *prev = current_buffer; ptrdiff_t count = SPECPDL_INDEX (); @@ -11467,11 +11494,18 @@ FRAME_PTR last_mouse_frame; int last_tool_bar_item; - +/* Select `frame' temporarily without running all the code in + do_switch_frame. + FIXME: Maybe do_switch_frame should be trimmed down similarly + when `norecord' is set. */ static Lisp_Object -update_tool_bar_unwind (Lisp_Object frame) +fast_set_selected_frame (Lisp_Object frame) { - selected_frame = frame; + if (!EQ (selected_frame, frame)) + { + selected_frame = frame; + selected_window = XFRAME (frame)->selected_window; + } return Qnil; } @@ -11508,12 +11542,7 @@ update_tool_bar (struct frame *f, int save_match_data) if (windows_or_buffers_changed || w->update_mode_line || update_mode_lines - || ((BUF_SAVE_MODIFF (XBUFFER (w->buffer)) - < BUF_MODIFF (XBUFFER (w->buffer))) - != w->last_had_star) - || ((!NILP (Vtransient_mark_mode) - && !NILP (BVAR (XBUFFER (w->buffer), mark_active))) - != !NILP (w->region_showing))) + || window_buffer_changed (w)) { struct buffer *prev = current_buffer; ptrdiff_t count = SPECPDL_INDEX (); @@ -11543,9 +11572,13 @@ update_tool_bar (struct frame *f, int save_match_data) before calling tool_bar_items, because the calculation of the tool-bar keymap uses the selected frame (see `tool-bar-make-keymap' in tool-bar.el). */ - record_unwind_protect (update_tool_bar_unwind, selected_frame); + eassert (EQ (selected_window, + /* Since we only explicitly preserve selected_frame, + check that selected_window would be redundant. */ + XFRAME (selected_frame)->selected_window)); + record_unwind_protect (fast_set_selected_frame, selected_frame); XSETFRAME (frame, f); - selected_frame = frame; + fast_set_selected_frame (frame); /* Build desired tool-bar items from keymaps. */ new_tool_bar @@ -12616,8 +12649,7 @@ text_outside_line_unchanged_p (struct window *w, int unchanged_p = 1; /* If text or overlays have changed, see where. */ - if (w->last_modified < MODIFF - || w->last_overlay_modified < OVERLAY_MODIFF) + if (window_outdated (w)) { /* Gap in the line? */ if (GPT < start || Z - GPT < end) @@ -12961,7 +12993,7 @@ redisplay_internal (void) ptrdiff_t count, count1; struct frame *sf; int polling_stopped_here = 0; - Lisp_Object old_frame = selected_frame; + Lisp_Object tail, frame, old_frame = selected_frame; struct backtrace backtrace; /* Non-zero means redisplay has to consider all windows on all @@ -13013,15 +13045,8 @@ redisplay_internal (void) backtrace.debug_on_exit = 0; backtrace_list = &backtrace; - { - Lisp_Object tail, frame; - - FOR_EACH_FRAME (tail, frame) - { - struct frame *f = XFRAME (frame); - f->already_hscrolled_p = 0; - } - } + FOR_EACH_FRAME (tail, frame) + XFRAME (frame)->already_hscrolled_p = 0; retry: /* Remember the currently selected window. */ @@ -13071,25 +13096,20 @@ redisplay_internal (void) FRAME_TTY (sf)->previous_frame = sf; } - /* Set the visible flags for all frames. Do this before checking - for resized or garbaged frames; they want to know if their frames - are visible. See the comment in frame.h for - FRAME_SAMPLE_VISIBILITY. */ - { - Lisp_Object tail, frame; + /* Set the visible flags for all frames. Do this before checking for + resized or garbaged frames; they want to know if their frames are + visible. See the comment in frame.h for FRAME_SAMPLE_VISIBILITY. */ + number_of_visible_frames = 0; - number_of_visible_frames = 0; - - FOR_EACH_FRAME (tail, frame) - { - struct frame *f = XFRAME (frame); + FOR_EACH_FRAME (tail, frame) + { + struct frame *f = XFRAME (frame); - FRAME_SAMPLE_VISIBILITY (f); - if (FRAME_VISIBLE_P (f)) - ++number_of_visible_frames; - clear_desired_matrices (f); - } - } + FRAME_SAMPLE_VISIBILITY (f); + if (FRAME_VISIBLE_P (f)) + ++number_of_visible_frames; + clear_desired_matrices (f); + } /* Notice any pending interrupt request to change frame size. */ do_pending_window_change (1); @@ -13116,7 +13136,7 @@ redisplay_internal (void) if ((SAVE_MODIFF < MODIFF) != w->last_had_star) { w->update_mode_line = 1; - if (buffer_shared > 1) + if (buffer_shared_and_changed ()) update_mode_lines++; } @@ -13128,9 +13148,7 @@ redisplay_internal (void) if (!NILP (w->column_number_displayed) /* This alternative quickly identifies a common case where no change is needed. */ - && !(PT == w->last_point - && w->last_modified >= MODIFF - && w->last_overlay_modified >= OVERLAY_MODIFF) + && !(PT == w->last_point && !window_outdated (w)) && (XFASTINT (w->column_number_displayed) != current_column ())) w->update_mode_line = 1; @@ -13141,7 +13159,8 @@ redisplay_internal (void) /* The variable buffer_shared is set in redisplay_window and indicates that we redisplay a buffer in different windows. See there. */ - consider_all_windows_p = (update_mode_lines || buffer_shared > 1 + consider_all_windows_p = (update_mode_lines + || buffer_shared_and_changed () || cursor_type_changed); /* If specs for an arrow have changed, do thorough redisplay @@ -13191,18 +13210,16 @@ redisplay_internal (void) } } else if (EQ (selected_window, minibuf_window) - && (current_buffer->clip_changed - || w->last_modified < MODIFF - || w->last_overlay_modified < OVERLAY_MODIFF) + && (current_buffer->clip_changed || window_outdated (w)) && resize_mini_window (w, 0)) { /* Resized active mini-window to fit the size of what it is showing if its contents might have changed. */ must_finish = 1; -/* FIXME: this causes all frames to be updated, which seems unnecessary - since only the current frame needs to be considered. This function needs - to be rewritten with two variables, consider_all_windows and - consider_all_frames. */ + /* FIXME: this causes all frames to be updated, which seems unnecessary + since only the current frame needs to be considered. This function + needs to be rewritten with two variables, consider_all_windows and + consider_all_frames. */ consider_all_windows_p = 1; ++windows_or_buffers_changed; ++update_mode_lines; @@ -13257,9 +13274,7 @@ redisplay_internal (void) || FETCH_BYTE (BYTEPOS (tlbufpos)) == '\n')) /* Former continuation line has disappeared by becoming empty. */ goto cancel; - else if (w->last_modified < MODIFF - || w->last_overlay_modified < OVERLAY_MODIFF - || MINI_WINDOW_P (w)) + else if (window_outdated (w) || MINI_WINDOW_P (w)) { /* We have to handle the case of continuation around a wide-column character (see the comment in indent.c around @@ -13433,7 +13448,7 @@ redisplay_internal (void) } CHARPOS (this_line_start_pos) = 0; - consider_all_windows_p |= buffer_shared > 1; + consider_all_windows_p |= buffer_shared_and_changed (); ++clear_face_cache_count; #ifdef HAVE_WINDOW_SYSTEM ++clear_image_cache_count; @@ -13445,8 +13460,6 @@ redisplay_internal (void) if (consider_all_windows_p) { - Lisp_Object tail, frame; - FOR_EACH_FRAME (tail, frame) XFRAME (frame)->updated_p = 0; @@ -13656,7 +13669,6 @@ redisplay_internal (void) frames here explicitly. */ if (!pending) { - Lisp_Object tail, frame; int new_count = 0; FOR_EACH_FRAME (tail, frame) @@ -15510,8 +15522,7 @@ redisplay_window (Lisp_Object window, int just_this_one_p) = (!NILP (w->window_end_valid) && !current_buffer->clip_changed && !current_buffer->prevent_redisplay_optimizations_p - && w->last_modified >= MODIFF - && w->last_overlay_modified >= OVERLAY_MODIFF); + && !window_outdated (w)); /* Run the window-bottom-change-functions 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) buffer_unchanged_p = (!NILP (w->window_end_valid) && !current_buffer->clip_changed - && w->last_modified >= MODIFF - && w->last_overlay_modified >= OVERLAY_MODIFF); + && !window_outdated (w)); /* When windows_or_buffers_changed is non-zero, we can't rely on 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) if (!NILP (w->column_number_displayed) /* This alternative quickly identifies a common case where no change is needed. */ - && !(PT == w->last_point - && w->last_modified >= MODIFF - && w->last_overlay_modified >= OVERLAY_MODIFF) + && !(PT == w->last_point && !window_outdated (w)) && (XFASTINT (w->column_number_displayed) != current_column ())) update_mode_line = 1; @@ -15803,8 +15811,7 @@ redisplay_window (Lisp_Object window, int just_this_one_p) && (CHARPOS (startp) < ZV /* Avoid starting at end of buffer. */ || CHARPOS (startp) == BEGV - || (w->last_modified >= MODIFF - && w->last_overlay_modified >= OVERLAY_MODIFF))) + || !window_outdated (w))) { int d1, d2, d3, d4, d5, d6; @@ -27678,12 +27685,6 @@ note_mouse_highlight (struct frame *f, int x, int y) if (hlinfo->mouse_face_defer) return; - if (gc_in_progress) - { - hlinfo->mouse_face_deferred_gc = 1; - return; - } - /* Which window is that in? */ window = window_from_coordinates (f, x, y, &part, 1); 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) ASET (font_object, FONT_FORMAT_INDEX, ftfont_font_format (xftfont->pattern, filename)); font = XFONT_OBJECT (font_object); - font->pixel_size = pixel_size; + font->pixel_size = size; font->driver = &xftfont_driver; font->encoding_charset = font->repertory_charset = -1; @@ -387,8 +387,6 @@ xftfont_open (FRAME_PTR f, Lisp_Object entity, int pixel_size) xftfont_info->matrix.xy = 0x10000L * matrix->xy; xftfont_info->matrix.yx = 0x10000L * matrix->yx; } - font->pixel_size = size; - font->driver = &xftfont_driver; if (INTEGERP (AREF (entity, FONT_SPACING_INDEX))) spacing = XINT (AREF (entity, FONT_SPACING_INDEX)); 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 XTframe_up_to_date (struct frame *f) { if (FRAME_X_P (f)) - { - Mouse_HLInfo *hlinfo = MOUSE_HL_INFO (f); - - if (hlinfo->mouse_face_deferred_gc - || f == hlinfo->mouse_face_mouse_frame) - { - block_input (); - if (hlinfo->mouse_face_mouse_frame) - note_mouse_highlight (hlinfo->mouse_face_mouse_frame, - hlinfo->mouse_face_mouse_x, - hlinfo->mouse_face_mouse_y); - hlinfo->mouse_face_deferred_gc = 0; - unblock_input (); - } - } + FRAME_MOUSE_UPDATE (f); } @@ -9502,7 +9488,6 @@ x_free_frame_resources (struct frame *f) hlinfo->mouse_face_end_row = hlinfo->mouse_face_end_col = -1; hlinfo->mouse_face_window = Qnil; - hlinfo->mouse_face_deferred_gc = 0; hlinfo->mouse_face_mouse_frame = 0; } @@ -10153,7 +10138,6 @@ x_term_init (Lisp_Object display_name, char *xrm_option, char *resource_name) dpyinfo->bitmaps_last = 0; dpyinfo->scratch_cursor_gc = 0; hlinfo->mouse_face_mouse_frame = 0; - hlinfo->mouse_face_deferred_gc = 0; hlinfo->mouse_face_beg_row = hlinfo->mouse_face_beg_col = -1; hlinfo->mouse_face_end_row = hlinfo->mouse_face_end_col = -1; 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 @@ +2012-11-20 Stefan Monnier <monnier@iro.umontreal.ca> + + * automated/advice-tests.el (advice-tests--data): Remove. + (advice-tests): Move the tests directly here instead. + Add called-interactively-p tests. + +2012-11-19 Stefan Monnier <monnier@iro.umontreal.ca> + + * automated/ert-x-tests.el: Use cl-lib. + * automated/ert-tests.el: Use lexical-binding and cl-lib. + 2012-11-14 Dmitry Gutov <dgutov@yandex.ru> * automated/ruby-mode-tests.el (ruby-indent-singleton-class): Pass. @@ -5,8 +16,8 @@ (ruby-indent-inside-heredoc-after-space): New tests. Change direct font-lock face references to var references. (ruby-interpolation-suppresses-syntax-inside): New test. - (ruby-interpolation-inside-percent-literal-with-paren): New - failing test. + (ruby-interpolation-inside-percent-literal-with-paren): + New failing test. 2012-11-13 Dmitry Gutov <dgutov@yandex.ru> 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 @@ ;;; Code: -(defvar advice-tests--data - '(((defun sm-test1 (x) (+ x 4)) - (sm-test1 6) 10) - ((advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 5))) - (sm-test1 6) 50) - ((defun sm-test1 (x) (+ x 14)) - (sm-test1 6) 100) - ((null (get 'sm-test1 'defalias-fset-function)) nil) - ((advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5))) - (sm-test1 6) 20) - ((null (get 'sm-test1 'defalias-fset-function)) t) +(ert-deftest advice-tests () + "Test advice code." + (with-temp-buffer + (defun sm-test1 (x) (+ x 4)) + (should (equal (sm-test1 6) 10)) + (advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 5))) + (should (equal (sm-test1 6) 50)) + (defun sm-test1 (x) (+ x 14)) + (should (equal (sm-test1 6) 100)) + (should (equal (null (get 'sm-test1 'defalias-fset-function)) nil)) + (advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5))) + (should (equal (sm-test1 6) 20)) + (should (equal (null (get 'sm-test1 'defalias-fset-function)) t)) - ((defun sm-test2 (x) (+ x 4)) - (sm-test2 6) 10) - ((defadvice sm-test2 (around sm-test activate) + (defun sm-test2 (x) (+ x 4)) + (should (equal (sm-test2 6) 10)) + (defadvice sm-test2 (around sm-test activate) ad-do-it (setq ad-return-value (* ad-return-value 5))) - (sm-test2 6) 50) - ((ad-deactivate 'sm-test2) - (sm-test2 6) 10) - ((ad-activate 'sm-test2) - (sm-test2 6) 50) - ((defun sm-test2 (x) (+ x 14)) - (sm-test2 6) 100) - ((null (get 'sm-test2 'defalias-fset-function)) nil) - ((ad-remove-advice 'sm-test2 'around 'sm-test) - (sm-test2 6) 100) - ((ad-activate 'sm-test2) - (sm-test2 6) 20) - ((null (get 'sm-test2 'defalias-fset-function)) t) + (should (equal (sm-test2 6) 50)) + (ad-deactivate 'sm-test2) + (should (equal (sm-test2 6) 10)) + (ad-activate 'sm-test2) + (should (equal (sm-test2 6) 50)) + (defun sm-test2 (x) (+ x 14)) + (should (equal (sm-test2 6) 100)) + (should (equal (null (get 'sm-test2 'defalias-fset-function)) nil)) + (ad-remove-advice 'sm-test2 'around 'sm-test) + (should (equal (sm-test2 6) 100)) + (ad-activate 'sm-test2) + (should (equal (sm-test2 6) 20)) + (should (equal (null (get 'sm-test2 'defalias-fset-function)) t)) - ((advice-add 'sm-test3 :around + (advice-add 'sm-test3 :around (lambda (f &rest args) `(toto ,(apply f args))) '((name . wrap-with-toto))) (defmacro sm-test3 (x) `(call-test3 ,x)) - (macroexpand '(sm-test3 56)) (toto (call-test3 56))) + (should (equal (macroexpand '(sm-test3 56)) '(toto (call-test3 56)))) - ((defadvice sm-test4 (around wrap-with-toto activate) + (defadvice sm-test4 (around wrap-with-toto activate) ad-do-it (setq ad-return-value `(toto ,ad-return-value))) (defmacro sm-test4 (x) `(call-test4 ,x)) - (macroexpand '(sm-test4 56)) (toto (call-test4 56))) - ((defmacro sm-test4 (x) `(call-testq ,x)) - (macroexpand '(sm-test4 56)) (toto (call-testq 56))) + (should (equal (macroexpand '(sm-test4 56)) '(toto (call-test4 56)))) + (defmacro sm-test4 (x) `(call-testq ,x)) + (should (equal (macroexpand '(sm-test4 56)) '(toto (call-testq 56)))) ;; Combining old style and new style advices. - ((defun sm-test5 (x) (+ x 4)) - (sm-test5 6) 10) - ((advice-add 'sm-test5 :around (lambda (f y) (* (funcall f y) 5))) - (sm-test5 6) 50) - ((defadvice sm-test5 (around test activate) + (defun sm-test5 (x) (+ x 4)) + (should (equal (sm-test5 6) 10)) + (advice-add 'sm-test5 :around (lambda (f y) (* (funcall f y) 5))) + (should (equal (sm-test5 6) 50)) + (defadvice sm-test5 (around test activate) ad-do-it (setq ad-return-value (+ ad-return-value 0.1))) - (sm-test5 5) 45.1) - ((ad-deactivate 'sm-test5) - (sm-test5 6) 50) - ((ad-activate 'sm-test5) - (sm-test5 6) 50.1) - ((defun sm-test5 (x) (+ x 14)) - (sm-test5 6) 100.1) - ((advice-remove 'sm-test5 (lambda (f y) (* (funcall f y) 5))) - (sm-test5 6) 20.1) + (should (equal (sm-test5 5) 45.1)) + (ad-deactivate 'sm-test5) + (should (equal (sm-test5 6) 50)) + (ad-activate 'sm-test5) + (should (equal (sm-test5 6) 50.1)) + (defun sm-test5 (x) (+ x 14)) + (should (equal (sm-test5 6) 100.1)) + (advice-remove 'sm-test5 (lambda (f y) (* (funcall f y) 5))) + (should (equal (sm-test5 6) 20.1)) ;; This used to signal an error (bug#12858). - ((autoload 'sm-test6 "foo") + (autoload 'sm-test6 "foo") (defadvice sm-test6 (around test activate) ad-do-it) - t t) + ;; Check interaction between advice and called-interactively-p. + (defun sm-test7 (&optional x) (interactive) (+ (or x 7) 4)) + (advice-add 'sm-test7 :around + (lambda (f &rest args) + (list (cons 1 (called-interactively-p)) (apply f args)))) + (should (equal (sm-test7) '((1 . nil) 11))) + (should (equal (call-interactively 'sm-test7) '((1 . t) 11))) + (let ((smi 7)) + (advice-add 'sm-test7 :before + (lambda (&rest args) + (setq smi (called-interactively-p)))) + (should (equal (list (sm-test7) smi) + '(((1 . nil) 11) nil))) + (should (equal (list (call-interactively 'sm-test7) smi) + '(((1 . t) 11) t)))) + (advice-add 'sm-test7 :around + (lambda (f &rest args) + (cons (cons 2 (called-interactively-p)) (apply f args)))) + (should (equal (call-interactively 'sm-test7) '((2 . t) (1 . t) 11))) )) -(ert-deftest advice-tests () - "Test advice code." - (with-temp-buffer - (dolist (test advice-tests--data) - (let ((res (eval `(progn ,@(butlast test))))) - (should (equal (car (last test)) res)))))) - ;; Local Variables: ;; no-byte-compile: t ;; 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 @@ -;;; ert-tests.el --- ERT's self-tests +;;; ert-tests.el --- ERT's self-tests -*- lexical-binding: t -*- ;; Copyright (C) 2007-2008, 2010-2012 Free Software Foundation, Inc. @@ -27,7 +27,7 @@ ;;; Code: (eval-when-compile - (require 'cl)) + (require 'cl-lib)) (require 'ert) @@ -45,7 +45,7 @@ ;; The buffer name chosen here should not compete with the default ;; results buffer name for completion in `switch-to-buffer'. (let ((stats (ert-run-tests-interactively "^ert-" " *ert self-tests*"))) - (assert ert--test-body-was-run) + (cl-assert ert--test-body-was-run) (if (zerop (ert-stats-completed-unexpected stats)) ;; Hide results window only when everything went well. (set-window-configuration window-configuration) @@ -71,26 +71,26 @@ failed or if there was a problem." (ert-deftest ert-test-nested-test-body-runs () "Test that nested test bodies run." - (lexical-let ((was-run nil)) + (let ((was-run nil)) (let ((test (make-ert-test :body (lambda () (setq was-run t))))) - (assert (not was-run)) + (cl-assert (not was-run)) (ert-run-test test) - (assert was-run)))) + (cl-assert was-run)))) ;;; Test that pass/fail works. (ert-deftest ert-test-pass () (let ((test (make-ert-test :body (lambda ())))) (let ((result (ert-run-test test))) - (assert (ert-test-passed-p result))))) + (cl-assert (ert-test-passed-p result))))) (ert-deftest ert-test-fail () (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) (let ((result (let ((ert-debug-on-error nil)) (ert-run-test test)))) - (assert (ert-test-failed-p result) t) - (assert (equal (ert-test-result-with-condition-condition result) + (cl-assert (ert-test-failed-p result) t) + (cl-assert (equal (ert-test-result-with-condition-condition result) '(ert-test-failed "failure message")) t)))) @@ -100,50 +100,50 @@ failed or if there was a problem." (progn (let ((ert-debug-on-error t)) (ert-run-test test)) - (assert nil)) + (cl-assert nil)) ((error) - (assert (equal condition '(ert-test-failed "failure message")) t))))) + (cl-assert (equal condition '(ert-test-failed "failure message")) t))))) (ert-deftest ert-test-fail-debug-with-debugger-1 () (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) - (let ((debugger (lambda (&rest debugger-args) - (assert nil)))) + (let ((debugger (lambda (&rest _args) + (cl-assert nil)))) (let ((ert-debug-on-error nil)) (ert-run-test test))))) (ert-deftest ert-test-fail-debug-with-debugger-2 () (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) - (block nil - (let ((debugger (lambda (&rest debugger-args) - (return-from nil nil)))) + (cl-block nil + (let ((debugger (lambda (&rest _args) + (cl-return-from nil nil)))) (let ((ert-debug-on-error t)) (ert-run-test test)) - (assert nil))))) + (cl-assert nil))))) (ert-deftest ert-test-fail-debug-nested-with-debugger () (let ((test (make-ert-test :body (lambda () (let ((ert-debug-on-error t)) (ert-fail "failure message")))))) - (let ((debugger (lambda (&rest debugger-args) - (assert nil nil "Assertion a")))) + (let ((debugger (lambda (&rest _args) + (cl-assert nil nil "Assertion a")))) (let ((ert-debug-on-error nil)) (ert-run-test test)))) (let ((test (make-ert-test :body (lambda () (let ((ert-debug-on-error nil)) (ert-fail "failure message")))))) - (block nil - (let ((debugger (lambda (&rest debugger-args) - (return-from nil nil)))) + (cl-block nil + (let ((debugger (lambda (&rest _args) + (cl-return-from nil nil)))) (let ((ert-debug-on-error t)) (ert-run-test test)) - (assert nil nil "Assertion b"))))) + (cl-assert nil nil "Assertion b"))))) (ert-deftest ert-test-error () (let ((test (make-ert-test :body (lambda () (error "Error message"))))) (let ((result (let ((ert-debug-on-error nil)) (ert-run-test test)))) - (assert (ert-test-failed-p result) t) - (assert (equal (ert-test-result-with-condition-condition result) + (cl-assert (ert-test-failed-p result) t) + (cl-assert (equal (ert-test-result-with-condition-condition result) '(error "Error message")) t)))) @@ -153,9 +153,9 @@ failed or if there was a problem." (progn (let ((ert-debug-on-error t)) (ert-run-test test)) - (assert nil)) + (cl-assert nil)) ((error) - (assert (equal condition '(error "Error message")) t))))) + (cl-assert (equal condition '(error "Error message")) t))))) ;;; Test that `should' works. @@ -163,13 +163,13 @@ failed or if there was a problem." (let ((test (make-ert-test :body (lambda () (should nil))))) (let ((result (let ((ert-debug-on-error nil)) (ert-run-test test)))) - (assert (ert-test-failed-p result) t) - (assert (equal (ert-test-result-with-condition-condition result) + (cl-assert (ert-test-failed-p result) t) + (cl-assert (equal (ert-test-result-with-condition-condition result) '(ert-test-failed ((should nil) :form nil :value nil))) t))) (let ((test (make-ert-test :body (lambda () (should t))))) (let ((result (ert-run-test test))) - (assert (ert-test-passed-p result) t)))) + (cl-assert (ert-test-passed-p result) t)))) (ert-deftest ert-test-should-value () (should (eql (should 'foo) 'foo)) @@ -179,17 +179,18 @@ failed or if there was a problem." (let ((test (make-ert-test :body (lambda () (should-not t))))) (let ((result (let ((ert-debug-on-error nil)) (ert-run-test test)))) - (assert (ert-test-failed-p result) t) - (assert (equal (ert-test-result-with-condition-condition result) + (cl-assert (ert-test-failed-p result) t) + (cl-assert (equal (ert-test-result-with-condition-condition result) '(ert-test-failed ((should-not t) :form t :value t))) t))) (let ((test (make-ert-test :body (lambda () (should-not nil))))) (let ((result (ert-run-test test))) - (assert (ert-test-passed-p result))))) + (cl-assert (ert-test-passed-p result))))) + (ert-deftest ert-test-should-with-macrolet () (let ((test (make-ert-test :body (lambda () - (macrolet ((foo () `(progn t nil))) + (cl-macrolet ((foo () `(progn t nil))) (should (foo))))))) (let ((result (let ((ert-debug-on-error nil)) (ert-run-test test)))) @@ -303,32 +304,33 @@ This macro is used to test if macroexpansion in `should' works." (ert-deftest ert-test-should-failure-debugging () "Test that `should' errors contain the information we expect them to." - (loop for (body expected-condition) in - `((,(lambda () (let ((x nil)) (should x))) - (ert-test-failed ((should x) :form x :value nil))) - (,(lambda () (let ((x t)) (should-not x))) - (ert-test-failed ((should-not x) :form x :value t))) - (,(lambda () (let ((x t)) (should (not x)))) - (ert-test-failed ((should (not x)) :form (not t) :value nil))) - (,(lambda () (let ((x nil)) (should-not (not x)))) - (ert-test-failed ((should-not (not x)) :form (not nil) :value t))) - (,(lambda () (let ((x t) (y nil)) (should-not - (ert--test-my-list x y)))) - (ert-test-failed - ((should-not (ert--test-my-list x y)) - :form (list t nil) - :value (t nil)))) - (,(lambda () (let ((x t)) (should (error "Foo")))) - (error "Foo"))) - do - (let ((test (make-ert-test :body body))) - (condition-case actual-condition - (progn - (let ((ert-debug-on-error t)) - (ert-run-test test)) - (assert nil)) - ((error) - (should (equal actual-condition expected-condition))))))) + (cl-loop + for (body expected-condition) in + `((,(lambda () (let ((x nil)) (should x))) + (ert-test-failed ((should x) :form x :value nil))) + (,(lambda () (let ((x t)) (should-not x))) + (ert-test-failed ((should-not x) :form x :value t))) + (,(lambda () (let ((x t)) (should (not x)))) + (ert-test-failed ((should (not x)) :form (not t) :value nil))) + (,(lambda () (let ((x nil)) (should-not (not x)))) + (ert-test-failed ((should-not (not x)) :form (not nil) :value t))) + (,(lambda () (let ((x t) (y nil)) (should-not + (ert--test-my-list x y)))) + (ert-test-failed + ((should-not (ert--test-my-list x y)) + :form (list t nil) + :value (t nil)))) + (,(lambda () (let ((_x t)) (should (error "Foo")))) + (error "Foo"))) + do + (let ((test (make-ert-test :body body))) + (condition-case actual-condition + (progn + (let ((ert-debug-on-error t)) + (ert-run-test test)) + (cl-assert nil)) + ((error) + (should (equal actual-condition expected-condition))))))) (ert-deftest ert-test-deftest () (should (equal (macroexpand '(ert-deftest abc () "foo" :tags '(bar))) @@ -520,7 +522,7 @@ This macro is used to test if macroexpansion in `should' works." (setf (cdr (last a)) (cddr a)) (should (not (ert--proper-list-p a)))) (let ((a (list 1 2 3 4))) - (setf (cdr (last a)) (cdddr a)) + (setf (cdr (last a)) (cl-cdddr a)) (should (not (ert--proper-list-p a))))) (ert-deftest ert-test-parse-keys-and-body () @@ -657,14 +659,14 @@ This macro is used to test if macroexpansion in `should' works." (i 0)) (let ((result (ert--remove-if-not (lambda (x) (should (eql x (nth i list))) - (incf i) + (cl-incf i) (member i '(2 3))) list))) (should (equal i 4)) (should (equal result '(b c))) (should (equal list '(a b c d))))) (should (equal '() - (ert--remove-if-not (lambda (x) (should nil)) '())))) + (ert--remove-if-not (lambda (_x) (should nil)) '())))) (ert-deftest ert-test-remove* () (let ((list (list 'a 'b 'c 'd)) @@ -676,13 +678,13 @@ This macro is used to test if macroexpansion in `should' works." (should (eql x (nth key-index list))) (prog1 (list key-index x) - (incf key-index))) + (cl-incf key-index))) :test (lambda (a b) (should (eql a 'foo)) (should (equal b (list test-index (nth test-index list)))) - (incf test-index) + (cl-incf test-index) (member test-index '(2 3)))))) (should (equal key-index 4)) (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 @@ ;;; Code: (eval-when-compile - (require 'cl)) + (require 'cl-lib)) (require 'ert) (require 'ert-x) @@ -233,8 +233,8 @@ desired effect." (should (equal (buffer-string) "")) (let ((message-log-max 2)) (let ((message-log-max t)) - (loop for i below 4 do - (message "%s" i)) + (cl-loop for i below 4 do + (message "%s" i)) (should (equal (buffer-string) "0\n1\n2\n3\n"))) (should (equal (buffer-string) "0\n1\n2\n3\n")) (message "") @@ -244,28 +244,28 @@ desired effect." (ert-deftest ert-test-force-message-log-buffer-truncation () :tags '(:causes-redisplay) - (labels ((body () - (loop for i below 3 do - (message "%s" i))) - ;; Uses the implicit messages buffer truncation implemented - ;; in Emacs' C core. - (c (x) - (ert-with-buffer-renamed ("*Messages*") - (let ((message-log-max x)) - (body)) - (with-current-buffer "*Messages*" - (buffer-string)))) - ;; Uses our lisp reimplementation. - (lisp (x) - (ert-with-buffer-renamed ("*Messages*") - (let ((message-log-max t)) - (body)) - (let ((message-log-max x)) - (ert--force-message-log-buffer-truncation)) - (with-current-buffer "*Messages*" - (buffer-string))))) - (loop for x in '(0 1 2 3 4 t) do - (should (equal (c x) (lisp x)))))) + (cl-labels ((body () + (cl-loop for i below 3 do + (message "%s" i))) + ;; Uses the implicit messages buffer truncation implemented + ;; in Emacs' C core. + (c (x) + (ert-with-buffer-renamed ("*Messages*") + (let ((message-log-max x)) + (body)) + (with-current-buffer "*Messages*" + (buffer-string)))) + ;; Uses our lisp reimplementation. + (lisp (x) + (ert-with-buffer-renamed ("*Messages*") + (let ((message-log-max t)) + (body)) + (let ((message-log-max x)) + (ert--force-message-log-buffer-truncation)) + (with-current-buffer "*Messages*" + (buffer-string))))) + (cl-loop for x in '(0 1 2 3 4 t) do + (should (equal (c x) (lisp x)))))) (provide 'ert-x-tests) |
