Now on revision 109046. ------------------------------------------------------------ revno: 109046 committer: Glenn Morris branch nick: trunk timestamp: Wed 2012-07-11 23:34:40 -0700 message: Move FIRST_PTY_LETTER, PTY_ITERATION from src/s to configure * configure.ac (FIRST_PTY_LETTER PTY_ITERATION): Move here from src/s. * src/s/aix4-2.h, src/s/bsd-common.h, src/s/cygwin.h, src/s/darwin.h: * src/s/gnu-linux.h, src/s/hpux10-20.h, src/s/irix6-5.h, src/s/template.h: * src/s/usg5-4-common.h: Move FIRST_PTY_LETTER, PTY_ITERATION to configure. diff: === modified file 'ChangeLog' --- ChangeLog 2012-07-12 02:14:29 +0000 +++ ChangeLog 2012-07-12 06:34:40 +0000 @@ -5,7 +5,8 @@ * configure.ac (NARROWPROTO, NO_ABORT, BROKEN_GET_CURRENT_DIR_NAME) (BROKEN_FIONREAD, BROKEN_PTY_READ_AFTER_EAGAIN, BROKEN_SIGAIO) - (BROKEN_SIGPOLL, BROKEN_SIGPTY, G_SLICE_ALWAYS_MALLOC, PREFER_VSUSP) + (BROKEN_SIGPOLL, BROKEN_SIGPTY, FIRST_PTY_LETTER) + (G_SLICE_ALWAYS_MALLOC, PREFER_VSUSP, PTY_ITERATION) (RUN_TIME_REMAP, SETPGRP_RELEASES_CTTY, TAB3, TABDLY, RUN_TIME_REMAP (XOS_NEEDS_TIME_H): Move here from src/s. === modified file 'configure.ac' --- configure.ac 2012-07-12 02:14:29 +0000 +++ configure.ac 2012-07-12 06:34:40 +0000 @@ -3291,6 +3291,66 @@ esac +dnl Used in process.c, this must be a loop, even if it only runs once. +dnl (Except on SGI; see below. Take that, clarity and consistency!) +AH_TEMPLATE(PTY_ITERATION, [How to iterate over PTYs.]) +dnl Only used if !PTY_ITERATION. Iterate from FIRST_PTY_LETTER to z, +dnl trying suffixes 0-16. +AH_TEMPLATE(FIRST_PTY_LETTER, [Letter to use in finding device name of + first PTY, if PTYs are supported.]) + +case $opsys in + aix4-2 ) + AC_DEFINE(PTY_ITERATION, [int c; for (c = 0; !c ; c++)] ) + ;; + + cygwin ) + AC_DEFINE(PTY_ITERATION, [int i; for (i = 0; i < 1; i++)] ) + ;; + + darwin ) + AC_DEFINE(PTY_ITERATION, [int i; for (i = 0; i < 1; i++)] ) + dnl Not used, because PTY_ITERATION is defined. + AC_DEFINE(FIRST_PTY_LETTER, ['p']) + ;; + + gnu | hpux* | freebsd | netbsd | openbsd ) + AC_DEFINE(FIRST_PTY_LETTER, ['p']) + ;; + + gnu-linux | gnu-kfreebsd ) + dnl if HAVE_GRANTPT + if test "x$ac_cv_func_grantpt" = xyes; then + AC_DEFINE(PTY_ITERATION, [int i; for (i = 0; i < 1; i++)] ) + else + AC_DEFINE(FIRST_PTY_LETTER, ['p']) + fi + ;; + + irix6-5 ) + dnl It looks like this cannot be right, because it is not a loop. + dnl However, process.c actually does this: + dnl # ifndef __sgi + dnl continue; + dnl # else + dnl return -1; + dnl # endif + dnl which presumably makes it OK, since irix == sgi (?). + dnl FIXME it seems like this special treatment is unnecessary? + dnl Why can't irix use a single-trip loop like eg cygwin? + AC_DEFINE(PTY_ITERATION, []) + dnl Not used, because PTY_ITERATION is defined. + AC_DEFINE(FIRST_PTY_LETTER, ['q']) + ;; + + sol2* | unixware ) + dnl This change means that we don't loop through allocate_pty too + dnl many times in the (rare) event of a failure. + AC_DEFINE(FIRST_PTY_LETTER, ['z']) + ;; +esac + + AH_TEMPLATE(SIGNALS_VIA_CHARACTERS, [Make process_send_signal work by "typing" a signal character on the pty.]) === modified file 'src/ChangeLog' --- src/ChangeLog 2012-07-12 03:45:46 +0000 +++ src/ChangeLog 2012-07-12 06:34:40 +0000 @@ -1,3 +1,9 @@ +2012-07-12 Glenn Morris + + * s/aix4-2.h, s/bsd-common.h, s/cygwin.h, s/darwin.h: + * s/gnu-linux.h, s/hpux10-20.h, s/irix6-5.h, s/template.h: + * s/usg5-4-common.h: Move FIRST_PTY_LETTER, PTY_ITERATION to configure. + 2012-07-12 Dmitry Antipov Use empty_unibyte_string where applicable. === modified file 'src/s/aix4-2.h' --- src/s/aix4-2.h 2012-07-12 02:14:29 +0000 +++ src/s/aix4-2.h 2012-07-12 06:34:40 +0000 @@ -28,7 +28,6 @@ /* In AIX, you allocate a pty by opening /dev/ptc to get the master side. To get the name of the slave side, you just ttyname() the master side. */ -#define PTY_ITERATION int c; for (c = 0; !c ; c++) #define PTY_NAME_SPRINTF strcpy (pty_name, "/dev/ptc"); #define PTY_TTY_NAME_SPRINTF strcpy (pty_name, ttyname (fd)); === modified file 'src/s/bsd-common.h' --- src/s/bsd-common.h 2012-07-12 01:49:28 +0000 +++ src/s/bsd-common.h 2012-07-12 06:34:40 +0000 @@ -36,6 +36,3 @@ /* For mem-limits.h. */ #define BSD4_2 - -/* First pty name is /dev/ptyp0. */ -#define FIRST_PTY_LETTER 'p' === modified file 'src/s/cygwin.h' --- src/s/cygwin.h 2012-07-12 02:14:29 +0000 +++ src/s/cygwin.h 2012-07-12 06:34:40 +0000 @@ -17,7 +17,6 @@ You should have received a copy of the GNU General Public License along with GNU Emacs. If not, see . */ -#define PTY_ITERATION int i; for (i = 0; i < 1; i++) /* ick */ #define PTY_NAME_SPRINTF /* none */ #define PTY_TTY_NAME_SPRINTF /* none */ #define PTY_OPEN \ === modified file 'src/s/darwin.h' --- src/s/darwin.h 2012-07-12 01:49:28 +0000 +++ src/s/darwin.h 2012-07-12 06:34:40 +0000 @@ -30,12 +30,6 @@ distinguish OS X from pure Darwin. */ #define DARWIN_OS -/* Letter to use in finding device name of first pty, - if system supports pty's. 'a' means it is /dev/ptya0 */ -#define FIRST_PTY_LETTER 'p' - -/* Run only once. We need a `for'-loop because the code uses `continue'. */ -#define PTY_ITERATION int i; for (i = 0; i < 1; i++) #define PTY_NAME_SPRINTF /* none */ #define PTY_TTY_NAME_SPRINTF /* none */ /* Note that openpty may fork via grantpt on Mac OS X 10.4/Darwin 8. === modified file 'src/s/gnu-linux.h' --- src/s/gnu-linux.h 2012-07-12 00:49:24 +0000 +++ src/s/gnu-linux.h 2012-07-12 06:34:40 +0000 @@ -28,9 +28,6 @@ #if defined HAVE_GRANTPT #define UNIX98_PTYS -/* Run only once. We need a `for'-loop because the code uses `continue'. */ -#define PTY_ITERATION int i; for (i = 0; i < 1; i++) - #ifdef HAVE_GETPT #define PTY_NAME_SPRINTF #define PTY_OPEN fd = getpt () @@ -56,13 +53,7 @@ sigunblock (sigmask (SIGCHLD)); \ } -#else /* not HAVE_GRANTPT */ - -/* Letter to use in finding device name of first pty, - if system supports pty's. 'p' means it is /dev/ptyp0 */ -#define FIRST_PTY_LETTER 'p' - -#endif /* not HAVE_GRANTPT */ +#endif /* HAVE_GRANTPT */ /* Here, on a separate page, add any special hacks needed to make Emacs work on this system. For example, === modified file 'src/s/hpux10-20.h' --- src/s/hpux10-20.h 2012-07-12 01:49:28 +0000 +++ src/s/hpux10-20.h 2012-07-12 06:34:40 +0000 @@ -24,10 +24,6 @@ #define USG5 #define HPUX -/* Letter to use in finding device name of first pty, - if system supports pty's. 'p' means it is /dev/ptym/ptyp0 */ -#define FIRST_PTY_LETTER 'p' - /* Special hacks needed to make Emacs run on this system. */ /* This is how to get the device name of the tty end of a pty. */ === modified file 'src/s/irix6-5.h' --- src/s/irix6-5.h 2012-07-12 01:49:28 +0000 +++ src/s/irix6-5.h 2012-07-12 06:34:40 +0000 @@ -26,11 +26,6 @@ #undef SETUP_SLAVE_PTY -/* Letter to use in finding device name of first pty, - if system supports pty's. 'a' means it is /dev/ptya0 */ -#undef FIRST_PTY_LETTER -#define FIRST_PTY_LETTER 'q' - /* No need to use sprintf to get the tty name--we get that from _getpty. */ #define PTY_TTY_NAME_SPRINTF /* No need to get the pty name at all. */ @@ -39,8 +34,6 @@ #ifdef emacs char *_getpty(); #endif -/* We need only try once to open a pty. */ -#define PTY_ITERATION /* Here is how to do it. */ #define PTY_OPEN \ { \ === modified file 'src/s/template.h' --- src/s/template.h 2012-07-12 00:49:24 +0000 +++ src/s/template.h 2012-07-12 06:34:40 +0000 @@ -29,10 +29,6 @@ /* #define BSD4_2 */ /* #define BSD_SYSTEM */ -/* Letter to use in finding device name of first pty, - if system supports pty's. 'a' means it is /dev/ptya0. */ -#define FIRST_PTY_LETTER 'a' - /* subprocesses should be undefined if you do NOT want to have code for asynchronous subprocesses (as used in M-x compile and M-x shell). === modified file 'src/s/usg5-4-common.h' --- src/s/usg5-4-common.h 2012-07-11 23:40:59 +0000 +++ src/s/usg5-4-common.h 2012-07-12 06:34:40 +0000 @@ -64,10 +64,6 @@ this is all we need. */ #define TIOCSIGSEND TIOCSIGNAL -/* This change means that we don't loop through allocate_pty too many - times in the (rare) event of a failure. */ -#define FIRST_PTY_LETTER 'z' - /* This sets the name of the master side of the PTY. */ #define PTY_NAME_SPRINTF strcpy (pty_name, "/dev/ptmx"); ------------------------------------------------------------ revno: 109045 committer: Dmitry Antipov branch nick: trunk timestamp: Thu 2012-07-12 07:45:46 +0400 message: Use empty_unibyte_string where applicable. * keyboard.c (parse_tool_bar_item): Use empty_unibyte_string. * lread.c (read1): Likewise. * xsettings.c (syms_of_xsettings): Likewise. diff: === modified file 'src/ChangeLog' --- src/ChangeLog 2012-07-12 02:14:29 +0000 +++ src/ChangeLog 2012-07-12 03:45:46 +0000 @@ -1,3 +1,10 @@ +2012-07-12 Dmitry Antipov + + Use empty_unibyte_string where applicable. + * keyboard.c (parse_tool_bar_item): Use empty_unibyte_string. + * lread.c (read1): Likewise. + * xsettings.c (syms_of_xsettings): Likewise. + 2012-07-12 Glenn Morris * s/cygwin.h (G_SLICE_ALWAYS_MALLOC): === modified file 'src/keyboard.c' --- src/keyboard.c 2012-07-10 23:24:36 +0000 +++ src/keyboard.c 2012-07-12 03:45:46 +0000 @@ -8331,7 +8331,7 @@ if (SCHARS (new_lbl) <= tool_bar_max_label_size) PROP (TOOL_BAR_ITEM_LABEL) = new_lbl; else - PROP (TOOL_BAR_ITEM_LABEL) = make_string ("", 0); + PROP (TOOL_BAR_ITEM_LABEL) = empty_unibyte_string; xfree (buf); } === modified file 'src/lread.c' --- src/lread.c 2012-07-11 08:33:04 +0000 +++ src/lread.c 2012-07-12 03:45:46 +0000 @@ -2670,13 +2670,13 @@ /* No symbol character follows, this is the empty symbol. */ UNREAD (c); - return Fmake_symbol (build_string ("")); + return Fmake_symbol (empty_unibyte_string); } goto read_symbol; } /* ## is the empty symbol. */ if (c == '#') - return Fintern (build_string (""), Qnil); + return Fintern (empty_unibyte_string, Qnil); /* Reader forms that can reuse previously read objects. */ if (c >= '0' && c <= '9') { === modified file 'src/xsettings.c' --- src/xsettings.c 2012-07-09 12:02:27 +0000 +++ src/xsettings.c 2012-07-12 03:45:46 +0000 @@ -1035,7 +1035,7 @@ DEFVAR_LISP ("xft-settings", Vxft_settings, doc: /* Font settings applied to Xft. */); - Vxft_settings = make_string ("", 0); + Vxft_settings = empty_unibyte_string; #ifdef HAVE_XFT Fprovide (intern_c_string ("font-render-setting"), Qnil); ------------------------------------------------------------ revno: 109044 committer: Glenn Morris branch nick: trunk timestamp: Wed 2012-07-11 22:14:29 -0400 message: Move more things from src/s to configure * configure.ac (BROKEN_GET_CURRENT_DIR_NAME, BROKEN_PTY_READ_AFTER_EAGAIN) (G_SLICE_ALWAYS_MALLOC): Move here from src/s. * src/s/freebsd.h (BROKEN_PTY_READ_AFTER_EAGAIN): * src/s/cygwin.h (G_SLICE_ALWAYS_MALLOC): * src/s/aix4-2.h (BROKEN_GET_CURRENT_DIR_NAME): Let configure set them. diff: === modified file 'ChangeLog' --- ChangeLog 2012-07-12 01:49:28 +0000 +++ ChangeLog 2012-07-12 02:14:29 +0000 @@ -3,9 +3,10 @@ * configure.ac (NO_MATHERR): Unconditionally define for Darwin; as src/s/darwin.h used to. - * configure.ac (NARROWPROTO, NO_ABORT, BROKEN_FIONREAD, BROKEN_SIGAIO) - (BROKEN_SIGPOLL, BROKEN_SIGPTY, PREFER_VSUSP, RUN_TIME_REMAP) - (SETPGRP_RELEASES_CTTY, TAB3, TABDLY, RUN_TIME_REMAP + * configure.ac (NARROWPROTO, NO_ABORT, BROKEN_GET_CURRENT_DIR_NAME) + (BROKEN_FIONREAD, BROKEN_PTY_READ_AFTER_EAGAIN, BROKEN_SIGAIO) + (BROKEN_SIGPOLL, BROKEN_SIGPTY, G_SLICE_ALWAYS_MALLOC, PREFER_VSUSP) + (RUN_TIME_REMAP, SETPGRP_RELEASES_CTTY, TAB3, TABDLY, RUN_TIME_REMAP (XOS_NEEDS_TIME_H): Move here from src/s. 2012-07-11 Glenn Morris === modified file 'configure.ac' --- configure.ac 2012-07-12 01:49:28 +0000 +++ configure.ac 2012-07-12 02:14:29 +0000 @@ -2722,11 +2722,14 @@ touchlock \ cfmakeraw cfsetspeed copysign __executable_start) +dnl FIXME Fragile: something else may test for getwd as a dependency. +dnl Change to defining BROKEN_xxx ? dnl getwd appears to be buggy on SVR4.2, so we don't use it. if test $opsys != unixware; then AC_CHECK_FUNCS(getwd) fi +dnl FIXME Fragile: see above. ## Eric Backus 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. @@ -3171,6 +3174,47 @@ AC_DEFINE(BROKEN_SIGAIO, 1, [Define if SIGAIO should not be used.]) AC_DEFINE(BROKEN_SIGPOLL,1, [Define if SIGPOLL should not be used.]) AC_DEFINE(BROKEN_SIGPTY, 1, [Define if SIGPTY should not be used.]) + + dnl On AIX Emacs uses the gmalloc.c malloc implementation. But given + dnl the way this system works, libc functions that return malloced + dnl memory use the libc malloc implementation. Calling xfree or + dnl xrealloc on the results of such functions results in a crash. + dnl + dnl One solution for this could be to define SYSTEM_MALLOC in configure, + dnl but that does not currently work on this system. + dnl + dnl It is possible to completely override the malloc implementation on + dnl AIX, but that involves putting the malloc functions in a shared + dnl library and setting the MALLOCTYPE environment variable to point to + dnl that shared library. + dnl + dnl Emacs currently calls xrealloc on the results of get_current_dir name, + dnl to avoid a crash just use the Emacs implementation for that function. + dnl + dnl FIXME We could change the AC_CHECK_FUNCS call near the start + dnl of this file, so that we do not check for get_current_dir_name + dnl on AIX. But that might be fragile if something else ends + dnl up testing for get_current_dir_name as a dependency. + AC_DEFINE(BROKEN_GET_CURRENT_DIR_NAME, 1, [Define if + get_current_dir_name should not be used.]) + ;; + + freebsd) + dnl Circumvent a bug in FreeBSD. In the following sequence of + dnl writes/reads on a PTY, read(2) returns bogus data: + dnl + dnl write(2) 1022 bytes + dnl write(2) 954 bytes, get EAGAIN + dnl read(2) 1024 bytes in process_read_output + dnl read(2) 11 bytes in process_read_output + dnl + dnl That is, read(2) returns more bytes than have ever been written + dnl successfully. The 1033 bytes read are the 1022 bytes written + dnl successfully after processing (for example with CRs added if the + dnl terminal is set up that way which it is here). The same bytes will + dnl be seen again in a later read(2), without the CRs. + AC_DEFINE(BROKEN_PTY_READ_AFTER_EAGAIN, 1, [Define on FreeBSD to + work around an issue when reading from a PTY.]) ;; dnl Define the following so emacs symbols will not conflict with those @@ -3393,6 +3437,16 @@ case $opsys in + dnl Emacs supplies its own malloc, but glib (part of Gtk+) calls + dnl memalign and on Cygwin, that becomes the Cygwin-supplied memalign. + dnl As malloc is not the Cygwin malloc, the Cygwin memalign always + dnl returns ENOSYS. A workaround is to set G_SLICE=always-malloc. */ + cygwin) + AC_DEFINE(G_SLICE_ALWAYS_MALLOC, 1, [Define to set the + G_SLICE environment variable to "always-malloc" at startup, if + using GTK.]) + ;; + gnu) opsysfile="s/bsd-common.h" ;; gnu-kfreebsd) opsysfile="s/gnu-linux.h" ;; === modified file 'src/ChangeLog' --- src/ChangeLog 2012-07-12 01:49:28 +0000 +++ src/ChangeLog 2012-07-12 02:14:29 +0000 @@ -1,5 +1,7 @@ 2012-07-12 Glenn Morris + * s/cygwin.h (G_SLICE_ALWAYS_MALLOC): + * s/freebsd.h (BROKEN_PTY_READ_AFTER_EAGAIN): * s/irix6-5.h (SETPGRP_RELEASES_CTTY, PREFER_VSUSP): * s/hpux10-20.h (RUN_TIME_REMAP): * s/bsd-common.h (TABDLY): Move to configure. @@ -9,7 +11,7 @@ * s/bsd-common.h, s/darwin.h: Move TAB3 to configure. * s/aix4-2.h (BROKEN_FIONREAD, BROKEN_SIGAIO, BROKEN_SIGPTY) - (BROKEN_SIGPOLL): Let configure set them. + (BROKEN_SIGPOLL, BROKEN_GET_CURRENT_DIR_NAME): Let configure set them. * s/darwin.h (NO_ABORT, NO_MATHERR): Let configure set them. === modified file 'src/s/aix4-2.h' --- src/s/aix4-2.h 2012-07-12 01:18:45 +0000 +++ src/s/aix4-2.h 2012-07-12 02:14:29 +0000 @@ -43,23 +43,6 @@ #define NO_EDITRES #endif -/* On AIX Emacs uses the gmalloc.c malloc implementation. But given - the way this system works, libc functions that return malloced - memory use the libc malloc implementation. Calling xfree or - xrealloc on the results of such functions results in a crash. - - One solution for this could be to define SYSTEM_MALLOC in configure, - but that does not currently work on this system. - - It is possible to completely override the malloc implementation on - AIX, but that involves putting the malloc functions in a shared - library and setting the MALLOCTYPE environment variable to point to - that shared library. - - Emacs currently calls xrealloc on the results of get_current_dir name, - to avoid a crash just use the Emacs implementation for that function. */ -#define BROKEN_GET_CURRENT_DIR_NAME 1 - /* Conservative garbage collection has not been tested, so for now play it safe and stick with the old-fashioned way of marking. */ #define GC_MARK_STACK GC_USE_GCPROS_AS_BEFORE === modified file 'src/s/cygwin.h' --- src/s/cygwin.h 2012-07-12 00:49:24 +0000 +++ src/s/cygwin.h 2012-07-12 02:14:29 +0000 @@ -36,9 +36,3 @@ /* Used in various places to enable cygwin-specific code changes. */ #define CYGWIN 1 - -/* Emacs supplies its own malloc, but glib (part of Gtk+) calls - memalign and on Cygwin, that becomes the Cygwin-supplied memalign. - As malloc is not the Cygwin malloc, the Cygwin memalign always - returns ENOSYS. A workaround is to set G_SLICE=always-malloc. */ -#define G_SLICE_ALWAYS_MALLOC === modified file 'src/s/freebsd.h' --- src/s/freebsd.h 2012-07-11 02:29:13 +0000 +++ src/s/freebsd.h 2012-07-12 02:14:29 +0000 @@ -33,21 +33,6 @@ #define BSD_SYSTEM 199506 #endif -/* Circumvent a bug in FreeBSD. In the following sequence of - writes/reads on a PTY, read(2) returns bogus data: - - write(2) 1022 bytes - write(2) 954 bytes, get EAGAIN - read(2) 1024 bytes in process_read_output - read(2) 11 bytes in process_read_output - - That is, read(2) returns more bytes than have ever been written - successfully. The 1033 bytes read are the 1022 bytes written - successfully after processing (for example with CRs added if the - terminal is set up that way which it is here). The same bytes will - be seen again in a later read(2), without the CRs. */ -#define BROKEN_PTY_READ_AFTER_EAGAIN 1 - /* Tell that garbage collector that setjmp is known to save all registers relevant for conservative garbage collection in the jmp_buf. */ #define GC_SETJMP_WORKS 1 ------------------------------------------------------------ revno: 109043 committer: Glenn Morris branch nick: trunk timestamp: Wed 2012-07-11 21:49:28 -0400 message: Move more stuff from src/s to configure * configure.ac (PREFER_VSUSP, RUN_TIME_REMAP, SETPGRP_RELEASES_CTTY) (TAB3, TABDLY, RUN_TIME_REMAP, XOS_NEEDS_TIME_H): Move here from src/s. * src/s/bsd-common.h, src/s/darwin.h: Move TAB3 to configure. * src/s/hpux10-20.h, src/s/sol2-6.h: Move XOS_NEEDS_TIME_H to configure. * src/s/irix6-5.h (SETPGRP_RELEASES_CTTY, PREFER_VSUSP): * src/s/hpux10-20.h (RUN_TIME_REMAP): * src/s/bsd-common.h (TABDLY): Move to configure. diff: === modified file 'ChangeLog' --- ChangeLog 2012-07-12 01:18:45 +0000 +++ ChangeLog 2012-07-12 01:49:28 +0000 @@ -3,8 +3,10 @@ * configure.ac (NO_MATHERR): Unconditionally define for Darwin; as src/s/darwin.h used to. - * configure.ac (NARROWPROTO, NO_ABORT, BROKEN_FIONREAD, BROKEN_SIGAIO): - (BROKEN_SIGPOLL, BROKEN_SIGPTY): Move here from src/s. + * configure.ac (NARROWPROTO, NO_ABORT, BROKEN_FIONREAD, BROKEN_SIGAIO) + (BROKEN_SIGPOLL, BROKEN_SIGPTY, PREFER_VSUSP, RUN_TIME_REMAP) + (SETPGRP_RELEASES_CTTY, TAB3, TABDLY, RUN_TIME_REMAP + (XOS_NEEDS_TIME_H): Move here from src/s. 2012-07-11 Glenn Morris === modified file 'configure.ac' --- configure.ac 2012-07-12 01:18:45 +0000 +++ configure.ac 2012-07-12 01:49:28 +0000 @@ -3365,33 +3365,67 @@ ;; esac -case $opsys in - gnu) opsysfile="s/bsd-common.h" ;; - - gnu-kfreebsd) opsysfile="s/gnu-linux.h" ;; - - hpux11) - dnl See comments in sysdep.c:sys_signal. - dnl SA_RESTART resets the timeout of `select' on hpux11. - dnl Defining BROKEN_SA_RESTART is not the same as undef'ing SA_RESTART. - AC_DEFINE(BROKEN_SA_RESTART, 1, [Define if SA_RESTART should only - be used in batch mode.]) - dnl It works to open the pty's tty in the parent (Emacs), then - dnl close and reopen it in the child. - AC_DEFINE(USG_SUBTTY_WORKS, 1, [Define for USG systems where it - works to open a pty's tty in the parent process, then close and - reopen it in the child.]) - - opsysfile="s/hpux10-20.h" - ;; - - openbsd) opsysfile="s/netbsd.h" ;; - - sol2-10) - AC_DEFINE(_STRUCTURED_PROC, 1, [Needed for system_process_attributes - on Solaris.]) - opsysfile="s/sol2-6.h" - ;; + +AH_TEMPLATE(TAB3, [Undocumented.]) + +case $opsys in + darwin) AC_DEFINE(TAB3, OXTABS) ;; + + gnu | freebsd | netbsd | openbsd ) + AC_DEFINE(TABDLY, OXTABS, [Undocumented.] ) + AC_DEFINE(TAB3, OXTABS) + ;; + + hpux*) + AC_DEFINE(RUN_TIME_REMAP, 1, [Define if emacs.c needs to call + run_time_remap; for HPUX.]) + ;; +esac + + +dnl Used in xfaces.c. +case $opsys in + hpux* | sol2* ) + AC_DEFINE(XOS_NEEDS_TIME_H, 1, [Compensate for a bug in Xos.h on + some systems, where it requires time.h.]) + ;; +esac + + +case $opsys in + gnu) opsysfile="s/bsd-common.h" ;; + + gnu-kfreebsd) opsysfile="s/gnu-linux.h" ;; + + hpux11) + dnl See comments in sysdep.c:sys_signal. + dnl SA_RESTART resets the timeout of `select' on hpux11. + dnl Defining BROKEN_SA_RESTART is not the same as undef'ing SA_RESTART. + AC_DEFINE(BROKEN_SA_RESTART, 1, [Define if SA_RESTART should only + be used in batch mode.]) + dnl It works to open the pty's tty in the parent (Emacs), then + dnl close and reopen it in the child. + AC_DEFINE(USG_SUBTTY_WORKS, 1, [Define for USG systems where it + works to open a pty's tty in the parent process, then close and + reopen it in the child.]) + + opsysfile="s/hpux10-20.h" + ;; + + irix6-5) + AC_DEFINE(PREFER_VSUSP, 1, [Define if process_send_signal should + use VSUSP instead of VSWTCH.]) + AC_DEFINE(SETPGRP_RELEASES_CTTY, 1, [Define if process.c:child_setup + should not call setpgrp.]) + ;; + + openbsd) opsysfile="s/netbsd.h" ;; + + sol2-10) + AC_DEFINE(_STRUCTURED_PROC, 1, [Needed for system_process_attributes + on Solaris.]) + opsysfile="s/sol2-6.h" + ;; esac # Set up the CFLAGS for real compilation, so we can substitute it. === modified file 'src/ChangeLog' --- src/ChangeLog 2012-07-12 01:18:45 +0000 +++ src/ChangeLog 2012-07-12 01:49:28 +0000 @@ -1,5 +1,13 @@ 2012-07-12 Glenn Morris + * s/irix6-5.h (SETPGRP_RELEASES_CTTY, PREFER_VSUSP): + * s/hpux10-20.h (RUN_TIME_REMAP): + * s/bsd-common.h (TABDLY): Move to configure. + + * s/hpux10-20.h, s/sol2-6.h: Move XOS_NEEDS_TIME_H to configure. + + * s/bsd-common.h, s/darwin.h: Move TAB3 to configure. + * s/aix4-2.h (BROKEN_FIONREAD, BROKEN_SIGAIO, BROKEN_SIGPTY) (BROKEN_SIGPOLL): Let configure set them. === modified file 'src/s/bsd-common.h' --- src/s/bsd-common.h 2012-07-12 00:49:24 +0000 +++ src/s/bsd-common.h 2012-07-12 01:49:28 +0000 @@ -37,8 +37,5 @@ /* For mem-limits.h. */ #define BSD4_2 -#define TABDLY OXTABS -#define TAB3 OXTABS - /* First pty name is /dev/ptyp0. */ #define FIRST_PTY_LETTER 'p' === modified file 'src/s/darwin.h' --- src/s/darwin.h 2012-07-12 01:14:56 +0000 +++ src/s/darwin.h 2012-07-12 01:49:28 +0000 @@ -60,9 +60,6 @@ also the name of a Mach system call. */ #define init_process emacs_init_process -/* System uses OXTABS instead of the expected TAB3. (Copied from bsd386.h.) */ -#define TAB3 OXTABS - /* Definitions for how to compile & link. */ #ifdef HAVE_NS #define SYSTEM_PURESIZE_EXTRA 200000 === modified file 'src/s/hpux10-20.h' --- src/s/hpux10-20.h 2012-07-11 23:40:59 +0000 +++ src/s/hpux10-20.h 2012-07-12 01:49:28 +0000 @@ -18,8 +18,6 @@ along with GNU Emacs. If not, see . */ -#define RUN_TIME_REMAP - /* Define symbols to identify the version of Unix this is. Define all the symbols that apply correctly. */ #define USG /* System III, System V, etc */ @@ -40,9 +38,6 @@ #define PTY_NAME_SPRINTF \ sprintf (pty_name, "/dev/ptym/pty%c%x", c, i); -/* This triggers a conditional in xfaces.c. */ -#define XOS_NEEDS_TIME_H - /* Assar Westerlund says this is necessary for HP-UX 10.20, and that it works for HP-UX 0 as well. */ #define NO_EDITRES === modified file 'src/s/irix6-5.h' --- src/s/irix6-5.h 2012-07-12 00:49:24 +0000 +++ src/s/irix6-5.h 2012-07-12 01:49:28 +0000 @@ -24,8 +24,6 @@ #undef _longjmp /* use system versions, not conservative aliases */ #undef _setjmp -#define SETPGRP_RELEASES_CTTY - #undef SETUP_SLAVE_PTY /* Letter to use in finding device name of first pty, @@ -67,9 +65,6 @@ /* Ulimit(UL_GMEMLIM) is busted... */ #define ULIMIT_BREAK_VALUE 0x14000000 -/* Tell process_send_signal to use VSUSP instead of VSWTCH. */ -#define PREFER_VSUSP - #undef SA_RESTART /* not the same as defining BROKEN_SA_RESTART */ #undef TIOCSIGSEND /* defined in usg5-4-common.h */ === modified file 'src/s/sol2-6.h' --- src/s/sol2-6.h 2012-07-11 23:44:03 +0000 +++ src/s/sol2-6.h 2012-07-12 01:49:28 +0000 @@ -21,9 +21,6 @@ #define SOLARIS2 -/* This triggers a conditional in xfaces.c. */ -#define XOS_NEEDS_TIME_H - /* This is the same definition as in usg5-4-common.h, but with sigblock/sigunblock rather than sighold/sigrelse, which appear to be BSD4.1 specific. It may also be appropriate for SVR4.x ------------------------------------------------------------ revno: 109042 committer: Glenn Morris branch nick: trunk timestamp: Wed 2012-07-11 21:18:45 -0400 message: Move some AIX defines from src/s to configure * configure.ac (BROKEN_FIONREAD, BROKEN_SIGAIO, BROKEN_SIGPOLL) (BROKEN_SIGPTY): Move here from src/s. * src/s/aix4-2.h (BROKEN_FIONREAD, BROKEN_SIGAIO, BROKEN_SIGPTY) (BROKEN_SIGPOLL): Let configure set them. * src/s/syssignal.h: Comment fix. diff: === modified file 'ChangeLog' --- ChangeLog 2012-07-12 01:14:56 +0000 +++ ChangeLog 2012-07-12 01:18:45 +0000 @@ -3,7 +3,8 @@ * configure.ac (NO_MATHERR): Unconditionally define for Darwin; as src/s/darwin.h used to. - * configure.ac (NARROWPROTO, NO_ABORT): Move here from src/s. + * configure.ac (NARROWPROTO, NO_ABORT, BROKEN_FIONREAD, BROKEN_SIGAIO): + (BROKEN_SIGPOLL, BROKEN_SIGPTY): Move here from src/s. 2012-07-11 Glenn Morris === modified file 'configure.ac' --- configure.ac 2012-07-12 01:14:56 +0000 +++ configure.ac 2012-07-12 01:18:45 +0000 @@ -3152,13 +3152,27 @@ ;; esac -dnl SIGIO exists, but the feature doesn't work in the way Emacs needs. -dnl See eg . + case $opsys in + dnl SIGIO exists, but the feature doesn't work in the way Emacs needs. + dnl See eg . hpux* | irix6-5 | openbsd | sol2* | unixware ) AC_DEFINE(BROKEN_SIGIO, 1, [Define if SIGIO should not be used.]) ;; + aix4-2) + dnl BUILD 9008 - FIONREAD problem still exists in X-Windows. + AC_DEFINE(BROKEN_FIONREAD, 1, [Define if FIONREAD should not be used.]) + dnl As we define BROKEN_FIONREAD, SIGIO will be undefined in systty.h. + dnl But, on AIX, SIGAIO, SIGPTY, and SIGPOLL are defined as SIGIO, + dnl which causes compilation error at init_signals in sysdep.c. + dnl So, we define these macros so that syssignal.h detects them + dnl and undefine SIGAIO, SIGPTY and SIGPOLL. + AC_DEFINE(BROKEN_SIGAIO, 1, [Define if SIGAIO should not be used.]) + AC_DEFINE(BROKEN_SIGPOLL,1, [Define if SIGPOLL should not be used.]) + AC_DEFINE(BROKEN_SIGPTY, 1, [Define if SIGPTY should not be used.]) + ;; + dnl Define the following so emacs symbols will not conflict with those dnl in the System framework. Otherwise -prebind will not work. darwin) === modified file 'src/ChangeLog' --- src/ChangeLog 2012-07-12 01:14:56 +0000 +++ src/ChangeLog 2012-07-12 01:18:45 +0000 @@ -1,6 +1,9 @@ 2012-07-12 Glenn Morris - * s/darwin.h (NO_ABORT, NO_MATHERR): Let configure set it. + * s/aix4-2.h (BROKEN_FIONREAD, BROKEN_SIGAIO, BROKEN_SIGPTY) + (BROKEN_SIGPOLL): Let configure set them. + + * s/darwin.h (NO_ABORT, NO_MATHERR): Let configure set them. * s/bsd-common.h, s/cygwin.h, s/gnu-linux.h, s/irix6-5.h: * s/template.h: Move NARROWPROTO to configure. === modified file 'src/s/aix4-2.h' --- src/s/aix4-2.h 2012-07-11 23:40:59 +0000 +++ src/s/aix4-2.h 2012-07-12 01:18:45 +0000 @@ -60,17 +60,6 @@ to avoid a crash just use the Emacs implementation for that function. */ #define BROKEN_GET_CURRENT_DIR_NAME 1 -/*** BUILD 9008 - FIONREAD problem still exists in X-Windows. ***/ -#define BROKEN_FIONREAD -/* As we define BROKEN_FIONREAD, SIGIO will be undefined in systty.h. - But, on AIX, SIGAIO, SIGPTY, and SIGPOLL are defined as SIGIO, - which causes compilation error at init_signals in sysdep.c. So, we - define these macros so that syssignal.h detects them and undefine - SIGAIO, SIGPTY and SIGPOLL. */ -#define BROKEN_SIGAIO -#define BROKEN_SIGPTY -#define BROKEN_SIGPOLL - /* Conservative garbage collection has not been tested, so for now play it safe and stick with the old-fashioned way of marking. */ #define GC_MARK_STACK GC_USE_GCPROS_AS_BEFORE === modified file 'src/syssignal.h' --- src/syssignal.h 2012-06-24 17:39:14 +0000 +++ src/syssignal.h 2012-07-12 01:18:45 +0000 @@ -86,15 +86,13 @@ #if defined (SIGIO) && defined (BROKEN_SIGIO) # undef SIGIO #endif -/* Last user: m/ibmrs6000.h */ +/* These are only used by AIX */ #if defined (SIGPOLL) && defined (BROKEN_SIGPOLL) #undef SIGPOLL #endif -/* Last user: m/ibmrs6000.h */ #if defined (SIGAIO) && defined (BROKEN_SIGAIO) #undef SIGAIO #endif -/* Last user: m/ibmrs6000.h */ #if defined (SIGPTY) && defined (BROKEN_SIGPTY) #undef SIGPTY #endif ------------------------------------------------------------ revno: 109041 committer: Glenn Morris branch nick: trunk timestamp: Wed 2012-07-11 21:14:56 -0400 message: Move NO_ABORT from src/s to configure * configure.ac (NO_ABORT): Move here from src/s. * src/s/darwin.h (NO_ABORT): Let configure set it. diff: === modified file 'ChangeLog' --- ChangeLog 2012-07-12 01:11:37 +0000 +++ ChangeLog 2012-07-12 01:14:56 +0000 @@ -3,7 +3,7 @@ * configure.ac (NO_MATHERR): Unconditionally define for Darwin; as src/s/darwin.h used to. - * configure.ac (NARROWPROTO): Move here from src/s. + * configure.ac (NARROWPROTO, NO_ABORT): Move here from src/s. 2012-07-11 Glenn Morris === modified file 'configure.ac' --- configure.ac 2012-07-12 01:11:37 +0000 +++ configure.ac 2012-07-12 01:14:56 +0000 @@ -3157,7 +3157,13 @@ case $opsys in hpux* | irix6-5 | openbsd | sol2* | unixware ) AC_DEFINE(BROKEN_SIGIO, 1, [Define if SIGIO should not be used.]) - ;; + ;; + + dnl Define the following so emacs symbols will not conflict with those + dnl in the System framework. Otherwise -prebind will not work. + darwin) + AC_DEFINE(NO_ABORT, 1, [Do not define abort in emacs.c.]) + ;; esac case $opsys in === modified file 'src/ChangeLog' --- src/ChangeLog 2012-07-12 01:11:37 +0000 +++ src/ChangeLog 2012-07-12 01:14:56 +0000 @@ -1,6 +1,6 @@ 2012-07-12 Glenn Morris - * s/darwin.h (NO_MATHERR): Let configure set it. + * s/darwin.h (NO_ABORT, NO_MATHERR): Let configure set it. * s/bsd-common.h, s/cygwin.h, s/gnu-linux.h, s/irix6-5.h: * s/template.h: Move NARROWPROTO to configure. === modified file 'src/s/darwin.h' --- src/s/darwin.h 2012-07-12 01:11:37 +0000 +++ src/s/darwin.h 2012-07-12 01:14:56 +0000 @@ -76,12 +76,6 @@ #undef HAVE_POSIX_MEMALIGN #endif -/* Define the following so emacs symbols will not conflict with those - in the System framework. Otherwise -prebind will not work. */ - -/* Do not define abort in emacs.c. */ -#define NO_ABORT - /* The following solves the problem that Emacs hangs when evaluating (make-comint "test0" "/nodir/nofile" nil "") when /nodir/nofile does not exist. Also, setsid is not allowed in the vfork child's ------------------------------------------------------------ revno: 109040 committer: Glenn Morris branch nick: trunk timestamp: Wed 2012-07-11 21:11:37 -0400 message: Move setting of NO_MATHERR for Darwin from src/s to configure * configure.ac (NO_MATHERR): Unconditionally define for Darwin; as src/s/darwin.h used to. * src/s/darwin.h (NO_MATHERR): Let configure set it. diff: === modified file 'ChangeLog' --- ChangeLog 2012-07-12 00:49:24 +0000 +++ ChangeLog 2012-07-12 01:11:37 +0000 @@ -1,5 +1,8 @@ 2012-07-12 Glenn Morris + * configure.ac (NO_MATHERR): Unconditionally define for Darwin; + as src/s/darwin.h used to. + * configure.ac (NARROWPROTO): Move here from src/s. 2012-07-11 Glenn Morris === modified file 'configure.ac' --- configure.ac 2012-07-12 00:49:24 +0000 +++ configure.ac 2012-07-12 01:11:37 +0000 @@ -1266,7 +1266,9 @@ [[static struct exception x; x.arg1 = x.arg2 = x.retval; x.name = ""; x.type = 1;]])], emacs_cv_struct_exception=yes, emacs_cv_struct_exception=no)) HAVE_EXCEPTION=$emacs_cv_struct_exception -if test $emacs_cv_struct_exception != yes; then +dnl Define on Darwin so emacs symbols will not conflict with those +dnl in the System framework. Otherwise -prebind will not work. +if test $emacs_cv_struct_exception != yes || test $opsys = darwin; then AC_DEFINE(NO_MATHERR, 1, [Define to 1 if you don't have struct exception in math.h.]) fi === modified file 'src/ChangeLog' --- src/ChangeLog 2012-07-12 00:49:24 +0000 +++ src/ChangeLog 2012-07-12 01:11:37 +0000 @@ -1,5 +1,7 @@ 2012-07-12 Glenn Morris + * s/darwin.h (NO_MATHERR): Let configure set it. + * s/bsd-common.h, s/cygwin.h, s/gnu-linux.h, s/irix6-5.h: * s/template.h: Move NARROWPROTO to configure. === modified file 'src/s/darwin.h' --- src/s/darwin.h 2012-07-11 23:40:59 +0000 +++ src/s/darwin.h 2012-07-12 01:11:37 +0000 @@ -82,9 +82,6 @@ /* Do not define abort in emacs.c. */ #define NO_ABORT -/* Do not define matherr in floatfns.c. */ -#define NO_MATHERR - /* The following solves the problem that Emacs hangs when evaluating (make-comint "test0" "/nodir/nofile" nil "") when /nodir/nofile does not exist. Also, setsid is not allowed in the vfork child's ------------------------------------------------------------ revno: 109039 committer: Glenn Morris branch nick: trunk timestamp: Wed 2012-07-11 20:49:24 -0400 message: Move NARROWPROTO from src/s to configure * configure.ac (NARROWPROTO): Move here from src/s. * src/s/bsd-common.h, src/s/cygwin.h, src/s/gnu-linux.h, src/s/irix6-5.h: * src/s/template.h: Move NARROWPROTO to configure. diff: === modified file 'ChangeLog' --- ChangeLog 2012-07-11 23:40:59 +0000 +++ ChangeLog 2012-07-12 00:49:24 +0000 @@ -1,3 +1,7 @@ +2012-07-12 Glenn Morris + + * configure.ac (NARROWPROTO): Move here from src/s. + 2012-07-11 Glenn Morris * configure.ac (INTERRUPT_INPUT): Move here from src/s. === modified file 'configure.ac' --- configure.ac 2012-07-11 23:40:59 +0000 +++ configure.ac 2012-07-12 00:49:24 +0000 @@ -3212,6 +3212,19 @@ esac +dnl If the system's imake configuration file defines `NeedWidePrototypes' +dnl as `NO', we must define NARROWPROTO manually. Such a define is +dnl generated in the Makefile generated by `xmkmf'. If we don't define +dnl NARROWPROTO, we will see the wrong function prototypes for X functions +dnl taking float or double parameters. +case $opsys in + cygwin|gnu|gnu-linux|gnu-kfreebsd|irix6-5|freebsd|netbsd|openbsd) + AC_DEFINE(NARROWPROTO, 1, [Define if system's imake configuration + file defines `NeedWidePrototypes' as `NO'.]) + ;; +esac + + AH_TEMPLATE(SIGNALS_VIA_CHARACTERS, [Make process_send_signal work by "typing" a signal character on the pty.]) === modified file 'src/ChangeLog' --- src/ChangeLog 2012-07-11 23:44:03 +0000 +++ src/ChangeLog 2012-07-12 00:49:24 +0000 @@ -1,3 +1,8 @@ +2012-07-12 Glenn Morris + + * s/bsd-common.h, s/cygwin.h, s/gnu-linux.h, s/irix6-5.h: + * s/template.h: Move NARROWPROTO to configure. + 2012-07-11 Glenn Morris * s/gnu-linux.h, s/sol2-6.h: No longer define POSIX, === modified file 'src/s/bsd-common.h' --- src/s/bsd-common.h 2012-07-11 23:40:59 +0000 +++ src/s/bsd-common.h 2012-07-12 00:49:24 +0000 @@ -40,12 +40,5 @@ #define TABDLY OXTABS #define TAB3 OXTABS -/* If the system's imake configuration file defines `NeedWidePrototypes' - as `NO', we must define NARROWPROTO manually. Such a define is - generated in the Makefile generated by `xmkmf'. If we don't - define NARROWPROTO, we will see the wrong function prototypes - for X functions taking float or double parameters. */ -#define NARROWPROTO 1 - /* First pty name is /dev/ptyp0. */ #define FIRST_PTY_LETTER 'p' === modified file 'src/s/cygwin.h' --- src/s/cygwin.h 2012-07-11 23:40:59 +0000 +++ src/s/cygwin.h 2012-07-12 00:49:24 +0000 @@ -34,13 +34,6 @@ } \ while (0) -/* If the system's imake configuration file defines `NeedWidePrototypes' - as `NO', we must define NARROWPROTO manually. Such a define is - generated in the Makefile generated by `xmkmf'. If we don't - define NARROWPROTO, we will see the wrong function prototypes - for X functions taking float or double parameters. */ -#define NARROWPROTO 1 - /* Used in various places to enable cygwin-specific code changes. */ #define CYGWIN 1 === modified file 'src/s/gnu-linux.h' --- src/s/gnu-linux.h 2012-07-11 23:44:03 +0000 +++ src/s/gnu-linux.h 2012-07-12 00:49:24 +0000 @@ -79,8 +79,6 @@ #define HAVE_XRMSETDATABASE #endif -#define NARROWPROTO 1 - #ifdef __ia64__ #define GC_MARK_SECONDARY_STACK() \ do { \ === modified file 'src/s/irix6-5.h' --- src/s/irix6-5.h 2012-07-11 07:28:27 +0000 +++ src/s/irix6-5.h 2012-07-12 00:49:24 +0000 @@ -70,8 +70,6 @@ /* Tell process_send_signal to use VSUSP instead of VSWTCH. */ #define PREFER_VSUSP -#define NARROWPROTO 1 - #undef SA_RESTART /* not the same as defining BROKEN_SA_RESTART */ #undef TIOCSIGSEND /* defined in usg5-4-common.h */ === modified file 'src/s/template.h' --- src/s/template.h 2012-07-11 23:40:59 +0000 +++ src/s/template.h 2012-07-12 00:49:24 +0000 @@ -52,14 +52,6 @@ your system and must be used only through an encapsulation (which you should place, by convention, in sysdep.c). */ -/* If the system's imake configuration file defines `NeedWidePrototypes' - as `NO', we must define NARROWPROTO manually. Such a define is - generated in the Makefile generated by `xmkmf'. If we don't - define NARROWPROTO, we will see the wrong function prototypes - for X functions taking float or double parameters. */ - -/* #define NARROWPROTO 1 */ - /* ============================================================ */ /* After adding support for a new system, modify the large case ------------------------------------------------------------ revno: 109038 committer: Glenn Morris branch nick: trunk timestamp: Wed 2012-07-11 19:44:03 -0400 message: Remove unneeded #define POSIX * src/s/gnu-linux.h, src/s/sol2-6.h: No longer define POSIX, unused since 2011-01-17 change to systty.h. * admin/CPP-DEFINES: Related edit. diff: === modified file 'admin/CPP-DEFINES' --- admin/CPP-DEFINES 2012-07-11 07:05:21 +0000 +++ admin/CPP-DEFINES 2012-07-11 23:44:03 +0000 @@ -192,7 +192,6 @@ O_RDWR PAGESIZE PENDING_OUTPUT_COUNT -POSIX PREFER_VSUSP PTY_ITERATION PTY_NAME_SPRINTF === modified file 'src/ChangeLog' --- src/ChangeLog 2012-07-11 23:40:59 +0000 +++ src/ChangeLog 2012-07-11 23:44:03 +0000 @@ -1,5 +1,8 @@ 2012-07-11 Glenn Morris + * s/gnu-linux.h, s/sol2-6.h: No longer define POSIX, + unused since 2011-01-17 change to systty.h. + * s/aix4-2.h, s/bsd-common.h, s/cygwin.h, s/darwin.h, s/gnu-linux.h: * s/hpux10-20.h, s/template.h, s/usg5-4-common.h: Move HAVE_PTYS and HAVE_SOCKETS to configure. === modified file 'src/s/gnu-linux.h' --- src/s/gnu-linux.h 2012-07-11 23:40:59 +0000 +++ src/s/gnu-linux.h 2012-07-11 23:44:03 +0000 @@ -71,7 +71,6 @@ your system and must be used only through an encapsulation (Which you should place, by convention, in sysdep.c). */ -#define POSIX /* affects getpagesize.h and systty.h */ /* This is to work around mysterious gcc failures in some system versions. It is unlikely that Emacs changes will work around this problem; === modified file 'src/s/sol2-6.h' --- src/s/sol2-6.h 2012-07-11 20:40:18 +0000 +++ src/s/sol2-6.h 2012-07-11 23:44:03 +0000 @@ -24,8 +24,6 @@ /* This triggers a conditional in xfaces.c. */ #define XOS_NEEDS_TIME_H -#define POSIX - /* This is the same definition as in usg5-4-common.h, but with sigblock/sigunblock rather than sighold/sigrelse, which appear to be BSD4.1 specific. It may also be appropriate for SVR4.x ------------------------------------------------------------ revno: 109037 committer: Glenn Morris branch nick: trunk timestamp: Wed 2012-07-11 19:40:59 -0400 message: All platforms using configure support HAVE_PTYS and HAVE_SOCKETS * configure.ac (HAVE_PTYS, HAVE_SOCKETS): Define unconditionally. * src/s/aix4-2.h, src/s/bsd-common.h, src/s/cygwin.h, src/s/darwin.h: * src/s/gnu-linux.h, src/s/hpux10-20.h, src/s/template.h: * src/s/usg5-4-common.h: Move HAVE_PTYS and HAVE_SOCKETS to configure. diff: === modified file 'ChangeLog' --- ChangeLog 2012-07-11 17:04:19 +0000 +++ ChangeLog 2012-07-11 23:40:59 +0000 @@ -1,6 +1,7 @@ 2012-07-11 Glenn Morris * configure.ac (INTERRUPT_INPUT): Move here from src/s. + (HAVE_PTYS, HAVE_SOCKETS): Define unconditionally. 2012-07-11 Paul Eggert === modified file 'configure.ac' --- configure.ac 2012-07-11 17:04:19 +0000 +++ configure.ac 2012-07-11 23:40:59 +0000 @@ -3132,6 +3132,18 @@ so that Emacs can tell instantly when you try to modify a file that someone else has modified in his/her Emacs.]) +dnl Everybody supports this, except MS. +dnl Seems like the kind of thing we should be testing for, though. +## Note: PTYs are broken on darwin <6. Use at your own risk. +AC_DEFINE(HAVE_PTYS, 1, [Define if the system supports pty devices.]) + +dnl Everybody supports this, except MS-DOS. +dnl Seems like the kind of thing we should be testing for, though. +dnl Compare with HAVE_INET_SOCKETS (which is unused...) above. +AC_DEFINE(HAVE_SOCKETS, 1, [Define if the system supports + 4.2-compatible sockets.]) + + case $opsys in darwin | gnu | hpux* | *bsd ) AC_DEFINE(NO_TERMIO, 1, [Define if termio.h should not be included.]) === modified file 'src/ChangeLog' --- src/ChangeLog 2012-07-11 20:40:18 +0000 +++ src/ChangeLog 2012-07-11 23:40:59 +0000 @@ -1,3 +1,9 @@ +2012-07-11 Glenn Morris + + * s/aix4-2.h, s/bsd-common.h, s/cygwin.h, s/darwin.h, s/gnu-linux.h: + * s/hpux10-20.h, s/template.h, s/usg5-4-common.h: + Move HAVE_PTYS and HAVE_SOCKETS to configure. + 2012-07-11 Paul Eggert * s/sol2-6.h (HAVE_LIBKSTAT): Remove. (Bug#11914) === modified file 'src/s/aix4-2.h' --- src/s/aix4-2.h 2012-07-11 07:28:27 +0000 +++ src/s/aix4-2.h 2012-07-11 23:40:59 +0000 @@ -32,11 +32,6 @@ #define PTY_NAME_SPRINTF strcpy (pty_name, "/dev/ptc"); #define PTY_TTY_NAME_SPRINTF strcpy (pty_name, ttyname (fd)); -/* Define HAVE_PTYS if the system supports pty devices. */ -#define HAVE_PTYS - -/* Define HAVE_SOCKETS if system supports 4.2-compatible sockets. */ -#define HAVE_SOCKETS /* Special items needed to make Emacs run on this system. */ === modified file 'src/s/bsd-common.h' --- src/s/bsd-common.h 2012-07-11 07:38:33 +0000 +++ src/s/bsd-common.h 2012-07-11 23:40:59 +0000 @@ -49,9 +49,3 @@ /* First pty name is /dev/ptyp0. */ #define FIRST_PTY_LETTER 'p' - -/* Define HAVE_PTYS if the system supports pty devices. */ -#define HAVE_PTYS - -/* Define HAVE_SOCKETS if system supports 4.2-compatible sockets. */ -#define HAVE_SOCKETS === modified file 'src/s/cygwin.h' --- src/s/cygwin.h 2012-07-11 07:38:33 +0000 +++ src/s/cygwin.h 2012-07-11 23:40:59 +0000 @@ -17,8 +17,6 @@ You should have received a copy of the GNU General Public License along with GNU Emacs. If not, see . */ -/* Define HAVE_PTYS if the system supports pty devices. */ -#define HAVE_PTYS #define PTY_ITERATION int i; for (i = 0; i < 1; i++) /* ick */ #define PTY_NAME_SPRINTF /* none */ #define PTY_TTY_NAME_SPRINTF /* none */ @@ -46,8 +44,6 @@ /* Used in various places to enable cygwin-specific code changes. */ #define CYGWIN 1 -#define HAVE_SOCKETS - /* Emacs supplies its own malloc, but glib (part of Gtk+) calls memalign and on Cygwin, that becomes the Cygwin-supplied memalign. As malloc is not the Cygwin malloc, the Cygwin memalign always === modified file 'src/s/darwin.h' --- src/s/darwin.h 2012-07-11 17:04:19 +0000 +++ src/s/darwin.h 2012-07-11 23:40:59 +0000 @@ -34,9 +34,6 @@ if system supports pty's. 'a' means it is /dev/ptya0 */ #define FIRST_PTY_LETTER 'p' -/* Define HAVE_PTYS if the system supports pty devices. - Note: PTYs are broken on darwin <6. Use at your own risk. */ -#define HAVE_PTYS /* Run only once. We need a `for'-loop because the code uses `continue'. */ #define PTY_ITERATION int i; for (i = 0; i < 1; i++) #define PTY_NAME_SPRINTF /* none */ @@ -66,9 +63,6 @@ /* System uses OXTABS instead of the expected TAB3. (Copied from bsd386.h.) */ #define TAB3 OXTABS -/* Define HAVE_SOCKETS if system supports 4.2-compatible sockets. */ -#define HAVE_SOCKETS - /* Definitions for how to compile & link. */ #ifdef HAVE_NS #define SYSTEM_PURESIZE_EXTRA 200000 === modified file 'src/s/gnu-linux.h' --- src/s/gnu-linux.h 2012-07-11 18:39:44 +0000 +++ src/s/gnu-linux.h 2012-07-11 23:40:59 +0000 @@ -64,11 +64,6 @@ #endif /* not HAVE_GRANTPT */ -/* Define HAVE_PTYS if the system supports pty devices. */ -#define HAVE_PTYS - -#define HAVE_SOCKETS - /* Here, on a separate page, add any special hacks needed to make Emacs work on this system. For example, you might define certain system call names that don't === modified file 'src/s/hpux10-20.h' --- src/s/hpux10-20.h 2012-07-11 07:07:19 +0000 +++ src/s/hpux10-20.h 2012-07-11 23:40:59 +0000 @@ -30,12 +30,6 @@ if system supports pty's. 'p' means it is /dev/ptym/ptyp0 */ #define FIRST_PTY_LETTER 'p' -/* Define HAVE_PTYS if the system supports pty devices. */ -#define HAVE_PTYS - -/* Define HAVE_SOCKETS if system supports 4.2-compatible sockets. */ -#define HAVE_SOCKETS - /* Special hacks needed to make Emacs run on this system. */ /* This is how to get the device name of the tty end of a pty. */ === modified file 'src/s/template.h' --- src/s/template.h 2012-07-11 17:04:19 +0000 +++ src/s/template.h 2012-07-11 23:40:59 +0000 @@ -33,9 +33,6 @@ if system supports pty's. 'a' means it is /dev/ptya0. */ #define FIRST_PTY_LETTER 'a' -/* Define HAVE_PTYS if the system supports pty devices. */ -#define HAVE_PTYS - /* subprocesses should be undefined if you do NOT want to have code for asynchronous subprocesses (as used in M-x compile and M-x shell). === modified file 'src/s/usg5-4-common.h' --- src/s/usg5-4-common.h 2012-07-11 07:07:19 +0000 +++ src/s/usg5-4-common.h 2012-07-11 23:40:59 +0000 @@ -51,9 +51,6 @@ constant to dimension an array. So wire in the appropriate value here. */ #define NSIG_MINIMUM 32 -/* Define HAVE_PTYS if the system supports pty devices. */ -#define HAVE_PTYS - /* It is possible to receive SIGCHLD when there are no children waiting, because a previous waitsys(2) cleaned up the carcass of child without clearing the SIGCHLD pending info. So, use a non-blocking @@ -82,6 +79,3 @@ fatal ("ioctl I_PUSH ldterm"); \ if (ioctl (xforkin, I_PUSH, "ttcompat") == -1) \ fatal ("ioctl I_PUSH ttcompat"); - -/* This definition was suggested for next release. So give it a try. */ -#define HAVE_SOCKETS ------------------------------------------------------------ revno: 109036 committer: Stefan Monnier branch nick: trunk timestamp: Wed 2012-07-11 19:13:41 -0400 message: More CL cleanups and reduction of use of cl.el. * woman.el, winner.el, vc/vc-rcs.el, vc/vc-hooks.el, vc/vc-hg.el: * vc/vc-git.el, vc/vc-dir.el, vc/vc-bzr.el, vc/vc-annotate.el: * textmodes/tex-mode.el, textmodes/sgml-mode.el, tar-mode.el: * strokes.el, ses.el, server.el, progmodes/js.el, progmodes/gdb-mi.el: * progmodes/flymake.el, progmodes/ebrowse.el, progmodes/compile.el: * play/tetris.el, play/snake.el, play/pong.el, play/landmark.el: * play/hanoi.el, play/decipher.el, play/5x5.el, nxml/nxml-mode.el: * net/secrets.el, net/quickurl.el, midnight.el, mail/footnote.el: * image-dired.el, ibuffer.el, ibuf-macs.el, ibuf-ext.el, hexl.el: * eshell/eshell.el, eshell/esh-io.el, eshell/esh-ext.el: * eshell/esh-cmd.el, eshell/em-ls.el, eshell/em-hist.el: * eshell/em-cmpl.el, eshell/em-banner.el: * url/url.el, url/url-queue.el, url/url-parse.el, url/url-http.el: * url/url-future.el, url/url-dav.el, url/url-cookie.el: * calendar/parse-time.el, test/eshell.el: Use cl-lib. * wid-browse.el, wdired.el, vc/vc.el, vc/vc-mtn.el, vc/vc-cvs.el: * vc/vc-arch.el, tree-widget.el, textmodes/texinfo.el: * textmodes/refill.el, textmodes/css-mode.el, term/tvi970.el: * term/ns-win.el, term.el, shell.el, ps-samp.el: * progmodes/perl-mode.el, progmodes/pascal.el, progmodes/gud.el: * progmodes/glasses.el, progmodes/etags.el, progmodes/cwarn.el: * play/gamegrid.el, play/bubbles.el, novice.el, notifications.el: * net/zeroconf.el, net/xesam.el, net/snmp-mode.el, net/mairix.el: * net/ldap.el, net/eudc.el, net/browse-url.el, man.el: * mail/mailheader.el, mail/feedmail.el: * url/url-util.el, url/url-privacy.el, url/url-nfs.el, url/url-misc.el: * url/url-methods.el, url/url-gw.el, url/url-file.el, url/url-expand.el: Dont use CL. * ibuf-ext.el (ibuffer-mark-old-buffers): Use float-time. * eshell/esh-opt.el (eshell-eval-using-options): Quote code with `lambda' rather than with `quote'. (eshell-do-opt): Adjust accordingly. (eshell-process-option): Simplify. * eshell/esh-var.el: * eshell/em-script.el: Require `esh-opt' for eshell-eval-using-options. * emacs-pcase.el (pcase--dontcare-upats, pcase--let*) (pcase--expand, pcase--u1): Rename pcase's internal `dontcare' pattern to `pcase--dontcare'. * emacs-cl.el (labels): Mark obsolete. (cl--letf, letf): Move to cl-lib. (cl--letf*, letf*): Remove. * emacs-cl-lib.el (cl-nth-value): Use defalias. * emacs-cl-macs.el (cl-dolist, cl-dotimes): Add indent rule. (cl-progv): Rewrite. (cl--letf, cl-letf): Move from cl.el. (cl-letf*): New macro. * emacs-cl-extra.el (cl--progv-before, cl--progv-after): Remove. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-07-11 12:03:19 +0000 +++ lisp/ChangeLog 2012-07-11 23:13:41 +0000 @@ -1,3 +1,49 @@ +2012-07-11 Stefan Monnier + + More CL cleanups and reduction of use of cl.el. + * woman.el, winner.el, vc/vc-rcs.el, vc/vc-hooks.el, vc/vc-hg.el: + * vc/vc-git.el, vc/vc-dir.el, vc/vc-bzr.el, vc/vc-annotate.el: + * textmodes/tex-mode.el, textmodes/sgml-mode.el, tar-mode.el: + * strokes.el, ses.el, server.el, progmodes/js.el, progmodes/gdb-mi.el: + * progmodes/flymake.el, progmodes/ebrowse.el, progmodes/compile.el: + * play/tetris.el, play/snake.el, play/pong.el, play/landmark.el: + * play/hanoi.el, play/decipher.el, play/5x5.el, nxml/nxml-mode.el: + * net/secrets.el, net/quickurl.el, midnight.el, mail/footnote.el: + * image-dired.el, ibuffer.el, ibuf-macs.el, ibuf-ext.el, hexl.el: + * eshell/eshell.el, eshell/esh-io.el, eshell/esh-ext.el: + * eshell/esh-cmd.el, eshell/em-ls.el, eshell/em-hist.el: + * eshell/em-cmpl.el, eshell/em-banner.el: + * calendar/parse-time.el: Use cl-lib. + * wid-browse.el, wdired.el, vc/vc.el, vc/vc-mtn.el, vc/vc-cvs.el: + * vc/vc-arch.el, tree-widget.el, textmodes/texinfo.el: + * textmodes/refill.el, textmodes/css-mode.el, term/tvi970.el: + * term/ns-win.el, term.el, shell.el, ps-samp.el: + * progmodes/perl-mode.el, progmodes/pascal.el, progmodes/gud.el: + * progmodes/glasses.el, progmodes/etags.el, progmodes/cwarn.el: + * play/gamegrid.el, play/bubbles.el, novice.el, notifications.el: + * net/zeroconf.el, net/xesam.el, net/snmp-mode.el, net/mairix.el: + * net/ldap.el, net/eudc.el, net/browse-url.el, man.el: + * mail/mailheader.el, mail/feedmail.el: Don't use CL. + * ibuf-ext.el (ibuffer-mark-old-buffers): Use float-time. + * eshell/esh-opt.el (eshell-eval-using-options): Quote code with + `lambda' rather than with `quote'. + (eshell-do-opt): Adjust accordingly. + (eshell-process-option): Simplify. + * eshell/esh-var.el: + * eshell/em-script.el: Require `esh-opt' for eshell-eval-using-options. + * emacs-lisp/pcase.el (pcase--dontcare-upats, pcase--let*) + (pcase--expand, pcase--u1): Rename pcase's internal `dontcare' pattern + to `pcase--dontcare'. + * emacs-lisp/cl.el (labels): Mark obsolete. + (cl--letf, letf): Move to cl-lib. + (cl--letf*, letf*): Remove. + * emacs-lisp/cl-lib.el (cl-nth-value): Use defalias. + * emacs-lisp/cl-macs.el (cl-dolist, cl-dotimes): Add indent rule. + (cl-progv): Rewrite. + (cl--letf, cl-letf): Move from cl.el. + (cl-letf*): New macro. + * emacs-lisp/cl-extra.el (cl--progv-before, cl--progv-after): Remove. + 2012-07-11 Michael Albinus * net/ange-ftp.el (ange-ftp-cf1): Update the files cache. === modified file 'lisp/calendar/parse-time.el' --- lisp/calendar/parse-time.el 2012-02-25 10:00:08 +0000 +++ lisp/calendar/parse-time.el 2012-07-11 23:13:41 +0000 @@ -34,7 +34,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) ;and ah ain't kiddin' 'bout it +(eval-when-compile (require 'cl-lib)) (defvar parse-time-digits (make-vector 256 nil)) @@ -43,8 +43,8 @@ (defvar parse-time-val) (unless (aref parse-time-digits ?0) - (loop for i from ?0 to ?9 - do (aset parse-time-digits i (- i ?0)))) + (cl-loop for i from ?0 to ?9 + do (aset parse-time-digits i (- i ?0)))) (defsubst digit-char-p (char) (aref parse-time-digits char)) @@ -92,11 +92,11 @@ (index 0) (c nil)) (while (< index end) - (while (and (< index end) ;skip invalid characters + (while (and (< index end) ;Skip invalid characters. (not (setq c (parse-time-string-chars (aref string index))))) - (incf index)) + (cl-incf index)) (setq start index all-digits (eq c ?0)) - (while (and (< (incf index) end) ;scan valid characters + (while (and (< (cl-incf index) end) ;Scan valid characters. (setq c (parse-time-string-chars (aref string index)))) (setq all-digits (and all-digits (eq c ?0)))) (if (<= index end) === modified file 'lisp/emacs-lisp/cl-extra.el' --- lisp/emacs-lisp/cl-extra.el 2012-06-22 21:24:54 +0000 +++ lisp/emacs-lisp/cl-extra.el 2012-07-11 23:13:41 +0000 @@ -313,25 +313,6 @@ (t (make-frame-visible frame))) val) -;;; Support for `cl-progv'. -(defvar cl--progv-save) -;;;###autoload -(defun cl--progv-before (syms values) - (while syms - (push (if (boundp (car syms)) - (cons (car syms) (symbol-value (car syms))) - (car syms)) cl--progv-save) - (if values - (set (pop syms) (pop values)) - (makunbound (pop syms))))) - -(defun cl--progv-after () - (while cl--progv-save - (if (consp (car cl--progv-save)) - (set (car (car cl--progv-save)) (cdr (car cl--progv-save))) - (makunbound (car cl--progv-save))) - (pop cl--progv-save))) - ;;; Numbers. === modified file 'lisp/emacs-lisp/cl-lib.el' --- lisp/emacs-lisp/cl-lib.el 2012-06-30 12:52:08 +0000 +++ lisp/emacs-lisp/cl-lib.el 2012-07-11 23:13:41 +0000 @@ -230,12 +230,13 @@ "Apply FUNCTION to ARGUMENTS, taking multiple values into account. This implementation only handles the case where there is only one argument.") -(defsubst cl-nth-value (n expression) +(cl--defalias 'cl-nth-value #'nth "Evaluate EXPRESSION to get multiple values and return the Nth one. This handles multiple values in Common Lisp style, but it does not work right when EXPRESSION calls an ordinary Emacs Lisp function that returns just -one value." - (nth n expression)) +one value. + +\(fn N EXPRESSION)") ;;; Declarations. === modified file 'lisp/emacs-lisp/cl-macs.el' --- lisp/emacs-lisp/cl-macs.el 2012-06-27 15:11:28 +0000 +++ lisp/emacs-lisp/cl-macs.el 2012-07-11 23:13:41 +0000 @@ -624,7 +624,7 @@ ;;;###autoload (defmacro cl-ecase (expr &rest clauses) - "Like `cl-case', but error if no cl-case fits. + "Like `cl-case', but error if no case fits. `otherwise'-clauses are not allowed. \n(fn EXPR (KEYLIST BODY...)...)" (declare (indent 1) (debug cl-case)) @@ -1482,7 +1482,8 @@ An implicit nil block is established around the loop. \(fn (VAR LIST [RESULT]) BODY...)" - (declare (debug ((symbolp form &optional form) cl-declarations body))) + (declare (debug ((symbolp form &optional form) cl-declarations body)) + (indent 1)) `(cl-block nil (,(if (eq 'cl-dolist (symbol-function 'dolist)) 'cl--dolist 'dolist) ,spec ,@body))) @@ -1495,7 +1496,7 @@ nil. \(fn (VAR COUNT [RESULT]) BODY...)" - (declare (debug cl-dolist)) + (declare (debug cl-dolist) (indent 1)) `(cl-block nil (,(if (eq 'cl-dotimes (symbol-function 'dotimes)) 'cl--dotimes 'dotimes) ,spec ,@body))) @@ -1546,10 +1547,19 @@ BODY forms are executed and their result is returned. This is much like a `let' form, except that the list of symbols can be computed at run-time." (declare (indent 2) (debug (form form body))) - `(let ((cl--progv-save nil)) - (unwind-protect - (progn (cl--progv-before ,symbols ,values) ,@body) - (cl--progv-after)))) + (let ((bodyfun (make-symbol "body")) + (binds (make-symbol "binds")) + (syms (make-symbol "syms")) + (vals (make-symbol "vals"))) + `(progn + (defvar ,bodyfun) + (let* ((,syms ,symbols) + (,vals ,values) + (,bodyfun (lambda () ,@body)) + (,binds ())) + (while ,syms + (push (list (pop ,syms) (list 'quote (pop ,vals))) ,binds)) + (eval (list 'let ,binds '(funcall ,bodyfun))))))) (defvar cl--labels-convert-cache nil) @@ -1600,7 +1610,7 @@ Like `cl-flet' but the definitions can refer to previous ones. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" - (declare (indent 1) (debug ((&rest (cl-defun)) cl-declarations body))) + (declare (indent 1) (debug cl-flet)) (cond ((null bindings) (macroexp-progn body)) ((null (cdr bindings)) `(cl-flet ,bindings ,@body)) @@ -1609,7 +1619,8 @@ ;;;###autoload (defmacro cl-labels (bindings &rest body) "Make temporary function bindings. -The bindings can be recursive. Assumes the use of `lexical-binding'. +The bindings can be recursive and the scoping is lexical, but capturing them +in closures will only work if `lexical-binding' is in use. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" (declare (indent 1) (debug cl-flet)) @@ -1911,6 +1922,86 @@ (macroexp-let* `((,temp ,getter)) `(progn ,(funcall setter form) nil)))))) +;; FIXME: `letf' is unsatisfactory because it does not really "restore" the +;; previous state. If the getter/setter loses information, that info is +;; not recovered. + +(defun cl--letf (bindings simplebinds binds body) + ;; It's not quite clear what the semantics of cl-letf should be. + ;; E.g. in (cl-letf ((PLACE1 VAL1) (PLACE2 VAL2)) BODY), while it's clear + ;; that the actual assignments ("bindings") should only happen after + ;; evaluating VAL1 and VAL2, it's not clear when the sub-expressions of + ;; PLACE1 and PLACE2 should be evaluated. Should we have + ;; PLACE1; VAL1; PLACE2; VAL2; bind1; bind2 + ;; or + ;; VAL1; VAL2; PLACE1; PLACE2; bind1; bind2 + ;; or + ;; VAL1; VAL2; PLACE1; bind1; PLACE2; bind2 + ;; Common-Lisp's `psetf' does the first, so we'll do the same. + (if (null bindings) + (if (and (null binds) (null simplebinds)) (macroexp-progn body) + `(let* (,@(mapcar (lambda (x) + (pcase-let ((`(,vold ,getter ,_setter ,_vnew) x)) + (list vold getter))) + binds) + ,@simplebinds) + (unwind-protect + ,(macroexp-progn + (append + (delq nil + (mapcar (lambda (x) + (pcase x + ;; If there's no vnew, do nothing. + (`(,_vold ,_getter ,setter ,vnew) + (funcall setter vnew)))) + binds)) + body)) + ,@(mapcar (lambda (x) + (pcase-let ((`(,vold ,_getter ,setter ,_vnew) x)) + (funcall setter vold))) + binds)))) + (let ((binding (car bindings))) + (gv-letplace (getter setter) (car binding) + (macroexp-let2 nil vnew (cadr binding) + (if (symbolp (car binding)) + ;; Special-case for simple variables. + (cl--letf (cdr bindings) + (cons `(,getter ,(if (cdr binding) vnew getter)) + simplebinds) + binds body) + (cl--letf (cdr bindings) simplebinds + (cons `(,(make-symbol "old") ,getter ,setter + ,@(if (cdr binding) (list vnew))) + binds) + body))))))) + +;;;###autoload +(defmacro cl-letf (bindings &rest body) + "Temporarily bind to PLACEs. +This is the analogue of `let', but with generalized variables (in the +sense of `setf') for the PLACEs. Each PLACE is set to the corresponding +VALUE, then the BODY forms are executed. On exit, either normally or +because of a `throw' or error, the PLACEs are set back to their original +values. Note that this macro is *not* available in Common Lisp. +As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', +the PLACE is not modified before executing BODY. + +\(fn ((PLACE VALUE) ...) BODY...)" + (declare (indent 1) (debug ((&rest (gate gv-place &optional form)) body))) + (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings))) + `(let ,bindings ,@body) + (cl--letf bindings () () body))) + +;;;###autoload +(defmacro cl-letf* (bindings &rest body) + "Temporarily bind to PLACEs. +Like `cl-letf' but where the bindings are performed one at a time, +rather than all at the end (i.e. like `let*' rather than like `let')." + (declare (indent 1) (debug cl-letf)) + (dolist (binding (reverse bindings)) + (setq body (list `(cl-letf (,binding) ,@body)))) + (macroexp-progn body)) + ;;;###autoload (defmacro cl-callf (func place &rest args) "Set PLACE to (FUNC PLACE ARGS...). === modified file 'lisp/emacs-lisp/cl.el' --- lisp/emacs-lisp/cl.el 2012-06-27 21:16:32 +0000 +++ lisp/emacs-lisp/cl.el 2012-07-11 23:13:41 +0000 @@ -222,7 +222,7 @@ callf2 callf letf* - letf + ;; letf rotatef shiftf remf @@ -449,16 +449,6 @@ (setq body (list `(lexical-let (,(pop bindings)) ,@body)))) (car body))) -(defmacro cl--symbol-function (symbol) - "Like `symbol-function' but return `cl--unbound' if not bound." - ;; (declare (gv-setter (lambda (store) - ;; `(if (eq ,store 'cl--unbound) - ;; (fmakunbound ,symbol) (fset ,symbol ,store))))) - `(if (fboundp ,symbol) (symbol-function ,symbol) 'cl--unbound)) -(gv-define-setter cl--symbol-function (store symbol) - `(if (eq ,store 'cl--unbound) (fmakunbound ,symbol) (fset ,symbol ,store))) - - ;; This should really have some way to shadow 'byte-compile properties, etc. (defmacro flet (bindings &rest body) "Make temporary overriding function definitions. @@ -470,38 +460,36 @@ definitions, or lack thereof). \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" - (declare (indent 1) (debug cl-flet)) - `(letf* ,(mapcar - (lambda (x) - (if (or (and (fboundp (car x)) - (eq (car-safe (symbol-function (car x))) 'macro)) - (cdr (assq (car x) macroexpand-all-environment))) - (error "Use `labels', not `flet', to rebind macro names")) - (let ((func `(cl-function - (lambda ,(cadr x) - (cl-block ,(car x) ,@(cddr x)))))) - (when (cl--compiling-file) - ;; Bug#411. It would be nice to fix this. - (and (get (car x) 'byte-compile) - (error "Byte-compiling a redefinition of `%s' \ + (declare (indent 1) (debug cl-flet) + (obsolete "Use either `cl-flet' or `cl-letf'." "24.2")) + `(letf ,(mapcar + (lambda (x) + (if (or (and (fboundp (car x)) + (eq (car-safe (symbol-function (car x))) 'macro)) + (cdr (assq (car x) macroexpand-all-environment))) + (error "Use `labels', not `flet', to rebind macro names")) + (let ((func `(cl-function + (lambda ,(cadr x) + (cl-block ,(car x) ,@(cddr x)))))) + (when (cl--compiling-file) + ;; Bug#411. It would be nice to fix this. + (and (get (car x) 'byte-compile) + (error "Byte-compiling a redefinition of `%s' \ will not work - use `labels' instead" (symbol-name (car x)))) - ;; FIXME This affects the rest of the file, when it - ;; should be restricted to the flet body. - (and (boundp 'byte-compile-function-environment) - (push (cons (car x) (eval func)) - byte-compile-function-environment))) - (list `(symbol-function ',(car x)) func))) - bindings) + ;; FIXME This affects the rest of the file, when it + ;; should be restricted to the flet body. + (and (boundp 'byte-compile-function-environment) + (push (cons (car x) (eval func)) + byte-compile-function-environment))) + (list `(symbol-function ',(car x)) func))) + bindings) ,@body)) -(make-obsolete 'flet "Use either `cl-flet' or `letf'." "24.2") (defmacro labels (bindings &rest body) "Make temporary function bindings. -This is like `flet', except the bindings are lexical instead of dynamic. -Unlike `flet', this macro is fully compliant with the Common Lisp standard. - -\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" - (declare (indent 1) (debug cl-flet)) +Like `cl-labels' except that the lexical scoping is handled via `lexical-let' +rather than relying on `lexical-binding'." + (declare (indent 1) (debug cl-flet) (obsolete 'cl-labels "24.2")) (let ((vars nil) (sets nil) (newenv macroexpand-all-environment)) (dolist (binding bindings) ;; It's important that (not (eq (symbol-name var1) (symbol-name var2))) @@ -521,93 +509,24 @@ ;; not 100% compatible: not worth the trouble to add them to cl-lib.el, but we ;; still need to support old users of cl.el. -;; FIXME: `letf' is unsatisfactory because it does not really "restore" the -;; previous state. If the getter/setter loses information, that info is -;; not recovered. - -(defun cl--letf (bindings simplebinds binds body) - ;; It's not quite clear what the semantics of let! should be. - ;; E.g. in (let! ((PLACE1 VAL1) (PLACE2 VAL2)) BODY), while it's clear - ;; that the actual assignments ("bindings") should only happen after - ;; evaluating VAL1 and VAL2, it's not clear when the sub-expressions of - ;; PLACE1 and PLACE2 should be evaluated. Should we have - ;; PLACE1; VAL1; PLACE2; VAL2; bind1; bind2 - ;; or - ;; VAL1; VAL2; PLACE1; PLACE2; bind1; bind2 - ;; or - ;; VAL1; VAL2; PLACE1; bind1; PLACE2; bind2 - ;; Common-Lisp's `psetf' does the first, so we'll do the same. - (if (null bindings) - (if (and (null binds) (null simplebinds)) (macroexp-progn body) - `(let* (,@(mapcar (lambda (x) - (pcase-let ((`(,vold ,getter ,_setter ,_vnew) x)) - (list vold getter))) - binds) - ,@simplebinds) - (unwind-protect - ,(macroexp-progn (append - (mapcar (lambda (x) (pcase x - (`(,_vold ,_getter ,setter ,vnew) - (funcall setter vnew)))) - binds) - body)) - ,@(mapcar (lambda (x) (pcase-let ((`(,vold ,_getter ,setter ,_vnew) x)) - (funcall setter vold))) - binds)))) - (let ((binding (car bindings))) - (if (eq (car-safe (car binding)) 'symbol-function) - (setcar (car binding) 'cl--symbol-function)) - (gv-letplace (getter setter) (car binding) - (macroexp-let2 nil vnew (cadr binding) - (if (symbolp (car binding)) - ;; Special-case for simple variables. - (cl--letf (cdr bindings) - (cons `(,getter ,(if (cdr binding) vnew getter)) - simplebinds) - binds body) - (cl--letf (cdr bindings) simplebinds - (cons `(,(make-symbol "old") ,getter ,setter - ,@(if (cdr binding) (list vnew))) - binds) - body))))))) +(defmacro cl--symbol-function (symbol) + "Like `symbol-function' but return `cl--unbound' if not bound." + ;; (declare (gv-setter (lambda (store) + ;; `(if (eq ,store 'cl--unbound) + ;; (fmakunbound ,symbol) (fset ,symbol ,store))))) + `(if (fboundp ,symbol) (symbol-function ,symbol) 'cl--unbound)) +(gv-define-setter cl--symbol-function (store symbol) + `(if (eq ,store 'cl--unbound) (fmakunbound ,symbol) (fset ,symbol ,store))) (defmacro letf (bindings &rest body) - "Temporarily bind to PLACEs. -This is the analogue of `let', but with generalized variables (in the -sense of `setf') for the PLACEs. Each PLACE is set to the corresponding -VALUE, then the BODY forms are executed. On exit, either normally or -because of a `throw' or error, the PLACEs are set back to their original -values. Note that this macro is *not* available in Common Lisp. -As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', -the PLACE is not modified before executing BODY. - -\(fn ((PLACE VALUE) ...) BODY...)" - (declare (indent 1) (debug ((&rest (gate gv-place &optional form)) body))) - (cl--letf bindings () () body)) - -(defun cl--letf* (bindings body) - (if (null bindings) - (macroexp-progn body) - (let ((binding (car bindings))) - (if (symbolp (car binding)) - ;; Special-case for simple variables. - (macroexp-let* (list (if (cdr binding) binding - (list (car binding) (car binding)))) - (cl--letf* (cdr bindings) body)) - (if (eq (car-safe (car binding)) 'symbol-function) - (setcar (car binding) 'cl--symbol-function)) - (gv-letplace (getter setter) (car binding) - (macroexp-let2 macroexp-copyable-p vnew (cadr binding) - (macroexp-let2 nil vold getter - `(unwind-protect - (progn - ,(if (cdr binding) (funcall setter vnew)) - ,(cl--letf* (cdr bindings) body)) - ,(funcall setter vold))))))))) - -(defmacro letf* (bindings &rest body) - (declare (indent 1) (debug letf)) - (cl--letf* bindings body)) + "Dynamically scoped let-style bindings for places. +Like `cl-letf', but with some extra backward compatibility." + ;; Like cl-letf, but with special handling of symbol-function. + `(cl-letf ,(mapcar (lambda (x) (if (eq (car-safe (car x)) 'symbol-function) + `((cl--symbol-function ,@(cdar x)) ,@(cdr x)) + x)) + bindings) + ,@body)) (defun cl--gv-adapt (cl-gv do) ;; This function is used by all .elc files that use define-setf-expander and === modified file 'lisp/emacs-lisp/elint.el' --- lisp/emacs-lisp/elint.el 2012-05-30 03:59:42 +0000 +++ lisp/emacs-lisp/elint.el 2012-07-11 23:13:41 +0000 @@ -466,6 +466,9 @@ (add-to-list 'elint-features name) ;; cl loads cl-macs in an opaque manner. ;; Since cl-macs requires cl, we can just process cl-macs. + ;; FIXME: AFAIK, `cl' now behaves properly and does not need any + ;; special treatment any more. Can someone who understands this + ;; code confirm? --Stef (and (eq name 'cl) (not elint-doing-cl) ;; We need cl if elint-form is to be able to expand cl macros. (require 'cl) === modified file 'lisp/emacs-lisp/pcase.el' --- lisp/emacs-lisp/pcase.el 2012-07-10 09:26:04 +0000 +++ lisp/emacs-lisp/pcase.el 2012-07-11 23:13:41 +0000 @@ -64,7 +64,7 @@ ;; (defconst pcase--memoize-1 (make-hash-table :test 'eq)) ;; (defconst pcase--memoize-2 (make-hash-table :weakness 'key :test 'equal)) -(defconst pcase--dontcare-upats '(t _ dontcare)) +(defconst pcase--dontcare-upats '(t _ pcase--dontcare)) (def-edebug-spec pcase-UPAT @@ -154,11 +154,12 @@ (pcase--expand (cadr binding) `((,(car binding) ,(pcase--let* bindings body)) - ;; We can either signal an error here, or just use `dontcare' which - ;; generates more efficient code. In practice, if we use `dontcare' - ;; we will still often get an error and the few cases where we don't - ;; do not matter that much, so it's a better choice. - (dontcare nil))))))) + ;; We can either signal an error here, or just use `pcase--dontcare' + ;; which generates more efficient code. In practice, if we use + ;; `pcase--dontcare' we will still often get an error and the few + ;; cases where we don't do not matter that much, so + ;; it's a better choice. + (pcase--dontcare nil))))))) ;;;###autoload (defmacro pcase-let* (bindings &rest body) @@ -275,7 +276,7 @@ vars)))) cases)))) (dolist (case cases) - (unless (or (memq case used-cases) (eq (car case) 'dontcare)) + (unless (or (memq case used-cases) (eq (car case) 'pcase--dontcare)) (message "Redundant pcase pattern: %S" (car case)))) (macroexp-let* defs main)))) @@ -575,7 +576,7 @@ (upat (cdr cdrpopmatches))) (cond ((memq upat '(t _)) (pcase--u1 matches code vars rest)) - ((eq upat 'dontcare) :pcase--dontcare) + ((eq upat 'pcase--dontcare) :pcase--dontcare) ((memq (car-safe upat) '(guard pred)) (if (eq (car upat) 'pred) (put sym 'pcase-used t)) (let* ((splitrest === modified file 'lisp/eshell/em-banner.el' --- lisp/eshell/em-banner.el 2012-06-27 07:08:06 +0000 +++ lisp/eshell/em-banner.el 2012-07-11 23:13:41 +0000 @@ -39,7 +39,7 @@ ;;; Code: (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'esh-mode) (require 'eshell)) @@ -77,10 +77,10 @@ ;; `insert', because `insert' doesn't know how to interact with the ;; I/O code used by Eshell (unless eshell-non-interactive-p - (assert eshell-mode) - (assert eshell-banner-message) + (cl-assert eshell-mode) + (cl-assert eshell-banner-message) (let ((msg (eval eshell-banner-message))) - (assert msg) + (cl-assert msg) (eshell-interactive-print msg)))) (provide 'em-banner) === modified file 'lisp/eshell/em-cmpl.el' --- lisp/eshell/em-cmpl.el 2012-06-27 07:08:06 +0000 +++ lisp/eshell/em-cmpl.el 2012-07-11 23:13:41 +0000 @@ -70,7 +70,7 @@ ;;; Code: (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'eshell)) (require 'esh-util) @@ -358,7 +358,7 @@ (nconc posns (list pos))) (setq pos (1+ pos)))) (setq posns (cdr posns)) - (assert (= (length args) (length posns))) + (cl-assert (= (length args) (length posns))) (let ((a args) (i 0) l final) @@ -370,7 +370,7 @@ (and l (setq args (nthcdr (1+ l) args) posns (nthcdr (1+ l) posns)))) - (assert (= (length args) (length posns))) + (cl-assert (= (length args) (length posns))) (when (and args (eq (char-syntax (char-before end)) ? ) (not (eq (char-before (1- end)) ?\\))) (nconc args (list "")) @@ -383,7 +383,7 @@ (let ((result (eshell-do-eval (list 'eshell-commands arg) t))) - (assert (eq (car result) 'quote)) + (cl-assert (eq (car result) 'quote)) (cadr result)) arg))) (if (numberp val) === modified file 'lisp/eshell/em-hist.el' --- lisp/eshell/em-hist.el 2012-06-27 07:08:06 +0000 +++ lisp/eshell/em-hist.el 2012-07-11 23:13:41 +0000 @@ -54,8 +54,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'ring) (require 'esh-opt) @@ -560,8 +559,8 @@ (forward-char)) (setq posb (cdr posb) pose (cdr pose)) - (assert (= (length posb) (length args))) - (assert (<= (length posb) (length pose)))) + (cl-assert (= (length posb) (length args))) + (cl-assert (<= (length posb) (length pose)))) (setq hist (buffer-substring-no-properties begin end)) (let ((b posb) (e pose)) (while b @@ -571,7 +570,7 @@ (setq b (cdr b) e (cdr e)))) (setq textargs (cdr textargs)) - (assert (= (length textargs) (length args))) + (cl-assert (= (length textargs) (length args))) (list textargs posb pose)))) (defun eshell-expand-history-references (beg end) === modified file 'lisp/eshell/em-ls.el' --- lisp/eshell/em-ls.el 2012-06-27 07:08:06 +0000 +++ lisp/eshell/em-ls.el 2012-07-11 23:13:41 +0000 @@ -27,7 +27,7 @@ ;;; Code: (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'eshell)) (require 'esh-util) (require 'esh-opt) @@ -463,7 +463,7 @@ (progn (setcdr fileinfo attr) (setcar fileinfo (eshell-ls-decorated-name fileinfo))) - (assert (eq listing-style 'long-listing)) + (cl-assert (eq listing-style 'long-listing)) (setcar fileinfo (concat (eshell-ls-decorated-name fileinfo) " -> " (eshell-ls-decorated-name @@ -698,7 +698,7 @@ (let* ((col-vals (if (eq listing-style 'by-columns) (eshell-ls-find-column-lengths display-files) - (assert (eq listing-style 'by-lines)) + (cl-assert (eq listing-style 'by-lines)) (eshell-ls-find-column-widths display-files))) (col-widths (car col-vals)) (display-files (cdr col-vals)) === modified file 'lisp/eshell/em-script.el' --- lisp/eshell/em-script.el 2012-06-27 07:08:06 +0000 +++ lisp/eshell/em-script.el 2012-07-11 23:13:41 +0000 @@ -24,6 +24,7 @@ ;;; Code: (require 'eshell) +(require 'esh-opt) ;;;###autoload (progn === modified file 'lisp/eshell/esh-cmd.el' --- lisp/eshell/esh-cmd.el 2012-06-26 16:23:01 +0000 +++ lisp/eshell/esh-cmd.el 2012-07-11 23:13:41 +0000 @@ -108,7 +108,7 @@ (require 'esh-ext) (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'pcomplete)) @@ -604,7 +604,7 @@ (list (if (<= (length pieces) 1) (car pieces) - (assert (not eshell-in-pipeline-p)) + (cl-assert (not eshell-in-pipeline-p)) `(eshell-execute-pipeline (quote ,pieces)))))) (setq bp (cdr bp)))) ;; `results' might be empty; this happens in the case of @@ -615,7 +615,7 @@ results (cdr results) sep-terms (nreverse sep-terms)) (while results - (assert (car sep-terms)) + (cl-assert (car sep-terms)) (setq final (eshell-structure-basic-command 'if (string= (car sep-terms) "&&") "if" `(eshell-protect ,(car results)) @@ -1026,7 +1026,7 @@ ;; `eshell-copy-tree' is needed here so that the test argument ;; doesn't get modified and thus always yield the same result. (when (car eshell-command-body) - (assert (not synchronous-p)) + (cl-assert (not synchronous-p)) (eshell-do-eval (car eshell-command-body)) (setcar eshell-command-body nil) (setcar eshell-test-body nil)) @@ -1046,7 +1046,7 @@ ;; doesn't get modified and thus always yield the same result. (if (car eshell-command-body) (progn - (assert (not synchronous-p)) + (cl-assert (not synchronous-p)) (eshell-do-eval (car eshell-command-body))) (unless (car eshell-test-body) (setcar eshell-test-body (eshell-copy-tree (car args)))) @@ -1201,7 +1201,7 @@ (setq eshell-last-arguments args eshell-last-command-name (eshell-stringify command)) (run-hook-with-args 'eshell-prepare-command-hook) - (assert (stringp eshell-last-command-name)) + (cl-assert (stringp eshell-last-command-name)) (if eshell-last-command-name (or (run-hook-with-args-until-success 'eshell-named-command-hook eshell-last-command-name === modified file 'lisp/eshell/esh-ext.el' --- lisp/eshell/esh-ext.el 2012-07-10 12:16:40 +0000 +++ lisp/eshell/esh-ext.el 2012-07-11 23:13:41 +0000 @@ -34,9 +34,10 @@ (provide 'esh-ext) (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'esh-cmd)) (require 'esh-util) +(require 'esh-opt) (defgroup eshell-ext nil "External commands are invoked when operating system executables are @@ -206,10 +207,10 @@ (defun eshell-external-command (command args) "Insert output from an external COMMAND, using ARGS." (setq args (eshell-stringify-list (eshell-flatten-list args))) -; (if (file-remote-p default-directory) -; (eshell-remote-command command args)) + ;; (if (file-remote-p default-directory) + ;; (eshell-remote-command command args)) (let ((interp (eshell-find-interpreter command))) - (assert interp) + (cl-assert interp) (if (functionp (car interp)) (apply (car interp) (append (cdr interp) args)) (eshell-gather-process-output === modified file 'lisp/eshell/esh-io.el' --- lisp/eshell/esh-io.el 2012-01-19 07:21:25 +0000 +++ lisp/eshell/esh-io.el 2012-07-11 23:13:41 +0000 @@ -59,7 +59,7 @@ (provide 'esh-io) (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'eshell)) (defgroup eshell-io nil @@ -298,7 +298,7 @@ command. If nil, then the meta variables for keeping track of the last execution result should not be changed." (let ((idx 0)) - (assert (or (not result) (eq (car result) 'quote))) + (cl-assert (or (not result) (eq (car result) 'quote))) (setq eshell-last-command-status exit-code eshell-last-command-result (cadr result)) (while (< idx eshell-number-of-handles) === modified file 'lisp/eshell/esh-opt.el' --- lisp/eshell/esh-opt.el 2012-01-19 07:21:25 +0000 +++ lisp/eshell/esh-opt.el 2012-07-11 23:13:41 +0000 @@ -106,7 +106,9 @@ (and (listp opt) (nth 3 opt))) (cadr options))) '(usage-msg last-value ext-command args)) - (eshell-do-opt ,name ,options (quote ,body-forms))))) + ;; FIXME: `options' ends up hiding some variable names under `quote', + ;; which is incompatible with lexical scoping!! + (eshell-do-opt ,name ,options (lambda () ,@body-forms))))) ;;; Internal Functions: @@ -117,7 +119,7 @@ ;; Documented part of the interface; see eshell-eval-using-options. (defvar args) -(defun eshell-do-opt (name options body-forms) +(defun eshell-do-opt (name options body-fun) "Helper function for `eshell-eval-using-options'. This code doesn't really need to be macro expanded everywhere." (setq args temp-args) @@ -133,8 +135,7 @@ (throw 'eshell-usage (eshell-show-usage name options))) (setq args (eshell-process-args name args options) - last-value (eval (append (list 'progn) - body-forms))) + last-value (funcall body-fun)) nil)) (error "%s" usage-msg)))) (throw 'eshell-external @@ -218,10 +219,8 @@ found) (while opts (if (and (listp (car opts)) - (nth kind (car opts)) - (if (= kind 0) - (eq switch (nth kind (car opts))) - (string= switch (nth kind (car opts))))) + (nth kind (car opts)) + (equal switch (nth kind (car opts)))) (progn (eshell-set-option name ai (car opts) options) (setq found t opts nil)) === modified file 'lisp/eshell/esh-var.el' --- lisp/eshell/esh-var.el 2012-01-19 07:21:25 +0000 +++ lisp/eshell/esh-var.el 2012-07-11 23:13:41 +0000 @@ -110,8 +110,8 @@ (eval-when-compile (require 'pcomplete) (require 'esh-util) - (require 'esh-opt) (require 'esh-mode)) +(require 'esh-opt) (require 'env) (require 'ring) === modified file 'lisp/eshell/eshell.el' --- lisp/eshell/eshell.el 2012-06-27 07:08:06 +0000 +++ lisp/eshell/eshell.el 2012-07-11 23:13:41 +0000 @@ -222,7 +222,7 @@ ;; things up. (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'esh-util)) (require 'esh-util) (require 'esh-mode) @@ -298,7 +298,7 @@ nonnumeric prefix arg means to create a new session. Returns the buffer selected (or created)." (interactive "P") - (assert eshell-buffer-name) + (cl-assert eshell-buffer-name) (let ((buf (cond ((numberp arg) (get-buffer-create (format "%s<%d>" eshell-buffer-name @@ -312,7 +312,7 @@ ;; window that that command was invoked from. To achieve this, ;; it's necessary to add `eshell-buffer-name' to the variable ;; `same-window-buffer-names', which is done when Eshell is loaded - (assert (and buf (buffer-live-p buf))) + (cl-assert (and buf (buffer-live-p buf))) (pop-to-buffer buf) (unless (eq major-mode 'eshell-mode) (eshell-mode)) @@ -380,11 +380,11 @@ (when intr (if (eshell-interactive-process) (eshell-wait-for-process (eshell-interactive-process))) - (assert (not (eshell-interactive-process))) + (cl-assert (not (eshell-interactive-process))) (goto-char (point-max)) (while (and (bolp) (not (bobp))) (delete-char -1))) - (assert (and buf (buffer-live-p buf))) + (cl-assert (and buf (buffer-live-p buf))) (unless arg (let ((len (if (not intr) 2 (count-lines (point-min) (point-max))))) @@ -424,7 +424,7 @@ (list 'eshell-commands (list 'eshell-command-to-value (eshell-parse-command command))) t))) - (assert (eq (car result) 'quote)) + (cl-assert (eq (car result) 'quote)) (if (and status-var (symbolp status-var)) (set status-var eshell-last-command-status)) (cadr result)))))) === modified file 'lisp/hexl.el' --- lisp/hexl.el 2012-07-10 11:51:54 +0000 +++ lisp/hexl.el 2012-07-11 23:13:41 +0000 @@ -41,7 +41,7 @@ ;;; Code: (require 'eldoc) -(eval-when-compile (require 'cl)) ;For letf (default-value 'major-mode). +(eval-when-compile (require 'cl-lib)) ;; ;; vars here @@ -462,7 +462,7 @@ (let ((completion-ignored-extensions nil)) (read-file-name "Filename: " nil nil 'ret-must-match)))) ;; Ignore the user's setting of default major-mode. - (letf (((default-value 'major-mode) 'fundamental-mode)) + (cl-letf (((default-value 'major-mode) 'fundamental-mode)) (find-file-literally filename)) (if (not (eq major-mode 'hexl-mode)) (hexl-mode))) === modified file 'lisp/ibuf-ext.el' --- lisp/ibuf-ext.el 2012-06-29 06:28:37 +0000 +++ lisp/ibuf-ext.el 2012-07-11 23:13:41 +0000 @@ -35,7 +35,7 @@ (eval-when-compile (require 'ibuf-macs) - (require 'cl)) + (require 'cl-lib)) ;;; Utility functions (defun ibuffer-delete-alist (key alist) @@ -497,12 +497,12 @@ (defun ibuffer-included-in-filter-p-1 (buf filter) (not (not - (case (car filter) - (or + (pcase (car filter) + (`or (memq t (mapcar #'(lambda (x) (ibuffer-included-in-filter-p buf x)) (cdr filter)))) - (saved + (`saved (let ((data (assoc (cdr filter) ibuffer-saved-filters))) @@ -510,19 +510,13 @@ (ibuffer-filter-disable t) (error "Unknown saved filter %s" (cdr filter))) (ibuffer-included-in-filters-p buf (cadr data)))) - (t - (let ((filterdat (assq (car filter) - ibuffer-filtering-alist))) - ;; filterdat should be like (TYPE DESCRIPTION FUNC) - ;; just a sanity check - (unless filterdat - (ibuffer-filter-disable t) - (error "Undefined filter %s" (car filter))) - (not - (not - (funcall (caddr filterdat) - buf - (cdr filter)))))))))) + (_ + (pcase-let ((`(,_type ,_desc ,func) + (assq (car filter) ibuffer-filtering-alist))) + (unless func + (ibuffer-filter-disable t) + (error "Undefined filter %s" (car filter))) + (funcall func buf (cdr filter)))))))) (defun ibuffer-generate-filter-groups (bmarklist &optional noempty nodefault) (let ((filter-group-alist (if nodefault @@ -536,14 +530,14 @@ (i 0)) (dolist (filtergroup filter-group-alist) (let ((filterset (cdr filtergroup))) - (multiple-value-bind (hip-crowd lamers) - (values-list + (cl-multiple-value-bind (hip-crowd lamers) + (cl-values-list (ibuffer-split-list (lambda (bufmark) (ibuffer-included-in-filters-p (car bufmark) filterset)) bmarklist)) (aset vec i hip-crowd) - (incf i) + (cl-incf i) (setq bmarklist lamers)))) (let (ret) (dotimes (j i ret) @@ -689,7 +683,7 @@ (if (equal (car groups) group) (setq found t groups nil) - (incf res) + (cl-incf res) (setq groups (cdr groups)))) res))) (cond ((not found) @@ -810,12 +804,12 @@ (when (null ibuffer-filtering-qualifiers) (error "No filters in effect")) (let ((lim (pop ibuffer-filtering-qualifiers))) - (case (car lim) - (or + (pcase (car lim) + (`or (setq ibuffer-filtering-qualifiers (append (cdr lim) ibuffer-filtering-qualifiers))) - (saved + (`saved (let ((data (assoc (cdr lim) ibuffer-saved-filters))) @@ -825,10 +819,10 @@ (setq ibuffer-filtering-qualifiers (append (cadr data) ibuffer-filtering-qualifiers)))) - (not + (`not (push (cdr lim) ibuffer-filtering-qualifiers)) - (t + (_ (error "Filter type %s is not compound" (car lim))))) (ibuffer-update nil t)) @@ -960,13 +954,13 @@ (ibuffer-format-qualifier-1 qualifier))) (defun ibuffer-format-qualifier-1 (qualifier) - (case (car qualifier) - (saved + (pcase (car qualifier) + (`saved (concat " [filter: " (cdr qualifier) "]")) - (or + (`or (concat " [OR" (mapconcat #'ibuffer-format-qualifier (cdr qualifier) "") "]")) - (t + (_ (let ((type (assq (car qualifier) ibuffer-filtering-alist))) (unless qualifier (error "Ibuffer: bad qualifier %s" qualifier)) @@ -1414,14 +1408,14 @@ (concat ibuffer-copy-filename-as-kill-result (let ((name (buffer-file-name buf))) (if name - (case type - (full + (pcase type + (`full name) - (relative + (`relative (file-relative-name name (or ibuffer-default-directory default-directory))) - (t + (_ (file-name-nondirectory name))) "")) " ")))) @@ -1550,13 +1544,8 @@ (with-current-buffer buf ;; hacked from midnight.el (when buffer-display-time - (let* ((tm (current-time)) - (now (+ (* (float (ash 1 16)) (car tm)) - (float (cadr tm)) (* 0.0000001 (caddr tm)))) - (then (+ (* (float (ash 1 16)) - (car buffer-display-time)) - (float (cadr buffer-display-time)) - (* 0.0000001 (caddr buffer-display-time))))) + (let* ((now (float-time)) + (then (float-time buffer-display-time))) (> (- now then) (* 60 60 ibuffer-old-time)))))))) ;;;###autoload === modified file 'lisp/ibuf-macs.el' --- lisp/ibuf-macs.el 2012-05-18 01:46:20 +0000 +++ lisp/ibuf-macs.el 2012-07-11 23:13:41 +0000 @@ -27,8 +27,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;; From Paul Graham's "ANSI Common Lisp", adapted for Emacs Lisp here. (defmacro ibuffer-aif (test true-body &rest false-body) @@ -73,7 +72,7 @@ (ibuffer-redisplay t)))))) ;;;###autoload -(defmacro* define-ibuffer-column (symbol (&key name inline props summarizer +(cl-defmacro define-ibuffer-column (symbol (&key name inline props summarizer header-mouse-map) &rest body) "Define a column SYMBOL for use with `ibuffer-formats'. @@ -129,7 +128,7 @@ :autoload-end))) ;;;###autoload -(defmacro* define-ibuffer-sorter (name documentation +(cl-defmacro define-ibuffer-sorter (name documentation (&key description) &rest body) @@ -160,7 +159,7 @@ :autoload-end)) ;;;###autoload -(defmacro* define-ibuffer-op (op args +(cl-defmacro define-ibuffer-op (op args documentation (&key interactive @@ -213,19 +212,19 @@ ,(if (not (null interactive)) `(interactive ,interactive) '(interactive)) - (assert (derived-mode-p 'ibuffer-mode)) + (cl-assert (derived-mode-p 'ibuffer-mode)) (setq ibuffer-did-modification nil) - (let ((marked-names (,(case mark + (let ((marked-names (,(pcase mark (:deletion 'ibuffer-deletion-marked-buffer-names) - (t + (_ 'ibuffer-marked-buffer-names))))) (when (null marked-names) (setq marked-names (list (buffer-name (ibuffer-current-buffer)))) - (ibuffer-set-mark ,(case mark + (ibuffer-set-mark ,(pcase mark (:deletion 'ibuffer-deletion-char) - (t + (_ 'ibuffer-marked-char)))) ,(let* ((finish (append '(progn) @@ -242,10 +241,10 @@ ,@body)) t))) (body `(let ((count - (,(case mark + (,(pcase mark (:deletion 'ibuffer-map-deletion-lines) - (t + (_ 'ibuffer-map-marked-lines)) #'(lambda (buf mark) ,(if (eq modifier-p :maybe) @@ -264,7 +263,7 @@ :autoload-end)) ;;;###autoload -(defmacro* define-ibuffer-filter (name documentation +(cl-defmacro define-ibuffer-filter (name documentation (&key reader description) === modified file 'lisp/ibuffer.el' --- lisp/ibuffer.el 2012-06-29 06:28:37 +0000 +++ lisp/ibuffer.el 2012-07-11 23:13:41 +0000 @@ -31,7 +31,7 @@ ;;; Code: (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'ibuf-macs) (require 'dired)) @@ -1017,7 +1017,7 @@ (when (get-text-property (point) 'ibuffer-title) (forward-line 1) (setq arg 1)) - (decf arg))) + (cl-decf arg))) (defun ibuffer-forward-line (&optional arg skip-group-names) "Move forward ARG lines, wrapping around the list if necessary." @@ -1032,7 +1032,7 @@ (and skip-group-names (get-text-property (point) 'ibuffer-filter-group-name))) (when (> arg 0) - (decf arg)) + (cl-decf arg)) (ibuffer-skip-properties (append '(ibuffer-title) (when skip-group-names '(ibuffer-filter-group-name))) @@ -1045,7 +1045,7 @@ (or (eobp) (get-text-property (point) 'ibuffer-summary))) (goto-char (point-min))) - (decf arg) + (cl-decf arg) (ibuffer-skip-properties (append '(ibuffer-title) (when skip-group-names '(ibuffer-filter-group-name))) @@ -1190,7 +1190,7 @@ (setq trying nil)) (error ;; Handle a failure - (if (or (> (incf attempts) 4) + (if (or (> (cl-incf attempts) 4) (and (stringp (cadr err)) ;; This definitely falls in the ;; ghetto hack category... @@ -1243,7 +1243,7 @@ (ibuffer-map-on-mark ibuffer-deletion-char func)) (defsubst ibuffer-assert-ibuffer-mode () - (assert (derived-mode-p 'ibuffer-mode))) + (cl-assert (derived-mode-p 'ibuffer-mode))) (defun ibuffer-buffer-file-name () (or buffer-file-name @@ -1504,11 +1504,11 @@ `(progn (setq tmp1 ,widthform tmp2 (/ tmp1 2)) - ,(case alignment + ,(pcase alignment (:right `(concat ,left ,right ,strvar)) (:center `(concat ,left ,strvar ,right)) (:left `(concat ,strvar ,left ,right)) - (t (error "Invalid alignment %s" alignment)))))) + (_ (error "Invalid alignment %s" alignment)))))) (defun ibuffer-compile-format (format) (let ((result nil) @@ -1529,7 +1529,7 @@ (max (nth 2 form)) (align (nth 3 form)) (elide (nth 4 form))) - (let* ((from-end-p (when (minusp min) + (let* ((from-end-p (when (cl-minusp min) (setq min (- min)) t)) (letbindings nil) @@ -1812,10 +1812,10 @@ (defun ibuffer-format-column (str width alignment) (let ((left (make-string (/ width 2) ?\s)) (right (make-string (- width (/ width 2)) ?\s))) - (case alignment + (pcase alignment (:right (concat left right str)) (:center (concat left str right)) - (t (concat str left right))))) + (_ (concat str left right))))) (defun ibuffer-buffer-name-face (buf mark) (cond ((char-equal mark ibuffer-marked-char) @@ -1913,18 +1913,18 @@ ;; `nil' if it chose not to affect the buffer ;; `kill' means the remove line from the buffer list ;; `t' otherwise - (incf ibuffer-map-lines-total) + (cl-incf ibuffer-map-lines-total) (cond ((null result) (forward-line 1)) ((eq result 'kill) (delete-region (line-beginning-position) (1+ (line-end-position))) - (incf ibuffer-map-lines-count) + (cl-incf ibuffer-map-lines-count) (when (< ibuffer-map-lines-total orig-target-line) - (decf target-line-offset))) + (cl-decf target-line-offset))) (t - (incf ibuffer-map-lines-count) + (cl-incf ibuffer-map-lines-count) (forward-line 1))))) ibuffer-map-lines-count) (progn @@ -2054,12 +2054,9 @@ (insert (if (stringp element) element - (let ((sym (car element)) - (min (cadr element)) - ;; (max (caddr element)) - (align (cadddr element))) + (pcase-let ((`(,sym ,min ,_max ,align) element)) ;; Ignore a negative min when we're inserting the title - (when (minusp min) + (when (cl-minusp min) (setq min (- min))) (let* ((name (or (get sym 'ibuffer-column-name) (error "Unknown column %s in ibuffer-formats" sym))) @@ -2107,24 +2104,23 @@ (insert (if (stringp element) (make-string (length element) ?\s) - (let ((sym (car element))) - (let ((min (cadr element)) - ;; (max (caddr element)) - (align (cadddr element))) - ;; Ignore a negative min when we're inserting the title - (when (minusp min) - (setq min (- min))) - (let* ((summary (if (get sym 'ibuffer-column-summarizer) - (funcall (get sym 'ibuffer-column-summarizer) - (get sym 'ibuffer-column-summary)) - (make-string (length (get sym 'ibuffer-column-name)) - ?\s))) - (len (length summary))) - (if (< len min) - (ibuffer-format-column summary - (- min len) - align) - summary))))))) + (pcase-let ((`(,sym ,min ,_max ,align) element)) + ;; Ignore a negative min when we're inserting the title. + (when (cl-minusp min) + (setq min (- min))) + (let* ((summary + (if (get sym 'ibuffer-column-summarizer) + (funcall (get sym 'ibuffer-column-summarizer) + (get sym 'ibuffer-column-summary)) + (make-string + (length (get sym 'ibuffer-column-name)) + ?\s))) + (len (length summary))) + (if (< len min) + (ibuffer-format-column summary + (- min len) + align) + summary)))))) (point)) `(ibuffer-summary t))))) @@ -2168,7 +2164,7 @@ (eq ibuffer-always-show-last-buffer :nomini) (minibufferp (cadr bufs))) - (caddr bufs) + (cl-caddr bufs) (cadr bufs)) (ibuffer-current-buffers-with-marks bufs) ibuffer-display-maybe-show-predicates))) @@ -2200,7 +2196,7 @@ (require 'ibuf-ext)) (let* ((sortdat (assq ibuffer-sorting-mode ibuffer-sorting-functions-alist)) - (func (caddr sortdat))) + (func (cl-caddr sortdat))) (let ((result ;; actually sort the buffers (if (and sortdat func) @@ -2574,11 +2570,11 @@ ;; `ibuffer-update' puts this on header-line-format when needed. (setq ibuffer-header-line-format ;; Display the part that won't be in the mode-line. - (list* "" mode-name - (mapcar (lambda (elem) - (if (eq (car-safe elem) 'header-line-format) - (nth 2 elem) elem)) - mode-line-process))) + `("" ,mode-name + ,@(mapcar (lambda (elem) + (if (eq (car-safe elem) 'header-line-format) + (nth 2 elem) elem)) + mode-line-process))) (setq buffer-read-only t) (buffer-disable-undo) @@ -2645,7 +2641,7 @@ ;;;;;; ibuffer-backward-filter-group ibuffer-forward-filter-group ;;;;;; ibuffer-toggle-filter-group ibuffer-mouse-toggle-filter-group ;;;;;; ibuffer-interactive-filter-by-mode ibuffer-mouse-filter-by-mode -;;;;;; ibuffer-auto-mode) "ibuf-ext" "ibuf-ext.el" "296999191b08d76d9763a8ebf510d5d8") +;;;;;; ibuffer-auto-mode) "ibuf-ext" "ibuf-ext.el" "c255d1ebe80ccabd8385f40bdd0b5451") ;;; Generated autoloads from ibuf-ext.el (autoload 'ibuffer-auto-mode "ibuf-ext" "\ === modified file 'lisp/image-dired.el' --- lisp/image-dired.el 2012-06-26 16:23:01 +0000 +++ lisp/image-dired.el 2012-07-11 23:13:41 +0000 @@ -157,7 +157,7 @@ (require 'widget) (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'wid-edit)) (defgroup image-dired nil @@ -653,21 +653,24 @@ (image-file (dired-get-filename nil t)) thumb-file overlay) - (when (and image-file (string-match-p (image-file-name-regexp) image-file)) + (when (and image-file + (string-match-p (image-file-name-regexp) image-file)) (setq thumb-file (image-dired-get-thumbnail-image image-file)) ;; If image is not already added, then add it. (let ((cur-ov (overlays-in (point) (1+ (point))))) (if cur-ov (delete-overlay (car cur-ov)) (put-image thumb-file image-pos) - (setq overlay (loop for o in (overlays-in (point) (1+ (point))) - when (overlay-get o 'put-image) collect o into ov - finally return (car ov))) + (setq overlay + (cl-loop for o in (overlays-in (point) (1+ (point))) + when (overlay-get o 'put-image) collect o into ov + finally return (car ov))) (overlay-put overlay 'image-file image-file) (overlay-put overlay 'thumb-file thumb-file))))) arg ; Show or hide image on ARG next files. 'show-progress) ; Update dired display after each image is updated. - (add-hook 'dired-after-readin-hook 'image-dired-dired-after-readin-hook nil t)) + (add-hook 'dired-after-readin-hook + 'image-dired-dired-after-readin-hook nil t)) (defun image-dired-dired-after-readin-hook () "Relocate existing thumbnail overlays in dired buffer after reverting. === modified file 'lisp/mail/feedmail.el' --- lisp/mail/feedmail.el 2012-05-04 05:14:14 +0000 +++ lisp/mail/feedmail.el 2012-07-11 23:13:41 +0000 @@ -372,8 +372,7 @@ (require 'mail-utils) ; pick up mail-strip-quoted-names (eval-when-compile - (require 'smtpmail) - (require 'cl)) + (require 'smtpmail)) (autoload 'mail-do-fcc "sendmail") @@ -1951,9 +1950,6 @@ (feedmail-say-debug ">in-> feedmail-run-the-queue-global-prompts") (let ((feedmail-queue-runner-confirm-global t)) (feedmail-run-the-queue arg))) -;; letf fools the byte-compiler. -(defvar file-name-buffer-file-type-alist) - ;;;###autoload (defun feedmail-run-the-queue (&optional arg) "Visit each message in the feedmail queue directory and send it out. @@ -2392,8 +2388,10 @@ (defun feedmail-send-it-immediately () "Handle immediate sending, including during a queue run." (feedmail-say-debug ">in-> feedmail-send-it-immediately") - (let ((feedmail-error-buffer (get-buffer-create " *FQM Outgoing Email Errors*")) - (feedmail-prepped-text-buffer (get-buffer-create " *FQM Outgoing Email Text*")) + (let ((feedmail-error-buffer + (get-buffer-create " *FQM Outgoing Email Errors*")) + (feedmail-prepped-text-buffer + (get-buffer-create " *FQM Outgoing Email Text*")) (feedmail-raw-text-buffer (current-buffer)) (feedmail-address-list) (eoh-marker) @@ -2405,7 +2403,7 @@ (a-re-dtcb "^\\(To\\|Cc\\|Bcc\\):") (a-re-dtc "^\\(To\\|Cc\\):") (a-re-db "^Bcc:") - ;; to get a temporary changeable copy + ;; To get a temporary changeable copy. (mail-header-separator mail-header-separator) ) (unwind-protect @@ -2413,10 +2411,10 @@ (set-buffer feedmail-error-buffer) (erase-buffer) (set-buffer feedmail-prepped-text-buffer) (erase-buffer) - ;; jam contents of user-supplied mail buffer into our scratch buffer + ;; Jam contents of user-supplied mail buffer into our scratch buffer. (insert-buffer-substring feedmail-raw-text-buffer) - ;; require one newline at the end. + ;; Require one newline at the end. (goto-char (point-max)) (or (= (preceding-char) ?\n) (insert ?\n)) @@ -2437,54 +2435,69 @@ (and (fboundp 'expand-mail-aliases) mail-aliases)) (expand-mail-aliases (point-min) eoh-marker)) - ;; make it pretty + ;; Make it pretty. (if feedmail-fill-to-cc (feedmail-fill-to-cc-function eoh-marker)) - ;; ignore any blank lines in the header + ;; Ignore any blank lines in the header. (goto-char (point-min)) - (while (and (re-search-forward "\n\n\n*" eoh-marker t) (< (point) eoh-marker)) + (while (and (re-search-forward "\n\n\n*" eoh-marker t) + (< (point) eoh-marker)) (replace-match "\n")) (let ((case-fold-search t) (addr-regexp)) (goto-char (point-min)) - ;; there are some RFC-822 combinations/cases missed here, - ;; but probably good enough and what users expect + ;; There are some RFC-822 combinations/cases missed here, + ;; but probably good enough and what users expect. ;; - ;; use resent-* stuff only if there is at least one non-empty one + ;; Use resent-* stuff only if there is at least one non-empty one. (setq feedmail-is-a-resend (re-search-forward - ;; header name, followed by optional whitespace, followed by - ;; non-whitespace, followed by anything, followed by newline; - ;; the idea is empty Resent-* headers are ignored + ;; Header name, followed by optional whitespace, followed by + ;; non-whitespace, followed by anything, followed by + ;; newline; the idea is empty Resent-* headers are ignored. "^\\(Resent-To:\\|Resent-Cc:\\|Resent-Bcc:\\)\\s-*\\S-+.*$" eoh-marker t)) - ;; if we say so, gather the Bcc stuff before the main course - (if (eq feedmail-deduce-bcc-where 'first) - (progn (if feedmail-is-a-resend (setq addr-regexp a-re-rb) (setq addr-regexp a-re-db)) - (setq feedmail-address-list (feedmail-deduce-address-list feedmail-prepped-text-buffer (point-min) eoh-marker addr-regexp feedmail-address-list)))) - ;; the main course - (if (or (eq feedmail-deduce-bcc-where 'first) (eq feedmail-deduce-bcc-where 'last)) - ;; handled by first or last cases, so don't get Bcc stuff - (progn (if feedmail-is-a-resend (setq addr-regexp a-re-rtc) (setq addr-regexp a-re-dtc)) - (setq feedmail-address-list (feedmail-deduce-address-list feedmail-prepped-text-buffer (point-min) eoh-marker addr-regexp feedmail-address-list))) - ;; not handled by first or last cases, so also get Bcc stuff - (progn (if feedmail-is-a-resend (setq addr-regexp a-re-rtcb) (setq addr-regexp a-re-dtcb)) - (setq feedmail-address-list (feedmail-deduce-address-list feedmail-prepped-text-buffer (point-min) eoh-marker addr-regexp feedmail-address-list)))) - ;; if we say so, gather the Bcc stuff after the main course - (if (eq feedmail-deduce-bcc-where 'last) - (progn (if feedmail-is-a-resend (setq addr-regexp a-re-rb) (setq addr-regexp a-re-db)) - (setq feedmail-address-list (feedmail-deduce-address-list feedmail-prepped-text-buffer (point-min) eoh-marker addr-regexp feedmail-address-list)))) - (if (not feedmail-address-list) (error "FQM: Sending...abandoned, no addressees")) - ;; not needed, but meets user expectations + ;; If we say so, gather the Bcc stuff before the main course. + (when (eq feedmail-deduce-bcc-where 'first) + (setq addr-regexp (if feedmail-is-a-resend a-re-rb a-re-db)) + (setq feedmail-address-list + (feedmail-deduce-address-list + feedmail-prepped-text-buffer (point-min) eoh-marker + addr-regexp feedmail-address-list))) + ;; The main course. + (setq addr-regexp + (if (memq feedmail-deduce-bcc-where '(first last)) + ;; Handled by first or last cases, so don't get + ;; Bcc stuff. + (if feedmail-is-a-resend a-re-rtc a-re-dtc) + ;; Not handled by first or last cases, so also get + ;; Bcc stuff. + (if feedmail-is-a-resend a-re-rtcb a-re-dtcb))) + (setq feedmail-address-list + (feedmail-deduce-address-list + feedmail-prepped-text-buffer (point-min) eoh-marker + addr-regexp feedmail-address-list)) + ;; If we say so, gather the Bcc stuff after the main course. + (when (eq feedmail-deduce-bcc-where 'last) + (setq addr-regexp (if feedmail-is-a-resend a-re-rb a-re-db)) + (setq feedmail-address-list + (feedmail-deduce-address-list + feedmail-prepped-text-buffer (point-min) eoh-marker + addr-regexp feedmail-address-list))) + (if (not feedmail-address-list) + (error "FQM: Sending...abandoned, no addressees")) + ;; Not needed, but meets user expectations. (setq feedmail-address-list (nreverse feedmail-address-list)) ;; Find and handle any Bcc fields. - (setq bcc-holder (feedmail-accume-n-nuke-header eoh-marker "^Bcc:")) - (setq resent-bcc-holder (feedmail-accume-n-nuke-header eoh-marker "^Resent-Bcc:")) - (if (and bcc-holder (not feedmail-nuke-bcc)) - (progn (goto-char (point-min)) - (insert bcc-holder))) - (if (and resent-bcc-holder (not feedmail-nuke-resent-bcc)) - (progn (goto-char (point-min)) - (insert resent-bcc-holder))) + (setq bcc-holder + (feedmail-accume-n-nuke-header eoh-marker "^Bcc:")) + (setq resent-bcc-holder + (feedmail-accume-n-nuke-header eoh-marker "^Resent-Bcc:")) + (when (and bcc-holder (not feedmail-nuke-bcc)) + (goto-char (point-min)) + (insert bcc-holder)) + (when (and resent-bcc-holder (not feedmail-nuke-resent-bcc)) + (goto-char (point-min)) + (insert resent-bcc-holder)) (goto-char (point-min)) ;; fiddle about, fiddle about, fiddle about.... @@ -2492,16 +2505,20 @@ (feedmail-fiddle-sender) (feedmail-fiddle-x-mailer) (feedmail-fiddle-message-id - (or feedmail-queue-runner-is-active (buffer-file-name feedmail-raw-text-buffer))) + (or feedmail-queue-runner-is-active + (buffer-file-name feedmail-raw-text-buffer))) (feedmail-fiddle-date - (or feedmail-queue-runner-is-active (buffer-file-name feedmail-raw-text-buffer))) - (feedmail-fiddle-list-of-fiddle-plexes feedmail-fiddle-plex-user-list) + (or feedmail-queue-runner-is-active + (buffer-file-name feedmail-raw-text-buffer))) + (feedmail-fiddle-list-of-fiddle-plexes + feedmail-fiddle-plex-user-list) ;; don't send out a blank headers of various sorts ;; (this loses on continued line with a blank first line) (goto-char (point-min)) (and feedmail-nuke-empty-headers ; hey, who's an empty-header? - (while (re-search-forward "^[A-Za-z0-9-]+:[ \t]*\n" eoh-marker t) + (while (re-search-forward "^[A-Za-z0-9-]+:[ \t]*\n" + eoh-marker t) (replace-match "")))) (feedmail-say-debug "last chance hook: %s" feedmail-last-chance-hook) @@ -2513,79 +2530,90 @@ (confirm (cond ((eq feedmail-confirm-outgoing 'immediate) (not feedmail-queue-runner-is-active)) - ((eq feedmail-confirm-outgoing 'queued) feedmail-queue-runner-is-active) + ((eq feedmail-confirm-outgoing 'queued) + feedmail-queue-runner-is-active) (t feedmail-confirm-outgoing))) (fullframe (cond ((eq feedmail-display-full-frame 'immediate) (not feedmail-queue-runner-is-active)) - ((eq feedmail-display-full-frame 'queued) feedmail-queue-runner-is-active) + ((eq feedmail-display-full-frame 'queued) + feedmail-queue-runner-is-active) (t feedmail-display-full-frame)))) (if fullframe (progn (switch-to-buffer feedmail-prepped-text-buffer t) (delete-other-windows))) - (if (or (not confirm) (feedmail-one-last-look feedmail-prepped-text-buffer)) - (let ((user-mail-address (feedmail-envelope-deducer eoh-marker))) + (if (or (not confirm) + (feedmail-one-last-look feedmail-prepped-text-buffer)) + (let ((user-mail-address + (feedmail-envelope-deducer eoh-marker))) (feedmail-say-debug "give it to buffer-eater") (feedmail-give-it-to-buffer-eater) (feedmail-say-debug "gave it to buffer-eater") - (if (and (not feedmail-queue-runner-is-active) (setq also-file (buffer-file-name feedmail-raw-text-buffer))) - (progn ; if a file but not running the queue, offer to delete it + (if (and (not feedmail-queue-runner-is-active) + (setq also-file + (buffer-file-name feedmail-raw-text-buffer))) + (progn + ;; If a file but not running the queue, + ;; offer to delete it (setq also-file (expand-file-name also-file)) (when (or feedmail-queue-auto-file-nuke (y-or-n-p (format "FQM: Delete message file %s? " also-file))) - ;; if we delete the affiliated file, get rid + ;; If we delete the affiliated file, get rid ;; of the file name association and make sure we - ;; don't annoy people with a prompt on exit + ;; don't annoy people with a prompt on exit. (delete-file also-file) (with-current-buffer feedmail-raw-text-buffer (setq buffer-offer-save nil) (setq buffer-file-name nil))))) (goto-char (point-min)) - ;; re-insert and handle any Fcc fields (and, optionally, any Bcc). - (if fcc (letf (((default-value 'buffer-file-type) - feedmail-force-binary-write)) - (insert fcc) - (if (not feedmail-nuke-bcc-in-fcc) - (progn (if bcc-holder (insert bcc-holder)) - (if resent-bcc-holder (insert resent-bcc-holder)))) - - (run-hooks 'feedmail-before-fcc-hook) - - (if feedmail-nuke-body-in-fcc - (progn (goto-char eoh-marker) - (if (natnump feedmail-nuke-body-in-fcc) - (forward-line feedmail-nuke-body-in-fcc)) - (delete-region (point) (point-max)) - )) - (mail-do-fcc eoh-marker) - ))) - ;; user bailed out of one-last-look + ;; Re-insert and handle any Fcc fields (and, optionally, + ;; any Bcc). + (when fcc + (let ((old (default-value 'buffer-file-type))) + (unwind-protect + (progn + (setq-default buffer-file-type + feedmail-force-binary-write) + (insert fcc) + (unless feedmail-nuke-bcc-in-fcc + (if bcc-holder (insert bcc-holder)) + (if resent-bcc-holder + (insert resent-bcc-holder))) + + (run-hooks 'feedmail-before-fcc-hook) + + (when feedmail-nuke-body-in-fcc + (goto-char eoh-marker) + (if (natnump feedmail-nuke-body-in-fcc) + (forward-line feedmail-nuke-body-in-fcc)) + (delete-region (point) (point-max))) + (mail-do-fcc eoh-marker)) + (setq-default buffer-file-type old))))) + ;; User bailed out of one-last-look. (if feedmail-queue-runner-is-active (throw 'skip-me-q 'skip-me-q) (throw 'skip-me-i 'skip-me-i)) )))) ; unwind-protect body (save-excursion) - ;; unwind-protect cleanup forms + ;; unwind-protect cleanup forms. (kill-buffer feedmail-prepped-text-buffer) (set-buffer feedmail-error-buffer) (if (zerop (buffer-size)) (kill-buffer feedmail-error-buffer) - (progn (display-buffer feedmail-error-buffer) - ;; read fast ... the meter is running - (if feedmail-queue-runner-is-active - (progn - (ding t) - (feedmail-say-chatter "Sending...failed"))) - (error "FQM: Sending...failed"))) + (display-buffer feedmail-error-buffer) + ;; Read fast ... the meter is running. + (if feedmail-queue-runner-is-active + (progn + (ding t) + (feedmail-say-chatter "Sending...failed"))) + (error "FQM: Sending...failed")) (set-buffer feedmail-raw-text-buffer)) ) ; let - (if (and feedmail-queue-chatty (not feedmail-queue-runner-is-active)) - (progn - (feedmail-queue-reminder 'after-immediate) - (sit-for feedmail-queue-chatty-sit-for))) - ) + (when (and feedmail-queue-chatty (not feedmail-queue-runner-is-active)) + (feedmail-queue-reminder 'after-immediate) + (sit-for feedmail-queue-chatty-sit-for))) (defun feedmail-fiddle-header (name value &optional action folding) === modified file 'lisp/mail/footnote.el' --- lisp/mail/footnote.el 2012-05-04 05:14:14 +0000 +++ lisp/mail/footnote.el 2012-07-11 23:13:41 +0000 @@ -35,9 +35,8 @@ ;;; Code: -(eval-when-compile - (require 'cl) - (defvar filladapt-token-table)) +(eval-when-compile (require 'cl-lib)) +(defvar filladapt-token-table) (defgroup footnote nil "Support for footnotes in mail and news messages." @@ -644,12 +643,12 @@ the buffer is narrowed to the footnote body. The restriction is removed by using `Footnote-back-to-message'." (interactive "*P") - (let (num) - (if footnote-text-marker-alist - (if (< (point) (cadar (last footnote-pointer-marker-alist))) - (setq num (Footnote-make-hole)) - (setq num (1+ (caar (last footnote-text-marker-alist))))) - (setq num 1)) + (let ((num + (if footnote-text-marker-alist + (if (< (point) (cl-cadar (last footnote-pointer-marker-alist))) + (Footnote-make-hole) + (1+ (caar (last footnote-text-marker-alist)))) + 1))) (message "Adding footnote %d" num) (Footnote-insert-footnote num) (insert-before-markers (make-string footnote-body-tag-spacing ? )) === modified file 'lisp/mail/mailheader.el' --- lisp/mail/mailheader.el 2012-01-19 07:21:25 +0000 +++ lisp/mail/mailheader.el 2012-07-11 23:13:41 +0000 @@ -45,9 +45,6 @@ ;;; Code: -(eval-when-compile - (require 'cl)) - (defun mail-header-extract () "Extract headers from current buffer after point. Returns a header alist, where each element is a cons cell (name . value), @@ -110,6 +107,8 @@ value is a list, its first element is the original value of the header, with any subsequent elements being the result of parsing the value. If HEADER-ALIST is nil, the dynamically bound variable `headers' is used." + (declare (gv-setter (lambda (value) + `(mail-header-set ,header ,value ,header-alist)))) (cdr (assq header (or header-alist headers)))) (defun mail-header-set (header value &optional header-alist) @@ -123,9 +122,6 @@ (nconc alist (list (cons header value))))) value) -(defsetf mail-header (header &optional header-alist) (value) - `(mail-header-set ,header ,value ,header-alist)) - (defun mail-header-merge (merge-rules headers) "Return a new header alist with MERGE-RULES applied to HEADERS. MERGE-RULES is an alist whose keys are header names (symbols) and whose === modified file 'lisp/man.el' --- lisp/man.el 2012-05-06 04:19:11 +0000 +++ lisp/man.el 2012-07-11 23:13:41 +0000 @@ -88,7 +88,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'button) ;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv @@ -989,41 +988,41 @@ See the variable `Man-notify-method' for the different notification behaviors." (let ((saved-frame (with-current-buffer man-buffer Man-original-frame))) - (case Man-notify-method - (newframe - ;; Since we run asynchronously, perhaps while Emacs is waiting - ;; for input, we must not leave a different buffer current. We - ;; can't rely on the editor command loop to reselect the - ;; selected window's buffer. - (save-excursion - (let ((frame (make-frame Man-frame-parameters))) - (set-window-buffer (frame-selected-window frame) man-buffer) - (set-window-dedicated-p (frame-selected-window frame) t) - (or (display-multi-frame-p frame) - (select-frame frame))))) - (pushy - (switch-to-buffer man-buffer)) - (bully - (and (frame-live-p saved-frame) - (select-frame saved-frame)) - (pop-to-buffer man-buffer) - (delete-other-windows)) - (aggressive - (and (frame-live-p saved-frame) - (select-frame saved-frame)) - (pop-to-buffer man-buffer)) - (friendly - (and (frame-live-p saved-frame) - (select-frame saved-frame)) - (display-buffer man-buffer 'not-this-window)) - (polite - (beep) - (message "Manual buffer %s is ready" (buffer-name man-buffer))) - (quiet - (message "Manual buffer %s is ready" (buffer-name man-buffer))) - (t ;; meek - (message "")) - ))) + (pcase Man-notify-method + (`newframe + ;; Since we run asynchronously, perhaps while Emacs is waiting + ;; for input, we must not leave a different buffer current. We + ;; can't rely on the editor command loop to reselect the + ;; selected window's buffer. + (save-excursion + (let ((frame (make-frame Man-frame-parameters))) + (set-window-buffer (frame-selected-window frame) man-buffer) + (set-window-dedicated-p (frame-selected-window frame) t) + (or (display-multi-frame-p frame) + (select-frame frame))))) + (`pushy + (switch-to-buffer man-buffer)) + (`bully + (and (frame-live-p saved-frame) + (select-frame saved-frame)) + (pop-to-buffer man-buffer) + (delete-other-windows)) + (`aggressive + (and (frame-live-p saved-frame) + (select-frame saved-frame)) + (pop-to-buffer man-buffer)) + (`friendly + (and (frame-live-p saved-frame) + (select-frame saved-frame)) + (display-buffer man-buffer 'not-this-window)) + (`polite + (beep) + (message "Manual buffer %s is ready" (buffer-name man-buffer))) + (`quiet + (message "Manual buffer %s is ready" (buffer-name man-buffer))) + (_ ;; meek + (message "")) + ))) (defun Man-softhyphen-to-minus () ;; \255 is SOFT HYPHEN in Latin-N. Versions of Debian man, at @@ -1061,14 +1060,14 @@ (setq faces (cond ((match-beginning 2) - (delq (case (char-after (match-beginning 2)) + (delq (pcase (char-after (match-beginning 2)) (?2 Man-overstrike-face) (?4 Man-underline-face) (?7 Man-reverse-face)) faces)) ((eq (char-after (match-beginning 1)) ?0) nil) (t - (cons (case (char-after (match-beginning 1)) + (cons (pcase (char-after (match-beginning 1)) (?1 Man-overstrike-face) (?4 Man-underline-face) (?7 Man-reverse-face)) === modified file 'lisp/midnight.el' --- lisp/midnight.el 2012-01-19 07:21:25 +0000 +++ lisp/midnight.el 2012-07-11 23:13:41 +0000 @@ -36,8 +36,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defgroup midnight nil "Run something every day at midnight." @@ -138,9 +137,9 @@ (defun midnight-find (el ls test &optional key) "A stopgap solution to the absence of `find' in ELisp." - (dolist (rr ls) + (cl-dolist (rr ls) (when (funcall test (if key (funcall key rr) rr) el) - (return rr)))) + (cl-return rr)))) (defun clean-buffer-list-delay (name) "Return the delay, in seconds, before killing a buffer named NAME. @@ -196,8 +195,7 @@ (defun midnight-next () "Return the number of seconds till the next midnight." - (multiple-value-bind (sec min hrs) - (values-list (decode-time)) + (pcase-let ((`(,sec ,min ,hrs) (decode-time))) (- (* 24 60 60) (* 60 60 hrs) (* 60 min) sec))) ;;;###autoload @@ -205,8 +203,8 @@ "Modify `midnight-timer' according to `midnight-delay'. Sets the first argument SYMB (which must be symbol `midnight-delay') to its second argument TM." - (assert (eq symb 'midnight-delay) t - "Invalid argument to `midnight-delay-set': `%s'") + (cl-assert (eq symb 'midnight-delay) t + "Invalid argument to `midnight-delay-set': `%s'") (set symb tm) (when (timerp midnight-timer) (cancel-timer midnight-timer)) (setq midnight-timer === modified file 'lisp/net/browse-url.el' --- lisp/net/browse-url.el 2012-05-09 12:39:40 +0000 +++ lisp/net/browse-url.el 2012-07-11 23:13:41 +0000 @@ -205,8 +205,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Variables -(eval-when-compile (require 'cl)) - (defgroup browse-url nil "Use a web browser to look at a URL." :prefix "browse-url-" @@ -1621,22 +1619,21 @@ (defun browse-url-elinks-sentinel (process url) "Determines if Elinks is running or a new one has to be started." - (let ((exit-status (process-exit-status process))) - ;; Try to determine if an instance is running or if we have to - ;; create a new one. - (case exit-status - (5 - ;; No instance, start a new one. - (browse-url-elinks-new-window url)) - (0 - ;; Found an instance, open URL in new tab. - (let ((process-environment (browse-url-process-environment))) - (start-process (concat "elinks:" url) nil - "elinks" "-remote" - (concat "openURL(\"" url "\",new-tab)")))) - (otherwise - (error "Unrecognized exit-code %d of process `elinks'" - exit-status))))) + ;; Try to determine if an instance is running or if we have to + ;; create a new one. + (pcase (process-exit-status process) + (5 + ;; No instance, start a new one. + (browse-url-elinks-new-window url)) + (0 + ;; Found an instance, open URL in new tab. + (let ((process-environment (browse-url-process-environment))) + (start-process (concat "elinks:" url) nil + "elinks" "-remote" + (concat "openURL(\"" url "\",new-tab)")))) + (exit-status + (error "Unrecognized exit-code %d of process `elinks'" + exit-status)))) (provide 'browse-url) === modified file 'lisp/net/eudc.el' --- lisp/net/eudc.el 2012-06-02 10:56:09 +0000 +++ lisp/net/eudc.el 2012-07-11 23:13:41 +0000 @@ -48,9 +48,7 @@ (eval-and-compile (if (not (fboundp 'make-overlay)) - (require 'overlay)) - (if (not (fboundp 'unless)) - (require 'cl))) + (require 'overlay))) (unless (fboundp 'custom-menu-create) (autoload 'custom-menu-create "cus-edit")) === modified file 'lisp/net/ldap.el' --- lisp/net/ldap.el 2012-01-19 07:21:25 +0000 +++ lisp/net/ldap.el 2012-07-11 23:13:41 +0000 @@ -34,7 +34,6 @@ ;;; Code: (require 'custom) -(eval-when-compile (require 'cl)) (autoload 'auth-source-search "auth-source") @@ -465,12 +464,12 @@ (error "No LDAP host specified")) (let ((host-plist (cdr (assoc host ldap-host-parameters-alist))) result) - (setq result (ldap-search-internal (list* 'host host - 'filter filter - 'attributes attributes - 'attrsonly attrsonly - 'withdn withdn - host-plist))) + (setq result (ldap-search-internal `(host ,host + filter ,filter + attributes ,attributes + attrsonly ,attrsonly + withdn ,withdn + ,@host-plist))) (if ldap-ignore-attribute-codings result (mapcar (lambda (record) === modified file 'lisp/net/mairix.el' --- lisp/net/mairix.el 2012-03-12 22:35:55 +0000 +++ lisp/net/mairix.el 2012-07-11 23:13:41 +0000 @@ -70,8 +70,6 @@ (require 'widget) (require 'cus-edit) -(eval-when-compile - (require 'cl)) ;;; Keymappings === modified file 'lisp/net/quickurl.el' --- lisp/net/quickurl.el 2012-04-09 13:05:48 +0000 +++ lisp/net/quickurl.el 2012-07-11 23:13:41 +0000 @@ -81,8 +81,7 @@ ;; Things we need: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'thingatpt) (require 'pp) (require 'browse-url) @@ -206,47 +205,40 @@ (list keyword url comment) (cons keyword url))) -(defun quickurl-url-keyword (url) +(defalias 'quickurl-url-keyword #'car "Return the keyword for the URL. - -Note that this function is a setfable place." - (car url)) - -(defsetf quickurl-url-keyword (url) (store) - `(setf (car ,url) ,store)) +\n\(fn URL)") (defun quickurl-url-url (url) "Return the actual URL of the URL. Note that this function is a setfable place." + (declare (gv-setter (lambda (store) + `(setf (if (quickurl-url-commented-p ,url) + (cadr ,url) + (cdr ,url)) + ,store)))) (if (quickurl-url-commented-p url) (cadr url) (cdr url))) -(defsetf quickurl-url-url (url) (store) - ` - (if (quickurl-url-commented-p ,url) - (setf (cadr ,url) ,store) - (setf (cdr ,url) ,store))) - (defun quickurl-url-comment (url) "Get the comment from a URL. If the URL has no comment an empty string is returned. Also note that this function is a setfable place." + (declare + (gv-setter (lambda (store) + `(if (quickurl-url-commented-p ,url) + (if (zerop (length ,store)) + (setf (cdr ,url) (cadr ,url)) + (setf (nth 2 ,url) ,store)) + (unless (zerop (length ,store)) + (setf (cdr ,url) (list (cdr ,url) ,store))))))) (if (quickurl-url-commented-p url) (nth 2 url) "")) -(defsetf quickurl-url-comment (url) (store) - ` - (if (quickurl-url-commented-p ,url) - (if (zerop (length ,store)) - (setf (cdr ,url) (cadr ,url)) - (setf (nth 2 ,url) ,store)) - (unless (zerop (length ,store)) - (setf (cdr ,url) (list (cdr ,url) ,store))))) - (defun quickurl-url-description (url) "Return a description for the URL. @@ -259,14 +251,14 @@ ;; Main code: -(defun* quickurl-read (&optional buffer) +(cl-defun quickurl-read (&optional buffer) "`read' the URL list from BUFFER into `quickurl-urls'. BUFFER, if nil, defaults to current buffer. Note that this function moves point to `point-min' before doing the `read' It also restores point after the `read'." (save-excursion - (setf (point) (point-min)) + (goto-char (point-min)) (setq quickurl-urls (funcall quickurl-sort-function (read (or buffer (current-buffer))))))) @@ -303,7 +295,7 @@ (message "Found %s" (quickurl-url-url url)))) ;;;###autoload -(defun* quickurl (&optional lookup) +(cl-defun quickurl (&optional lookup) "Insert a URL based on LOOKUP. If not supplied LOOKUP is taken to be the word at point in the current @@ -464,20 +456,21 @@ (defun quickurl-list-populate-buffer () "Populate the `quickurl-list' buffer." (with-current-buffer (get-buffer quickurl-list-buffer-name) - (let ((buffer-read-only nil) - (fmt (format "%%-%ds %%s\n" - (apply #'max (or (loop for url in quickurl-urls - collect (length (quickurl-url-description url))) - (list 20)))))) - (setf (buffer-string) "") - (loop for url in quickurl-urls - do (let ((start (point))) - (insert (format fmt (quickurl-url-description url) - (quickurl-url-url url))) - (add-text-properties start (1- (point)) - '(mouse-face highlight - help-echo "mouse-2: insert this URL")))) - (setf (point) (point-min))))) + (let* ((sizes (or (cl-loop for url in quickurl-urls + collect (length (quickurl-url-description url))) + (list 20))) + (fmt (format "%%-%ds %%s\n" (apply #'max sizes))) + (inhibit-read-only t)) + (erase-buffer) + (cl-loop for url in quickurl-urls + do (let ((start (point))) + (insert (format fmt (quickurl-url-description url) + (quickurl-url-url url))) + (add-text-properties + start (1- (point)) + '(mouse-face highlight + help-echo "mouse-2: insert this URL")))) + (goto-char (point-min))))) (defun quickurl-list-add-url (word url comment) "Wrapper for `quickurl-add-url' that doesn't guess the parameters." @@ -494,7 +487,7 @@ (defun quickurl-list-mouse-select (event) "Select the URL under the mouse click." (interactive "e") - (setf (point) (posn-point (event-end event))) + (goto-char (posn-point (event-end event))) (quickurl-list-insert-url)) (defun quickurl-list-insert (type) @@ -510,16 +503,16 @@ (if url (with-current-buffer quickurl-list-last-buffer (insert - (case type - (url (funcall quickurl-format-function url)) - (naked-url (quickurl-url-url url)) - (with-lookup (format "%s " + (pcase type + (`url (funcall quickurl-format-function url)) + (`naked-url (quickurl-url-url url)) + (`with-lookup (format "%s " (quickurl-url-keyword url) (quickurl-url-url url))) - (with-desc (format "%S " + (`with-desc (format "%S " (quickurl-url-description url) (quickurl-url-url url))) - (lookup (quickurl-url-keyword url))))) + (`lookup (quickurl-url-keyword url))))) (error "No URL details on that line")) url)) === modified file 'lisp/net/secrets.el' --- lisp/net/secrets.el 2012-06-30 21:22:18 +0000 +++ lisp/net/secrets.el 2012-07-11 23:13:41 +0000 @@ -142,8 +142,7 @@ ;; Pacify byte-compiler. D-Bus support in the Emacs core can be ;; disabled with configuration option "--without-dbus". Declare used ;; subroutines and variables of `dbus' therefore. -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defvar dbus-debug) @@ -648,7 +647,7 @@ (let ((item-path (secrets-item-path collection item))) (unless (secrets-empty-path item-path) (dbus-byte-array-to-string - (caddr + (cl-caddr (dbus-call-method :session secrets-service item-path secrets-interface-item "GetSecret" :object-path secrets-session-path)))))) === modified file 'lisp/net/snmp-mode.el' --- lisp/net/snmp-mode.el 2012-04-09 13:05:48 +0000 +++ lisp/net/snmp-mode.el 2012-07-11 23:13:41 +0000 @@ -85,7 +85,6 @@ ;;; Code: (eval-when-compile - (require 'cl) (require 'imenu) ; Need this stuff when compiling for imenu macros, etc. (require 'tempo)) === modified file 'lisp/net/xesam.el' --- lisp/net/xesam.el 2012-06-30 21:22:18 +0000 +++ lisp/net/xesam.el 2012-07-11 23:13:41 +0000 @@ -129,10 +129,6 @@ (require 'dbus) -;; Pacify byte compiler. -(eval-when-compile - (require 'cl)) - ;; Widgets are used to highlight the search results. (require 'widget) (require 'wid-edit) @@ -409,24 +405,24 @@ ;; That is not the case now, so we set it ourselves. ;; Hopefully, this will change later. (setq hit-fields - (case (intern vendor-id) - (Beagle + (pcase (intern vendor-id) + (`Beagle '("xesam:mimeType" "xesam:url")) - (Strigi + (`Strigi '("xesam:author" "xesam:cc" "xesam:charset" "xesam:contentType" "xesam:fileExtension" "xesam:id" "xesam:lineCount" "xesam:links" "xesam:mimeType" "xesam:name" "xesam:size" "xesam:sourceModified" "xesam:subject" "xesam:to" "xesam:url")) - (TrackerXesamSession + (`TrackerXesamSession '("xesam:relevancyRating" "xesam:url")) - (Debbugs + (`Debbugs '("xesam:keyword" "xesam:owner" "xesam:title" "xesam:url" "xesam:sourceModified" "xesam:mimeType" "debbugs:key")) ;; xesam-tools yahoo service. - (t '("xesam:contentModified" "xesam:mimeType" "xesam:summary" + (_ '("xesam:contentModified" "xesam:mimeType" "xesam:summary" "xesam:title" "xesam:url" "yahoo:displayUrl")))) (xesam-set-property engine "hit.fields" hit-fields) === modified file 'lisp/net/zeroconf.el' --- lisp/net/zeroconf.el 2012-06-30 21:22:18 +0000 +++ lisp/net/zeroconf.el 2012-07-11 23:13:41 +0000 @@ -102,9 +102,6 @@ ;; Pacify byte-compiler. D-Bus support in the Emacs core can be ;; disabled with configuration option "--without-dbus". Declare used ;; subroutines and variables of `dbus' therefore. -(eval-when-compile - (require 'cl)) - (defvar dbus-debug) (require 'dbus) @@ -546,7 +543,7 @@ ((string-equal (dbus-event-member-name last-input-event) "ItemNew") ;; Parameters: (interface protocol type domain flags) ;; Register a service browser. - (let ((object-path (zeroconf-register-service-browser (nth-value 2 val)))) + (let ((object-path (zeroconf-register-service-browser (nth 2 val)))) ;; Register the signals. (dolist (member '("ItemNew" "ItemRemove" "Failure")) (dbus-register-signal === modified file 'lisp/notifications.el' --- lisp/notifications.el 2012-05-02 11:38:01 +0000 +++ lisp/notifications.el 2012-07-11 23:13:41 +0000 @@ -34,9 +34,6 @@ ;; active D-Bus session bus. ;;; Code: -(eval-when-compile - (require 'cl)) - (require 'dbus) (defconst notifications-specification-version "1.2" @@ -226,10 +223,10 @@ (when urgency (add-to-list 'hints `(:dict-entry "urgency" - (:variant :byte ,(case urgency - (low 0) - (critical 2) - (t 1)))) t)) + (:variant :byte ,(pcase urgency + (`low 0) + (`critical 2) + (_ 1)))) t)) (when category (add-to-list 'hints `(:dict-entry "category" === modified file 'lisp/novice.el' --- lisp/novice.el 2012-05-13 03:05:06 +0000 +++ lisp/novice.el 2012-07-11 23:13:41 +0000 @@ -33,8 +33,6 @@ ;; The command is found in this-command ;; and the keys are returned by (this-command-keys). -(eval-when-compile (require 'cl)) - ;;;###autoload (define-obsolete-variable-alias 'disabled-command-hook 'disabled-command-function "22.1") @@ -101,7 +99,7 @@ (ding) (message "Please type y, n, ! or SPC (the space bar): ")))) (setq char (downcase char)) - (case char + (pcase char (?\C-g (setq quit-flag t)) (?! (setq disabled-command-function nil)) (?y === modified file 'lisp/nxml/nxml-mode.el' --- lisp/nxml/nxml-mode.el 2012-06-12 05:47:14 +0000 +++ lisp/nxml/nxml-mode.el 2012-07-11 23:13:41 +0000 @@ -29,7 +29,7 @@ (when (featurep 'mucs) (error "nxml-mode is not compatible with Mule-UCS")) -(eval-when-compile (require 'cl)) ; for assert +(eval-when-compile (require 'cl-lib)) (require 'xmltok) (require 'nxml-enc) @@ -930,16 +930,16 @@ (nxml-debug-change "nxml-fontify-matcher" (point) bound) (when (< (point) nxml-prolog-end) - ;; prolog needs to be fontified in one go, and + ;; Prolog needs to be fontified in one go, and ;; nxml-extend-region makes sure we start at BOB. - (assert (bobp)) + (cl-assert (bobp)) (nxml-fontify-prolog) (goto-char nxml-prolog-end)) (let (xmltok-dependent-regions xmltok-errors) (while (and (nxml-tokenize-forward) - (<= (point) bound)) ; intervals are open-ended + (<= (point) bound)) ; Intervals are open-ended. (nxml-apply-fontify-rule))) (setq nxml-last-fontify-end (point))) === modified file 'lisp/play/5x5.el' --- lisp/play/5x5.el 2012-06-27 15:11:28 +0000 +++ lisp/play/5x5.el 2012-07-11 23:13:41 +0000 @@ -50,8 +50,7 @@ ;; Things we need. -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;; Customize options. @@ -260,8 +259,8 @@ (defun 5x5-make-new-grid () "Create and return a new `5x5' grid structure." (let ((grid (make-vector 5x5-grid-size nil))) - (loop for y from 0 to (1- 5x5-grid-size) do - (aset grid y (make-vector 5x5-grid-size nil))) + (dotimes (y 5x5-grid-size) + (aset grid y (make-vector 5x5-grid-size nil))) grid)) (defun 5x5-cell (grid y x) @@ -279,9 +278,9 @@ (defun 5x5-copy-grid (grid) "Make a new copy of GRID." (let ((copy (5x5-make-new-grid))) - (loop for y from 0 to (1- 5x5-grid-size) do - (loop for x from 0 to (1- 5x5-grid-size) do - (5x5-set-cell copy y x (5x5-cell grid y x)))) + (dotimes (y 5x5-grid-size) + (dotimes (x 5x5-grid-size) + (5x5-set-cell copy y x (5x5-cell grid y x)))) copy)) (defun 5x5-make-move (grid row col) @@ -299,45 +298,46 @@ (defun 5x5-row-value (row) "Get the \"on-value\" for grid row ROW." - (loop for y from 0 to (1- 5x5-grid-size) sum (if (aref row y) 1 0))) + (cl-loop for y from 0 to (1- 5x5-grid-size) sum (if (aref row y) 1 0))) (defun 5x5-grid-value (grid) "Get the \"on-value\" for grid GRID." - (loop for y from 0 to (1- 5x5-grid-size) sum (5x5-row-value (aref grid y)))) + (cl-loop for y from 0 to (1- 5x5-grid-size) + sum (5x5-row-value (aref grid y)))) (defun 5x5-draw-grid-end () "Draw the top/bottom of the grid." (insert "+") - (loop for x from 0 to (1- 5x5-grid-size) do - (insert "-" (make-string 5x5-x-scale ?-))) + (dotimes (x 5x5-grid-size) + (insert "-" (make-string 5x5-x-scale ?-))) (insert "-+ ")) (defun 5x5-draw-grid (grids) "Draw the grids GRIDS into the current buffer." (let ((inhibit-read-only t) grid-org) (erase-buffer) - (loop for grid in grids do (5x5-draw-grid-end)) + (dolist (grid grids) (5x5-draw-grid-end)) (insert "\n") (setq grid-org (point)) - (loop for y from 0 to (1- 5x5-grid-size) do - (loop for lines from 0 to (1- 5x5-y-scale) do - (loop for grid in grids do - (loop for x from 0 to (1- 5x5-grid-size) do - (insert (if (zerop x) "| " " ") - (make-string 5x5-x-scale - (if (5x5-cell grid y x) ?# ?.)))) - (insert " | ")) - (insert "\n"))) + (dotimes (y 5x5-grid-size) + (dotimes (lines 5x5-y-scale) + (dolist (grid grids) + (dotimes (x 5x5-grid-size) + (insert (if (zerop x) "| " " ") + (make-string 5x5-x-scale + (if (5x5-cell grid y x) ?# ?.)))) + (insert " | ")) + (insert "\n"))) (when 5x5-solver-output (if (= (car 5x5-solver-output) 5x5-moves) (save-excursion (goto-char grid-org) (beginning-of-line (+ 1 (/ 5x5-y-scale 2))) - (let ((solution-grid (cdadr 5x5-solver-output))) - (dotimes (y 5x5-grid-size) + (let ((solution-grid (cl-cdadr 5x5-solver-output))) + (dotimes (y 5x5-grid-size) (save-excursion (forward-char (+ 1 (/ (1+ 5x5-x-scale) 2))) - (dotimes (x 5x5-grid-size) + (dotimes (x 5x5-grid-size) (when (5x5-cell solution-grid y x) (if (= 0 (mod 5x5-x-scale 2)) (progn @@ -350,7 +350,7 @@ (forward-char (1+ 5x5-x-scale)))) (forward-line 5x5-y-scale)))) (setq 5x5-solver-output nil))) - (loop for grid in grids do (5x5-draw-grid-end)) + (dolist (grid grids) (5x5-draw-grid-end)) (insert "\n") (insert (format "On: %d Moves: %d" (5x5-grid-value (car grids)) 5x5-moves)))) @@ -362,16 +362,16 @@ (defun 5x5-made-move () "Keep track of how many moves have been made." - (incf 5x5-moves)) + (cl-incf 5x5-moves)) (defun 5x5-make-random-grid (&optional move) "Make a random grid." (setq move (or move (symbol-function '5x5-flip-cell))) (let ((grid (5x5-make-new-grid))) - (loop for y from 0 to (1- 5x5-grid-size) do - (loop for x from 0 to (1- 5x5-grid-size) do - (if (zerop (random 2)) - (funcall move grid y x)))) + (dotimes (y 5x5-grid-size) + (dotimes (x 5x5-grid-size) + (if (zerop (random 2)) + (funcall move grid y x)))) grid)) ;; Cracker functions. @@ -444,20 +444,20 @@ (defun 5x5-make-xor-with-mutation (current best) "Xor current and best solution then mutate the result." (let ((xored (5x5-make-new-grid))) - (loop for y from 0 to (1- 5x5-grid-size) do - (loop for x from 0 to (1- 5x5-grid-size) do - (5x5-set-cell xored y x - (5x5-xor (5x5-cell current y x) - (5x5-cell best y x))))) + (dotimes (y 5x5-grid-size) + (dotimes (x 5x5-grid-size) + (5x5-set-cell xored y x + (5x5-xor (5x5-cell current y x) + (5x5-cell best y x))))) (5x5-mutate-solution xored))) (defun 5x5-mutate-solution (solution) "Randomly flip bits in the solution." - (loop for y from 0 to (1- 5x5-grid-size) do - (loop for x from 0 to (1- 5x5-grid-size) do - (if (= (random (/ (* 5x5-grid-size 5x5-grid-size) 2)) - (/ (/ (* 5x5-grid-size 5x5-grid-size) 2) 2)) - (5x5-flip-cell solution y x)))) + (dotimes (y 5x5-grid-size) + (dotimes (x 5x5-grid-size) + (if (= (random (/ (* 5x5-grid-size 5x5-grid-size) 2)) + (/ (/ (* 5x5-grid-size 5x5-grid-size) 2) 2)) + (5x5-flip-cell solution y x)))) solution) (defun 5x5-play-solution (solution best) @@ -465,15 +465,15 @@ in progress because it is an animated attempt." (5x5-new-game) (let ((inhibit-quit t)) - (loop for y from 0 to (1- 5x5-grid-size) do - (loop for x from 0 to (1- 5x5-grid-size) do - (setq 5x5-y-pos y - 5x5-x-pos x) - (if (5x5-cell solution y x) - (5x5-flip-current)) - (5x5-draw-grid (list 5x5-grid solution best)) - (5x5-position-cursor) - (sit-for 5x5-animate-delay)))) + (dotimes (y 5x5-grid-size) + (dotimes (x 5x5-grid-size) + (setq 5x5-y-pos y + 5x5-x-pos x) + (if (5x5-cell solution y x) + (5x5-flip-current)) + (5x5-draw-grid (list 5x5-grid solution best)) + (5x5-position-cursor) + (sit-for 5x5-animate-delay)))) 5x5-grid) ;; Arithmetic solver @@ -758,9 +758,9 @@ ;; The Hamming Weight is computed by matrix reduction ;; with an ad-hoc operator. (math-reduce-vec - ;; (cadadr '(vec (mod x 2))) => x - (lambda (r x) (+ (if (integerp r) r (cadadr r)) - (cadadr x))) + ;; (cl-cadadr '(vec (mod x 2))) => x + (lambda (r x) (+ (if (integerp r) r (cl-cadadr r)) + (cl-cadadr x))) solution); car (5x5-vec-to-grid (calcFunc-arrange solution 5x5-grid-size));cdr @@ -878,28 +878,28 @@ "Move up." (interactive) (unless (zerop 5x5-y-pos) - (decf 5x5-y-pos) + (cl-decf 5x5-y-pos) (5x5-position-cursor))) (defun 5x5-down () "Move down." (interactive) (unless (= 5x5-y-pos (1- 5x5-grid-size)) - (incf 5x5-y-pos) + (cl-incf 5x5-y-pos) (5x5-position-cursor))) (defun 5x5-left () "Move left." (interactive) (unless (zerop 5x5-x-pos) - (decf 5x5-x-pos) + (cl-decf 5x5-x-pos) (5x5-position-cursor))) (defun 5x5-right () "Move right." (interactive) (unless (= 5x5-x-pos (1- 5x5-grid-size)) - (incf 5x5-x-pos) + (cl-incf 5x5-x-pos) (5x5-position-cursor))) (defun 5x5-bol () === modified file 'lisp/play/bubbles.el' --- lisp/play/bubbles.el 2012-01-19 07:21:25 +0000 +++ lisp/play/bubbles.el 2012-07-11 23:13:41 +0000 @@ -82,7 +82,6 @@ (defconst bubbles-version "0.5" "Version number of bubbles.el.") (require 'gamegrid) -(eval-when-compile (require 'cl)) ; for 'case ;; User options @@ -718,58 +717,58 @@ (defsubst bubbles--grid-width () "Return the grid width for the current game theme." - (car (case bubbles-game-theme - (easy + (car (pcase bubbles-game-theme + (`easy bubbles--grid-small) - (medium + (`medium bubbles--grid-medium) - (difficult + (`difficult bubbles--grid-large) - (hard + (`hard bubbles--grid-huge) - (user-defined + (`user-defined bubbles-grid-size)))) (defsubst bubbles--grid-height () "Return the grid height for the current game theme." - (cdr (case bubbles-game-theme - (easy + (cdr (pcase bubbles-game-theme + (`easy bubbles--grid-small) - (medium + (`medium bubbles--grid-medium) - (difficult + (`difficult bubbles--grid-large) - (hard + (`hard bubbles--grid-huge) - (user-defined + (`user-defined bubbles-grid-size)))) (defsubst bubbles--colors () "Return the color list for the current game theme." - (case bubbles-game-theme - (easy + (pcase bubbles-game-theme + (`easy bubbles--colors-2) - (medium + (`medium bubbles--colors-3) - (difficult + (`difficult bubbles--colors-4) - (hard + (`hard bubbles--colors-5) - (user-defined + (`user-defined bubbles-colors))) (defsubst bubbles--shift-mode () "Return the shift mode for the current game theme." - (case bubbles-game-theme - (easy - 'default) - (medium - 'default) - (difficult - 'always) - (hard - 'always) - (user-defined + (pcase bubbles-game-theme + (`easy + 'default) + (`medium + 'default) + (`difficult + 'always) + (`hard + 'always) + (`user-defined bubbles-shift-mode))) (defun bubbles-save-settings () @@ -1345,12 +1344,12 @@ "Prepare images for playing `bubbles'." (when (and (display-images-p) (not (eq bubbles-graphics-theme 'ascii))) - (let ((template (case bubbles-graphics-theme - (circles bubbles--image-template-circle) - (balls bubbles--image-template-ball) - (squares bubbles--image-template-square) - (diamonds bubbles--image-template-diamond) - (emacs bubbles--image-template-emacs)))) + (let ((template (pcase bubbles-graphics-theme + (`circles bubbles--image-template-circle) + (`balls bubbles--image-template-ball) + (`squares bubbles--image-template-square) + (`diamonds bubbles--image-template-diamond) + (`emacs bubbles--image-template-emacs)))) (setq bubbles--empty-image (create-image (replace-regexp-in-string "^\"\\(.*\\)\t.*c .*\",$" === modified file 'lisp/play/decipher.el' --- lisp/play/decipher.el 2012-01-19 07:21:25 +0000 +++ lisp/play/decipher.el 2012-07-11 23:13:41 +0000 @@ -88,8 +88,7 @@ ;;; Variables: ;;;=================================================================== -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defgroup decipher nil "Cryptanalyze monoalphabetic substitution ciphers." @@ -170,7 +169,7 @@ (let ((key ?a)) (while (<= key ?z) (define-key map (vector key) 'decipher-keypress) - (incf key))) + (cl-incf key))) map) "Keymap for Decipher mode.") @@ -194,7 +193,7 @@ (c ?0)) (while (<= c ?9) (modify-syntax-entry c "_" table) ;Digits are not part of words - (incf c)) + (cl-incf c)) (setq decipher-mode-syntax-table table))) (defvar decipher-alphabet nil) @@ -414,7 +413,7 @@ (if undo-rec (progn (push undo-rec decipher-undo-list) - (incf decipher-undo-list-size) + (cl-incf decipher-undo-list-size) (if (> decipher-undo-list-size decipher-undo-limit) (let ((new-size (- decipher-undo-limit 100))) ;; Truncate undo list to NEW-SIZE elements: @@ -588,7 +587,7 @@ (progn (while (rassoc cipher-char decipher-alphabet) ;; Find the next unused letter - (incf cipher-char)) + (cl-incf cipher-char)) (push (cons ?\s cipher-char) undo-rec) (decipher-set-map cipher-char (car plain-map) t)))) (decipher-add-undo undo-rec))) @@ -644,7 +643,7 @@ (while (>= plain-char ?a) (backward-char) (push (cons plain-char (following-char)) decipher-alphabet) - (decf plain-char))))) + (cl-decf plain-char))))) ;;;=================================================================== ;;; Analyzing ciphertext: @@ -805,8 +804,8 @@ (while temp-list (insert (caar temp-list) (format "%4d%3d%% " - (cadar temp-list) - (/ (* 100 (cadar temp-list)) total))) + (cl-cadar temp-list) + (/ (* 100 (cl-cadar temp-list)) total))) (setq temp-list (nthcdr 4 temp-list))) (insert ?\n) (setq freq-list (cdr freq-list) @@ -838,17 +837,17 @@ ;; A vector of 26 integers, counting the number of occurrences ;; of the corresponding characters. (setq decipher--digram (format "%c%c" decipher--prev-char decipher-char)) - (incf (cdr (or (assoc decipher--digram decipher--digram-list) + (cl-incf (cdr (or (assoc decipher--digram decipher--digram-list) (car (push (cons decipher--digram 0) decipher--digram-list))))) (and (>= decipher--prev-char ?A) - (incf (aref (aref decipher--before (- decipher--prev-char ?A)) + (cl-incf (aref (aref decipher--before (- decipher--prev-char ?A)) (if (equal decipher-char ?\s) 26 (- decipher-char ?A))))) (and (>= decipher-char ?A) - (incf (aref decipher--freqs (- decipher-char ?A))) - (incf (aref (aref decipher--after (- decipher-char ?A)) + (cl-incf (aref decipher--freqs (- decipher-char ?A))) + (cl-incf (aref (aref decipher--after (- decipher-char ?A)) (if (equal decipher--prev-char ?\s) 26 (- decipher--prev-char ?A))))) @@ -859,8 +858,8 @@ (let ((total 0)) (concat (mapconcat (lambda (x) - (cond ((> x 99) (incf total) "XX") - ((> x 0) (incf total) (format "%2d" x)) + (cond ((> x 99) (cl-incf total) "XX") + ((> x 0) (cl-incf total) (format "%2d" x)) (t " "))) counts "") @@ -873,10 +872,10 @@ ;; We do not include spaces (word divisions) in this count. (let ((total 0) (i 26)) - (while (>= (decf i) 0) + (while (>= (cl-decf i) 0) (if (or (> (aref before-count i) 0) (> (aref after-count i) 0)) - (incf total))) + (cl-incf total))) total)) (defun decipher-analyze-buffer () @@ -890,7 +889,7 @@ decipher--digram decipher--digram-list freq-list) (message "Scanning buffer...") (let ((i 26)) - (while (>= (decf i) 0) + (while (>= (cl-decf i) 0) (aset decipher--before i (make-vector 27 0)) (aset decipher--after i (make-vector 27 0)))) (if decipher-ignore-spaces @@ -898,7 +897,7 @@ (decipher-loop-no-breaks 'decipher--analyze) ;; The first character of ciphertext was marked as following a space: (let ((i 26)) - (while (>= (decf i) 0) + (while (>= (cl-decf i) 0) (aset (aref decipher--after i) 26 0)))) (decipher-loop-with-breaks 'decipher--analyze)) (message "Processing results...") @@ -913,7 +912,7 @@ ;; of times it occurs, and DIFFERENT is the number of different ;; letters it appears next to. (let ((i 26)) - (while (>= (decf i) 0) + (while (>= (cl-decf i) 0) (setq freq-list (cons (list (+ i ?A) (aref decipher--freqs i) @@ -933,7 +932,7 @@ (insert ?\n) ;; Display frequency counts for letters in order of frequency: (setq freq-list (sort freq-list - (lambda (a b) (> (second a) (second b))))) + (lambda (a b) (> (cl-second a) (cl-second b))))) (decipher-insert-frequency-counts freq-list total-chars) ;; Display letters in order of frequency: (insert ?\n (mapconcat (lambda (a) (char-to-string (car a))) @@ -957,11 +956,11 @@ ;; Display adjacency list for each letter, sorted in descending ;; order of the number of adjacent letters: (setq freq-list (sort freq-list - (lambda (a b) (> (third a) (third b))))) + (lambda (a b) (> (cl-third a) (cl-third b))))) (let ((temp-list freq-list) entry i) (while (setq entry (pop temp-list)) - (if (equal 0 (second entry)) + (if (equal 0 (cl-second entry)) nil ;This letter was not used (setq i (- (car entry) ?A)) (insert ?\n " " @@ -969,8 +968,8 @@ (car entry) ": A B C D E F G H I J K L M N O P Q R S T U V W X Y Z *" (format "%4d %4d %3d%%\n " - (third entry) (second entry) - (/ (* 100 (second entry)) total-chars)) + (cl-third entry) (cl-second entry) + (/ (* 100 (cl-second entry)) total-chars)) (decipher--digram-counts (aref decipher--after i)) ?\n)))) (setq buffer-read-only t) (set-buffer-modified-p nil) === modified file 'lisp/play/gamegrid.el' --- lisp/play/gamegrid.el 2012-01-19 07:21:25 +0000 +++ lisp/play/gamegrid.el 2012-07-11 23:13:41 +0000 @@ -26,9 +26,6 @@ ;;; Code: -(eval-when-compile - (require 'cl)) - ;; ;;;;;;;;;;;;; buffer-local variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar gamegrid-use-glyphs t @@ -212,20 +209,20 @@ (defun gamegrid-make-face (data-spec-list color-spec-list) (let ((data (gamegrid-match-spec-list data-spec-list)) (color (gamegrid-match-spec-list color-spec-list))) - (case data - (color-x + (pcase data + (`color-x (gamegrid-make-color-x-face color)) - (grid-x + (`grid-x (unless gamegrid-grid-x-face (setq gamegrid-grid-x-face (gamegrid-make-grid-x-face))) gamegrid-grid-x-face) - (mono-x + (`mono-x (unless gamegrid-mono-x-face (setq gamegrid-mono-x-face (gamegrid-make-mono-x-face))) gamegrid-mono-x-face) - (color-tty + (`color-tty (gamegrid-make-color-tty-face color)) - (mono-tty + (`mono-tty (unless gamegrid-mono-tty-face (setq gamegrid-mono-tty-face (gamegrid-make-mono-tty-face))) gamegrid-mono-tty-face)))) @@ -311,13 +308,13 @@ (intern (concat "gamegrid-face-" (buffer-name))))) (when (eq gamegrid-display-mode 'glyph) (let ((max-height nil)) - (loop for c from 0 to 255 do - (let ((glyph (aref gamegrid-display-table c))) - (when (and (listp glyph) (eq (car glyph) 'image)) - (let ((height (cdr (image-size glyph)))) - (if (or (null max-height) - (< max-height height)) - (setq max-height height)))))) + (dotimes (c 256) + (let ((glyph (aref gamegrid-display-table c))) + (when (and (listp glyph) (eq (car glyph) 'image)) + (let ((height (cdr (image-size glyph)))) + (if (or (null max-height) + (< max-height height)) + (setq max-height height)))))) (when (and max-height (< max-height 1)) (let ((default-font-height (face-attribute 'default :height)) (resy (/ (display-pixel-height) (/ (display-mm-height) 25.4))) @@ -332,10 +329,10 @@ (setq gamegrid-display-mode (gamegrid-display-type)) (setq gamegrid-display-table (make-display-table)) (setq gamegrid-face-table (make-vector 256 nil)) - (loop for c from 0 to 255 do + (dotimes (c 256) (let* ((spec (aref gamegrid-display-options c)) - (glyph (gamegrid-make-glyph (car spec) (caddr spec))) - (face (gamegrid-make-face (cadr spec) (caddr spec)))) + (glyph (gamegrid-make-glyph (car spec) (nth 2 spec))) + (face (gamegrid-make-face (cadr spec) (nth 2 spec)))) (aset gamegrid-face-table c face) (aset gamegrid-display-table c glyph))) (gamegrid-setup-default-font) @@ -451,10 +448,10 @@ On non-POSIX systems Emacs searches for FILE in the directory specified by the variable `temporary-file-directory'. If necessary, FILE is created there." - (case system-type - ((ms-dos windows-nt) + (pcase system-type + ((or `ms-dos `windows-nt) (gamegrid-add-score-insecure file score)) - (t + (_ (gamegrid-add-score-with-update-game-score file score)))) === modified file 'lisp/play/hanoi.el' --- lisp/play/hanoi.el 2011-07-01 01:55:02 +0000 +++ lisp/play/hanoi.el 2012-07-11 23:13:41 +0000 @@ -56,15 +56,14 @@ ;;; Code: -(eval-when-compile - (require 'cl) - ;; dynamic bondage: - (defvar baseward-step) - (defvar fly-step) - (defvar fly-row-start) - (defvar pole-width) - (defvar pole-char) - (defvar line-offset)) +(eval-when-compile (require 'cl-lib)) +;; dynamic bondage: +(defvar baseward-step) +(defvar fly-step) +(defvar fly-row-start) +(defvar pole-width) +(defvar pole-char) +(defvar line-offset) (defgroup hanoi nil "The Towers of Hanoi." @@ -124,9 +123,9 @@ Repent before ring 31 moves." (interactive) (let* ((start (ftruncate (float-time))) - (bits (loop repeat 32 - for x = (/ start (expt 2.0 31)) then (* x 2.0) - collect (truncate (mod x 2.0)))) + (bits (cl-loop repeat 32 + for x = (/ start (expt 2.0 31)) then (* x 2.0) + collect (truncate (mod x 2.0)))) (hanoi-move-period 1.0)) (hanoi-internal 32 bits start))) @@ -138,9 +137,9 @@ to be updated." (interactive) (let* ((start (ftruncate (float-time))) - (bits (loop repeat 64 - for x = (/ start (expt 2.0 63)) then (* x 2.0) - collect (truncate (mod x 2.0)))) + (bits (cl-loop repeat 64 + for x = (/ start (expt 2.0 63)) then (* x 2.0) + collect (truncate (mod x 2.0)))) (hanoi-move-period 1.0)) (hanoi-internal 64 bits start))) @@ -197,22 +196,22 @@ (setq fly-row-start (1- line-offset)) (setq fly-step line-offset) (setq baseward-step -1) - (loop repeat base-len do - (unless (zerop base-lines) - (insert-char ?\ (1- base-lines)) - (insert base-char) - (hanoi-put-face (1- (point)) (point) hanoi-base-face)) - (insert-char ?\ (+ 2 nrings)) - (insert ?\n)) + (cl-loop repeat base-len do + (unless (zerop base-lines) + (insert-char ?\ (1- base-lines)) + (insert base-char) + (hanoi-put-face (1- (point)) (point) hanoi-base-face)) + (insert-char ?\ (+ 2 nrings)) + (insert ?\n)) (delete-char -1) - (loop for coord in pole-coords do - (loop for row from (- coord (/ pole-width 2)) - for start = (+ (* row line-offset) base-lines 1) - repeat pole-width do - (subst-char-in-region start (+ start nrings 1) - ?\ pole-char) - (hanoi-put-face start (+ start nrings 1) - hanoi-pole-face)))) + (dolist (coord pole-coords) + (cl-loop for row from (- coord (/ pole-width 2)) + for start = (+ (* row line-offset) base-lines 1) + repeat pole-width do + (subst-char-in-region start (+ start nrings 1) + ?\ pole-char) + (hanoi-put-face start (+ start nrings 1) + hanoi-pole-face)))) ;; vertical (setq line-offset (1+ base-len)) (setq fly-step 1) @@ -222,17 +221,17 @@ (setq fly-row-start (point)) (insert-char ?\ base-len) (insert ?\n) - (loop repeat (1+ nrings) - with pole-line = - (loop with line = (make-string base-len ?\ ) - for coord in pole-coords - for start = (- coord (/ pole-width 2)) - for end = (+ start pole-width) do - (hanoi-put-face start end hanoi-pole-face line) - (loop for i from start below end do - (aset line i pole-char)) - finally return line) - do (insert pole-line ?\n)) + (cl-loop repeat (1+ nrings) + with pole-line = + (cl-loop with line = (make-string base-len ?\ ) + for coord in pole-coords + for start = (- coord (/ pole-width 2)) + for end = (+ start pole-width) do + (hanoi-put-face start end hanoi-pole-face line) + (cl-loop for i from start below end do + (aset line i pole-char)) + finally return line) + do (insert pole-line ?\n)) (insert-char base-char base-len) (hanoi-put-face (- (point) base-len) (point) hanoi-base-face) (set-window-start (selected-window) @@ -244,40 +243,41 @@ ;; the car is the position of the top ring currently on the pole, ;; (or the base of the pole if it is empty). ;; the cdr is in the fly-row just above the pole. - (poles (loop for coord in pole-coords - for fly-pos = (+ fly-row-start (* fly-step coord)) - for base = (+ fly-pos (* baseward-step (+ 2 nrings))) - collect (cons base fly-pos))) + (poles + (cl-loop for coord in pole-coords + for fly-pos = (+ fly-row-start (* fly-step coord)) + for base = (+ fly-pos (* baseward-step (+ 2 nrings))) + collect (cons base fly-pos))) ;; compute the string for each ring and make the list of ;; ring pairs. Each ring pair is initially (str . diameter). ;; Once placed in buffer it is changed to (center-pos . diameter). (rings - (loop - ;; radii are measured from the edge of the pole out. - ;; So diameter = 2 * radius + pole-width. When - ;; there's room, we make each ring's radius = - ;; pole-number + 1. If there isn't room, we step - ;; evenly from the max radius down to 1. - with max-radius = (min nrings - (/ (- max-ring-diameter pole-width) 2)) - for n from (1- nrings) downto 0 - for radius = (1+ (/ (* n max-radius) nrings)) - for diameter = (+ pole-width (* 2 radius)) - with format-str = (format "%%0%dd" pole-width) - for str = (concat (if vert "<" "^") - (make-string (1- radius) (if vert ?\- ?\|)) - (format format-str n) - (make-string (1- radius) (if vert ?\- ?\|)) - (if vert ">" "v")) - for face = - (if (eq (logand n 1) 1) ; oddp would require cl at runtime - hanoi-odd-ring-face hanoi-even-ring-face) - do (hanoi-put-face 0 (length str) face str) - collect (cons str diameter))) + (cl-loop + ;; radii are measured from the edge of the pole out. + ;; So diameter = 2 * radius + pole-width. When + ;; there's room, we make each ring's radius = + ;; pole-number + 1. If there isn't room, we step + ;; evenly from the max radius down to 1. + with max-radius = (min nrings + (/ (- max-ring-diameter pole-width) 2)) + for n from (1- nrings) downto 0 + for radius = (1+ (/ (* n max-radius) nrings)) + for diameter = (+ pole-width (* 2 radius)) + with format-str = (format "%%0%dd" pole-width) + for str = (concat (if vert "<" "^") + (make-string (1- radius) (if vert ?\- ?\|)) + (format format-str n) + (make-string (1- radius) (if vert ?\- ?\|)) + (if vert ">" "v")) + for face = + (if (eq (logand n 1) 1) ; oddp would require cl at runtime + hanoi-odd-ring-face hanoi-even-ring-face) + do (hanoi-put-face 0 (length str) face str) + collect (cons str diameter))) ;; Disable display of line and column numbers, for speed. (line-number-mode nil) (column-number-mode nil)) ;; do it! - (hanoi-n bits rings (car poles) (cadr poles) (caddr poles) + (hanoi-n bits rings (car poles) (cadr poles) (cl-caddr poles) start-time)) (message "Done")) (setq buffer-read-only t) @@ -322,14 +322,14 @@ ;; put never-before-placed RING on POLE and update their cars. (defun hanoi-insert-ring (ring pole) - (decf (car pole) baseward-step) + (cl-decf (car pole) baseward-step) (let ((str (car ring)) (start (- (car pole) (* (/ (cdr ring) 2) fly-step)))) (setcar ring (car pole)) - (loop for pos upfrom start by fly-step - for i below (cdr ring) do - (subst-char-in-region pos (1+ pos) (char-after pos) (aref str i)) - (set-text-properties pos (1+ pos) (text-properties-at i str))) + (cl-loop for pos upfrom start by fly-step + for i below (cdr ring) do + (subst-char-in-region pos (1+ pos) (char-after pos) (aref str i)) + (set-text-properties pos (1+ pos) (text-properties-at i str))) (hanoi-goto-char (car pole)))) ;; like goto-char, but if position is outside the window, then move to @@ -341,8 +341,8 @@ ;; do one pole-to-pole move and update the ring and pole pairs. (defun hanoi-move-ring (ring from to start-time) - (incf (car from) baseward-step) - (decf (car to) baseward-step) + (cl-incf (car from) baseward-step) + (cl-decf (car to) baseward-step) (let* ;; We move flywards-steps steps up the pole to the fly row, ;; then fly fly-steps steps across the fly row, then go ;; baseward-steps steps down the new pole. @@ -378,15 +378,15 @@ (/ (- tick flyward-ticks fly-ticks) ticks-per-pole-step)))))))) (if hanoi-move-period - (loop for elapsed = (- (float-time) start-time) - while (< elapsed hanoi-move-period) - with tick-period = (/ (float hanoi-move-period) total-ticks) - for tick = (ceiling (/ elapsed tick-period)) do - (hanoi-ring-to-pos ring (funcall tick-to-pos tick)) - (hanoi-sit-for (- (* tick tick-period) elapsed))) - (loop for tick from 1 to total-ticks by 2 do - (hanoi-ring-to-pos ring (funcall tick-to-pos tick)) - (hanoi-sit-for 0))) + (cl-loop for elapsed = (- (float-time) start-time) + while (< elapsed hanoi-move-period) + with tick-period = (/ (float hanoi-move-period) total-ticks) + for tick = (ceiling (/ elapsed tick-period)) do + (hanoi-ring-to-pos ring (funcall tick-to-pos tick)) + (hanoi-sit-for (- (* tick tick-period) elapsed))) + (cl-loop for tick from 1 to total-ticks by 2 do + (hanoi-ring-to-pos ring (funcall tick-to-pos tick)) + (hanoi-sit-for 0))) ;; Always make last move to keep pole and ring data consistent (hanoi-ring-to-pos ring (car to)) (if hanoi-move-period (+ start-time hanoi-move-period)))) @@ -403,11 +403,12 @@ (let* ((start (- (car ring) (* (/ (cdr ring) 2) fly-step))) (new-start (- pos (- (car ring) start)))) (if hanoi-horizontal-flag - (loop for i below (cdr ring) - for j = (if (< new-start start) i (- (cdr ring) i 1)) - for old-pos = (+ start (* j fly-step)) - for new-pos = (+ new-start (* j fly-step)) do - (transpose-regions old-pos (1+ old-pos) new-pos (1+ new-pos))) + (cl-loop for i below (cdr ring) + for j = (if (< new-start start) i (- (cdr ring) i 1)) + for old-pos = (+ start (* j fly-step)) + for new-pos = (+ new-start (* j fly-step)) do + (transpose-regions old-pos (1+ old-pos) + new-pos (1+ new-pos))) (let ((end (+ start (cdr ring))) (new-end (+ new-start (cdr ring)))) (if (< (abs (- new-start start)) (- end start)) @@ -425,9 +426,9 @@ (curr-char (if on-pole ?\ pole-char)) (face (if on-pole hanoi-pole-face nil))) (if hanoi-horizontal-flag - (loop for pos from pole-start below pole-end by line-offset do - (subst-char-in-region pos (1+ pos) curr-char new-char) - (hanoi-put-face pos (1+ pos) face)) + (cl-loop for pos from pole-start below pole-end by line-offset do + (subst-char-in-region pos (1+ pos) curr-char new-char) + (hanoi-put-face pos (1+ pos) face)) (subst-char-in-region pole-start pole-end curr-char new-char) (hanoi-put-face pole-start pole-end face)))) (setcar ring pos)) === modified file 'lisp/play/landmark.el' --- lisp/play/landmark.el 2012-04-09 13:05:48 +0000 +++ lisp/play/landmark.el 2012-07-11 23:13:41 +0000 @@ -56,7 +56,7 @@ ;; concise problem description. ;;;_* Require -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;;;_* From Gomoku @@ -1417,7 +1417,7 @@ (put 'z 't-1 (get 'z 't)) (put 'z 't (calc-smell-internal 'landmark-tree)) (if (= (- (get 'z 't) (get 'z 't-1)) 0.0) - (incf landmark-no-payoff) + (cl-incf landmark-no-payoff) (setf landmark-no-payoff 0))) (defun landmark-store-old-y_t () @@ -1464,7 +1464,7 @@ (landmark-e forward-char) (landmark-w backward-char))) (landmark-plot-square (landmark-point-square) 1) - (incf landmark-number-of-moves) + (cl-incf landmark-number-of-moves) (if landmark-output-moves (message "Moves made: %d" landmark-number-of-moves))) @@ -1591,11 +1591,11 @@ ; this a worka! ; (eval (cons '+ list)) ;;;_ - landmark-set-landmark-signal-strengths () -;;; on a screen higher than wide, I noticed that the robot would amble -;;; left and right and not move forward. examining *landmark-blackbox* -;;; revealed that there was no scent from the north and south -;;; landmarks, hence, they need less factoring down of the effect of -;;; distance on scent. +;; on a screen higher than wide, I noticed that the robot would amble +;; left and right and not move forward. examining *landmark-blackbox* +;; revealed that there was no scent from the north and south +;; landmarks, hence, they need less factoring down of the effect of +;; distance on scent. (defun landmark-set-landmark-signal-strengths () (setq landmark-tree-r (* (sqrt (+ (square landmark-cx) (square landmark-cy))) 1.5)) === modified file 'lisp/play/pong.el' --- lisp/play/pong.el 2012-01-19 07:21:25 +0000 +++ lisp/play/pong.el 2012-07-11 23:13:41 +0000 @@ -26,7 +26,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gamegrid) @@ -214,18 +214,18 @@ (defun pong-display-options () "Computes display options (required by gamegrid for colors)." (let ((options (make-vector 256 nil))) - (loop for c from 0 to 255 do + (dotimes (c 256) (aset options c - (cond ((= c pong-blank) - pong-blank-options) + (cond ((= c pong-blank) + pong-blank-options) ((= c pong-bat) - pong-bat-options) + pong-bat-options) ((= c pong-ball) - pong-ball-options) + pong-ball-options) ((= c pong-border) - pong-border-options) + pong-border-options) (t - '(nil nil nil))))) + '(nil nil nil))))) options)) @@ -246,18 +246,19 @@ ?\s) (let ((buffer-read-only nil)) - (loop for y from 0 to (1- pong-height) do - (loop for x from 0 to (1- pong-width) do - (gamegrid-set-cell x y pong-border))) - (loop for y from 1 to (- pong-height 2) do - (loop for x from 1 to (- pong-width 2) do - (gamegrid-set-cell x y pong-blank)))) - - (loop for y from pong-bat-player1 to (1- (+ pong-bat-player1 pong-bat-width)) do - (gamegrid-set-cell 2 y pong-bat)) - (loop for y from pong-bat-player2 to (1- (+ pong-bat-player2 pong-bat-width)) do - (gamegrid-set-cell (- pong-width 3) y pong-bat))) - + (dotimes (y pong-height) + (dotimes (x pong-width) + (gamegrid-set-cell x y pong-border))) + (cl-loop for y from 1 to (- pong-height 2) do + (cl-loop for x from 1 to (- pong-width 2) do + (gamegrid-set-cell x y pong-blank)))) + + (cl-loop for y from pong-bat-player1 + to (1- (+ pong-bat-player1 pong-bat-width)) + do (gamegrid-set-cell 2 y pong-bat)) + (cl-loop for y from pong-bat-player2 + to (1- (+ pong-bat-player2 pong-bat-width)) + do (gamegrid-set-cell (- pong-width 3) y pong-bat))) (defun pong-move-left () @@ -401,13 +402,12 @@ (defun pong-update-score () "Update score and print it on bottom of the game grid." - (let* ((string (format "Score: %d / %d" pong-score-player1 pong-score-player2)) + (let* ((string (format "Score: %d / %d" + pong-score-player1 pong-score-player2)) (len (length string))) - (loop for x from 0 to (1- len) do - (if (string-equal (buffer-name (current-buffer)) pong-buffer-name) - (gamegrid-set-cell x - pong-height - (aref string x)))))) + (dotimes (x len) + (if (string-equal (buffer-name (current-buffer)) pong-buffer-name) + (gamegrid-set-cell x pong-height (aref string x)))))) === modified file 'lisp/play/snake.el' --- lisp/play/snake.el 2012-01-19 07:21:25 +0000 +++ lisp/play/snake.el 2012-07-11 23:13:41 +0000 @@ -25,8 +25,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gamegrid) @@ -195,7 +194,7 @@ (defun snake-display-options () (let ((options (make-vector 256 nil))) - (loop for c from 0 to 255 do + (dotimes (c 256) (aset options c (cond ((= c snake-blank) snake-blank-options) @@ -214,7 +213,7 @@ (defun snake-update-score () (let* ((string (format "Score: %05d" snake-score)) (len (length string))) - (loop for x from 0 to (1- len) do + (dotimes (x len) (gamegrid-set-cell (+ snake-score-x x) snake-score-y (aref string x))))) @@ -224,12 +223,12 @@ snake-buffer-height snake-space) (let ((buffer-read-only nil)) - (loop for y from 0 to (1- snake-height) do - (loop for x from 0 to (1- snake-width) do - (gamegrid-set-cell x y snake-border))) - (loop for y from 1 to (- snake-height 2) do - (loop for x from 1 to (- snake-width 2) do - (gamegrid-set-cell x y snake-blank))))) + (dotimes (y snake-height) + (dotimes (x snake-width) + (gamegrid-set-cell x y snake-border))) + (cl-loop for y from 1 to (- snake-height 2) do + (cl-loop for x from 1 to (- snake-width 2) do + (gamegrid-set-cell x y snake-blank))))) (defun snake-reset-game () (gamegrid-kill-timer) @@ -248,8 +247,8 @@ (dotimes (i snake-length) (gamegrid-set-cell x y snake-snake) (setq snake-positions (cons (vector x y) snake-positions)) - (incf x snake-velocity-x) - (incf y snake-velocity-y))) + (cl-incf x snake-velocity-x) + (cl-incf y snake-velocity-y))) (snake-update-score)) (defun snake-update-game (snake-buffer) @@ -267,8 +266,8 @@ (= c snake-snake)) (snake-end-game) (cond ((= c snake-dot) - (incf snake-length) - (incf snake-score) + (cl-incf snake-length) + (cl-incf snake-score) (snake-update-score)) (t (let* ((last-cons (nthcdr (- snake-length 2) @@ -280,7 +279,7 @@ (if (= (% snake-cycle 5) 0) snake-dot snake-blank)) - (incf snake-cycle) + (cl-incf snake-cycle) (setcdr last-cons nil)))) (gamegrid-set-cell x y snake-snake) (setq snake-positions === modified file 'lisp/play/tetris.el' --- lisp/play/tetris.el 2012-01-19 07:21:25 +0000 +++ lisp/play/tetris.el 2012-07-11 23:13:41 +0000 @@ -26,8 +26,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'gamegrid) @@ -285,20 +284,20 @@ (defun tetris-display-options () (let ((options (make-vector 256 nil))) - (loop for c from 0 to 255 do + (dotimes (c 256) (aset options c (cond ((= c tetris-blank) - tetris-blank-options) + tetris-blank-options) ((and (>= c 0) (<= c 6)) (append tetris-cell-options `((((glyph color-x) ,(aref tetris-x-colors c)) (color-tty ,(aref tetris-tty-colors c)) (t nil))))) - ((= c tetris-border) - tetris-border-options) - ((= c tetris-space) - tetris-space-options) + ((= c tetris-border) + tetris-border-options) + ((= c tetris-space) + tetris-space-options) (t '(nil nil nil))))) options)) @@ -325,13 +324,13 @@ (let ((strings (vector (format "Shapes: %05d" tetris-n-shapes) (format "Rows: %05d" tetris-n-rows) (format "Score: %05d" tetris-score)))) - (loop for y from 0 to 2 do - (let* ((string (aref strings y)) - (len (length string))) - (loop for x from 0 to (1- len) do - (gamegrid-set-cell (+ tetris-score-x x) - (+ tetris-score-y y) - (aref string x))))))) + (dotimes (y 3) + (let* ((string (aref strings y)) + (len (length string))) + (dotimes (x len) + (gamegrid-set-cell (+ tetris-score-x x) + (+ tetris-score-y y) + (aref string x))))))) (defun tetris-update-score () (tetris-draw-score) @@ -351,88 +350,88 @@ (tetris-update-score))) (defun tetris-draw-next-shape () - (loop for x from 0 to 3 do - (loop for y from 0 to 3 do - (gamegrid-set-cell (+ tetris-next-x x) - (+ tetris-next-y y) - tetris-blank))) - (loop for i from 0 to 3 do - (let ((tetris-shape tetris-next-shape) - (tetris-rot 0)) - (gamegrid-set-cell (+ tetris-next-x - (aref (tetris-get-shape-cell i) 0)) - (+ tetris-next-y - (aref (tetris-get-shape-cell i) 1)) - tetris-shape)))) + (dotimes (x 4) + (dotimes (y 4) + (gamegrid-set-cell (+ tetris-next-x x) + (+ tetris-next-y y) + tetris-blank))) + (dotimes (i 4) + (let ((tetris-shape tetris-next-shape) + (tetris-rot 0)) + (gamegrid-set-cell (+ tetris-next-x + (aref (tetris-get-shape-cell i) 0)) + (+ tetris-next-y + (aref (tetris-get-shape-cell i) 1)) + tetris-shape)))) (defun tetris-draw-shape () - (loop for i from 0 to 3 do - (let ((c (tetris-get-shape-cell i))) - (gamegrid-set-cell (+ tetris-top-left-x - tetris-pos-x - (aref c 0)) - (+ tetris-top-left-y - tetris-pos-y - (aref c 1)) - tetris-shape)))) + (dotimes (i 4) + (let ((c (tetris-get-shape-cell i))) + (gamegrid-set-cell (+ tetris-top-left-x + tetris-pos-x + (aref c 0)) + (+ tetris-top-left-y + tetris-pos-y + (aref c 1)) + tetris-shape)))) (defun tetris-erase-shape () - (loop for i from 0 to 3 do - (let ((c (tetris-get-shape-cell i))) - (gamegrid-set-cell (+ tetris-top-left-x - tetris-pos-x - (aref c 0)) - (+ tetris-top-left-y - tetris-pos-y - (aref c 1)) - tetris-blank)))) + (dotimes (i 4) + (let ((c (tetris-get-shape-cell i))) + (gamegrid-set-cell (+ tetris-top-left-x + tetris-pos-x + (aref c 0)) + (+ tetris-top-left-y + tetris-pos-y + (aref c 1)) + tetris-blank)))) (defun tetris-test-shape () (let ((hit nil)) - (loop for i from 0 to 3 do - (unless hit - (setq hit - (let* ((c (tetris-get-shape-cell i)) - (xx (+ tetris-pos-x - (aref c 0))) - (yy (+ tetris-pos-y - (aref c 1)))) - (or (>= xx tetris-width) - (>= yy tetris-height) - (/= (gamegrid-get-cell - (+ xx tetris-top-left-x) - (+ yy tetris-top-left-y)) - tetris-blank)))))) + (dotimes (i 4) + (unless hit + (setq hit + (let* ((c (tetris-get-shape-cell i)) + (xx (+ tetris-pos-x + (aref c 0))) + (yy (+ tetris-pos-y + (aref c 1)))) + (or (>= xx tetris-width) + (>= yy tetris-height) + (/= (gamegrid-get-cell + (+ xx tetris-top-left-x) + (+ yy tetris-top-left-y)) + tetris-blank)))))) hit)) (defun tetris-full-row (y) (let ((full t)) - (loop for x from 0 to (1- tetris-width) do - (if (= (gamegrid-get-cell (+ tetris-top-left-x x) - (+ tetris-top-left-y y)) - tetris-blank) - (setq full nil))) + (dotimes (x tetris-width) + (if (= (gamegrid-get-cell (+ tetris-top-left-x x) + (+ tetris-top-left-y y)) + tetris-blank) + (setq full nil))) full)) (defun tetris-shift-row (y) (if (= y 0) - (loop for x from 0 to (1- tetris-width) do + (dotimes (x tetris-width) (gamegrid-set-cell (+ tetris-top-left-x x) (+ tetris-top-left-y y) tetris-blank)) - (loop for x from 0 to (1- tetris-width) do - (let ((c (gamegrid-get-cell (+ tetris-top-left-x x) - (+ tetris-top-left-y y -1)))) - (gamegrid-set-cell (+ tetris-top-left-x x) - (+ tetris-top-left-y y) + (dotimes (x tetris-width) + (let ((c (gamegrid-get-cell (+ tetris-top-left-x x) + (+ tetris-top-left-y y -1)))) + (gamegrid-set-cell (+ tetris-top-left-x x) + (+ tetris-top-left-y y) c))))) (defun tetris-shift-down () - (loop for y0 from 0 to (1- tetris-height) do - (if (tetris-full-row y0) - (progn (setq tetris-n-rows (1+ tetris-n-rows)) - (loop for y from y0 downto 0 do - (tetris-shift-row y)))))) + (dotimes (y0 tetris-height) + (when (tetris-full-row y0) + (setq tetris-n-rows (1+ tetris-n-rows)) + (cl-loop for y from y0 downto 0 do + (tetris-shift-row y))))) (defun tetris-draw-border-p () (or (not (eq gamegrid-display-mode 'glyph)) @@ -444,22 +443,22 @@ tetris-space) (let ((buffer-read-only nil)) (if (tetris-draw-border-p) - (loop for y from -1 to tetris-height do - (loop for x from -1 to tetris-width do - (gamegrid-set-cell (+ tetris-top-left-x x) - (+ tetris-top-left-y y) - tetris-border)))) - (loop for y from 0 to (1- tetris-height) do - (loop for x from 0 to (1- tetris-width) do - (gamegrid-set-cell (+ tetris-top-left-x x) - (+ tetris-top-left-y y) - tetris-blank))) + (cl-loop for y from -1 to tetris-height do + (cl-loop for x from -1 to tetris-width do + (gamegrid-set-cell (+ tetris-top-left-x x) + (+ tetris-top-left-y y) + tetris-border)))) + (dotimes (y tetris-height) + (dotimes (x tetris-width) + (gamegrid-set-cell (+ tetris-top-left-x x) + (+ tetris-top-left-y y) + tetris-blank))) (if (tetris-draw-border-p) - (loop for y from -1 to 4 do - (loop for x from -1 to 4 do - (gamegrid-set-cell (+ tetris-next-x x) - (+ tetris-next-y y) - tetris-border)))))) + (cl-loop for y from -1 to 4 do + (cl-loop for x from -1 to 4 do + (gamegrid-set-cell (+ tetris-next-x x) + (+ tetris-next-y y) + tetris-border)))))) (defun tetris-reset-game () (gamegrid-kill-timer) === modified file 'lisp/progmodes/compile.el' --- lisp/progmodes/compile.el 2012-06-03 14:37:13 +0000 +++ lisp/progmodes/compile.el 2012-07-11 23:13:41 +0000 @@ -30,7 +30,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'tool-bar) (require 'comint) @@ -791,7 +791,7 @@ 3))) (setq compilation-skip-threshold level) (message "Skipping %s" - (case compilation-skip-threshold + (pcase compilation-skip-threshold (0 "Nothing") (1 "Info messages") (2 "Warnings and info")))) @@ -826,7 +826,7 @@ ;; modified using the same *compilation* buffer. this necessitates ;; re-parsing markers. -;; (defstruct (compilation--loc +;; (cl-defstruct (compilation--loc ;; (:constructor nil) ;; (:copier nil) ;; (:constructor compilation--make-loc @@ -875,7 +875,7 @@ ;; These are the value of the `compilation-message' text-properties in the ;; compilation buffer. -(defstruct (compilation--message +(cl-defstruct (compilation--message (:constructor nil) (:copier nil) ;; (:type list) ;Old representation. @@ -1212,7 +1212,7 @@ (goto-char end) (unless (bolp) ;; We generally don't like to parse partial lines. - (assert (eobp)) + (cl-assert (eobp)) (when (let ((proc (get-buffer-process (current-buffer)))) (and proc (memq (process-status proc) '(run open)))) (setq end (line-beginning-position)))) @@ -2415,7 +2415,7 @@ (push fs compilation-gcpro) (let ((loc (compilation-assq (or line 1) (cdr fs)))) (setq loc (compilation-assq col loc)) - (assert (null (cdr loc))) + (cl-assert (null (cdr loc))) (setcdr loc (compilation--make-cdrloc line fs marker)) loc))) @@ -2685,8 +2685,8 @@ (defun compilation--flush-file-structure (file) (or (consp file) (setq file (list file))) (let ((fs (compilation-get-file-structure file))) - (assert (eq fs (gethash file compilation-locs))) - (assert (eq fs (gethash (cons (caar fs) (cadr (car fs))) + (cl-assert (eq fs (gethash file compilation-locs))) + (cl-assert (eq fs (gethash (cons (caar fs) (cadr (car fs))) compilation-locs))) (maphash (lambda (k v) (if (eq v fs) (remhash k compilation-locs))) === modified file 'lisp/progmodes/cwarn.el' --- lisp/progmodes/cwarn.el 2012-06-12 05:47:14 +0000 +++ lisp/progmodes/cwarn.el 2012-07-11 23:13:41 +0000 @@ -105,8 +105,6 @@ ;;{{{ Dependencies -(eval-when-compile (require 'cl)) - (require 'custom) (require 'font-lock) (require 'cc-mode) === modified file 'lisp/progmodes/ebrowse.el' --- lisp/progmodes/ebrowse.el 2012-06-27 15:11:28 +0000 +++ lisp/progmodes/ebrowse.el 2012-07-11 23:13:41 +0000 @@ -38,7 +38,7 @@ (require 'ebuff-menu) (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'helper)) @@ -249,6 +249,7 @@ (defmacro ebrowse-output (&rest body) "Eval BODY with a writable current buffer. Preserve buffer's modified state." + (declare (indent 0) (debug t)) (let ((modified (make-symbol "--ebrowse-output--"))) `(let (buffer-read-only (,modified (buffer-modified-p))) (unwind-protect @@ -258,35 +259,30 @@ (defmacro ebrowse-ignoring-completion-case (&rest body) "Eval BODY with `completion-ignore-case' bound to t." + (declare (indent 0) (debug t)) `(let ((completion-ignore-case t)) ,@body)) - (defmacro ebrowse-save-selective (&rest body) "Eval BODY with `selective-display' restored at the end." - (let ((var (make-symbol "var"))) - `(let ((,var selective-display)) - (unwind-protect - (progn ,@body) - (setq selective-display ,var))))) - + (declare (indent 0) (debug t)) + ;; FIXME: Don't use selective-display. + `(let ((selective-display selective-display)) + ,@body)) (defmacro ebrowse-for-all-trees (spec &rest body) "For all trees in SPEC, eval BODY." + (declare (indent 1) (debug ((sexp form) body))) (let ((var (make-symbol "var")) (spec-var (car spec)) (array (cadr spec))) - `(loop for ,var being the symbols of ,array - as ,spec-var = (get ,var 'ebrowse-root) do - (when (vectorp ,spec-var) - ,@body)))) + `(cl-loop for ,var being the symbols of ,array + as ,spec-var = (get ,var 'ebrowse-root) do + (when (vectorp ,spec-var) + ,@body)))) ;;; Set indentation for macros above. -(put 'ebrowse-output 'lisp-indent-hook 0) -(put 'ebrowse-ignoring-completion-case 'lisp-indent-hook 0) -(put 'ebrowse-save-selective 'lisp-indent-hook 0) -(put 'ebrowse-for-all-trees 'lisp-indent-hook 1) (defsubst ebrowse-set-face (start end face) @@ -307,17 +303,6 @@ (ebrowse-ignoring-completion-case (completing-read prompt table nil t initial-input))) - -(defun ebrowse-value-in-buffer (sym buffer) - "Return the value of SYM in BUFFER." - (let ((old-buffer (current-buffer))) - (unwind-protect - (progn - (set-buffer buffer) - (symbol-value sym)) - (set-buffer old-buffer)))) - - (defun ebrowse-rename-buffer (new-name) "Rename current buffer to NEW-NAME. If a buffer with name NEW-NAME already exists, delete it first." @@ -333,9 +318,9 @@ Replace sequences of newlines with a single space." (when (string-match "^[ \t\n\r]+" string) (setq string (substring string (match-end 0)))) - (loop while (string-match "[\n]+" string) - finally return string do - (setq string (replace-match " " nil t string)))) + (cl-loop while (string-match "[\n]+" string) + finally return string do + (setq string (replace-match " " nil t string)))) (defun ebrowse-width-of-drawable-area () @@ -350,7 +335,7 @@ ;;; Structure definitions -(defstruct (ebrowse-hs (:type vector) :named) +(cl-defstruct (ebrowse-hs (:type vector) :named) "Header structure found at the head of BROWSE files." ;; A version string that is compared against the version number of ;; the Lisp package when the file is loaded. This is done to @@ -367,7 +352,7 @@ member-table) -(defstruct (ebrowse-ts (:type vector) :named) +(cl-defstruct (ebrowse-ts (:type vector) :named) "Tree structure. Following the header structure, a BROWSE file contains a number of `ebrowse-ts' structures, each one describing one root class of @@ -387,7 +372,7 @@ mark) -(defstruct (ebrowse-bs (:type vector) :named) +(cl-defstruct (ebrowse-bs (:type vector) :named) "Common sub-structure. A common structure defining an occurrence of some name in the source files." @@ -414,14 +399,14 @@ point) -(defstruct (ebrowse-cs (:include ebrowse-bs) (:type vector) :named) +(cl-defstruct (ebrowse-cs (:include ebrowse-bs) (:type vector) :named) "Class structure. This is the structure stored in the CLASS slot of a `ebrowse-ts' structure. It describes the location of the class declaration." source-file) -(defstruct (ebrowse-ms (:include ebrowse-bs) (:type vector) :named) +(cl-defstruct (ebrowse-ms (:include ebrowse-bs) (:type vector) :named) "Member structure. This is the structure describing a single member. The `ebrowse-ts' structure contains various lists for the different types of @@ -691,7 +676,7 @@ (ebrowse-for-all-trees (tree ebrowse--tree-obarray) (when (or (not marked-only) (ebrowse-ts-mark tree)) (let ((class (ebrowse-ts-class tree))) - (when (zerop (% (incf i) 20)) + (when (zerop (% (cl-incf i) 20)) (ebrowse-show-progress "Preparing file list" (zerop i))) ;; Add files mentioned in class description (let ((source-file (ebrowse-cs-source-file class)) @@ -701,14 +686,14 @@ (when file (puthash file file files)) ;; For all member lists in this class - (loop for accessor in ebrowse-member-list-accessors do - (loop for m in (funcall accessor tree) - for file = (ebrowse-ms-file m) - for def-file = (ebrowse-ms-definition-file m) do - (when file - (puthash file file files)) - (when def-file - (puthash def-file def-file files)))))))) + (dolist (accessor ebrowse-member-list-accessors) + (cl-loop for m in (funcall accessor tree) + for file = (ebrowse-ms-file m) + for def-file = (ebrowse-ms-definition-file m) do + (when file + (puthash file file files)) + (when def-file + (puthash def-file def-file files)))))))) files)) @@ -721,11 +706,11 @@ list)) -(defun* ebrowse-marked-classes-p () +(cl-defun ebrowse-marked-classes-p () "Value is non-nil if any class in the current class tree is marked." (ebrowse-for-all-trees (tree ebrowse--tree-obarray) (when (ebrowse-ts-mark tree) - (return-from ebrowse-marked-classes-p tree)))) + (cl-return-from ebrowse-marked-classes-p tree)))) (defsubst ebrowse-globals-tree-p (tree) @@ -752,12 +737,13 @@ (if qualified-names-p (ebrowse-for-all-trees (tree ebrowse--tree-obarray) (setq alist - (acons (ebrowse-qualified-class-name (ebrowse-ts-class tree)) - tree alist))) + (cl-acons (ebrowse-qualified-class-name + (ebrowse-ts-class tree)) + tree alist))) (ebrowse-for-all-trees (tree ebrowse--tree-obarray) (setq alist - (acons (ebrowse-cs-name (ebrowse-ts-class tree)) - tree alist)))) + (cl-acons (ebrowse-cs-name (ebrowse-ts-class tree)) + tree alist)))) alist)) @@ -792,15 +778,15 @@ computes this information lazily." (or (ebrowse-ts-base-classes tree) (setf (ebrowse-ts-base-classes tree) - (loop with to-search = (list tree) - with result = nil - as search = (pop to-search) - while search finally return result - do (ebrowse-for-all-trees (ti ebrowse--tree-obarray) - (when (memq search (ebrowse-ts-subclasses ti)) - (unless (memq ti result) - (setq result (nconc result (list ti)))) - (push ti to-search))))))) + (cl-loop with to-search = (list tree) + with result = nil + as search = (pop to-search) + while search finally return result + do (ebrowse-for-all-trees (ti ebrowse--tree-obarray) + (when (memq search (ebrowse-ts-subclasses ti)) + (unless (memq ti result) + (setq result (nconc result (list ti)))) + (push ti to-search))))))) (defun ebrowse-direct-base-classes (tree) @@ -820,8 +806,8 @@ ACCESSOR is the accessor function for the member list. Elements of the result have the form (NAME . ACCESSOR), where NAME is the member name." - (loop for member in (funcall accessor tree) - collect (cons (ebrowse-ms-name member) accessor))) + (cl-loop for member in (funcall accessor tree) + collect (cons (ebrowse-ms-name member) accessor))) (defun ebrowse-name/accessor-alist-for-visible-members () @@ -834,10 +820,10 @@ ebrowse--accessor))) (if ebrowse--show-inherited-flag (nconc list - (loop for tree in (ebrowse-base-classes - ebrowse--displayed-class) - nconc (ebrowse-name/accessor-alist - tree ebrowse--accessor))) + (cl-loop for tree in (ebrowse-base-classes + ebrowse--displayed-class) + nconc (ebrowse-name/accessor-alist + tree ebrowse--accessor))) list))) @@ -908,8 +894,7 @@ See that variable's documentation for the meaning of IGNORE-AUTO-SAVE and NOCONFIRM." (when (or noconfirm (yes-or-no-p "Revert tree from disk? ")) - (loop for member-buffer in (ebrowse-same-tree-member-buffer-list) - do (kill-buffer member-buffer)) + (mapc #'kill-buffer (ebrowse-same-tree-member-buffer-list)) (erase-buffer) (with-no-warnings (insert-file (or buffer-file-name ebrowse--tags-file-name))) @@ -934,9 +919,9 @@ ebrowse--frozen-flag nil) (ebrowse-redraw-tree) (set-buffer-modified-p nil) - (case pop - (switch (switch-to-buffer name)) - (pop (pop-to-buffer name))) + (pcase pop + (`switch (switch-to-buffer name)) + (`pop (pop-to-buffer name))) (current-buffer))) @@ -962,14 +947,14 @@ (garbage-collect) ;; For all classes... (ebrowse-for-all-trees (c ebrowse--tree-obarray) - (when (zerop (% (incf i) 10)) + (when (zerop (% (cl-incf i) 10)) (ebrowse-show-progress "Preparing member lookup" (zerop i))) - (loop for f in ebrowse-member-list-accessors do - (loop for m in (funcall f c) do - (let* ((member-name (ebrowse-ms-name m)) - (value (gethash member-name members))) - (push (list c f m) value) - (puthash member-name value members))))) + (dolist (f ebrowse-member-list-accessors) + (dolist (m (funcall f c)) + (let* ((member-name (ebrowse-ms-name m)) + (value (gethash member-name members))) + (push (list c f m) value) + (puthash member-name value members))))) (setf (ebrowse-hs-member-table ebrowse--header) members))) @@ -977,11 +962,11 @@ "Return the member obarray. Build it if it hasn't been set up yet. HEADER is the tree header structure of the class tree." (when (null (ebrowse-hs-member-table header)) - (loop for buffer in (ebrowse-browser-buffer-list) - until (eq header (ebrowse-value-in-buffer 'ebrowse--header buffer)) - finally do - (with-current-buffer buffer - (ebrowse-fill-member-table)))) + (cl-loop for buffer in (ebrowse-browser-buffer-list) + until (eq header (buffer-local-value 'ebrowse--header buffer)) + finally do + (with-current-buffer buffer + (ebrowse-fill-member-table)))) (ebrowse-hs-member-table header)) @@ -993,11 +978,12 @@ Build obarray of all classes in TREE." (let ((classes (make-vector 127 0))) ;; Add root classes... - (loop for root in tree - as sym = - (intern (ebrowse-qualified-class-name (ebrowse-ts-class root)) classes) - do (unless (get sym 'ebrowse-root) - (setf (get sym 'ebrowse-root) root))) + (cl-loop for root in tree + as sym = + (intern (ebrowse-qualified-class-name (ebrowse-ts-class root)) + classes) + do (unless (get sym 'ebrowse-root) + (setf (get sym 'ebrowse-root) root))) ;; Process subclasses (ebrowse-insert-supers tree classes) classes)) @@ -1015,29 +1001,30 @@ We have to be cautious here not to end up in an infinite recursion if for some reason a circle is in the inheritance graph." - (loop for class in tree - as subclasses = (ebrowse-ts-subclasses class) do - ;; Make sure every class is represented by a unique object - (loop for subclass on subclasses - as sym = (intern - (ebrowse-qualified-class-name (ebrowse-ts-class (car subclass))) - classes) - as next = nil - do - ;; Replace the subclass tree with the one found in - ;; CLASSES if there is already an entry for that class - ;; in it. Otherwise make a new entry. - ;; - ;; CAVEAT: If by some means (e.g., use of the - ;; preprocessor in class declarations, a name is marked - ;; as a subclass of itself on some path, we would end up - ;; in an endless loop. We have to omit subclasses from - ;; the recursion that already have been processed. - (if (get sym 'ebrowse-root) - (setf (car subclass) (get sym 'ebrowse-root)) - (setf (get sym 'ebrowse-root) (car subclass)))) - ;; Process subclasses - (ebrowse-insert-supers subclasses classes))) + (cl-loop for class in tree + as subclasses = (ebrowse-ts-subclasses class) do + ;; Make sure every class is represented by a unique object + (cl-loop for subclass on subclasses + as sym = (intern + (ebrowse-qualified-class-name + (ebrowse-ts-class (car subclass))) + classes) + as next = nil + do + ;; Replace the subclass tree with the one found in + ;; CLASSES if there is already an entry for that class + ;; in it. Otherwise make a new entry. + ;; + ;; CAVEAT: If by some means (e.g., use of the + ;; preprocessor in class declarations, a name is marked + ;; as a subclass of itself on some path, we would end up + ;; in an endless loop. We have to omit subclasses from + ;; the recursion that already have been processed. + (if (get sym 'ebrowse-root) + (setf (car subclass) (get sym 'ebrowse-root)) + (setf (get sym 'ebrowse-root) (car subclass)))) + ;; Process subclasses + (ebrowse-insert-supers subclasses classes))) ;;; Tree buffers @@ -1111,7 +1098,7 @@ (unless (zerop (buffer-size)) (goto-char (point-min)) - (multiple-value-setq (header tree) (values-list (ebrowse-read))) + (cl-multiple-value-setq (header tree) (cl-values-list (ebrowse-read))) (message "Sorting. Please be patient...") (setq tree (ebrowse-sort-tree-list tree)) (erase-buffer) @@ -1199,32 +1186,32 @@ ;; Get the classes whose mark must be toggled. Note that ;; ebrowse-tree-at-point might issue an error. (ignore-errors - (loop repeat (or n-times 1) - as tree = (ebrowse-tree-at-point) - do (progn - (setf (ebrowse-ts-mark tree) (not (ebrowse-ts-mark tree))) - (forward-line 1) - (push tree to-change)))) + (cl-loop repeat (or n-times 1) + as tree = (ebrowse-tree-at-point) + do (progn + (setf (ebrowse-ts-mark tree) (not (ebrowse-ts-mark tree))) + (forward-line 1) + (push tree to-change)))) (save-excursion ;; For all these classes, reverse the mark char in the display ;; by a regexp replace over the whole buffer. The reason for this ;; is that classes might have multiple base classes. If this is ;; the case, they are displayed more than once in the tree. (ebrowse-output - (loop for tree in to-change - as regexp = (concat "^.*\\b" - (regexp-quote - (ebrowse-cs-name (ebrowse-ts-class tree))) - "\\b") - do - (goto-char (point-min)) - (loop while (re-search-forward regexp nil t) - do (progn - (goto-char (match-beginning 0)) - (delete-char 1) - (insert-char (if (ebrowse-ts-mark tree) ?> ? ) 1) - (ebrowse-set-mark-props (1- (point)) (point) tree) - (goto-char (match-end 0))))))))) + (cl-loop + for tree in to-change + as regexp = (concat "^.*\\b" + (regexp-quote + (ebrowse-cs-name (ebrowse-ts-class tree))) + "\\b") + do + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (goto-char (match-beginning 0)) + (delete-char 1) + (insert-char (if (ebrowse-ts-mark tree) ?> ? ) 1) + (ebrowse-set-mark-props (1- (point)) (point) tree) + (goto-char (match-end 0)))))))) (defun ebrowse-mark-all-classes (prefix) @@ -1345,7 +1332,7 @@ (set (make-hash-table)) result) (dolist (buffer buffers) - (let ((tree (ebrowse-value-in-buffer 'ebrowse--tree buffer))) + (let ((tree (buffer-local-value 'ebrowse--tree buffer))) (unless (gethash tree set) (push buffer result)) (puthash tree t set))) @@ -1356,7 +1343,7 @@ "Return a list of members buffers with same tree as current buffer." (ebrowse-delete-if-not (lambda (buffer) - (eq (ebrowse-value-in-buffer 'ebrowse--tree buffer) + (eq (buffer-local-value 'ebrowse--tree buffer) ebrowse--tree)) (ebrowse-member-buffer-list))) @@ -1367,7 +1354,7 @@ Switch to buffer if prefix ARG. If no member buffer exists, make one." (interactive "P") - (let ((buf (or (first (ebrowse-same-tree-member-buffer-list)) + (let ((buf (or (cl-first (ebrowse-same-tree-member-buffer-list)) (get-buffer ebrowse-member-buffer-name) (ebrowse-tree-command:show-member-functions)))) (when buf @@ -1391,9 +1378,9 @@ (defun ebrowse-kill-member-buffers-displaying (tree) "Kill all member buffers displaying TREE." - (loop for buffer in (ebrowse-member-buffer-list) - as class = (ebrowse-value-in-buffer 'ebrowse--displayed-class buffer) - when (eq class tree) do (kill-buffer buffer))) + (cl-loop for buffer in (ebrowse-member-buffer-list) + as class = (buffer-local-value 'ebrowse--displayed-class buffer) + when (eq class tree) do (kill-buffer buffer))) (defun ebrowse-frozen-tree-buffer-name (tags-file) @@ -1429,7 +1416,7 @@ (int-to-string ebrowse--indentation) "): ") nil nil ebrowse--indentation)))) - (when (plusp width) + (when (cl-plusp width) (set (make-local-variable 'ebrowse--indentation) width) (ebrowse-redraw-tree)))) @@ -1504,7 +1491,7 @@ (error "Not on a class"))) -(defun* ebrowse-view/find-class-declaration (&key view where) +(cl-defun ebrowse-view/find-class-declaration (&key view where) "View or find the declarator of the class point is on. VIEW non-nil means view it. WHERE is additional position info." (let* ((class (ebrowse-ts-class (ebrowse-tree-at-point))) @@ -1583,9 +1570,9 @@ exit-action ebrowse--view-exit-action)) ;; Delete the frame in which we viewed. (mapc 'delete-frame - (loop for frame in (frame-list) - when (not (assq frame original-frame-configuration)) - collect frame)) + (cl-loop for frame in (frame-list) + when (not (assq frame original-frame-configuration)) + collect frame)) (when exit-action (funcall exit-action buffer)))) @@ -1639,15 +1626,15 @@ (unless (boundp 'view-mode-hook) (setq view-mode-hook nil)) (push 'ebrowse-find-pattern view-mode-hook) - (case where - (other-window (view-file-other-window file)) - (other-frame (ebrowse-view-file-other-frame file)) - (t (view-file file)))) + (pcase where + (`other-window (view-file-other-window file)) + (`other-frame (ebrowse-view-file-other-frame file)) + (_ (view-file file)))) (t - (case where - (other-window (find-file-other-window file)) - (other-frame (find-file-other-frame file)) - (t (find-file file))) + (pcase where + (`other-window (find-file-other-window file)) + (`other-frame (find-file-other-frame file)) + (_ (find-file file))) (ebrowse-find-pattern struc info)))) @@ -1657,14 +1644,14 @@ which may contain whitespace. For these symbols, replace white space in the symbol name (generated by BROWSE) with a regular expression matching any number of whitespace characters." - (loop with regexp = (regexp-quote name) - with start = 0 - finally return regexp - while (string-match "[ \t]+" regexp start) - do (setq regexp (concat (substring regexp 0 (match-beginning 0)) - "[ \t]*" - (substring regexp (match-end 0))) - start (+ (match-beginning 0) 5)))) + (cl-loop with regexp = (regexp-quote name) + with start = 0 + finally return regexp + while (string-match "[ \t]+" regexp start) + do (setq regexp (concat (substring regexp 0 (match-beginning 0)) + "[ \t]*" + (substring regexp (match-end 0))) + start (+ (match-beginning 0) 5)))) (defun ebrowse-class-declaration-regexp (name) @@ -1692,7 +1679,7 @@ (concat "^[ \t]*#[ \t]*define[ \t]+" (regexp-quote name))) -(defun* ebrowse-find-pattern (&optional position info &aux viewing) +(cl-defun ebrowse-find-pattern (&optional position info &aux viewing) "Find a pattern. This is a kluge: Ebrowse allows you to find or view a file containing @@ -1711,25 +1698,26 @@ (start (ebrowse-bs-point position)) (offset 100) found) - (destructuring-bind (header class-or-member member-list) info + (pcase-let ((`(,header ,class-or-member ,member-list) info)) ;; If no pattern is specified, construct one from the member name. (when (stringp pattern) (setq pattern (concat "^.*" (regexp-quote pattern)))) ;; Construct a regular expression if none given. (unless pattern - (typecase class-or-member + (cl-typecase class-or-member (ebrowse-ms - (case member-list - ((ebrowse-ts-member-variables - ebrowse-ts-static-variables - ebrowse-ts-types) - (setf pattern (ebrowse-variable-declaration-regexp - (ebrowse-bs-name position)))) - (otherwise - (if (ebrowse-define-p class-or-member) - (setf pattern (ebrowse-pp-define-regexp (ebrowse-bs-name position))) - (setf pattern (ebrowse-function-declaration/definition-regexp - (ebrowse-bs-name position))))))) + (setf pattern + (pcase member-list + ((or `ebrowse-ts-member-variables + `ebrowse-ts-static-variables + `ebrowse-ts-types) + (ebrowse-variable-declaration-regexp + (ebrowse-bs-name position))) + (_ + (if (ebrowse-define-p class-or-member) + (ebrowse-pp-define-regexp (ebrowse-bs-name position)) + (ebrowse-function-declaration/definition-regexp + (ebrowse-bs-name position))))))) (ebrowse-cs (setf pattern (ebrowse-class-declaration-regexp (ebrowse-bs-name position)))))) @@ -1743,10 +1731,11 @@ (y-or-n-p (format "start = %d? " start)) (y-or-n-p pattern)) (setf found - (loop do (goto-char (max (point-min) (- start offset))) - when (re-search-forward pattern (+ start offset) t) return t - never (bobp) - do (incf offset offset))) + (cl-loop do (goto-char (max (point-min) (- start offset))) + when (re-search-forward pattern (+ start offset) t) + return t + never (bobp) + do (cl-incf offset offset))) (cond (found (beginning-of-line) (run-hooks 'ebrowse-view/find-hook)) @@ -1790,57 +1779,57 @@ (ebrowse-set-face start end 'ebrowse-tree-mark)) -(defun* ebrowse-draw-tree-fn (&aux stack1 stack2 start) +(cl-defun ebrowse-draw-tree-fn (&aux stack1 stack2 start) "Display a single class and recursively its subclasses. This function may look weird, but this is faster than recursion." (setq stack1 (make-list (length ebrowse--tree) 0) stack2 (copy-sequence ebrowse--tree)) - (loop while stack2 - as level = (pop stack1) - as tree = (pop stack2) - as class = (ebrowse-ts-class tree) do - (let ((start-of-line (point)) - start-of-class-name end-of-class-name) - ;; Insert mark - (insert (if (ebrowse-ts-mark tree) ">" " ")) - - ;; Indent and insert class name - (indent-to (+ (* level ebrowse--indentation) - ebrowse-tree-left-margin)) - (setq start (point)) - (insert (ebrowse-qualified-class-name class)) - - ;; If template class, add <> - (when (ebrowse-template-p class) - (insert "<>")) - (ebrowse-set-face start (point) (if (zerop level) - 'ebrowse-root-class - 'ebrowse-default)) - (setf start-of-class-name start - end-of-class-name (point)) - ;; If filenames are to be displayed... - (when ebrowse--show-file-names-flag - (indent-to ebrowse-source-file-column) - (setq start (point)) - (insert "(" - (or (ebrowse-cs-file class) - "unknown") - ")") - (ebrowse-set-face start (point) 'ebrowse-file-name)) - (ebrowse-set-mark-props start-of-line (1+ start-of-line) tree) - (add-text-properties - start-of-class-name end-of-class-name - `(mouse-face highlight ebrowse-what class-name - ebrowse-tree ,tree - help-echo "double-mouse-1: (un)expand tree; mouse-2: member functions, mouse-3: menu")) - (insert "\n")) - ;; Push subclasses, if any. - (when (ebrowse-ts-subclasses tree) - (setq stack2 - (nconc (copy-sequence (ebrowse-ts-subclasses tree)) stack2) - stack1 - (nconc (make-list (length (ebrowse-ts-subclasses tree)) - (1+ level)) stack1))))) + (cl-loop while stack2 + as level = (pop stack1) + as tree = (pop stack2) + as class = (ebrowse-ts-class tree) do + (let ((start-of-line (point)) + start-of-class-name end-of-class-name) + ;; Insert mark + (insert (if (ebrowse-ts-mark tree) ">" " ")) + + ;; Indent and insert class name + (indent-to (+ (* level ebrowse--indentation) + ebrowse-tree-left-margin)) + (setq start (point)) + (insert (ebrowse-qualified-class-name class)) + + ;; If template class, add <> + (when (ebrowse-template-p class) + (insert "<>")) + (ebrowse-set-face start (point) (if (zerop level) + 'ebrowse-root-class + 'ebrowse-default)) + (setf start-of-class-name start + end-of-class-name (point)) + ;; If filenames are to be displayed... + (when ebrowse--show-file-names-flag + (indent-to ebrowse-source-file-column) + (setq start (point)) + (insert "(" + (or (ebrowse-cs-file class) + "unknown") + ")") + (ebrowse-set-face start (point) 'ebrowse-file-name)) + (ebrowse-set-mark-props start-of-line (1+ start-of-line) tree) + (add-text-properties + start-of-class-name end-of-class-name + `(mouse-face highlight ebrowse-what class-name + ebrowse-tree ,tree + help-echo "double-mouse-1: (un)expand tree; mouse-2: member functions, mouse-3: menu")) + (insert "\n")) + ;; Push subclasses, if any. + (when (ebrowse-ts-subclasses tree) + (setq stack2 + (nconc (copy-sequence (ebrowse-ts-subclasses tree)) stack2) + stack1 + (nconc (make-list (length (ebrowse-ts-subclasses tree)) + (1+ level)) stack1))))) @@ -2096,8 +2085,8 @@ "Read a browser buffer name from the minibuffer and return that buffer." (let* ((buffers (ebrowse-known-class-trees-buffer-list))) (if buffers - (if (not (second buffers)) - (first buffers) + (if (not (cl-second buffers)) + (cl-first buffers) (or (ebrowse-electric-choose-tree) (error "No tree buffer"))) (let* ((insert-default-directory t) (file (read-file-name "Find tree: " nil nil t))) @@ -2283,7 +2272,7 @@ ebrowse--decl-column ebrowse--column-width)) "): "))))) - (when (plusp width) + (when (cl-plusp width) (if ebrowse--long-display-flag (setq ebrowse--decl-column width) (setq ebrowse--column-width width)) @@ -2323,15 +2312,15 @@ (let ((index (ebrowse-position ebrowse--accessor ebrowse-member-list-accessors))) (setf ebrowse--accessor - (cond ((plusp incr) + (cond ((cl-plusp incr) (or (nth (1+ index) ebrowse-member-list-accessors) - (first ebrowse-member-list-accessors))) - ((minusp incr) - (or (and (>= (decf index) 0) + (cl-first ebrowse-member-list-accessors))) + ((cl-minusp incr) + (or (and (>= (cl-decf index) 0) (nth index ebrowse-member-list-accessors)) - (first (last ebrowse-member-list-accessors)))))) + (cl-first (last ebrowse-member-list-accessors)))))) (ebrowse-display-member-list-for-accessor ebrowse--accessor))) @@ -2516,7 +2505,7 @@ (ebrowse-view/find-member-declaration/definition prefix t)) -(defun* ebrowse-view/find-member-declaration/definition +(cl-defun ebrowse-view/find-member-declaration/definition (prefix view &optional definition info header tags-file) "Find or view a member declaration or definition. With PREFIX 4. find file in another window, with prefix 5 @@ -2536,15 +2525,15 @@ ;; If not given as parameters, get the necessary information ;; out of the member buffer. (if info - (setq tree (first info) - accessor (second info) - member (third info)) - (multiple-value-setq (tree member on-class) - (values-list (ebrowse-member-info-from-point))) + (setq tree (cl-first info) + accessor (cl-second info) + member (cl-third info)) + (cl-multiple-value-setq (tree member on-class) + (cl-values-list (ebrowse-member-info-from-point))) (setq accessor ebrowse--accessor)) ;; View/find class if on a line containing a class name. (when on-class - (return-from ebrowse-view/find-member-declaration/definition + (cl-return-from ebrowse-view/find-member-declaration/definition (ebrowse-view/find-file-and-search-pattern (ebrowse-ts-class tree) (list ebrowse--header (ebrowse-ts-class tree) nil) @@ -2802,11 +2791,11 @@ mouse-face highlight ebrowse-tree ,tree help-echo "mouse-2: view definition; mouse-3: menu")) - (incf i) + (cl-incf i) (when (>= i ebrowse--n-columns) (setf i 0) (insert "\n"))))) - (when (plusp i) + (when (cl-plusp i) (insert "\n")) (goto-char (point-min)))) @@ -2884,7 +2873,7 @@ (error "Not found")))) -(defun* ebrowse-move-point-to-member (name &optional count &aux member) +(cl-defun ebrowse-move-point-to-member (name &optional count &aux member) "Set point on member NAME in the member buffer COUNT, if specified, says search the COUNT'th member with the same name." (goto-char (point-min)) @@ -2905,8 +2894,8 @@ "Switch member buffer to a class read from the minibuffer. Use TITLE as minibuffer prompt. COMPL-LIST is a completion list to use." - (let* ((initial (unless (second compl-list) - (first (first compl-list)))) + (let* ((initial (unless (cl-second compl-list) + (cl-first (cl-first compl-list)))) (class (or (ebrowse-completing-read-value title compl-list initial) (error "Not found")))) (setf ebrowse--displayed-class class @@ -2926,14 +2915,14 @@ (interactive "P") (let ((supers (or (ebrowse-direct-base-classes ebrowse--displayed-class) (error "No base classes")))) - (if (and arg (second supers)) - (let ((alist (loop for s in supers - collect (cons (ebrowse-qualified-class-name - (ebrowse-ts-class s)) - s)))) + (if (and arg (cl-second supers)) + (let ((alist (cl-loop for s in supers + collect (cons (ebrowse-qualified-class-name + (ebrowse-ts-class s)) + s)))) (ebrowse-switch-member-buffer-to-other-class "Goto base class: " alist)) - (setq ebrowse--displayed-class (first supers) + (setq ebrowse--displayed-class (cl-first supers) ebrowse--member-list (funcall ebrowse--accessor ebrowse--displayed-class)) (ebrowse-redisplay-member-buffer)))) @@ -2958,20 +2947,21 @@ index cls (supers (ebrowse-direct-base-classes ebrowse--displayed-class))) (cl-flet ((trees-alist (trees) - (loop for tr in trees - collect (cons (ebrowse-cs-name - (ebrowse-ts-class tr)) tr)))) + (cl-loop for tr in trees + collect (cons (ebrowse-cs-name + (ebrowse-ts-class tr)) + tr)))) (when supers - (let ((tree (if (second supers) + (let ((tree (if (cl-second supers) (ebrowse-completing-read-value "Relative to base class: " (trees-alist supers) nil) - (first supers)))) + (cl-first supers)))) (unless tree (error "Not found")) (setq containing-list (ebrowse-ts-subclasses tree))))) (setq index (+ inc (ebrowse-position ebrowse--displayed-class containing-list))) - (cond ((minusp index) (message "No previous class")) + (cond ((cl-minusp index) (message "No previous class")) ((null (nth index containing-list)) (message "No next class"))) (setq index (max 0 (min index (1- (length containing-list))))) (setq cls (nth index containing-list)) @@ -2986,16 +2976,16 @@ the first derived class." (interactive "P") (cl-flet ((ebrowse-tree-obarray-as-alist () - (loop for s in (ebrowse-ts-subclasses - ebrowse--displayed-class) - collect (cons (ebrowse-cs-name - (ebrowse-ts-class s)) s)))) + (cl-loop for s in (ebrowse-ts-subclasses + ebrowse--displayed-class) + collect (cons (ebrowse-cs-name + (ebrowse-ts-class s)) s)))) (let ((subs (or (ebrowse-ts-subclasses ebrowse--displayed-class) (error "No derived classes")))) - (if (and arg (second subs)) + (if (and arg (cl-second subs)) (ebrowse-switch-member-buffer-to-other-class "Goto derived class: " (ebrowse-tree-obarray-as-alist)) - (setq ebrowse--displayed-class (first subs) + (setq ebrowse--displayed-class (cl-first subs) ebrowse--member-list (funcall ebrowse--accessor ebrowse--displayed-class)) (ebrowse-redisplay-member-buffer))))) @@ -3191,15 +3181,15 @@ EVENT is the mouse event." (interactive "e") (mouse-set-point event) - (case (event-click-count event) + (pcase (event-click-count event) (2 (ebrowse-find-member-definition)) - (1 (case (get-text-property (posn-point (event-start event)) - 'ebrowse-what) - (member-name + (1 (pcase (get-text-property (posn-point (event-start event)) + 'ebrowse-what) + (`member-name (ebrowse-popup-menu ebrowse-member-name-object-menu event)) - (class-name + (`class-name (ebrowse-popup-menu ebrowse-member-class-name-object-menu event)) - (t + (_ (ebrowse-popup-menu ebrowse-member-buffer-object-menu event)))))) @@ -3208,11 +3198,11 @@ EVENT is the mouse event." (interactive "e") (mouse-set-point event) - (case (event-click-count event) + (pcase (event-click-count event) (2 (ebrowse-find-member-definition)) - (1 (case (get-text-property (posn-point (event-start event)) + (1 (pcase (get-text-property (posn-point (event-start event)) 'ebrowse-what) - (member-name + (`member-name (ebrowse-view-member-definition 0)))))) @@ -3233,11 +3223,11 @@ alist) (when name (dolist (info (gethash name table) alist) - (unless (memq (first info) known-classes) - (setf alist (acons (ebrowse-qualified-class-name - (ebrowse-ts-class (first info))) - info alist) - known-classes (cons (first info) known-classes))))))) + (unless (memq (cl-first info) known-classes) + (setf alist (cl-acons (ebrowse-qualified-class-name + (ebrowse-ts-class (cl-first info))) + info alist) + known-classes (cons (cl-first info) known-classes))))))) (defun ebrowse-choose-tree () @@ -3247,8 +3237,8 @@ the class tree, HEADER the header structure of the tree, and BUFFER being the tree or member buffer containing the tree." (let* ((buffer (ebrowse-choose-from-browser-buffers))) - (if buffer (list (ebrowse-value-in-buffer 'ebrowse--tree buffer) - (ebrowse-value-in-buffer 'ebrowse--header buffer) + (if buffer (list (buffer-local-value 'ebrowse--tree buffer) + (buffer-local-value 'ebrowse--header buffer) buffer)))) @@ -3259,8 +3249,8 @@ from point as default. Value is a list (CLASS-NAME MEMBER-NAME)." (save-excursion (let ((members (ebrowse-member-table header))) - (multiple-value-bind (class-name member-name) - (values-list (ebrowse-tags-read-member+class-name)) + (cl-multiple-value-bind (class-name member-name) + (cl-values-list (ebrowse-tags-read-member+class-name)) (unless member-name (error "No member name at point")) (if members @@ -3272,7 +3262,7 @@ (unless (gethash name members) (if (y-or-n-p "No exact match found. Try substrings? ") (setq name - (or (first (ebrowse-list-of-matching-members + (or (cl-first (ebrowse-list-of-matching-members members (regexp-quote name) name)) (error "Sorry, nothing found"))) (error "Canceled"))) @@ -3305,15 +3295,15 @@ (let ((alist (or (ebrowse-class-alist-for-member header name) (error "No classes with member `%s' found" name)))) (ebrowse-ignoring-completion-case - (if (null (second alist)) - (cdr (first alist)) + (if (null (cl-second alist)) + (cdr (cl-first alist)) (push ?\? unread-command-events) (cdr (assoc (completing-read "In class: " alist nil t initial-class-name) alist)))))) -(defun* ebrowse-tags-view/find-member-decl/defn +(cl-defun ebrowse-tags-view/find-member-decl/defn (prefix &key view definition member-name) "If VIEW is t, view, else find an occurrence of MEMBER-NAME. @@ -3324,16 +3314,16 @@ the user choose the class to use. As a last step, a tags search is performed that positions point on the member declaration or definition." - (multiple-value-bind - (tree header tree-buffer) (values-list (ebrowse-choose-tree)) + (cl-multiple-value-bind + (tree header tree-buffer) (cl-values-list (ebrowse-choose-tree)) (unless tree (error "No class tree")) (let* ((marker (point-marker)) class-name (name member-name) info) (unless name - (multiple-value-setq (class-name name) - (values-list + (cl-multiple-value-setq (class-name name) + (cl-values-list (ebrowse-tags-read-name header (concat (if view "View" "Find") " member " @@ -3344,7 +3334,7 @@ (ebrowse-view/find-member-declaration/definition prefix view definition info header - (ebrowse-value-in-buffer 'ebrowse--tags-file-name tree-buffer)) + (buffer-local-value 'ebrowse--tags-file-name tree-buffer)) ;; Record position jumped to (ebrowse-push-position (point-marker) info t)))) @@ -3439,14 +3429,14 @@ (cond ((null buffer) (set-buffer tree-buffer) (switch-to-buffer (ebrowse-display-member-buffer - (second info) nil (first info)))) + (cl-second info) nil (cl-first info)))) (t (switch-to-buffer buffer) - (setq ebrowse--displayed-class (first info) - ebrowse--accessor (second info) + (setq ebrowse--displayed-class (cl-first info) + ebrowse--accessor (cl-second info) ebrowse--member-list (funcall ebrowse--accessor ebrowse--displayed-class)) (ebrowse-redisplay-member-buffer))) - (ebrowse-move-point-to-member (ebrowse-ms-name (third info))))) + (ebrowse-move-point-to-member (ebrowse-ms-name (cl-third info))))) (defun ebrowse-tags-display-member-buffer (&optional fix-name) @@ -3454,13 +3444,13 @@ FIX-NAME non-nil means display the buffer for that member. Otherwise read a member name from point." (interactive) - (multiple-value-bind - (tree header tree-buffer) (values-list (ebrowse-choose-tree)) + (cl-multiple-value-bind + (tree header tree-buffer) (cl-values-list (ebrowse-choose-tree)) (unless tree (error "No class tree")) (let* ((marker (point-marker)) class-name (name fix-name) info) (unless name - (multiple-value-setq (class-name name) - (values-list + (cl-multiple-value-setq (class-name name) + (cl-values-list (ebrowse-tags-read-name header (concat "Find member list of: "))))) (setq info (ebrowse-tags-choose-class tree header name class-name)) @@ -3487,7 +3477,7 @@ (interactive) (let* ((buffer (or (ebrowse-choose-from-browser-buffers) (error "No tree buffer"))) - (header (ebrowse-value-in-buffer 'ebrowse--header buffer)) + (header (buffer-local-value 'ebrowse--header buffer)) (members (ebrowse-member-table header)) temp-buffer-setup-hook (regexp (read-from-minibuffer "List members matching regexp: "))) @@ -3495,9 +3485,9 @@ (set-buffer standard-output) (erase-buffer) (insert "Members matching `" regexp "'\n\n") - (loop for s in (ebrowse-list-of-matching-members members regexp) do - (loop for info in (gethash s members) do - (ebrowse-draw-file-member-info info)))))) + (cl-loop for s in (ebrowse-list-of-matching-members members regexp) do + (cl-loop for info in (gethash s members) do + (ebrowse-draw-file-member-info info)))))) (defun ebrowse-tags-list-members-in-file () @@ -3508,50 +3498,50 @@ (error "No tree buffer"))) (files (with-current-buffer buffer (ebrowse-files-table))) (file (completing-read "List members in file: " files nil t)) - (header (ebrowse-value-in-buffer 'ebrowse--header buffer)) + (header (buffer-local-value 'ebrowse--header buffer)) temp-buffer-setup-hook (members (ebrowse-member-table header))) (with-output-to-temp-buffer (concat "*Members in file " file "*") (set-buffer standard-output) (maphash (lambda (_member-name list) - (loop for info in list - as member = (third info) - as class = (ebrowse-ts-class (first info)) - when (or (and (null (ebrowse-ms-file member)) - (string= (ebrowse-cs-file class) file)) - (string= file (ebrowse-ms-file member))) - do (ebrowse-draw-file-member-info info "decl.") - when (or (and (null (ebrowse-ms-definition-file member)) - (string= (ebrowse-cs-source-file class) file)) - (string= file (ebrowse-ms-definition-file member))) - do (ebrowse-draw-file-member-info info "defn."))) + (cl-loop for info in list + as member = (cl-third info) + as class = (ebrowse-ts-class (cl-first info)) + when (or (and (null (ebrowse-ms-file member)) + (string= (ebrowse-cs-file class) file)) + (string= file (ebrowse-ms-file member))) + do (ebrowse-draw-file-member-info info "decl.") + when (or (and (null (ebrowse-ms-definition-file member)) + (string= (ebrowse-cs-source-file class) file)) + (string= file (ebrowse-ms-definition-file member))) + do (ebrowse-draw-file-member-info info "defn."))) members)))) -(defun* ebrowse-draw-file-member-info (info &optional (kind "")) +(cl-defun ebrowse-draw-file-member-info (info &optional (kind "")) "Display a line in the members info buffer. INFO describes the member. It has the form (TREE ACCESSOR MEMBER). TREE is the class of the member to display. ACCESSOR is the accessor symbol of its member list. MEMBER is the member structure. KIND is an additional string printed in the buffer." - (let* ((tree (first info)) + (let* ((tree (cl-first info)) (globals-p (ebrowse-globals-tree-p tree))) (unless globals-p (insert (ebrowse-cs-name (ebrowse-ts-class tree)))) - (insert "::" (ebrowse-ms-name (third info))) + (insert "::" (ebrowse-ms-name (cl-third info))) (indent-to 40) (insert kind) (indent-to 50) - (insert (case (second info) - (ebrowse-ts-member-functions "member function") - (ebrowse-ts-member-variables "member variable") - (ebrowse-ts-static-functions "static function") - (ebrowse-ts-static-variables "static variable") - (ebrowse-ts-friends (if globals-p "define" "friend")) - (ebrowse-ts-types "type") - (t "unknown")) + (insert (pcase (cl-second info) + (`ebrowse-ts-member-functions "member function") + (`ebrowse-ts-member-variables "member variable") + (`ebrowse-ts-static-functions "static function") + (`ebrowse-ts-static-variables "static variable") + (`ebrowse-ts-friends (if globals-p "define" "friend")) + (`ebrowse-ts-types "type") + (_ "unknown")) "\n"))) (defvar ebrowse-last-completion nil @@ -3582,11 +3572,11 @@ If there's only one tree loaded, use that. Otherwise let the use choose a tree." (let* ((buffers (ebrowse-known-class-trees-buffer-list)) - (buffer (cond ((and (first buffers) (not (second buffers))) - (first buffers)) + (buffer (cond ((and (cl-first buffers) (not (cl-second buffers))) + (cl-first buffers)) (t (or (ebrowse-electric-choose-tree) (error "No tree buffer"))))) - (header (ebrowse-value-in-buffer 'ebrowse--header buffer))) + (header (buffer-local-value 'ebrowse--header buffer))) (ebrowse-member-table header))) @@ -3594,13 +3584,13 @@ "Return the item following STRING in LIST. If STRING is the last element, return the first element as successor." (or (nth (1+ (ebrowse-position string list 'string=)) list) - (first list))) + (cl-first list))) ;;; Symbol completion ;;;###autoload -(defun* ebrowse-tags-complete-symbol (prefix) +(cl-defun ebrowse-tags-complete-symbol (prefix) "Perform completion on the C++ symbol preceding point. A second call of this function without changing point inserts the next match. A call with prefix PREFIX reads the symbol to insert from the minibuffer with @@ -3640,7 +3630,7 @@ ;; buffer: Start new completion. (t (let* ((members (ebrowse-some-member-table)) - (completion (first (all-completions pattern members nil)))) + (completion (cl-first (all-completions pattern members nil)))) (cond ((eq completion t)) ((null completion) (error "Can't find completion for `%s'" pattern)) @@ -3766,15 +3756,15 @@ looks like a function call to the member." (interactive) ;; Choose the tree to use if there is more than one. - (multiple-value-bind (tree header tree-buffer) - (values-list (ebrowse-choose-tree)) + (cl-multiple-value-bind (tree header tree-buffer) + (cl-values-list (ebrowse-choose-tree)) (unless tree (error "No class tree")) ;; Get the member name NAME (class-name is ignored). (let ((name fix-name) class-name regexp) (unless name - (multiple-value-setq (class-name name) - (values-list (ebrowse-tags-read-name header "Find calls of: ")))) + (cl-multiple-value-setq (class-name name) + (cl-values-list (ebrowse-tags-read-name header "Find calls of: ")))) ;; Set tags loop form to search for member and begin loop. (setq regexp (concat "\\<" name "[ \t]*(") ebrowse-tags-loop-form (list 're-search-forward regexp nil t)) @@ -3786,7 +3776,7 @@ ;;; Structures of this kind are the elements of the position stack. -(defstruct (ebrowse-position (:type vector) :named) +(cl-defstruct (ebrowse-position (:type vector) :named) file-name ; in which file point ; point in file target ; t if target of a jump @@ -3806,8 +3796,8 @@ The string is printed in the electric position list buffer." (let ((info (ebrowse-position-info position))) (concat (if (ebrowse-position-target position) "at " "to ") - (ebrowse-cs-name (ebrowse-ts-class (first info))) - "::" (ebrowse-ms-name (third info))))) + (ebrowse-cs-name (ebrowse-ts-class (cl-first info))) + "::" (ebrowse-ms-name (cl-third info))))) (defun ebrowse-view/find-position (position &optional view) @@ -3837,7 +3827,7 @@ (let ((too-much (- (length ebrowse-position-stack) ebrowse-max-positions))) ;; Do not let the stack grow to infinity. - (when (plusp too-much) + (when (cl-plusp too-much) (setq ebrowse-position-stack (butlast ebrowse-position-stack too-much))) ;; Push the position. @@ -4108,9 +4098,9 @@ (let ((tree-file (buffer-file-name)) temp-buffer-setup-hook) (with-output-to-temp-buffer "*Tree Statistics*" - (multiple-value-bind (classes member-functions member-variables + (cl-multiple-value-bind (classes member-functions member-variables static-functions static-variables) - (values-list (ebrowse-gather-statistics)) + (cl-values-list (ebrowse-gather-statistics)) (set-buffer standard-output) (erase-buffer) (insert "STATISTICS FOR TREE " (or tree-file "unknown") ":\n\n") @@ -4142,11 +4132,11 @@ (let ((classes 0) (member-functions 0) (member-variables 0) (static-functions 0) (static-variables 0)) (ebrowse-for-all-trees (tree ebrowse--tree-obarray) - (incf classes) - (incf member-functions (length (ebrowse-ts-member-functions tree))) - (incf member-variables (length (ebrowse-ts-member-variables tree))) - (incf static-functions (length (ebrowse-ts-static-functions tree))) - (incf static-variables (length (ebrowse-ts-static-variables tree)))) + (cl-incf classes) + (cl-incf member-functions (length (ebrowse-ts-member-functions tree))) + (cl-incf member-variables (length (ebrowse-ts-member-variables tree))) + (cl-incf static-functions (length (ebrowse-ts-static-functions tree))) + (cl-incf static-variables (length (ebrowse-ts-static-variables tree)))) (list classes member-functions member-variables static-functions static-variables))) @@ -4390,12 +4380,12 @@ (mouse-set-point event) (let* ((where (posn-point (event-start event))) (property (get-text-property where 'ebrowse-what))) - (case (event-click-count event) + (pcase (event-click-count event) (1 - (case property - (class-name + (pcase property + (`class-name (ebrowse-popup-menu ebrowse-tree-buffer-class-object-menu event)) - (t + (_ (ebrowse-popup-menu ebrowse-tree-buffer-object-menu event))))))) @@ -4406,9 +4396,9 @@ (mouse-set-point event) (let* ((where (posn-point (event-start event))) (property (get-text-property where 'ebrowse-what))) - (case (event-click-count event) - (1 (case property - (class-name + (pcase (event-click-count event) + (1 (pcase property + (`class-name (ebrowse-tree-command:show-member-functions))))))) @@ -4419,13 +4409,13 @@ (mouse-set-point event) (let* ((where (posn-point (event-start event))) (property (get-text-property where 'ebrowse-what))) - (case (event-click-count event) - (2 (case property - (class-name + (pcase (event-click-count event) + (2 (pcase property + (`class-name (let ((collapsed (save-excursion (skip-chars-forward "^\r\n") (looking-at "\r")))) (ebrowse-collapse-fn (not collapsed)))) - (mark + (`mark (ebrowse-toggle-mark-at-point 1))))))) === modified file 'lisp/progmodes/etags.el' --- lisp/progmodes/etags.el 2012-05-04 23:16:47 +0000 +++ lisp/progmodes/etags.el 2012-07-11 23:13:41 +0000 @@ -26,8 +26,6 @@ ;;; Code: -(eval-when-compile - (require 'cl)) (require 'ring) (require 'button) === modified file 'lisp/progmodes/flymake.el' --- lisp/progmodes/flymake.el 2012-06-26 16:23:01 +0000 +++ lisp/progmodes/flymake.el 2012-07-11 23:13:41 +0000 @@ -35,7 +35,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (if (featurep 'xemacs) (require 'overlay)) (defvar flymake-is-running nil @@ -684,7 +684,7 @@ (defun flymake-er-get-line-err-info-list (err-info) (nth 1 err-info)) -(defstruct (flymake-ler +(cl-defstruct (flymake-ler (:constructor nil) (:constructor flymake-ler-make-ler (file line type text &optional full-file))) file line type text full-file) === modified file 'lisp/progmodes/gdb-mi.el' --- lisp/progmodes/gdb-mi.el 2012-05-25 14:47:57 +0000 +++ lisp/progmodes/gdb-mi.el 2012-07-11 23:13:41 +0000 @@ -91,7 +91,7 @@ (require 'gud) (require 'json) (require 'bindat) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (declare-function speedbar-change-initial-expansion-list "speedbar" (new-default)) @@ -2269,8 +2269,7 @@ ;; gdb-table struct is a way to programmatically construct simple ;; tables. It help to reliably align columns of data in GDB buffers ;; and provides -(defstruct - gdb-table +(cl-defstruct gdb-table (column-sizes nil) (rows nil) (row-properties nil) @@ -2757,9 +2756,9 @@ (add-to-list 'gdb-threads-list (cons (bindat-get-field thread 'id) thread)) - (if running - (incf gdb-running-threads-count) - (incf gdb-stopped-threads-count)) + (cl-incf (if running + gdb-running-threads-count + gdb-stopped-threads-count)) (gdb-table-add-row table (list === modified file 'lisp/progmodes/glasses.el' --- lisp/progmodes/glasses.el 2012-04-09 13:05:48 +0000 +++ lisp/progmodes/glasses.el 2012-07-11 23:13:41 +0000 @@ -51,10 +51,6 @@ ;;; Code: -(eval-when-compile - (require 'cl)) - - ;;; User variables === modified file 'lisp/progmodes/gud.el' --- lisp/progmodes/gud.el 2012-06-26 16:23:01 +0000 +++ lisp/progmodes/gud.el 2012-07-11 23:13:41 +0000 @@ -37,8 +37,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) ; for case macro - (require 'comint) (defvar gdb-active-process) @@ -528,10 +526,10 @@ nil 'gdb-edit-value) nil (if gdb-show-changed-values - (or parent (case status - (changed 'font-lock-warning-face) - (out-of-scope 'shadow) - (t t))) + (or parent (pcase status + (`changed 'font-lock-warning-face) + (`out-of-scope 'shadow) + (_ t))) t) depth) (if (eq status 'out-of-scope) (setq parent 'shadow)) @@ -549,10 +547,10 @@ nil 'gdb-edit-value) nil (if gdb-show-changed-values - (or parent (case status - (changed 'font-lock-warning-face) - (out-of-scope 'shadow) - (t t))) + (or parent (pcase status + (`changed 'font-lock-warning-face) + (`out-of-scope 'shadow) + (_ t))) t) depth) (speedbar-make-tag-line @@ -3412,11 +3410,11 @@ (defun gud-tooltip-print-command (expr) "Return a suitable command to print the expression EXPR." - (case gud-minor-mode - (gdbmi (concat "-data-evaluate-expression " expr)) - (dbx (concat "print " expr)) - ((xdb pdb) (concat "p " expr)) - (sdb (concat expr "/")))) + (pcase gud-minor-mode + (`gdbmi (concat "-data-evaluate-expression " expr)) + (`dbx (concat "print " expr)) + ((or `xdb `pdb) (concat "p " expr)) + (`sdb (concat expr "/")))) (declare-function gdb-input "gdb-mi" (command handler)) (declare-function tooltip-expr-to-print "tooltip" (event)) === modified file 'lisp/progmodes/js.el' --- lisp/progmodes/js.el 2012-06-27 15:11:28 +0000 +++ lisp/progmodes/js.el 2012-07-11 23:13:41 +0000 @@ -54,7 +54,7 @@ (require 'json nil t) (eval-when-compile - (require 'cl) + (require 'cl-lib) (require 'comint) (require 'ido)) @@ -240,12 +240,11 @@ ") (defconst js--available-frameworks - (loop with available-frameworks - for style in js--class-styles - for framework = (plist-get style :framework) - unless (memq framework available-frameworks) - collect framework into available-frameworks - finally return available-frameworks) + (cl-loop for style in js--class-styles + for framework = (plist-get style :framework) + unless (memq framework available-frameworks) + collect framework into available-frameworks + finally return available-frameworks) "List of available JavaScript frameworks symbols.") (defconst js--function-heading-1-re @@ -374,7 +373,7 @@ ;; (The exception for b-end and its caveats is described below.) ;; -(defstruct (js--pitem (:type list)) +(cl-defstruct (js--pitem (:type list)) ;; IMPORTANT: Do not alter the position of fields within the list. ;; Various bits of code depend on their positions, particularly ;; anything that manipulates the list of children. @@ -555,10 +554,10 @@ (make-variable-buffer-local 'js--state-at-last-parse-pos) (defun js--flatten-list (list) - (loop for item in list - nconc (cond ((consp item) - (js--flatten-list item)) - (item (list item))))) + (cl-loop for item in list + nconc (cond ((consp item) + (js--flatten-list item)) + (item (list item))))) (defun js--maybe-join (prefix separator suffix &rest list) "Helper function for `js--update-quick-match-re'. @@ -768,13 +767,13 @@ "Move forward over a whole JavaScript expression. This function doesn't move over expressions continued across lines." - (loop + (cl-loop ;; non-continued case; simplistic, but good enough? - do (loop until (or (eolp) - (progn - (forward-comment most-positive-fixnum) - (memq (char-after) '(?\, ?\; ?\] ?\) ?\})))) - do (forward-sexp)) + do (cl-loop until (or (eolp) + (progn + (forward-comment most-positive-fixnum) + (memq (char-after) '(?\, ?\; ?\] ?\) ?\})))) + do (forward-sexp)) while (and (eq (char-after) ?\n) (save-excursion @@ -788,7 +787,7 @@ If this is a syntactically-correct non-expression function, return the name of the function, or t if the name could not be determined. Otherwise, return nil." - (assert (looking-at "\\_")) + (cl-assert (looking-at "\\_")) (let ((name t)) (forward-word) (forward-comment most-positive-fixnum) @@ -847,32 +846,32 @@ "Helper function for `js--beginning-of-defun-nested'. If PSTATE represents a non-empty top-level defun, return the top-most pitem. Otherwise, return nil." - (loop for pitem in pstate - with func-depth = 0 - with func-pitem - if (eq 'function (js--pitem-type pitem)) - do (incf func-depth) - and do (setq func-pitem pitem) - finally return (if (eq func-depth 1) func-pitem))) + (cl-loop for pitem in pstate + with func-depth = 0 + with func-pitem + if (eq 'function (js--pitem-type pitem)) + do (cl-incf func-depth) + and do (setq func-pitem pitem) + finally return (if (eq func-depth 1) func-pitem))) (defun js--beginning-of-defun-nested () "Helper function for `js--beginning-of-defun'. Return the pitem of the function we went to the beginning of." (or ;; Look for the smallest function that encloses point... - (loop for pitem in (js--parse-state-at-point) - if (and (eq 'function (js--pitem-type pitem)) - (js--inside-pitem-p pitem)) - do (goto-char (js--pitem-h-begin pitem)) - and return pitem) + (cl-loop for pitem in (js--parse-state-at-point) + if (and (eq 'function (js--pitem-type pitem)) + (js--inside-pitem-p pitem)) + do (goto-char (js--pitem-h-begin pitem)) + and return pitem) ;; ...and if that isn't found, look for the previous top-level ;; defun - (loop for pstate = (js--backward-pstate) - while pstate - if (js--pstate-is-toplevel-defun pstate) - do (goto-char (js--pitem-h-begin it)) - and return it))) + (cl-loop for pstate = (js--backward-pstate) + while pstate + if (js--pstate-is-toplevel-defun pstate) + do (goto-char (js--pitem-h-begin it)) + and return it))) (defun js--beginning-of-defun-flat () "Helper function for `js-beginning-of-defun'." @@ -884,7 +883,7 @@ "Value of `beginning-of-defun-function' for `js-mode'." (setq arg (or arg 1)) (while (and (not (eobp)) (< arg 0)) - (incf arg) + (cl-incf arg) (when (and (not js-flat-functions) (or (eq (js-syntactic-context) 'function) (js--function-prologue-beginning))) @@ -896,7 +895,7 @@ (goto-char (point-max)))) (while (> arg 0) - (decf arg) + (cl-decf arg) ;; If we're just past the end of a function, the user probably wants ;; to go to the beginning of *that* function (when (eq (char-before) ?}) @@ -925,14 +924,14 @@ (defun js--ensure-cache--pop-if-ended (open-items paren-depth) (let ((top-item (car open-items))) (when (<= paren-depth (js--pitem-paren-depth top-item)) - (assert (not (get-text-property (1- (point)) 'js-pend))) + (cl-assert (not (get-text-property (1- (point)) 'js-pend))) (put-text-property (1- (point)) (point) 'js--pend top-item) (setf (js--pitem-b-end top-item) (point)) (setq open-items ;; open-items must contain at least two items for this to ;; work, but because we push a dummy item to start with, ;; that assumption holds. - (cons (js--pitem-add-child (second open-items) top-item) + (cons (js--pitem-add-child (cl-second open-items) top-item) (cddr open-items))))) open-items) @@ -950,7 +949,7 @@ ;; Make sure parse-partial-sexp doesn't stop because we *entered* ;; the given depth -- i.e., make sure we're deeper than the target ;; depth. - (assert (> (nth 0 parse) + (cl-assert (> (nth 0 parse) (js--pitem-paren-depth (car open-items)))) (setq parse (parse-partial-sexp prev-parse-point goal-point @@ -1045,10 +1044,10 @@ ;; Figure out which class styles we need to look for (setq filtered-class-styles - (loop for style in js--class-styles - if (memq (plist-get style :framework) - js-enabled-frameworks) - collect style)) + (cl-loop for style in js--class-styles + if (memq (plist-get style :framework) + js-enabled-frameworks) + collect style)) (save-excursion (save-restriction @@ -1067,7 +1066,7 @@ (unless (bobp) (setq open-items (get-text-property (1- (point)) 'js--pstate)) - (assert open-items)))) + (cl-assert open-items)))) (unless open-items ;; Make a placeholder for the top-level definition @@ -1080,97 +1079,98 @@ (narrow-to-region (point-min) limit) - (loop while (re-search-forward js--quick-match-re-func nil t) - for orig-match-start = (goto-char (match-beginning 0)) - for orig-match-end = (match-end 0) - do (js--ensure-cache--update-parse) - for orig-depth = (nth 0 parse) - - ;; Each of these conditions should return non-nil if - ;; we should add a new item and leave point at the end - ;; of the new item's header (h-end in the - ;; js--pitem diagram). This point is the one - ;; after the last character we need to unambiguously - ;; detect this construct. If one of these evaluates to - ;; nil, the location of the point is ignored. - if (cond - ;; In comment or string - ((nth 8 parse) nil) - - ;; Regular function declaration - ((and (looking-at "\\_") - (setq name (js--forward-function-decl))) - - (when (eq name t) - (setq name (js--guess-function-name orig-match-end)) - (if name - (when js--guess-function-name-start - (setq orig-match-start - js--guess-function-name-start)) - - (setq name t))) - - (assert (eq (char-after) ?{)) - (forward-char) - (make-js--pitem - :paren-depth orig-depth - :h-begin orig-match-start - :type 'function - :name (if (eq name t) - name - (js--split-name name)))) - - ;; Macro - ((looking-at js--macro-decl-re) - - ;; Macros often contain unbalanced parentheses. - ;; Make sure that h-end is at the textual end of - ;; the macro no matter what the parenthesis say. - (c-end-of-macro) - (js--ensure-cache--update-parse) - - (make-js--pitem - :paren-depth (nth 0 parse) - :h-begin orig-match-start - :type 'macro - :name (list (match-string-no-properties 1)))) - - ;; "Prototype function" declaration - ((looking-at js--plain-method-re) - (goto-char (match-beginning 3)) - (when (save-match-data - (js--forward-function-decl)) - (forward-char) - (make-js--pitem - :paren-depth orig-depth - :h-begin orig-match-start - :type 'function - :name (nconc (js--split-name - (match-string-no-properties 1)) - (list (match-string-no-properties 2)))))) - - ;; Class definition - ((loop with syntactic-context = - (js--syntactic-context-from-pstate open-items) - for class-style in filtered-class-styles - if (and (memq syntactic-context - (plist-get class-style :contexts)) - (looking-at (plist-get class-style - :class-decl))) - do (goto-char (match-end 0)) - and return - (make-js--pitem - :paren-depth orig-depth - :h-begin orig-match-start - :type class-style - :name (js--split-name - (match-string-no-properties 1)))))) - - do (js--ensure-cache--update-parse) - and do (push it open-items) - and do (put-text-property - (1- (point)) (point) 'js--pstate open-items) - else do (goto-char orig-match-end)) + (cl-loop while (re-search-forward js--quick-match-re-func nil t) + for orig-match-start = (goto-char (match-beginning 0)) + for orig-match-end = (match-end 0) + do (js--ensure-cache--update-parse) + for orig-depth = (nth 0 parse) + + ;; Each of these conditions should return non-nil if + ;; we should add a new item and leave point at the end + ;; of the new item's header (h-end in the + ;; js--pitem diagram). This point is the one + ;; after the last character we need to unambiguously + ;; detect this construct. If one of these evaluates to + ;; nil, the location of the point is ignored. + if (cond + ;; In comment or string + ((nth 8 parse) nil) + + ;; Regular function declaration + ((and (looking-at "\\_") + (setq name (js--forward-function-decl))) + + (when (eq name t) + (setq name (js--guess-function-name orig-match-end)) + (if name + (when js--guess-function-name-start + (setq orig-match-start + js--guess-function-name-start)) + + (setq name t))) + + (cl-assert (eq (char-after) ?{)) + (forward-char) + (make-js--pitem + :paren-depth orig-depth + :h-begin orig-match-start + :type 'function + :name (if (eq name t) + name + (js--split-name name)))) + + ;; Macro + ((looking-at js--macro-decl-re) + + ;; Macros often contain unbalanced parentheses. + ;; Make sure that h-end is at the textual end of + ;; the macro no matter what the parenthesis say. + (c-end-of-macro) + (js--ensure-cache--update-parse) + + (make-js--pitem + :paren-depth (nth 0 parse) + :h-begin orig-match-start + :type 'macro + :name (list (match-string-no-properties 1)))) + + ;; "Prototype function" declaration + ((looking-at js--plain-method-re) + (goto-char (match-beginning 3)) + (when (save-match-data + (js--forward-function-decl)) + (forward-char) + (make-js--pitem + :paren-depth orig-depth + :h-begin orig-match-start + :type 'function + :name (nconc (js--split-name + (match-string-no-properties 1)) + (list (match-string-no-properties 2)))))) + + ;; Class definition + ((cl-loop + with syntactic-context = + (js--syntactic-context-from-pstate open-items) + for class-style in filtered-class-styles + if (and (memq syntactic-context + (plist-get class-style :contexts)) + (looking-at (plist-get class-style + :class-decl))) + do (goto-char (match-end 0)) + and return + (make-js--pitem + :paren-depth orig-depth + :h-begin orig-match-start + :type class-style + :name (js--split-name + (match-string-no-properties 1)))))) + + do (js--ensure-cache--update-parse) + and do (push it open-items) + and do (put-text-property + (1- (point)) (point) 'js--pstate open-items) + else do (goto-char orig-match-end)) (goto-char limit) (js--ensure-cache--update-parse) @@ -1181,12 +1181,12 @@ (defun js--end-of-defun-flat () "Helper function for `js-end-of-defun'." - (loop while (js--re-search-forward "}" nil t) - do (js--ensure-cache) - if (get-text-property (1- (point)) 'js--pend) - if (eq 'function (js--pitem-type it)) - return t - finally do (goto-char (point-max)))) + (cl-loop while (js--re-search-forward "}" nil t) + do (js--ensure-cache) + if (get-text-property (1- (point)) 'js--pend) + if (eq 'function (js--pitem-type it)) + return t + finally do (goto-char (point-max)))) (defun js--end-of-defun-nested () "Helper function for `js-end-of-defun'." @@ -1218,14 +1218,14 @@ "Value of `end-of-defun-function' for `js-mode'." (setq arg (or arg 1)) (while (and (not (bobp)) (< arg 0)) - (incf arg) + (cl-incf arg) (js-beginning-of-defun) (js-beginning-of-defun) (unless (bobp) (js-end-of-defun))) (while (> arg 0) - (decf arg) + (cl-decf arg) ;; look for function backward. if we're inside it, go to that ;; function's end. otherwise, search for the next function's end and ;; go there @@ -1349,7 +1349,7 @@ If FUNC is supplied, call it with no arguments before every variable name in the spec. Return true iff this was actually a spec. FUNC must preserve the match data." - (case (char-after) + (pcase (char-after) (?\[ (forward-char) (while @@ -1554,8 +1554,8 @@ (defun js--inside-pitem-p (pitem) "Return whether point is inside the given pitem's header or body." (js--ensure-cache) - (assert (js--pitem-h-begin pitem)) - (assert (js--pitem-paren-depth pitem)) + (cl-assert (js--pitem-h-begin pitem)) + (cl-assert (js--pitem-paren-depth pitem)) (and (> (point) (js--pitem-h-begin pitem)) (or (null (js--pitem-b-end pitem)) @@ -1576,11 +1576,11 @@ ;; Loop until we either hit a pitem at BOB or pitem ends after ;; point (or at point if we're at eob) - (loop for pitem = (car pstate) - until (or (eq (js--pitem-type pitem) - 'toplevel) - (js--inside-pitem-p pitem)) - do (pop pstate)) + (cl-loop for pitem = (car pstate) + until (or (eq (js--pitem-type pitem) + 'toplevel) + (js--inside-pitem-p pitem)) + do (pop pstate)) pstate)))) @@ -1609,22 +1609,22 @@ (defun js--class-decl-matcher (limit) "Font lock function used by `js-mode'. This performs fontification according to `js--class-styles'." - (loop initially (js--ensure-cache limit) - while (re-search-forward js--quick-match-re limit t) - for orig-end = (match-end 0) - do (goto-char (match-beginning 0)) - if (loop for style in js--class-styles - for decl-re = (plist-get style :class-decl) - if (and (memq (plist-get style :framework) - js-enabled-frameworks) - (memq (js-syntactic-context) - (plist-get style :contexts)) - decl-re - (looking-at decl-re)) - do (goto-char (match-end 0)) - and return t) - return t - else do (goto-char orig-end))) + (cl-loop initially (js--ensure-cache limit) + while (re-search-forward js--quick-match-re limit t) + for orig-end = (match-end 0) + do (goto-char (match-beginning 0)) + if (cl-loop for style in js--class-styles + for decl-re = (plist-get style :class-decl) + if (and (memq (plist-get style :framework) + js-enabled-frameworks) + (memq (js-syntactic-context) + (plist-get style :contexts)) + decl-re + (looking-at decl-re)) + do (goto-char (match-end 0)) + and return t) + return t + else do (goto-char orig-end))) (defconst js--font-lock-keywords '(js--font-lock-keywords-3 js--font-lock-keywords-1 @@ -1789,7 +1789,7 @@ js-expr-indent-offset)) (t (+ (current-column) js-indent-level - (case (char-after (nth 1 parse-status)) + (pcase (char-after (nth 1 parse-status)) (?\( js-paren-indent-offset) (?\[ js-square-indent-offset) (?\{ js-curly-indent-offset)))))) @@ -1821,15 +1821,17 @@ (defun js-c-fill-paragraph (&optional justify) "Fill the paragraph with `c-fill-paragraph'." (interactive "*P") - (letf (((symbol-function 'c-forward-sws) - (lambda (&optional limit) - (js--forward-syntactic-ws limit))) - ((symbol-function 'c-backward-sws) - (lambda (&optional limit) - (js--backward-syntactic-ws limit))) - ((symbol-function 'c-beginning-of-macro) - (lambda (&optional limit) - (js--beginning-of-macro limit)))) + ;; FIXME: Such redefinitions are bad style. We should try and use some other + ;; way to get the same result. + (cl-letf (((symbol-function 'c-forward-sws) + (lambda (&optional limit) + (js--forward-syntactic-ws limit))) + ((symbol-function 'c-backward-sws) + (lambda (&optional limit) + (js--backward-syntactic-ws limit))) + ((symbol-function 'c-beginning-of-macro) + (lambda (&optional limit) + (js--beginning-of-macro limit)))) (let ((fill-paragraph-function 'c-fill-paragraph)) (c-fill-paragraph justify)))) @@ -1924,8 +1926,8 @@ name-parts (mapcar #'js--pitem-name items)) - (assert (stringp top-name)) - (assert (> (length top-name) 0)) + (cl-assert (stringp top-name)) + (cl-assert (> (length top-name) 0)) ;; If top-name isn't found in items, then we build a copy of items ;; and throw it away. But that's okay, since most of the time, we @@ -1990,10 +1992,10 @@ (defun js--pitem-add-child (pitem child) "Copy `js--pitem' PITEM, and push CHILD onto its list of children." - (assert (integerp (js--pitem-h-begin child))) - (assert (if (consp (js--pitem-name child)) - (loop for part in (js--pitem-name child) - always (stringp part)) + (cl-assert (integerp (js--pitem-h-begin child))) + (cl-assert (if (consp (js--pitem-name child)) + (cl-loop for part in (js--pitem-name child) + always (stringp part)) t)) ;; This trick works because we know (based on our defstructs) that @@ -2015,7 +2017,7 @@ ;; name is a list here because down in ;; `js--ensure-cache', we made sure to only add ;; class entries with lists for :name - (assert (consp name)) + (cl-assert (consp name)) (js--splice-into-items (car pitem) child name)) (t @@ -2040,11 +2042,11 @@ (setq pitem-name (js--pitem-strname pitem)) (when (eq pitem-name t) (setq pitem-name (format "[unknown %s]" - (incf (car unknown-ctr))))) + (cl-incf (car unknown-ctr))))) (cond ((memq pitem-type '(function macro)) - (assert (integerp (js--pitem-h-begin pitem))) + (cl-assert (integerp (js--pitem-h-begin pitem))) (push (cons pitem-name (js--maybe-make-marker (js--pitem-h-begin pitem))) @@ -2059,7 +2061,7 @@ imenu-items)) ((js--pitem-h-begin pitem) - (assert (integerp (js--pitem-h-begin pitem))) + (cl-assert (integerp (js--pitem-h-begin pitem))) (setq subitems (list (cons "[empty]" (js--maybe-make-marker @@ -2078,7 +2080,7 @@ (widen) (goto-char (point-max)) (js--ensure-cache) - (assert (or (= (point-min) (point-max)) + (cl-assert (or (= (point-min) (point-max)) (eq js--last-parse-pos (point)))) (when js--last-parse-pos (let ((state js--state-at-last-parse-pos) @@ -2087,10 +2089,10 @@ ;; Make sure everything is closed (while (cdr state) (setq state - (cons (js--pitem-add-child (second state) (car state)) + (cons (js--pitem-add-child (cl-second state) (car state)) (cddr state)))) - (assert (= (length state) 1)) + (cl-assert (= (length state) 1)) ;; Convert the new-finalized state into what imenu expects (js--pitems-to-imenu @@ -2104,34 +2106,34 @@ (mapconcat #'identity parts ".")) (defun js--imenu-to-flat (items prefix symbols) - (loop for item in items - if (imenu--subalist-p item) - do (js--imenu-to-flat - (cdr item) (concat prefix (car item) ".") - symbols) - else - do (let* ((name (concat prefix (car item))) - (name2 name) - (ctr 0)) - - (while (gethash name2 symbols) - (setq name2 (format "%s<%d>" name (incf ctr)))) - - (puthash name2 (cdr item) symbols)))) + (cl-loop for item in items + if (imenu--subalist-p item) + do (js--imenu-to-flat + (cdr item) (concat prefix (car item) ".") + symbols) + else + do (let* ((name (concat prefix (car item))) + (name2 name) + (ctr 0)) + + (while (gethash name2 symbols) + (setq name2 (format "%s<%d>" name (cl-incf ctr)))) + + (puthash name2 (cdr item) symbols)))) (defun js--get-all-known-symbols () "Return a hash table of all JavaScript symbols. This searches all existing `js-mode' buffers. Each key is the name of a symbol (possibly disambiguated with , where N > 1), and each value is a marker giving the location of that symbol." - (loop with symbols = (make-hash-table :test 'equal) - with imenu-use-markers = t - for buffer being the buffers - for imenu-index = (with-current-buffer buffer - (when (derived-mode-p 'js-mode) - (js--imenu-create-index))) - do (js--imenu-to-flat imenu-index "" symbols) - finally return symbols)) + (cl-loop with symbols = (make-hash-table :test 'equal) + with imenu-use-markers = t + for buffer being the buffers + for imenu-index = (with-current-buffer buffer + (when (derived-mode-p 'js-mode) + (js--imenu-create-index))) + do (js--imenu-to-flat imenu-index "" symbols) + finally return symbols)) (defvar js--symbol-history nil "History of entered JavaScript symbols.") @@ -2149,8 +2151,8 @@ (let ((choice (ido-completing-read prompt - (loop for key being the hash-keys of symbols-table - collect key) + (cl-loop for key being the hash-keys of symbols-table + collect key) nil t initial-input 'js--symbol-history))) (cons choice (gethash choice symbols-table)))) @@ -2204,20 +2206,20 @@ set. If START is non-nil, look for output starting from START. Otherwise, use the current value of `process-mark'." (with-current-buffer (process-buffer process) - (loop with start-pos = (or start - (marker-position (process-mark process))) - with end-time = (+ (float-time) timeout) - for time-left = (- end-time (float-time)) - do (goto-char (point-max)) - if (looking-back regexp start-pos) return t - while (> time-left 0) - do (accept-process-output process time-left nil t) - do (goto-char (process-mark process)) - finally do (signal - 'js-moz-bad-rpc - (list (format "Timed out waiting for output matching %S" regexp)))))) + (cl-loop with start-pos = (or start + (marker-position (process-mark process))) + with end-time = (+ (float-time) timeout) + for time-left = (- end-time (float-time)) + do (goto-char (point-max)) + if (looking-back regexp start-pos) return t + while (> time-left 0) + do (accept-process-output process time-left nil t) + do (goto-char (process-mark process)) + finally do (signal + 'js-moz-bad-rpc + (list (format "Timed out waiting for output matching %S" regexp)))))) -(defstruct js--js-handle +(cl-defstruct js--js-handle ;; Integer, mirrors the value we see in JS (id nil :read-only t) @@ -2626,11 +2628,11 @@ (inferior-moz-process) js--js-repl-prompt-regexp js-js-timeout)) - (incf js--js-repl-depth))) + (cl-incf js--js-repl-depth))) (defun js--js-leave-repl () - (assert (> js--js-repl-depth 0)) - (when (= 0 (decf js--js-repl-depth)) + (cl-assert (> js--js-repl-depth 0)) + (when (= 0 (cl-decf js--js-repl-depth)) (with-current-buffer inferior-moz-buffer (goto-char (point-max)) (js--js-wait-for-eval-prompt) @@ -2649,33 +2651,33 @@ (eval-and-compile (defun js--optimize-arglist (arglist) "Convert immediate js< and js! references to deferred ones." - (loop for item in arglist - if (eq (car-safe item) 'js<) - collect (append (list 'list ''js--funcall - '(list 'interactor "_getProp")) - (js--optimize-arglist (cdr item))) - else if (eq (car-safe item) 'js>) - collect (append (list 'list ''js--funcall - '(list 'interactor "_putProp")) + (cl-loop for item in arglist + if (eq (car-safe item) 'js<) + collect (append (list 'list ''js--funcall + '(list 'interactor "_getProp")) + (js--optimize-arglist (cdr item))) + else if (eq (car-safe item) 'js>) + collect (append (list 'list ''js--funcall + '(list 'interactor "_putProp")) - (if (atom (cadr item)) - (list (cadr item)) - (list - (append - (list 'list ''js--funcall - '(list 'interactor "_mkArray")) - (js--optimize-arglist (cadr item))))) - (js--optimize-arglist (cddr item))) - else if (eq (car-safe item) 'js!) - collect (destructuring-bind (ignored function &rest body) item - (append (list 'list ''js--funcall - (if (consp function) - (cons 'list - (js--optimize-arglist function)) - function)) - (js--optimize-arglist body))) - else - collect item))) + (if (atom (cadr item)) + (list (cadr item)) + (list + (append + (list 'list ''js--funcall + '(list 'interactor "_mkArray")) + (js--optimize-arglist (cadr item))))) + (js--optimize-arglist (cddr item))) + else if (eq (car-safe item) 'js!) + collect (pcase-let ((`(,_ ,function . ,body) item)) + (append (list 'list ''js--funcall + (if (consp function) + (cons 'list + (js--optimize-arglist function)) + function)) + (js--optimize-arglist body))) + else + collect item))) (defmacro js--js-get-service (class-name interface-name) `(js! ("Components" "classes" ,class-name "getService") @@ -2698,56 +2700,56 @@ `(progn (js--js-enter-repl) (unwind-protect - (macrolet ((js? (&rest body) `(js--js-true ,@body)) - (js! (function &rest body) - `(js--js-funcall - ,(if (consp function) - (cons 'list - (js--optimize-arglist function)) - function) - ,@(js--optimize-arglist body))) - - (js-new (function &rest body) - `(js--js-new + (cl-macrolet ((js? (&rest body) `(js--js-true ,@body)) + (js! (function &rest body) + `(js--js-funcall ,(if (consp function) (cons 'list (js--optimize-arglist function)) function) - ,@body)) - - (js-eval (thisobj js) - `(js--js-eval - ,@(js--optimize-arglist - (list thisobj js)))) - - (js-list (&rest args) - `(js--js-list - ,@(js--optimize-arglist args))) - - (js-get-service (&rest args) - `(js--js-get-service - ,@(js--optimize-arglist args))) - - (js-create-instance (&rest args) - `(js--js-create-instance - ,@(js--optimize-arglist args))) - - (js-qi (&rest args) - `(js--js-qi - ,@(js--optimize-arglist args))) - - (js< (&rest body) `(js--js-get - ,@(js--optimize-arglist body))) - (js> (props value) - `(js--js-funcall - '(interactor "_putProp") - ,(if (consp props) - (cons 'list - (js--optimize-arglist props)) - props) - ,@(js--optimize-arglist (list value)) - )) - (js-handle? (arg) `(js--js-handle-p ,arg))) + ,@(js--optimize-arglist body))) + + (js-new (function &rest body) + `(js--js-new + ,(if (consp function) + (cons 'list + (js--optimize-arglist function)) + function) + ,@body)) + + (js-eval (thisobj js) + `(js--js-eval + ,@(js--optimize-arglist + (list thisobj js)))) + + (js-list (&rest args) + `(js--js-list + ,@(js--optimize-arglist args))) + + (js-get-service (&rest args) + `(js--js-get-service + ,@(js--optimize-arglist args))) + + (js-create-instance (&rest args) + `(js--js-create-instance + ,@(js--optimize-arglist args))) + + (js-qi (&rest args) + `(js--js-qi + ,@(js--optimize-arglist args))) + + (js< (&rest body) `(js--js-get + ,@(js--optimize-arglist body))) + (js> (props value) + `(js--js-funcall + '(interactor "_putProp") + ,(if (consp props) + (cons 'list + (js--optimize-arglist props)) + props) + ,@(js--optimize-arglist (list value)) + )) + (js-handle? (arg) `(js--js-handle-p ,arg))) ,@forms) (js--js-leave-repl)))) @@ -2756,21 +2758,22 @@ If nil, the whole Array is treated as a JS symbol.") (defun js--js-decode-retval (result) - (ecase (intern (first result)) - (atom (second result)) - (special (intern (second result))) - (array - (mapcar #'js--js-decode-retval (second result))) - (objid - (or (gethash (second result) - js--js-references) - (puthash (second result) - (make-js--js-handle - :id (second result) - :process (inferior-moz-process)) - js--js-references))) + (pcase (intern (cl-first result)) + (`atom (cl-second result)) + (`special (intern (cl-second result))) + (`array + (mapcar #'js--js-decode-retval (cl-second result))) + (`objid + (or (gethash (cl-second result) + js--js-references) + (puthash (cl-second result) + (make-js--js-handle + :id (cl-second result) + :process (inferior-moz-process)) + js--js-references))) - (error (signal 'js-js-error (list (second result)))))) + (`error (signal 'js-js-error (list (cl-second result)))) + (x (error "Unmatched case in js--js-decode-retval: %S" x)))) (defun js--js-funcall (function &rest arguments) "Call the Mozilla function FUNCTION with arguments ARGUMENTS. @@ -2853,9 +2856,9 @@ (looking-back js--js-prompt-regexp (save-excursion (forward-line 0) (point)))))) - (setq keys (loop for x being the hash-keys - of js--js-references - collect x)) + (setq keys (cl-loop for x being the hash-keys + of js--js-references + collect x)) (setq num (js--js-funcall '(repl "_jsGC") (or keys []))) (setq js--js-last-gcs-done this-gcs-done) @@ -2889,58 +2892,58 @@ (with-js (let (windows) - (loop with window-mediator = (js! ("Components" "classes" - "@mozilla.org/appshell/window-mediator;1" - "getService") - (js< "Components" "interfaces" - "nsIWindowMediator")) - with enumerator = (js! (window-mediator "getEnumerator") nil) - - while (js? (js! (enumerator "hasMoreElements"))) - for window = (js! (enumerator "getNext")) - for window-info = (js-list window - (js< window "document" "title") - (js! (window "location" "toString")) - (js< window "closed") - (js< window "windowState")) - - unless (or (js? (fourth window-info)) - (eq (fifth window-info) 2)) - do (push window-info windows)) - - (loop for window-info in windows - for window = (first window-info) - collect (list (second window-info) - (third window-info) - window) - - for gbrowser = (js< window "gBrowser") - if (js-handle? gbrowser) - nconc (loop - for x below (js< gbrowser "browsers" "length") - collect (js-list (js< gbrowser - "browsers" - x - "contentDocument" - "title") - - (js! (gbrowser - "browsers" - x - "contentWindow" - "location" - "toString")) - (js< gbrowser - "browsers" - x) - - (js! (gbrowser - "tabContainer" - "childNodes" - "item") - x) - - gbrowser)))))) + (cl-loop with window-mediator = (js! ("Components" "classes" + "@mozilla.org/appshell/window-mediator;1" + "getService") + (js< "Components" "interfaces" + "nsIWindowMediator")) + with enumerator = (js! (window-mediator "getEnumerator") nil) + + while (js? (js! (enumerator "hasMoreElements"))) + for window = (js! (enumerator "getNext")) + for window-info = (js-list window + (js< window "document" "title") + (js! (window "location" "toString")) + (js< window "closed") + (js< window "windowState")) + + unless (or (js? (cl-fourth window-info)) + (eq (cl-fifth window-info) 2)) + do (push window-info windows)) + + (cl-loop for window-info in windows + for window = (cl-first window-info) + collect (list (cl-second window-info) + (cl-third window-info) + window) + + for gbrowser = (js< window "gBrowser") + if (js-handle? gbrowser) + nconc (cl-loop + for x below (js< gbrowser "browsers" "length") + collect (js-list (js< gbrowser + "browsers" + x + "contentDocument" + "title") + + (js! (gbrowser + "browsers" + x + "contentWindow" + "location" + "toString")) + (js< gbrowser + "browsers" + x) + + (js! (gbrowser + "tabContainer" + "childNodes" + "item") + x) + + gbrowser)))))) (defvar js-read-tab-history nil) @@ -2960,106 +2963,110 @@ selected-tab prev-hitab) ;; Disambiguate names - (setq tabs (loop with tab-names = (make-hash-table :test 'equal) - for tab in tabs - for cname = (format "%s (%s)" (second tab) (first tab)) - for num = (incf (gethash cname tab-names -1)) - if (> num 0) - do (setq cname (format "%s <%d>" cname num)) - collect (cons cname tab))) - - (labels ((find-tab-by-cname - (cname) - (loop for tab in tabs - if (equal (car tab) cname) - return (cdr tab))) - - (mogrify-highlighting - (hitab unhitab) - - ;; Hack to reduce the number of - ;; round-trips to mozilla - (let (cmds) - (cond - ;; Highlighting tab - ((fourth hitab) - (push '(js! ((fourth hitab) "setAttribute") - "style" - "color: red; font-weight: bold") - cmds) - - ;; Highlight window proper - (push '(js! ((third hitab) - "setAttribute") - "style" - "border: 8px solid red") - cmds) - - ;; Select tab, when appropriate - (when js-js-switch-tabs - (push - '(js> ((fifth hitab) "selectedTab") (fourth hitab)) - cmds))) - - ;; Highlighting whole window - ((third hitab) - (push '(js! ((third hitab) "document" - "documentElement" "setAttribute") - "style" - (concat "-moz-appearance: none;" - "border: 8px solid red;")) - cmds))) - - (cond - ;; Unhighlighting tab - ((fourth unhitab) - (push '(js! ((fourth unhitab) "setAttribute") "style" "") - cmds) - (push '(js! ((third unhitab) "setAttribute") "style" "") - cmds)) - - ;; Unhighlighting window - ((third unhitab) - (push '(js! ((third unhitab) "document" - "documentElement" "setAttribute") - "style" "") - cmds))) - - (eval (list 'with-js - (cons 'js-list (nreverse cmds)))))) - - (command-hook - () - (let* ((tab (find-tab-by-cname (car ido-matches)))) - (mogrify-highlighting tab prev-hitab) - (setq prev-hitab tab))) - - (setup-hook - () - ;; Fiddle with the match list a bit: if our first match - ;; is a tabbrowser window, rotate the match list until - ;; the active tab comes up - (let ((matched-tab (find-tab-by-cname (car ido-matches)))) - (when (and matched-tab - (null (fourth matched-tab)) - (equal "navigator:browser" - (js! ((third matched-tab) - "document" - "documentElement" - "getAttribute") - "windowtype"))) - - (loop with tab-to-match = (js< (third matched-tab) - "gBrowser" - "selectedTab") - - for match in ido-matches - for candidate-tab = (find-tab-by-cname match) - if (eq (fourth candidate-tab) tab-to-match) - do (setq ido-cur-list (ido-chop ido-cur-list match)) - and return t))) - - (add-hook 'post-command-hook #'command-hook t t))) + (setq tabs + (cl-loop with tab-names = (make-hash-table :test 'equal) + for tab in tabs + for cname = (format "%s (%s)" + (cl-second tab) (cl-first tab)) + for num = (cl-incf (gethash cname tab-names -1)) + if (> num 0) + do (setq cname (format "%s <%d>" cname num)) + collect (cons cname tab))) + + (cl-labels + ((find-tab-by-cname + (cname) + (cl-loop for tab in tabs + if (equal (car tab) cname) + return (cdr tab))) + + (mogrify-highlighting + (hitab unhitab) + + ;; Hack to reduce the number of + ;; round-trips to mozilla + (let (cmds) + (cond + ;; Highlighting tab + ((cl-fourth hitab) + (push '(js! ((cl-fourth hitab) "setAttribute") + "style" + "color: red; font-weight: bold") + cmds) + + ;; Highlight window proper + (push '(js! ((cl-third hitab) + "setAttribute") + "style" + "border: 8px solid red") + cmds) + + ;; Select tab, when appropriate + (when js-js-switch-tabs + (push + '(js> ((cl-fifth hitab) "selectedTab") (cl-fourth hitab)) + cmds))) + + ;; Highlighting whole window + ((cl-third hitab) + (push '(js! ((cl-third hitab) "document" + "documentElement" "setAttribute") + "style" + (concat "-moz-appearance: none;" + "border: 8px solid red;")) + cmds))) + + (cond + ;; Unhighlighting tab + ((cl-fourth unhitab) + (push '(js! ((cl-fourth unhitab) "setAttribute") "style" "") + cmds) + (push '(js! ((cl-third unhitab) "setAttribute") "style" "") + cmds)) + + ;; Unhighlighting window + ((cl-third unhitab) + (push '(js! ((cl-third unhitab) "document" + "documentElement" "setAttribute") + "style" "") + cmds))) + + (eval (list 'with-js + (cons 'js-list (nreverse cmds)))))) + + (command-hook + () + (let* ((tab (find-tab-by-cname (car ido-matches)))) + (mogrify-highlighting tab prev-hitab) + (setq prev-hitab tab))) + + (setup-hook + () + ;; Fiddle with the match list a bit: if our first match + ;; is a tabbrowser window, rotate the match list until + ;; the active tab comes up + (let ((matched-tab (find-tab-by-cname (car ido-matches)))) + (when (and matched-tab + (null (cl-fourth matched-tab)) + (equal "navigator:browser" + (js! ((cl-third matched-tab) + "document" + "documentElement" + "getAttribute") + "windowtype"))) + + (cl-loop with tab-to-match = (js< (cl-third matched-tab) + "gBrowser" + "selectedTab") + + for match in ido-matches + for candidate-tab = (find-tab-by-cname match) + if (eq (cl-fourth candidate-tab) tab-to-match) + do (setq ido-cur-list + (ido-chop ido-cur-list match)) + and return t))) + + (add-hook 'post-command-hook #'command-hook t t))) (unwind-protect @@ -3078,13 +3085,12 @@ (add-to-history 'js-read-tab-history selected-tab-cname) - (setq selected-tab (loop for tab in tabs - if (equal (car tab) selected-tab-cname) - return (cdr tab))) + (setq selected-tab (cl-loop for tab in tabs + if (equal (car tab) selected-tab-cname) + return (cdr tab))) - (if (fourth selected-tab) - (cons 'browser (third selected-tab)) - (cons 'window (third selected-tab))))))) + (cons (if (cl-fourth selected-tab) 'browser 'window) + (cl-third selected-tab)))))) (defun js--guess-eval-defun-info (pstate) "Helper function for `js-eval-defun'. @@ -3092,19 +3098,19 @@ strings making up the class name and NAME is the name of the function part." (cond ((and (= (length pstate) 3) - (eq (js--pitem-type (first pstate)) 'function) - (= (length (js--pitem-name (first pstate))) 1) - (consp (js--pitem-type (second pstate)))) + (eq (js--pitem-type (cl-first pstate)) 'function) + (= (length (js--pitem-name (cl-first pstate))) 1) + (consp (js--pitem-type (cl-second pstate)))) - (append (js--pitem-name (second pstate)) - (list (first (js--pitem-name (first pstate)))))) + (append (js--pitem-name (cl-second pstate)) + (list (cl-first (js--pitem-name (cl-first pstate)))))) ((and (= (length pstate) 2) - (eq (js--pitem-type (first pstate)) 'function)) + (eq (js--pitem-type (cl-first pstate)) 'function)) (append - (butlast (js--pitem-name (first pstate))) - (list (car (last (js--pitem-name (first pstate))))))) + (butlast (js--pitem-name (cl-first pstate))) + (list (car (last (js--pitem-name (cl-first pstate))))))) (t (error "Function not a toplevel defun or class member")))) @@ -3148,19 +3154,21 @@ (with-js (when (or (null js--js-context) (js--js-handle-expired-p (cdr js--js-context)) - (ecase (car js--js-context) - (window (js? (js< (cdr js--js-context) "closed"))) - (browser (not (js? (js< (cdr js--js-context) - "contentDocument")))))) + (pcase (car js--js-context) + (`window (js? (js< (cdr js--js-context) "closed"))) + (`browser (not (js? (js< (cdr js--js-context) + "contentDocument")))) + (x (error "Unmatched case in js--get-js-context: %S" x)))) (setq js--js-context (js--read-tab "Javascript Context: "))) js--js-context)) (defun js--js-content-window (context) (with-js - (ecase (car context) - (window (cdr context)) - (browser (js< (cdr context) - "contentWindow" "wrappedJSObject"))))) + (pcase (car context) + (`window (cdr context)) + (`browser (js< (cdr context) + "contentWindow" "wrappedJSObject")) + (x (error "Unmatched case in js--js-content-window: %S" x))))) (defun js--make-nsilocalfile (path) (with-js @@ -3179,7 +3187,7 @@ (path-uri (js! (io-service "newFileURI") path-file))) (js! (res-prot "setSubstitution") alias path-uri)))) -(defun* js-eval-defun () +(cl-defun js-eval-defun () "Update a Mozilla tab using the JavaScript defun at point." (interactive) @@ -3215,7 +3223,7 @@ (unless (y-or-n-p (format "Send %s to Mozilla? " (mapconcat #'identity defun-info "."))) (message "") ; question message lingers until next command - (return-from js-eval-defun)) + (cl-return-from js-eval-defun)) (delete-overlay overlay))) (setq defun-body (buffer-substring-no-properties begin end)) === modified file 'lisp/progmodes/pascal.el' --- lisp/progmodes/pascal.el 2012-06-12 05:47:14 +0000 +++ lisp/progmodes/pascal.el 2012-07-11 23:13:41 +0000 @@ -57,7 +57,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (defgroup pascal nil "Major mode for editing Pascal source in Emacs." === modified file 'lisp/progmodes/perl-mode.el' --- lisp/progmodes/perl-mode.el 2012-04-17 02:46:22 +0000 +++ lisp/progmodes/perl-mode.el 2012-07-11 23:13:41 +0000 @@ -102,7 +102,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (defvar font-lock-comment-face) (defvar font-lock-doc-face) === modified file 'lisp/ps-samp.el' --- lisp/ps-samp.el 2012-01-19 07:21:25 +0000 +++ lisp/ps-samp.el 2012-07-11 23:13:41 +0000 @@ -251,8 +251,6 @@ ;; * CUPS has enabled the option "Share published printers connected ;; to this system" (see ). -(eval-when-compile - (require 'cl)) (require 'printing) (require 'zeroconf) === modified file 'lisp/server.el' --- lisp/server.el 2012-06-25 23:01:42 +0000 +++ lisp/server.el 2012-07-11 23:13:41 +0000 @@ -81,7 +81,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defgroup server nil "Emacs running as a server process." @@ -478,11 +478,11 @@ See `server-quote-arg' and `server-process-filter'." (replace-regexp-in-string "&." (lambda (s) - (case (aref s 1) + (pcase (aref s 1) (?& "&") (?- "-") (?n "\n") - (t " "))) + (_ " "))) arg t t)) (defun server-quote-arg (arg) @@ -493,7 +493,7 @@ See `server-unquote-arg' and `server-process-filter'." (replace-regexp-in-string "[-&\n ]" (lambda (s) - (case (aref s 0) + (pcase (aref s 0) (?& "&&") (?- "&-") (?\n "&n") @@ -514,7 +514,7 @@ (setq dir (directory-file-name dir)) (let ((attrs (file-attributes dir 'integer))) (unless attrs - (letf (((default-file-modes) ?\700)) (make-directory dir t)) + (cl-letf (((default-file-modes) ?\700)) (make-directory dir t)) (setq attrs (file-attributes dir 'integer))) ;; Check that it's safe for use. @@ -550,9 +550,9 @@ If called interactively, also inserts it into current buffer." (interactive) (let ((auth-key - (loop repeat 64 - collect (+ 33 (random 94)) into auth - finally return (concat auth)))) + (cl-loop repeat 64 + collect (+ 33 (random 94)) into auth + finally return (concat auth)))) (if (called-interactively-p 'interactive) (insert auth-key)) auth-key)) @@ -632,11 +632,13 @@ (server-ensure-safe-dir server-dir) (when server-process (server-log (message "Restarting server"))) - (letf (((default-file-modes) ?\700)) + (cl-letf (((default-file-modes) ?\700)) (add-hook 'suspend-tty-functions 'server-handle-suspend-tty) (add-hook 'delete-frame-functions 'server-handle-delete-frame) - (add-hook 'kill-buffer-query-functions 'server-kill-buffer-query-function) - (add-hook 'kill-emacs-query-functions 'server-kill-emacs-query-function) + (add-hook 'kill-buffer-query-functions + 'server-kill-buffer-query-function) + (add-hook 'kill-emacs-query-functions + 'server-kill-emacs-query-function) (add-hook 'kill-emacs-hook 'server-force-stop) ;Cleanup upon exit. (setq server-process (apply #'make-network-process @@ -886,7 +888,7 @@ (process-put proc 'continuation nil) (if continuation (ignore-errors (funcall continuation))))) -(defun* server-process-filter (proc string) +(cl-defun server-process-filter (proc string) "Process a request from the server to edit some files. PROC is the server process. STRING consists of a sequence of commands prefixed by a dash. Some commands have arguments; @@ -1001,8 +1003,8 @@ ;; receive the error string and shut down on its own. (sit-for 1) (delete-process proc) - ;; We return immediately - (return-from server-process-filter))) + ;; We return immediately. + (cl-return-from server-process-filter))) (let ((prev (process-get proc 'previous-string))) (when prev (setq string (concat prev string)) @@ -1021,7 +1023,7 @@ ;; In earlier versions of server.el (where we used an `emacsserver' ;; process), there could be multiple lines. Nowadays this is not ;; supported any more. - (assert (eq (match-end 0) (length string))) + (cl-assert (eq (match-end 0) (length string))) (let ((request (substring string 0 (match-beginning 0))) (coding-system (and (default-value 'enable-multibyte-characters) (or file-name-coding-system === modified file 'lisp/ses.el' --- lisp/ses.el 2012-06-27 15:11:28 +0000 +++ lisp/ses.el 2012-07-11 23:13:41 +0000 @@ -56,7 +56,7 @@ ;;; Code: (require 'unsafep) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;;---------------------------------------------------------------------------- @@ -1520,7 +1520,7 @@ (funcall field (ses-sym-rowcol min)))) ;; This range has changed size. (setq ses-relocate-return 'range)) - `(ses-range ,min ,max ,@(cdddr range))))) + `(ses-range ,min ,max ,@(cl-cdddr range))))) (defun ses-relocate-all (minrow mincol rowincr colincr) "Alter all cell values, symbols, formulas, and reference-lists to relocate @@ -3345,19 +3345,20 @@ (push result-row result) (while rest (let ((x (pop rest))) - (case x - ((>v) (setq transpose nil reorient-x nil reorient-y nil)) - ((>^)(setq transpose nil reorient-x nil reorient-y t)) - ((<^)(setq transpose nil reorient-x t reorient-y t)) - (()(setq transpose t reorient-x nil reorient-y t)) - ((^>)(setq transpose t reorient-x nil reorient-y nil)) - ((^<)(setq transpose t reorient-x t reorient-y nil)) - ((v<)(setq transpose t reorient-x t reorient-y t)) - ((* *2 *1) (setq vectorize x)) - ((!) (setq clean 'ses--clean-!)) - ((_) (setq clean `(lambda (&rest x) (ses--clean-_ x ,(if rest (pop rest) 0))))) - (t + (pcase x + (`>v (setq transpose nil reorient-x nil reorient-y nil)) + (`>^ (setq transpose nil reorient-x nil reorient-y t)) + (`<^ (setq transpose nil reorient-x t reorient-y t)) + (` (setq transpose t reorient-x nil reorient-y t)) + (`^> (setq transpose t reorient-x nil reorient-y nil)) + (`^< (setq transpose t reorient-x t reorient-y nil)) + (`v< (setq transpose t reorient-x t reorient-y t)) + ((or `* `*2 `*1) (setq vectorize x)) + (`! (setq clean 'ses--clean-!)) + (`_ (setq clean `(lambda (&rest x) + (ses--clean-_ x ,(if rest (pop rest) 0))))) + (_ (cond ; shorthands one row ((and (null (cddr result)) (memq x '(> <))) @@ -3389,14 +3390,14 @@ (mapcar (lambda (x) (cons clean (cons (quote 'vec) x))) result))))) - (case vectorize - ((nil) (cons clean (apply 'append result))) - ((*1) (vectorize-*1 clean result)) - ((*2) (vectorize-*2 clean result)) - ((*) (funcall (if (cdr result) - #'vectorize-*2 - #'vectorize-*1) - clean result)))))) + (pcase vectorize + (`nil (cons clean (apply 'append result))) + (`*1 (vectorize-*1 clean result)) + (`*2 (vectorize-*2 clean result)) + (`* (funcall (if (cdr result) + #'vectorize-*2 + #'vectorize-*1) + clean result)))))) (defun ses-delete-blanks (&rest args) "Return ARGS reversed, with the blank elements (nil and *skip*) removed." === modified file 'lisp/shell.el' --- lisp/shell.el 2012-05-15 16:58:35 +0000 +++ lisp/shell.el 2012-07-11 23:13:41 +0000 @@ -96,7 +96,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'comint) (require 'pcomplete) @@ -1243,7 +1242,7 @@ (variables (mapcar (lambda (x) (substring x 0 (string-match "=" x))) process-environment)) - (suffix (case (char-before start) (?\{ "}") (?\( ")") (t "")))) + (suffix (pcase (char-before start) (?\{ "}") (?\( ")") (_ "")))) (list start end variables :exit-function (lambda (s finished) === modified file 'lisp/strokes.el' --- lisp/strokes.el 2012-06-02 10:56:09 +0000 +++ lisp/strokes.el 2012-07-11 23:13:41 +0000 @@ -180,7 +180,7 @@ ;;; Requirements and provisions... (autoload 'mail-position-on-field "sendmail") -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;;; Constants... @@ -542,10 +542,10 @@ (defun strokes-eliminate-consecutive-redundancies (entries) "Return a list with no consecutive redundant entries." ;; defun a grande vitesse grace a Dave G. - (loop for element on entries - if (not (equal (car element) (cadr element))) - collect (car element))) -;; (loop for element on entries + (cl-loop for element on entries + if (not (equal (car element) (cadr element))) + collect (car element))) +;; (cl-loop for element on entries ;; nconc (if (not (equal (car el) (cadr el))) ;; (list (car el))))) ;; yet another (orig) way of doing it... @@ -584,68 +584,70 @@ (if (and (strokes-click-p unfilled-stroke) (not force)) unfilled-stroke - (loop for grid-locs on unfilled-stroke - nconc (let* ((current (car grid-locs)) - (current-is-a-point-p (consp current)) - (next (cadr grid-locs)) - (next-is-a-point-p (consp next)) - (both-are-points-p (and current-is-a-point-p - next-is-a-point-p)) - (x1 (and current-is-a-point-p - (car current))) - (y1 (and current-is-a-point-p - (cdr current))) - (x2 (and next-is-a-point-p - (car next))) - (y2 (and next-is-a-point-p - (cdr next))) - (delta-x (and both-are-points-p - (- x2 x1))) - (delta-y (and both-are-points-p - (- y2 y1))) - (slope (and both-are-points-p - (if (zerop delta-x) - nil ; undefined vertical slope - (/ (float delta-y) - delta-x))))) - (cond ((not both-are-points-p) - (list current)) - ((null slope) ; undefined vertical slope - (if (>= delta-y 0) - (loop for y from y1 below y2 - collect (cons x1 y)) - (loop for y from y1 above y2 - collect (cons x1 y)))) - ((zerop slope) ; (= y1 y2) - (if (>= delta-x 0) - (loop for x from x1 below x2 - collect (cons x y1)) - (loop for x from x1 above x2 - collect (cons x y1)))) - ((>= (abs delta-x) (abs delta-y)) - (if (> delta-x 0) - (loop for x from x1 below x2 - collect (cons x - (+ y1 - (round (* slope - (- x x1)))))) - (loop for x from x1 above x2 - collect (cons x - (+ y1 - (round (* slope - (- x x1)))))))) - (t ; (< (abs delta-x) (abs delta-y)) - (if (> delta-y 0) - (loop for y from y1 below y2 - collect (cons (+ x1 - (round (/ (- y y1) - slope))) - y)) - (loop for y from y1 above y2 - collect (cons (+ x1 - (round (/ (- y y1) - slope))) - y)))))))))) + (cl-loop + for grid-locs on unfilled-stroke + nconc (let* ((current (car grid-locs)) + (current-is-a-point-p (consp current)) + (next (cadr grid-locs)) + (next-is-a-point-p (consp next)) + (both-are-points-p (and current-is-a-point-p + next-is-a-point-p)) + (x1 (and current-is-a-point-p + (car current))) + (y1 (and current-is-a-point-p + (cdr current))) + (x2 (and next-is-a-point-p + (car next))) + (y2 (and next-is-a-point-p + (cdr next))) + (delta-x (and both-are-points-p + (- x2 x1))) + (delta-y (and both-are-points-p + (- y2 y1))) + (slope (and both-are-points-p + (if (zerop delta-x) + nil ; undefined vertical slope + (/ (float delta-y) + delta-x))))) + (cond ((not both-are-points-p) + (list current)) + ((null slope) ; undefined vertical slope + (if (>= delta-y 0) + (cl-loop for y from y1 below y2 + collect (cons x1 y)) + (cl-loop for y from y1 above y2 + collect (cons x1 y)))) + ((zerop slope) ; (= y1 y2) + (if (>= delta-x 0) + (cl-loop for x from x1 below x2 + collect (cons x y1)) + (cl-loop for x from x1 above x2 + collect (cons x y1)))) + ((>= (abs delta-x) (abs delta-y)) + (if (> delta-x 0) + (cl-loop for x from x1 below x2 + collect (cons x + (+ y1 + (round (* slope + (- x x1)))))) + (cl-loop for x from x1 above x2 + collect (cons x + (+ y1 + (round (* slope + (- x x1)))))))) + (t ; (< (abs delta-x) (abs delta-y)) + (if (> delta-y 0) + ;; FIXME: Reduce redundancy between branches. + (cl-loop for y from y1 below y2 + collect (cons (+ x1 + (round (/ (- y y1) + slope))) + y)) + (cl-loop for y from y1 above y2 + collect (cons (+ x1 + (round (/ (- y y1) + slope))) + y)))))))))) (defun strokes-rate-stroke (stroke1 stroke2) "Rates STROKE1 with STROKE2 and return a score based on a distance metric. @@ -723,9 +725,9 @@ (defsubst strokes-fill-current-buffer-with-whitespace () "Erase the contents of the current buffer and fill it with whitespace." (erase-buffer) - (loop repeat (frame-height) do - (insert-char ?\s (1- (frame-width))) - (newline)) + (cl-loop repeat (frame-height) do + (insert-char ?\s (1- (frame-width))) + (newline)) (goto-char (point-min))) ;;;###autoload @@ -1173,40 +1175,40 @@ (set-buffer buf) (erase-buffer) (insert strokes-xpm-header) - (loop repeat 33 do - (insert ?\") - (insert-char ?\s 33) - (insert "\",") - (newline) - finally - (forward-line -1) - (end-of-line) - (insert "}\n")) - (loop for point in stroke - for x = (car-safe point) - for y = (cdr-safe point) do - (cond ((consp point) - ;; draw a point, and possibly a starting-point - (if (and lift-flag (not b/w-only)) - ;; mark starting point with the appropriate color - (let ((char (or (car rainbow-chars) ?\.))) - (loop for i from 0 to 2 do - (loop for j from 0 to 2 do - (goto-char (point-min)) - (forward-line (+ 15 i y)) - (forward-char (+ 1 j x)) - (delete-char 1) - (insert char))) - (setq rainbow-chars (cdr rainbow-chars) - lift-flag nil)) - ;; Otherwise, just plot the point... - (goto-char (point-min)) - (forward-line (+ 16 y)) - (forward-char (+ 2 x)) - (subst-char-in-region (point) (1+ (point)) ?\s ?\*))) - ((strokes-lift-p point) - ;; a lift--tell the loop to X out the next point... - (setq lift-flag t)))) + (cl-loop repeat 33 do + (insert ?\") + (insert-char ?\s 33) + (insert "\",") + (newline) + finally + (forward-line -1) + (end-of-line) + (insert "}\n")) + (cl-loop for point in stroke + for x = (car-safe point) + for y = (cdr-safe point) do + (cond ((consp point) + ;; draw a point, and possibly a starting-point + (if (and lift-flag (not b/w-only)) + ;; mark starting point with the appropriate color + (let ((char (or (car rainbow-chars) ?\.))) + (cl-loop for i from 0 to 2 do + (cl-loop for j from 0 to 2 do + (goto-char (point-min)) + (forward-line (+ 15 i y)) + (forward-char (+ 1 j x)) + (delete-char 1) + (insert char))) + (setq rainbow-chars (cdr rainbow-chars) + lift-flag nil)) + ;; Otherwise, just plot the point... + (goto-char (point-min)) + (forward-line (+ 16 y)) + (forward-char (+ 2 x)) + (subst-char-in-region (point) (1+ (point)) ?\s ?\*))) + ((strokes-lift-p point) + ;; a lift--tell the loop to X out the next point... + (setq lift-flag t)))) (when (called-interactively-p 'interactive) (pop-to-buffer " *strokes-xpm*") ;; (xpm-mode 1) @@ -1288,7 +1290,7 @@ ;; (insert ;; "Command Stroke\n" ;; "------- ------") -;; (loop for def in strokes-map +;; (cl-loop for def in strokes-map ;; for i from 0 to (1- (length strokes-map)) do ;; (let ((stroke (car def)) ;; (command-name (symbol-name (cdr def)))) @@ -1343,27 +1345,28 @@ (insert "Command Stroke\n" "------- ------") - (loop for def in strokes-map do - (let ((stroke (car def)) - (command-name (if (symbolp (cdr def)) - (symbol-name (cdr def)) - (prin1-to-string (cdr def))))) - (strokes-xpm-for-stroke stroke " *strokes-xpm*") - (newline 2) - (insert-char ?\s 45) - (beginning-of-line) - (insert command-name) - (beginning-of-line) - (forward-char 45) - (insert-image - (create-image (with-current-buffer " *strokes-xpm*" - (buffer-string)) - 'xpm t - :color-symbols - `(("foreground" - . ,(frame-parameter nil 'foreground-color)))))) - finally do (unless (eobp) - (kill-region (1+ (point)) (point-max)))) + (cl-loop + for def in strokes-map do + (let ((stroke (car def)) + (command-name (if (symbolp (cdr def)) + (symbol-name (cdr def)) + (prin1-to-string (cdr def))))) + (strokes-xpm-for-stroke stroke " *strokes-xpm*") + (newline 2) + (insert-char ?\s 45) + (beginning-of-line) + (insert command-name) + (beginning-of-line) + (forward-char 45) + (insert-image + (create-image (with-current-buffer " *strokes-xpm*" + (buffer-string)) + 'xpm t + :color-symbols + `(("foreground" + . ,(frame-parameter nil 'foreground-color)))))) + finally do (unless (eobp) + (kill-region (1+ (point)) (point-max)))) (view-buffer "*Strokes List*" nil) (set (make-local-variable 'view-mode-map) (let ((map (copy-keymap view-mode-map))) @@ -1588,7 +1591,7 @@ ;; yet another of the same bit-type, so we continue ;; counting... (progn - (incf count) + (cl-incf count) (forward-char 1)) ;; otherwise, it's the opposite bit-type, so we do a ;; write and then restart count ### NOTE (for myself @@ -1727,10 +1730,10 @@ (delete-char 1) (setq current-char-is-on-p (not current-char-is-on-p))) (goto-char (point-min)) - (loop repeat 33 do - (insert ?\") - (forward-char 33) - (insert "\",\n")) + (cl-loop repeat 33 do + (insert ?\") + (forward-char 33) + (insert "\",\n")) (goto-char (point-min)) (insert strokes-xpm-header)))) === modified file 'lisp/tar-mode.el' --- lisp/tar-mode.el 2012-05-04 06:13:18 +0000 +++ lisp/tar-mode.el 2012-07-11 23:13:41 +0000 @@ -97,7 +97,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defgroup tar nil "Simple editing of tar files." @@ -168,7 +168,7 @@ ;; state correctly: the raw data is expected to be always larger than ;; the summary. (progn - (assert (or (= (buffer-size tar-data-buffer) (buffer-size)) + (cl-assert (or (= (buffer-size tar-data-buffer) (buffer-size)) (eq tar-data-swapped (> (buffer-size tar-data-buffer) (buffer-size))))) tar-data-swapped))) @@ -186,7 +186,7 @@ ;;; down to business. -(defstruct (tar-header +(cl-defstruct (tar-header (:constructor nil) (:type vector) :named @@ -226,8 +226,8 @@ This is a list of name, mode, uid, gid, size, write-date, checksum, link-type, and link-name." (if (> (+ pos 512) (point-max)) (error "Malformed Tar header")) - (assert (zerop (mod (- pos (point-min)) 512))) - (assert (not enable-multibyte-characters)) + (cl-assert (zerop (mod (- pos (point-min)) 512))) + (cl-assert (not enable-multibyte-characters)) (let ((string (buffer-substring pos (setq pos (+ pos 512))))) (when ;(some 'plusp string) ; <-- oops, massive cycle hog! (or (not (= 0 (aref string 0))) ; This will do. @@ -373,7 +373,7 @@ (defun tar-header-block-checksum (string) "Compute and return a tar-acceptable checksum for this block." - (assert (not (multibyte-string-p string))) + (cl-assert (not (multibyte-string-p string))) (let* ((chk-field-start tar-chk-offset) (chk-field-end (+ chk-field-start 8)) (sum 0) @@ -486,7 +486,7 @@ (defun tar-summarize-buffer () "Parse the contents of the tar file in the current buffer." - (assert (tar-data-swapped-p)) + (cl-assert (tar-data-swapped-p)) (let* ((modified (buffer-modified-p)) (result '()) (pos (point-min)) @@ -654,7 +654,7 @@ (widen) ;; Now move the Tar data into an auxiliary buffer, so we can use the main ;; buffer for the summary. - (assert (not (tar-data-swapped-p))) + (cl-assert (not (tar-data-swapped-p))) (set (make-local-variable 'revert-buffer-function) 'tar-mode-revert) ;; We started using write-contents-functions, but this hook is not ;; used during auto-save, so we now use @@ -1119,15 +1119,15 @@ (insert (tar-header-block-summarize descriptor) "\n"))) (forward-line -1) (move-to-column col)) - (assert (tar-data-swapped-p)) + (cl-assert (tar-data-swapped-p)) (with-current-buffer tar-data-buffer (let* ((start (- (tar-header-data-start descriptor) 512))) ;; ;; delete the old field and insert a new one. (goto-char (+ start data-position)) (delete-region (point) (+ (point) (length new-data-string))) ; <-- - (assert (not (or enable-multibyte-characters - (multibyte-string-p new-data-string)))) + (cl-assert (not (or enable-multibyte-characters + (multibyte-string-p new-data-string)))) (insert new-data-string) ;; ;; compute a new checksum and insert it. === modified file 'lisp/term.el' --- lisp/term.el 2012-06-28 10:40:24 +0000 +++ lisp/term.el 2012-07-11 23:13:41 +0000 @@ -393,9 +393,7 @@ ;; so it is important to increase it if there are protocol-relevant changes. (defconst term-protocol-version "0.96") -(eval-when-compile - (require 'ange-ftp) - (require 'cl)) +(eval-when-compile (require 'ange-ftp)) (require 'ring) (require 'ehelp) @@ -3220,11 +3218,11 @@ (when term-ansi-current-bold (setq term-current-face - (list* term-current-face :inherit 'term-bold))) + `(,term-current-face :inherit term-bold))) (when term-ansi-current-underline (setq term-current-face - (list* term-current-face :inherit 'term-underline))))) + `(,term-current-face :inherit term-underline))))) ;; (message "Debug %S" term-current-face) ;; FIXME: shouldn't we set term-ansi-face-already-done to t here? --Stef === modified file 'lisp/term/ns-win.el' --- lisp/term/ns-win.el 2012-06-02 10:56:09 +0000 +++ lisp/term/ns-win.el 2012-07-11 23:13:41 +0000 @@ -44,8 +44,6 @@ (error "%s: Loading ns-win.el but not compiled for GNUstep/MacOS" (invocation-name))) -(eval-when-compile (require 'cl)) - ;; Documentation-purposes only: actually loaded in loadup.el. (require 'frame) (require 'mouse) === modified file 'lisp/term/tvi970.el' --- lisp/term/tvi970.el 2012-01-19 07:21:25 +0000 +++ lisp/term/tvi970.el 2012-07-11 23:13:41 +0000 @@ -27,8 +27,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (defvar tvi970-terminal-map (let ((map (make-sparse-keymap))) === modified file 'lisp/textmodes/css-mode.el' --- lisp/textmodes/css-mode.el 2012-01-19 07:21:25 +0000 +++ lisp/textmodes/css-mode.el 2012-07-11 23:13:41 +0000 @@ -37,7 +37,6 @@ "Cascading Style Sheets (CSS) editing mode." :group 'languages) -(eval-when-compile (require 'cl)) (defun css-extract-keyword-list (res) (with-temp-buffer === modified file 'lisp/textmodes/refill.el' --- lisp/textmodes/refill.el 2012-01-19 07:21:25 +0000 +++ lisp/textmodes/refill.el 2012-07-11 23:13:41 +0000 @@ -83,8 +83,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (defgroup refill nil "Refilling paragraphs on changes." :group 'fill) @@ -169,8 +167,8 @@ "Post-command function to do refilling (conditionally)." (when refill-doit ; there was a change ;; There's probably scope for more special cases here... - (case this-command - (self-insert-command + (pcase this-command + (`self-insert-command ;; Treat self-insertion commands specially, since they don't ;; always reset `refill-doit' -- for self-insertion commands that ;; *don't* cause a refill, we want to leave it turned on so that @@ -180,9 +178,9 @@ ;; newline, covered below). (refill-fill-paragraph-at refill-doit) (setq refill-doit nil))) - ((quoted-insert fill-paragraph fill-region) nil) - ((newline newline-and-indent open-line indent-new-comment-line - reindent-then-newline-and-indent) + ((or `quoted-insert `fill-paragraph `fill-region) nil) + ((or `newline `newline-and-indent `open-line `indent-new-comment-line + `reindent-then-newline-and-indent) ;; Don't zap what was just inserted. (save-excursion (beginning-of-line) ; for newline-and-indent @@ -196,7 +194,7 @@ (save-restriction (narrow-to-region (line-beginning-position) (point-max)) (refill-fill-paragraph-at refill-doit)))) - (t + (_ (refill-fill-paragraph-at refill-doit))) (setq refill-doit nil))) === modified file 'lisp/textmodes/sgml-mode.el' --- lisp/textmodes/sgml-mode.el 2012-06-02 10:56:09 +0000 +++ lisp/textmodes/sgml-mode.el 2012-07-11 23:13:41 +0000 @@ -35,7 +35,7 @@ (eval-when-compile (require 'skeleton) (require 'outline) - (require 'cl)) + (require 'cl-lib)) (defgroup sgml nil "SGML editing mode." @@ -1192,7 +1192,7 @@ ;; Parsing -(defstruct (sgml-tag +(cl-defstruct (sgml-tag (:constructor sgml-make-tag (type start end name))) type start end name) @@ -1272,7 +1272,7 @@ (throw 'found (sgml-parse-tag-backward limit)))) (point)))) (goto-char (1+ tag-start)) - (case (char-after) + (pcase (char-after) (?! (setq tag-type 'decl)) ; declaration (?? (setq tag-type 'pi)) ; processing-instruction (?% (setq tag-type 'jsp)) ; JSP tags @@ -1280,7 +1280,7 @@ (forward-char 1) (setq tag-type 'close name (sgml-parse-tag-name))) - (t ; open or empty tag + (_ ; open or empty tag (setq tag-type 'open name (sgml-parse-tag-name)) (if (or (eq ?/ (char-before (- tag-end 1))) @@ -1405,19 +1405,19 @@ Depending on context, inserts a matching close-tag, or closes the current start-tag or the current comment or the current cdata, ..." (interactive) - (case (car (sgml-lexical-context)) - (comment (insert " -->")) - (cdata (insert "]]>")) - (pi (insert " ?>")) - (jsp (insert " %>")) - (tag (insert " />")) - (text + (pcase (car (sgml-lexical-context)) + (`comment (insert " -->")) + (`cdata (insert "]]>")) + (`pi (insert " ?>")) + (`jsp (insert " %>")) + (`tag (insert " />")) + (`text (let ((context (save-excursion (sgml-get-context)))) (if context (progn (insert "") (indent-according-to-mode))))) - (otherwise + (_ (error "Nothing to close")))) (defun sgml-empty-tag-p (tag-name) @@ -1442,9 +1442,9 @@ (save-excursion (goto-char (cdr lcon)) (looking-at "