mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2025-01-16 17:19:41 +00:00
Code Issues Releases Activity

Merge from emacs--devo--0

Browse Source 
Patches applied:

 * emacs--devo--0  (patch 803-813)

   - Update from CVS
   - Merge from emacs--rel--22

 * emacs--rel--22  (patch 51-58)

   - Update from CVS
   - Merge from gnus--rel--5.10

 * gnus--rel--5.10  (patch 233-236)

   - Merge from emacs--devo--0
   - Update from CVS

Revision: emacs@sv.gnu.org/emacs--multi-tty--0--patch-25
This commit is contained in:
Miles Bader 2007-07-15 02:05:20 +00:00
commit 7eb1e4534e
201 changed files with 20916 additions and 10304 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
ChangeLog
View File

@ -1,3 +1,12 @@
2007-06-20 Jan Dj,Ad(Brv <jan.h.d@swipnet.se>
* configure.in: Complain if X seems to be installed but no
development files were found.
2007-06-20 Glenn Morris <rgm@gnu.org>
* configure.in: Prefer libgif over libungif.
2007-06-14 Jan Dj,Ad(Brv <jan.h.d@swipnet.se>
* configure.in: Check for all image libraries before exiting.
@ -6,11 +15,6 @@
* configure.in: Exit with error if image libraries aren't found.
2007-06-13 Michael Kifer <kifer@cs.stonybrook.edu>
* ediff-ptch.el (ediff-context-diff-label-regexp): partially undid
previous patch
2007-06-13 Chong Yidong <cyd@stupidchicken.com>
* configure.in: Merge xaw3d and libXaw checks. Check xaw3d even

228
configure vendored
View File

@ -686,6 +686,7 @@ ALSA_LIBS
CFLAGS_SOUND
SET_MAKE
XMKMF
HAVE_XSERVER
GTK_CFLAGS
GTK_LIBS
XFT_CFLAGS
@ -1337,7 +1338,7 @@ Optional Packages:
--with-xpm use -lXpm for displaying XPM images
--with-jpeg use -ljpeg for displaying JPEG images
--with-tiff use -ltiff for displaying TIFF images
--with-gif use -lungif (or -lgif) for displaying GIF images
--with-gif use -lgif (or -lungif) for displaying GIF images
--with-png use -lpng for displaying PNG images
--with-gpm use -lgpm for mouse support on a GNU/Linux console
--with-gtk use GTK (same as --with-x-toolkit=gtk)
@ -9584,6 +9585,68 @@ case "${window_system}" in
;;
esac
if test "$window_system" = none && test "X$with_x" != "Xno"; then
# Extract the first word of "X", so it can be a program name with args.
set dummy X; ac_word=$2
{ echo "$as_me:$LINENO: checking for $ac_word" >&5
echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; }
if test "${ac_cv_prog_HAVE_XSERVER+set}" = set; then
echo $ECHO_N "(cached) $ECHO_C" >&6
else
if test -n "$HAVE_XSERVER"; then
ac_cv_prog_HAVE_XSERVER="$HAVE_XSERVER" # Let the user override the test.
else
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
ac_cv_prog_HAVE_XSERVER="true"
echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
test -z "$ac_cv_prog_HAVE_XSERVER" && ac_cv_prog_HAVE_XSERVER="false"
fi
fi
HAVE_XSERVER=$ac_cv_prog_HAVE_XSERVER
if test -n "$HAVE_XSERVER"; then
{ echo "$as_me:$LINENO: result: $HAVE_XSERVER" >&5
echo "${ECHO_T}$HAVE_XSERVER" >&6; }
else
{ echo "$as_me:$LINENO: result: no" >&5
echo "${ECHO_T}no" >&6; }
fi
if test "$HAVE_XSERVER" = true ||
test -n "$DISPLAY" ||
test "`echo /usr/lib/libX11.*`" != "/usr/lib/libX11.*"; then
{ { echo "$as_me:$LINENO: error: You seem to be running X, but no X development libraries
where found. You should install the relevant development files for X
and the for the toolkit you want, such as Gtk+, Lesstif or Motif. Also make
sure you have development files for image handling, i.e.
tiff, gif, jpeg, png and xpm.
If you are sure you want Emacs compiled without X window support, pass
--without-x
to configure." >&5
echo "$as_me: error: You seem to be running X, but no X development libraries
where found. You should install the relevant development files for X
and the for the toolkit you want, such as Gtk+, Lesstif or Motif. Also make
sure you have development files for image handling, i.e.
tiff, gif, jpeg, png and xpm.
If you are sure you want Emacs compiled without X window support, pass
--without-x
to configure." >&2;}
{ (exit 1); exit 1; }; }
fi
fi
### If we're using X11, we should use the X menu package.
HAVE_MENUS=no
case ${HAVE_X11} in
@ -13880,83 +13943,6 @@ fi
if test $ac_cv_header_gif_lib_h = yes; then
# EGifPutExtensionLast only exists from version libungif-4.1.0b1.
# Earlier versions can crash Emacs.
{ echo "$as_me:$LINENO: checking for EGifPutExtensionLast in -lungif" >&5
echo $ECHO_N "checking for EGifPutExtensionLast in -lungif... $ECHO_C" >&6; }
if test "${ac_cv_lib_ungif_EGifPutExtensionLast+set}" = set; then
echo $ECHO_N "(cached) $ECHO_C" >&6
else
ac_check_lib_save_LIBS=$LIBS
LIBS="-lungif $LIBS"
cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h. */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
#ifdef __cplusplus
extern "C"
#endif
char EGifPutExtensionLast ();
int
main ()
{
return EGifPutExtensionLast ();
;
return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (ac_try="$ac_link"
case "(($ac_try" in
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
*) ac_try_echo=$ac_try;;
esac
eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
(eval "$ac_link") 2>conftest.er1
ac_status=$?
grep -v '^ *+' conftest.er1 >conftest.err
rm -f conftest.er1
cat conftest.err >&5
echo "$as_me:$LINENO: \$? = $ac_status" >&5
(exit $ac_status); } && {
test -z "$ac_c_werror_flag" ||
test ! -s conftest.err
} && test -s conftest$ac_exeext &&
$as_test_x conftest$ac_exeext; then
ac_cv_lib_ungif_EGifPutExtensionLast=yes
else
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5
ac_cv_lib_ungif_EGifPutExtensionLast=no
fi
rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ echo "$as_me:$LINENO: result: $ac_cv_lib_ungif_EGifPutExtensionLast" >&5
echo "${ECHO_T}$ac_cv_lib_ungif_EGifPutExtensionLast" >&6; }
if test $ac_cv_lib_ungif_EGifPutExtensionLast = yes; then
HAVE_GIF=yes
else
try_libgif=yes
fi
fi
if test "$HAVE_GIF" = yes; then
ac_gif_lib_name="-lungif"
fi
# If gif_lib.h but no libungif, try libgif.
if test x"$try_libgif" = xyes; then
{ echo "$as_me:$LINENO: checking for EGifPutExtensionLast in -lgif" >&5
echo $ECHO_N "checking for EGifPutExtensionLast in -lgif... $ECHO_C" >&6; }
if test "${ac_cv_lib_gif_EGifPutExtensionLast+set}" = set; then
@ -14020,16 +14006,93 @@ fi
echo "${ECHO_T}$ac_cv_lib_gif_EGifPutExtensionLast" >&6; }
if test $ac_cv_lib_gif_EGifPutExtensionLast = yes; then
HAVE_GIF=yes
else
try_libungif=yes
fi
fi
if test "$HAVE_GIF" = yes; then
ac_gif_lib_name="-lgif"
fi
# If gif_lib.h but no libgif, try libungif.
if test x"$try_libungif" = xyes; then
{ echo "$as_me:$LINENO: checking for EGifPutExtensionLast in -lungif" >&5
echo $ECHO_N "checking for EGifPutExtensionLast in -lungif... $ECHO_C" >&6; }
if test "${ac_cv_lib_ungif_EGifPutExtensionLast+set}" = set; then
echo $ECHO_N "(cached) $ECHO_C" >&6
else
ac_check_lib_save_LIBS=$LIBS
LIBS="-lungif $LIBS"
cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h. */
_ACEOF
cat confdefs.h >>conftest.$ac_ext
cat >>conftest.$ac_ext <<_ACEOF
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
#ifdef __cplusplus
extern "C"
#endif
char EGifPutExtensionLast ();
int
main ()
{
return EGifPutExtensionLast ();
;
return 0;
}
_ACEOF
rm -f conftest.$ac_objext conftest$ac_exeext
if { (ac_try="$ac_link"
case "(($ac_try" in
*\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
*) ac_try_echo=$ac_try;;
esac
eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
(eval "$ac_link") 2>conftest.er1
ac_status=$?
grep -v '^ *+' conftest.er1 >conftest.err
rm -f conftest.er1
cat conftest.err >&5
echo "$as_me:$LINENO: \$? = $ac_status" >&5
(exit $ac_status); } && {
test -z "$ac_c_werror_flag" ||
test ! -s conftest.err
} && test -s conftest$ac_exeext &&
$as_test_x conftest$ac_exeext; then
ac_cv_lib_ungif_EGifPutExtensionLast=yes
else
echo "$as_me: failed program was:" >&5
sed 's/^/| /' conftest.$ac_ext >&5
ac_cv_lib_ungif_EGifPutExtensionLast=no
fi
rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ echo "$as_me:$LINENO: result: $ac_cv_lib_ungif_EGifPutExtensionLast" >&5
echo "${ECHO_T}$ac_cv_lib_ungif_EGifPutExtensionLast" >&6; }
if test $ac_cv_lib_ungif_EGifPutExtensionLast = yes; then
HAVE_GIF=yes
fi
if test "$HAVE_GIF" = yes; then
cat >>confdefs.h <<\_ACEOF
#define LIBGIF -lgif
#define LIBGIF -lungif
_ACEOF
ac_gif_lib_name="-lgif"
ac_gif_lib_name="-lungif"
fi
fi
@ -24215,6 +24278,7 @@ ALSA_LIBS!$ALSA_LIBS$ac_delim
CFLAGS_SOUND!$CFLAGS_SOUND$ac_delim
SET_MAKE!$SET_MAKE$ac_delim
XMKMF!$XMKMF$ac_delim
HAVE_XSERVER!$HAVE_XSERVER$ac_delim
GTK_CFLAGS!$GTK_CFLAGS$ac_delim
GTK_LIBS!$GTK_LIBS$ac_delim
XFT_CFLAGS!$XFT_CFLAGS$ac_delim
@ -24241,7 +24305,6 @@ bitmapdir!$bitmapdir$ac_delim
gamedir!$gamedir$ac_delim
gameuser!$gameuser$ac_delim
c_switch_system!$c_switch_system$ac_delim
c_switch_machine!$c_switch_machine$ac_delim
_ACEOF
if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 97; then
@ -24283,6 +24346,7 @@ _ACEOF
ac_delim='%!_!# '
for ac_last_try in false false false false false :; do
cat >conf$$subs.sed <<_ACEOF
c_switch_machine!$c_switch_machine$ac_delim
LD_SWITCH_X_SITE!$LD_SWITCH_X_SITE$ac_delim
LD_SWITCH_X_SITE_AUX!$LD_SWITCH_X_SITE_AUX$ac_delim
C_SWITCH_X_SITE!$C_SWITCH_X_SITE$ac_delim
@ -24293,7 +24357,7 @@ carbon_appdir!$carbon_appdir$ac_delim
LTLIBOBJS!$LTLIBOBJS$ac_delim
_ACEOF
if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 8; then
if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 9; then
break
elif $ac_last_try; then
{ { echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5

34
configure.in
View File

@ -105,7 +105,7 @@ AC_ARG_WITH(jpeg,
AC_ARG_WITH(tiff,
[ --with-tiff use -ltiff for displaying TIFF images])
AC_ARG_WITH(gif,
[ --with-gif use -lungif (or -lgif) for displaying GIF images])
[ --with-gif use -lgif (or -lungif) for displaying GIF images])
AC_ARG_WITH(png,
[ --with-png use -lpng for displaying PNG images])
AC_ARG_WITH(gpm,
@ -1892,6 +1892,22 @@ dnl use the toolkit if we have gtk, or X11R5 or newer.
;;
esac
if test "$window_system" = none && test "X$with_x" != "Xno"; then
AC_CHECK_PROG(HAVE_XSERVER, X, true, false)
if test "$HAVE_XSERVER" = true ||
test -n "$DISPLAY" ||
test "`echo /usr/lib/libX11.*`" != "/usr/lib/libX11.*"; then
AC_MSG_ERROR([You seem to be running X, but no X development libraries
were found. You should install the relevant development files for X
and for the toolkit you want, such as Gtk+, Lesstif or Motif. Also make
sure you have development files for image handling, i.e.
tiff, gif, jpeg, png and xpm.
If you are sure you want Emacs compiled without X window support, pass
--without-x
to configure.])
fi
fi
### If we're using X11, we should use the X menu package.
HAVE_MENUS=no
case ${HAVE_X11} in
@ -2528,24 +2544,24 @@ if test "${HAVE_X11}" = "yes" && test "${with_gif}" != "no"; then
AC_CHECK_HEADER(gif_lib.h,
# EGifPutExtensionLast only exists from version libungif-4.1.0b1.
# Earlier versions can crash Emacs.
AC_CHECK_LIB(ungif, EGifPutExtensionLast, HAVE_GIF=yes, try_libgif=yes))
AC_CHECK_LIB(gif, EGifPutExtensionLast, HAVE_GIF=yes, try_libungif=yes))
if test "$HAVE_GIF" = yes; then
ac_gif_lib_name="-lungif"
ac_gif_lib_name="-lgif"
fi
# If gif_lib.h but no libungif, try libgif.
if test x"$try_libgif" = xyes; then
AC_CHECK_LIB(gif, EGifPutExtensionLast, HAVE_GIF=yes)
# If gif_lib.h but no libgif, try libungif.
if test x"$try_libungif" = xyes; then
AC_CHECK_LIB(ungif, EGifPutExtensionLast, HAVE_GIF=yes)
if test "$HAVE_GIF" = yes; then
AC_DEFINE(LIBGIF, -lgif, [Compiler option to link with the gif library (if not -lungif).])
ac_gif_lib_name="-lgif"
AC_DEFINE(LIBGIF, -lungif, [Compiler option to link with the gif library (if not -lgif).])
ac_gif_lib_name="-lungif"
fi
fi
if test "${HAVE_GIF}" = "yes"; then
AC_DEFINE(HAVE_GIF, 1, [Define to 1 if you have a gif library (default -lungif; otherwise specify with LIBGIF).])
AC_DEFINE(HAVE_GIF, 1, [Define to 1 if you have a gif library (default -lgif; otherwise specify with LIBGIF).])
fi
fi

37
etc/ChangeLog
View File

@ -1,3 +1,40 @@
2007-07-15 Karl Fogel <kfogel@red-bean.com>
* NEWS: Revert 2007-07-13T23:20:21Z!kfogel@red-bean.com, which
documented bookmark keybinding changes that were later reverted.
2007-07-14 Jan Dj,Ad(Brv <jan.h.d@swipnet.se>
* PROBLEMS: Mention gtk-engines-qt problem.
2007-07-13 Karl Fogel <kfogel@red-bean.com>
* NEWS: Update for recent bookmark keybinding changes.
2007-07-10 Michael Albinus <michael.albinus@gmx.de>
* NEWS: Add Tramp and comint-mode changes.
2007-07-08 Michael Albinus <michael.albinus@gmx.de>
* NEWS: `file-remote-p' has a new optional parameter CONNECTED.
2007-07-07 Michael Albinus <michael.albinus@gmx.de>
* NEWS: New function `start-file-process'.
2007-07-02 Carsten Dominik <dominik@science.uva.nl>
* orgcard.tex: Version 5.01
2007-06-27 Michael Albinus <michael.albinus@gmx.de>
* NEWS: `dired-call-process' has been removed.
2007-06-20 Glenn Morris <rgm@gnu.org>
* NEWS: configure prefers libgif over libungif.
2007-06-14 Nick Roberts <nickrob@snap.net.nz>
* NEWS: Mention mouse highlighting in a GNU/Linux console.

102
etc/NEWS
View File

@ -28,17 +28,24 @@ so we will look at it and add it to the manual.
** The default X toolkit is now Gtk+, rather than Lucid.
** configure now checks for libgif (as well as libungif) when
searching for a GIF library.
** configure now checks for libgif before libungif when searching for
a GIF library.
* Changes in Emacs 23.1
** If you set find-file-confirm-nonexistent-file to t, then C-x C-f
requires confirmation before opening a non-existent file.
** If the gpm mouse server is running and t-mouse-mode enabled, Emacs uses a
Unix socket in a GNU/Linux console to talk to server, rather than faking events
using the client program mev. This C level approach provides mouse
highlighting, and help echoing in the minibuffer.
** The new variable next-error-recenter specifies how next-error should
recenter the visited source file. Its value can be a number (for example,
0 for top line, -1 for bottom line), or nil for no recentering.
* Startup Changes in Emacs 23.1
@ -57,6 +64,8 @@ highlighting, and help echoing in the minibuffer.
** bibtex-style-mode helps you write BibTeX's *.bst files.
** vera-mode to edit Vera files.
** socks.el (which had been part of W3) is now part of Emacs.
** minibuffer-indicate-depth-mode shows the minibuffer depth in the prompt.
@ -64,22 +73,96 @@ highlighting, and help echoing in the minibuffer.
* Changes in Specialized Modes and Packages in Emacs 23.1
** compilation-auto-jump-to-first-error tells `compile' to jump to
the first error encountered during compilations.
** In the `copyright' package, you can specify your copyright holders's names.
Only copyright lines with holders matching copyright-names-regexp will be
considered for update.
** VC
*** VC backends can provide completion of revision names.
*** VC has some support for Bazaar (bzr).
** VC has some support for Bazaar (bzr).
*** VC has some support for Mercurial (hg).
** sgml-electric-tag-pair-mode lets you simultaneously edit matched tag pairs.
** BibTeX mode:
*** New `bibtex-entry-format' options `whitespace', `braces', and
`string', disabled by default.
*** New variable `bibtex-cite-matcher-alist' contains rules to
identify cited keys in BibTeX entries, used by `bibtex-find-crossref.
*** Command `bibtex-url' now allows multiple URLs per entry.
+++
** Tramp
*** New connection methods.
The new methods "plinkx", "plink2", "psftp", "sftp" and "fish" have
been introduced. There are also new so-called gateway methods
"tunnel" and "socks".
*** Multihop syntax has been removed.
The pseudo-method "multi" has been removed. Instead of, multi hops
can be specified by the new variable `tramp-default-proxies-alist'.
*** More default settings.
Default values can be set via the variables `tramp-default-user',
`tramp-default-user-alist' and `tramp-default-host'.
*** Connection information is cached.
In order to reduce connection setup, information about used
connections are kept persistent in a file. The name of this file is
defined in the variable `tramp-persistency-file-name'.
*** Control of remote processes.
Running processes on a remote host can be controlled by settings in
`tramp-remote-path' and `tramp-remote-process-environment'.
*** Success of remote copy is checked.
When the variable `file-precious-flag' is set, the success of a remote
file copy is checked via the file's checksum.
** comint-mode uses `start-file-process' now (see Lisp Changes).
If `default-directory' is a remote file name, subprocesses are started
on the corresponding remote system.
* Changes in Emacs 23.1 on non-free operating systems
---
** IPv6 is supported on MS-Windows.
Emacs now supports IPv6 on Windows XP and later, and earlier versions
of Windows with third party IPv6 stacks installed. Previously IPv6 was
supported on other platforms, but not on Windows due to using the winsock
1.1 header file, even though Emacs was linking to the winsock 2 library.
* Incompatible Lisp Changes in Emacs 23.1
+++
** The function `dired-call-process' has been removed.
* Lisp Changes in Emacs 23.1
+++
** In `condition-case', a handler can specify "let the debugger run first".
You do this by writing `debug' in the list of conditions to be handled,
like this:
(condition-case nil
(foo bar)
((debug error) nil))
** The `require-match' argument to `completing-read' accepts a new value
`confirm-only'.
+++
** The regexp form \(?<num>:<regexp>\) specifies the group number explicitly.
@ -91,6 +174,19 @@ Use this instead of "~/.emacs.d".
** The new function `image-refresh' refreshes all images associated
with a given image specification.
+++
** The new function `start-file-process is similar to `start-process',
but obeys file handlers. The file handler is chosen based on
`default-directory'.
+++
** `file-remote-p' has a new optional parameter CONNECTED.
With this paramter passed non-nil, it is checked whether a remote
connection has been established already.
** The two new functions `looking-at-p' and `string-match-p' can do
the same matching as `looking-at' and `string-match' without changing
the match data.
* New Packages for Lisp Programming in Emacs 23.1

19
etc/NEWS.22
View File

@ -46,12 +46,23 @@ before deleting/copying the indicated directory recursively.
than the window, the usual keys for moving the cursor cause the image
to be scrolled horizontally or vertically instead.
** Scrollbars follow the system theme on Windows XP and later.
Windows XP introduced themed scrollbars, but applications have to take
special steps to use them. Emacs now has the appropriate resources linked
in to make it use the scrollbars from the system theme.
* New Modes and Packages in Emacs 22.2
** The new package css-mode.el provides a major mode for editing CSS files.
** The new package vera-mode.el provides a major mode for editing Vera files.
** The new package socks.el implements the SOCKS v5 protocol.
** VC
*** VC has some support for Mercurial (hg).
* Installation Changes in Emacs 22.1
@ -259,6 +270,14 @@ need to quote the space with a C-q. The underlying changes in the
keymaps that are active in the minibuffer are described below under
"New keymaps for typing file names".
If you want the old behavior back, put these two key bindings to your
~/.emacs init file:
(define-key minibuffer-local-filename-completion-map
" " 'minibuffer-complete-word)
(define-key minibuffer-local-must-match-filename-map
" " 'minibuffer-complete-word)
** The completion commands TAB, SPC and ? in the minibuffer apply only
to the text before point. If there is text in the buffer after point,
it remains unchanged.

4
etc/PROBLEMS
View File

@ -1160,6 +1160,10 @@ present or commented out:
Emacs*Foreground
Emacs*Background
It is also reported that a bug in the gtk-engines-qt engine can cause this if
Emacs is compiled with Gtk+.
The bug is fixed in version 0.7 or newer of gtk-engines-qt.
*** KDE: Emacs hangs on KDE when a large portion of text is killed.
This is caused by a bug in the KDE applet `klipper' which periodically

68
etc/orgcard.tex
View File

@ -1,5 +1,5 @@
% Reference Card for Org Mode
\def\orgversionnumber{4.77}
\def\orgversionnumber{5.03}
\def\versionyear{2007} % latest update
\def\year{2007} % latest copyright year
@ -111,14 +111,17 @@
\footline{\hss\folio}
\def\makefootline{\baselineskip10pt\hsize6.5in\line{\the\footline}}
\else %2 or 3 columns uses prereduced size
\hsize 3.2in
\if 1\the\letterpaper
\hsize 3.2in
\vsize 7.95in
\hoffset -.75in
\voffset -.745in
\else
\hsize 3.2in
\vsize 7.65in
\hoffset -.25in
\voffset -.745in
\fi
\hoffset -.75in
\voffset -.745in
\font\titlefont=cmbx10 \scaledmag2
\font\headingfont=cmbx10 \scaledmag1
\font\smallfont=cmr6
@ -418,6 +421,7 @@ \section{Tables}
\key{toggle coordinate grid}{C-c \}}
\key{toggle formula debugger}{C-c \{}
\newcolumn
{\it Formula Editor}
\key{edit formulas in separate buffer}{C-c '}
@ -540,6 +544,24 @@ \section{Tags}
\key{create sparse tree with matching tags}{C-c \\}
\key{globally (agenda) match tags at cursor}{C-c C-o}
\section{Properties and Column View}
\key{special commands in property lines}{C-c C-c}
\key{next/previous allowed value}{S-left/right}
\key{turn on column view}{C-c C-x C-c}
\key{quit column view}{q}
\key{next/previous allowed value}{S-left/right}
\key{next/previous allowed value}{n / p}
\key{edit value}{e}
\key{edit allowed values list}{a}
\key{show value}{v}
\key{make column wider/narrower}{> / <}
\key{move column left/right}{M-left/right}
\key{add new column}{M-S-right}
\key{Delete current column}{M-S-left}
\section{Timestamps}
\key{prompt for date and insert timestamp}{C-c .}
@ -562,6 +584,8 @@ \section{Timestamps}
%\key{... forward/backward one month}{M-S-LEFT/RIGT}
\key{Toggle custom format display for dates/times}{C-c C-x C-t}
\newcolumn
{\bf Clocking time}
\key{start clock on current item}{C-c C-x C-i}
@ -571,12 +595,6 @@ \section{Timestamps}
\key{remove displayed times}{C-c C-c}
\key{insert/update table with clock report}{C-c C-x C-r}
\section{LaTeX and cdlatex-mode}
\key{preview LaTeX fragment}{C-c C-x C-l}
\key{Expand abbreviation (cdlatex-mode)}{TAB}
\key{Insert/modify math symbol (cdlatex-mode)}{` / '}
\section{Agenda Views}
\key{add/move current file to front of agenda}{C-c [}
@ -617,7 +635,7 @@ \section{Agenda Views}
{\bf Change display}
\key{delete other windows}{o}
\key{switch to daily / weekly view}{d / w}
\key{switch to day/week/month/year view}{d w m y}
\key{toggle inclusion of diary entries}{D}
\key{toggle time grid for daily schedule}{g}
\key{toggle display of logbook entries}{l}
@ -644,6 +662,7 @@ \section{Agenda Views}
\key{change timestamp to today}{>}
\key{insert new entry into diary}{i}
\newcolumn
\key{start the clock on current item (clock-in)}{I}
\key{stop the clock (clock-out)}{O}
\key{cancel current clock}{X}
@ -652,7 +671,6 @@ \section{Agenda Views}
\key{Open link in current line}{C-c C-o}
\newcolumn
{\bf Calendar commands}
\key{find agenda cursor date in calendar}{c}
@ -674,6 +692,12 @@ \section{Calendar and Diary Integration}
(setq org-agenda-include-diary t)
\endexample
\section{LaTeX and cdlatex-mode}
\key{preview LaTeX fragment}{C-c C-x C-l}
\key{Expand abbreviation (cdlatex-mode)}{TAB}
\key{Insert/modify math symbol (cdlatex-mode)}{` / '}
\section{Exporting and Publishing}
Exporting creates files with extensions {\it .txt\/} and {\it .html\/}
@ -686,17 +710,17 @@ \section{Exporting and Publishing}
\key{insert template of export options}{C-c C-x t}
\key{toggle fixed width for entry or region}{C-c :}
{\bf HTML formatting}
%{\bf HTML formatting}
\key{make words {\bf bold}}{*bold*}
\key{make words {\it italic}}{/italic/}
\key{make words \underbar{underlined}}{_underlined_}
\key{sub- and superscripts}{x\^{}3, J_dust}
\key{\TeX{}-like macros}{\\alpha, \\to}
\key{typeset lines in fixed width font}{start with :}
\key{tables are exported as HTML tables}{start with |}
\key{links become HTML links}{http:... etc}
\key{include html tags}{@<b>...@</b>}
%\key{make words {\bf bold}}{*bold*}
%\key{make words {\it italic}}{/italic/}
%\key{make words \underbar{underlined}}{_underlined_}
%\key{sub- and superscripts}{x\^{}3, J_dust}
%\key{\TeX{}-like macros}{\\alpha, \\to}
%\key{typeset lines in fixed width font}{start with :}
%\key{tables are exported as HTML tables}{start with |}
%\key{links become HTML links}{http:... etc}
%\key{include html tags}{@<b>...@</b>}
%{\bf Export options}
%

1162
lisp/ChangeLog
View File

File diff suppressed because it is too large Load Diff

4
lisp/ChangeLog.10
View File

@ -1340,7 +1340,7 @@
(shell-directory-tracker): Make regexp used for skipping to next
command correspond to one used for command itself.
2003-06-13 Katsumi Yamaoka <yamaoka@jpl.org> (tiny change)
2003-06-13 Katsumi Yamaoka <yamaoka@jpl.org>
* textmodes/texinfmt.el (texinfo-format-scan):
Silence `whitespace-cleanup'.
@ -11805,7 +11805,7 @@
* vc-hooks.el (vc-kill-buffer-hook): Add it to kill-buffer-hook again.
2002-08-22 Katsumi Yamaoka <yamaoka@jpl.org> (tiny change)
2002-08-22 Katsumi Yamaoka <yamaoka@jpl.org>
* frame.el (select-frame-by-name, select-frame-set-input-focus):
Always call x-focus-frame, if using x.

2
lisp/ChangeLog.11
View File

@ -5295,7 +5295,7 @@
(reb-lisp-syntax-p, reb-change-syntax): `rx' is a Lisp syntax.
(reb-cook-regexp): Call `rx-to-string' when `re-reb-syntax' is `rx'.
2004-08-05 Katsumi Yamaoka <yamaoka@jpl.org> (tiny change)
2004-08-05 Katsumi Yamaoka <yamaoka@jpl.org>
* mail/mail-extr.el (mail-extr-disable-voodoo): New variable.
(mail-extr-voodoo): Check mail-extr-disable-voodoo.

47
lisp/ChangeLog.12
View File

@ -1092,8 +1092,8 @@
North American rule. Replace "daylight savings" with "daylight
saving" in doc.
* calendar/cal-china.el,cal-dst.el,calendar.el,diary-lib.el:
* calendar/lunar.el,solar.el: Replace "daylight savings" with
* calendar/cal-china.el, cal-dst.el, calendar.el, diary-lib.el:
* calendar/lunar.el, solar.el: Replace "daylight savings" with
"daylight saving" in text.
* woman.el (woman-change-fonts): Tweak previous change by using
@ -2595,7 +2595,7 @@
path. Rewrite function in `cond' style for readability.
Suggested by: Stephen Eglen <S.J.Eglen{_AT_}damtp.cam.ac.uk>.
(The path shortening, that is, not the rearrarangement.)
(The path shortening, that is, not the rearrangement.)
2007-01-15 YAMAMOTO Mitsuharu <mituharu@math.s.chiba-u.ac.jp>
@ -6360,7 +6360,7 @@
* help.el (describe-key-briefly): When reading a down-event on
mode lines or scroll bar, swallow the following up event, too.
Use the new mouse sensitity of `key-binding' for lookup.
Use the new mouse sensitivity of `key-binding' for lookup.
(describe-key): The same here.
2006-09-15 Juanma Barranquero <lekktu@gmail.com>
@ -7911,11 +7911,11 @@
* tumme.el (tumme-display-thumbnail-original-image): Make sure
image display buffer is displayed before call to
`tumme-display-image.
`tumme-display-image'.
(tumme-dired-display-image): Make sure image display buffer is
displayed before call to `tumme-display-image.
displayed before call to `tumme-display-image'.
(tumme-mouse-display-image): Make sure image display buffer is
displayed before call to `tumme-display-image.
displayed before call to `tumme-display-image'.
(tumme-widget-list): Add.
(tumme-dired-edit-comment-and-tags): Add.
(tumme-save-information-from-widgets): Add.
@ -8042,7 +8042,7 @@
instead of retired `allout-resumptions'. For hook functions, use
`local' parameter so hook settings are created and removed as
buffer-local settings. Revise (resumptions) setting
auto-fill-function so it is set only if already active. (The
auto-fill-function so it is set only if already active. The
related fill-function settings are all made in either case, so
that activating auto-fill-mode activity will have the custom
allout-mode behaviors (hanging indent on topics, if configured for it).
@ -8709,7 +8709,7 @@
* term.el (term-handle-scroll, term-delete-lines)
(term-insert-lines): Fix off by one errors.
2006-06-15 Katsumi Yamaoka <yamaoka@jpl.org> (tiny change)
2006-06-15 Katsumi Yamaoka <yamaoka@jpl.org>
* net/tramp.el (tramp-touch): Use UTC to express time.
@ -9788,7 +9788,7 @@
* calendar/cal-menu.el (calendar-mode-map, calendar-mouse-3-map):
* calendar/calendar.el (calendar-mode-map):
* calendar/diary-lib.el (include-other-diary-files,diary-mail-entries):
* calendar/diary-lib.el (include-other-diary-files, diary-mail-entries):
* calendar/appt.el (appt-check, appt-make-list): Refer to
diary-view-entries, diary-list-entries, diary-show-all-entries
rather than obsolete aliases.
@ -9998,7 +9998,7 @@
2006-05-09 Masatake YAMATO <jet@gyve.org>
* font-lock.el (cpp-font-lock-keywords-source-directives): Addded
* font-lock.el (cpp-font-lock-keywords-source-directives): Added
"warning" and "import".
(cpp-font-lock-keywords): Added "warning".
@ -10865,7 +10865,7 @@
(org-table-create-or-convert-from-region): New commands
(org-table-toggle-vline-visibility): Command removed.
(org-table-convert-region): Made a command.
(orgtbl-deleta-backward-char,orgtbl-delete-char): Remove commands.
(orgtbl-deleta-backward-char, orgtbl-delete-char): Remove commands.
Replace with the normal org- functions.
(org-self-insert-command): Don't trigger realign unnecessarily
when blanking a field that is not full.
@ -11275,7 +11275,7 @@
(ibuffer-mode-header-map): New keymaps.
(ibuffer-update-title-and-summary): Enable mouse face highlighting
and keybindings for column headers.
(name,size,mode) <define-ibuffer-column>: Add a header-mouse-map
(name, size, mode) <define-ibuffer-column>: Add a header-mouse-map
property.
2006-04-02 Drew Adams <drew.adams@oracle.com> (tiny change)
@ -20649,7 +20649,7 @@
(ibuffer-do-print, ibuffer-filter-by-mode, ibuffer-filter-by-used-mode)
(ibuffer-filter-by-name, ibuffer-filter-by-filename)
(ibuffer-filter-by-size-gt, ibuffer-filter-by-size-lt)
(ibuffer-filter-by-content, ibuffer-filter-by-predicate
(ibuffer-filter-by-content, ibuffer-filter-by-predicate)
(ibuffer-do-sort-by-major-mode, ibuffer-do-sort-by-mode-name)
(ibuffer-do-sort-by-alphabetic, ibuffer-do-sort-by-size):
Autoload file sans suffix.
@ -20758,7 +20758,7 @@
(gdb-info-frames-custom): Put `font-lock-function-name-face'
and `font-lock-variable-name-face'
(gdb-registers-font-lock-keywords): New font lock keywords definition.
(gdb-registers-mode): Use `gdb-registers-font-lock-keywords`.
(gdb-registers-mode): Use `gdb-registers-font-lock-keywords'.
(gdb-memory-font-lock-keywords): New font lock keywords definition.
(gdb-memory-mode): Use `gdb-memory-font-lock-keywords'.
(gdb-local-font-lock-keywords): New font lock keywords definition.
@ -22168,7 +22168,7 @@
2005-08-30 Richard M. Stallman <rms@gnu.org>
* files.el (risky-local-variable-p):
Match `-predicates' and `-commands.
Match `-predicates' and `-commands'.
* cus-edit.el (custom-buffer-sort-alphabetically): Default to t.
(custom-save-all): Visit the file if necessary;
@ -22969,7 +22969,7 @@
* menu-bar.el (menu-bar-showhide-menu): Add `showhide-battery'.
2005-08-09 Katsumi Yamaoka <yamaoka@jpl.org> (tiny change)
2005-08-09 Katsumi Yamaoka <yamaoka@jpl.org>
* net/ange-ftp.el (ange-ftp-send-cmd): Make it work properly with
uploading files.
@ -23161,7 +23161,7 @@
(tramp-handle-set-visited-file-modtime)
(tramp-handle-insert-file-contents)
(tramp-handle-write-region): No special handling for
`last-coding-system-used, because this is done in
`last-coding-system-used', because this is done in
`tramp-accept-process-output' now.
(tramp-accept-process-output): New defun.
(tramp-process-one-action, tramp-process-one-multi-action)
@ -23199,7 +23199,7 @@
* net/tramp-smb.el: Remove defvar of `last-coding-system-used' in the
XEmacs case; not necessary anymore.
(tramp-smb-handle-write-region): No special handling for
`last-coding-system-used, because this is done in
`last-coding-system-used', because this is done in
`tramp-accept-process-output' now.
(tramp-smb-wait-for-output): Call `tramp-accept-process-output'.
@ -24623,7 +24623,7 @@
(tree-widget-theme, tree-widget-image-properties-emacs)
(tree-widget-image-properties-xemacs, tree-widget-create-image)
(tree-widget-image-formats, tree-widget-control)
(tree-widget-empty-control, tree-widget-leaf-control
(tree-widget-empty-control, tree-widget-leaf-control)
(tree-widget-guide, tree-widget-end-guide, tree-widget-no-guide)
(tree-widget-handle, tree-widget-no-handle, tree-widget-p)
(tree-widget-keep, tree-widget-after-toggle-functions)
@ -25831,8 +25831,7 @@
(ebrowse-draw-member-buffer-class-line, ebrowse-draw-member-long-fn)
(ebrowse-draw-member-short-fn): Use renamed ebrowse faces.
* progmodes/antlr-mode.el (antlr-default, antlr-keyword,
antlr-syntax)
* progmodes/antlr-mode.el (antlr-default, antlr-keyword, antlr-syntax)
(antlr-ruledef, antlr-tokendef, antlr-ruleref, antlr-tokenref)
(antlr-literal): Remove "-face" suffix and "font-lock-" from face
names.
@ -27770,7 +27769,7 @@
* progmodes/make-mode.el (makefile-add-this-line-targets):
Simplify and integrate into `makefile-pickup-targets'.
(makefile-add-this-line-macro): Simplify and integrate into
`makefile-pickup-macros.
`makefile-pickup-macros'.
(makefile-pickup-filenames-as-targets): Simplify.
(makefile-previous-dependency, makefile-match-dependency):
Don't stumble over `::'.
@ -32755,7 +32754,7 @@
Adrian Aichner <adrian@xemacs.org>.
* net/tramp-smb.el (tramp-smb-file-name-handler-alist): Add entry for
`substitute-in-file-name.
`substitute-in-file-name'.
(tramp-smb-handle-substitute-in-file-name): New defun.
(tramp-smb-advice-PC-do-completion): Delete advice.

8
lisp/Makefile.in
View File

@ -239,7 +239,7 @@ MH_E_SRC = $(lisp)/mh-e/mh-acros.el $(lisp)/mh-e/mh-alias.el \
$(lisp)/mh-e/mh-xface.el
mh-autoloads: $(lisp)/mh-e/mh-loaddefs.el
$(lisp)/mh-e/mh-loaddefs.el: $(MH_E_SRC)
$(lisp)/mh-e/mh-loaddefs.el: $(lisp)/subdirs.el $(MH_E_SRC)
echo ";;; mh-loaddefs.el --- automatically extracted autoloads" > $@
echo "" >> $@
echo ";; Copyright (C) 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc." >> $@
@ -275,6 +275,9 @@ $(lisp)/mh-e/mh-loaddefs.el: $(MH_E_SRC)
# an up-to-date copy of loaddefs.el that is uncorrupted by
# local changes. (Because loaddefs.el is an automatically generated
# file, we don't want to store it in the source repository).
#
# The chmod +w is to handle env var CVSREAD=1. Files named
# are identified by being the value of `generated-autoload-file'.
bootstrap-prepare:
if test -x $(EMACS); then \
@ -282,6 +285,9 @@ bootstrap-prepare:
else \
cp $(lisp)/ldefs-boot.el $(lisp)/loaddefs.el; \
fi
chmod +w $(lisp)/loaddefs.el \
$(lisp)/ps-print.el \
$(lisp)/emacs-lisp/cl-loaddefs.el
maintainer-clean: distclean
cd $(lisp); rm -f *.elc */*.elc $(AUTOGENEL)

3
lisp/add-log.el
View File

@ -695,7 +695,8 @@ Runs `change-log-mode-hook'.
(setq left-margin 8
fill-column 74
indent-tabs-mode t
tab-width 8)
tab-width 8
show-trailing-whitespace t)
(set (make-local-variable 'fill-paragraph-function)
'change-log-fill-paragraph)
(set (make-local-variable 'indent-line-function) 'change-log-indent)

2
lisp/autoinsert.el
View File

@ -188,7 +188,7 @@ If this contains a %s, that will be replaced by the matching rule."
\;; This file is free software; you can redistribute it and/or modify
\;; it under the terms of the GNU General Public License as published by
\;; the Free Software Foundation; either version 2, or (at your option)
\;; the Free Software Foundation; either version 3, or (at your option)
\;; any later version.
\;; This file is distributed in the hope that it will be useful,

11
lisp/autorevert.el
View File

@ -447,20 +447,21 @@ This is an internal function used by Auto-Revert Mode."
(defun auto-revert-tail-handler ()
(let ((size (nth 7 (file-attributes buffer-file-name)))
(modified (buffer-modified-p))
buffer-read-only ; ignore
(inhibit-read-only t) ; Ignore.
(file buffer-file-name)
buffer-file-name) ; ignore that file has changed
(buffer-file-name nil)) ; Ignore that file has changed.
(when (> size auto-revert-tail-pos)
(run-hooks 'before-revert-hook)
(undo-boundary)
(save-restriction
(widen)
(save-excursion
(goto-char (point-max))
(insert-file-contents file nil auto-revert-tail-pos size)))
(run-mode-hooks 'after-revert-hook)
(run-hooks 'after-revert-hook)
(undo-boundary)
(setq auto-revert-tail-pos size)
(set-buffer-modified-p modified)))
(restore-buffer-modified-p modified)))
(set-visited-file-modtime))
(defun auto-revert-buffers ()
@ -534,5 +535,5 @@ the timer when no buffers need to be checked."
(run-hooks 'auto-revert-load-hook)
;;; arch-tag: f6bcb07b-4841-477e-9e44-b18678e58876
;; arch-tag: f6bcb07b-4841-477e-9e44-b18678e58876
;;; autorevert.el ends here

28
lisp/bookmark.el
View File

@ -240,12 +240,13 @@ functions have a binding in this keymap.")
;; Read the help on all of these functions for details...
;;;###autoload (define-key bookmark-map "x" 'bookmark-set)
;;;###autoload (define-key bookmark-map "m" 'bookmark-set) ; "m" for "mark"
;;;###autoload (define-key bookmark-map "m" 'bookmark-set) ;"m"ark
;;;###autoload (define-key bookmark-map "j" 'bookmark-jump)
;;;###autoload (define-key bookmark-map "g" 'bookmark-jump) ; "g" for "go"
;;;###autoload (define-key bookmark-map "g" 'bookmark-jump) ;"g"o
;;;###autoload (define-key bookmark-map "o" 'bookmark-jump-other-window)
;;;###autoload (define-key bookmark-map "i" 'bookmark-insert)
;;;###autoload (define-key bookmark-map "e" 'edit-bookmarks)
;;;###autoload (define-key bookmark-map "f" 'bookmark-insert-location) ; "f" for "find"
;;;###autoload (define-key bookmark-map "f" 'bookmark-insert-location) ;"f"ind
;;;###autoload (define-key bookmark-map "r" 'bookmark-rename)
;;;###autoload (define-key bookmark-map "d" 'bookmark-delete)
;;;###autoload (define-key bookmark-map "l" 'bookmark-load)
@ -1083,6 +1084,27 @@ of the old one in the permanent bookmark record."
(bookmark-show-annotation bookmark)))))
;;;###autoload
(defun bookmark-jump-other-window (bookmark)
"Jump to BOOKMARK (a point in some file) in another window.
See `bookmark-jump'."
(interactive
(let ((bkm (bookmark-completing-read "Jump to bookmark (in another window)"
bookmark-current-bookmark)))
(if (> emacs-major-version 21)
(list bkm) bkm)))
(when bookmark
(bookmark-maybe-historicize-string bookmark)
(let ((cell (bookmark-jump-noselect bookmark)))
(and cell
(switch-to-buffer-other-window (car cell))
(goto-char (cdr cell))
(if bookmark-automatically-show-annotations
;; if there is an annotation for this bookmark,
;; show it in a buffer.
(bookmark-show-annotation bookmark))))))
(defun bookmark-file-or-variation-thereof (file)
"Return FILE (a string) if it exists, or return a reasonable
variation of FILE if that exists. Reasonable variations are checked

12
lisp/calc/calc-aent.el
View File

@ -100,7 +100,7 @@
(cond
((and (consp str) (not (symbolp (car str))))
(let ((calc-language nil)
(math-expr-opers math-standard-opers)
(math-expr-opers (math-standard-ops))
(calc-internal-prec 12)
(calc-word-size 32)
(calc-symbolic-mode nil)
@ -254,7 +254,7 @@ The value t means abort and give an error message.")
(interactive "P")
(calc-wrapper
(let ((calc-language (if prefix nil calc-language))
(math-expr-opers (if prefix math-standard-opers math-expr-opers)))
(math-expr-opers (if prefix (math-standard-ops) (math-expr-ops))))
(calc-alg-entry (and auto (char-to-string last-command-char))))))
(defvar calc-alg-entry-history nil
@ -876,7 +876,10 @@ in Calc algebraic input.")
calcFunc-eq calcFunc-neq))
(defun math-read-expr-level (exp-prec &optional exp-term)
(let* ((x (math-read-factor)) (first t) op op2)
(let* ((math-expr-opers (math-expr-ops))
(x (math-read-factor))
(first t)
op op2)
(while (and (or (and calc-user-parse-table
(setq op (calc-check-user-syntax x exp-prec))
(setq x op
@ -1121,7 +1124,8 @@ in Calc algebraic input.")
(assoc math-expr-data '(("(") ("[") ("{"))))))
(defun math-read-factor ()
(let (op)
(let ((math-expr-opers (math-expr-ops))
op)
(cond ((eq math-exp-token 'number)
(let ((num (math-read-number math-expr-data)))
(if (not num)

58
lisp/calc/calc-bin.el
View File

@ -32,6 +32,17 @@
(require 'calc-ext)
(require 'calc-macs)
;;; Some useful numbers
(defconst math-bignum-logb-digit-size
(eval-when-compile (logb math-bignum-digit-size))
"The logb of the size of a bignum digit.
This is the largest value of B such that 2^B is less than
the size of a Calc bignum digit.")
(defconst math-bignum-digit-power-of-two
(eval-when-compile (expt 2 (logb math-bignum-digit-size)))
"The largest power of 2 less than the size of a Calc bignum digit.")
;;; b-prefix binary commands.
(defun calc-and (n)
@ -297,11 +308,11 @@
(defun math-and-bignum (a b) ; [l l l]
(and a b
(let ((qa (math-div-bignum-digit a 512))
(qb (math-div-bignum-digit b 512)))
(let ((qa (math-div-bignum-digit a math-bignum-digit-power-of-two))
(qb (math-div-bignum-digit b math-bignum-digit-power-of-two)))
(math-mul-bignum-digit (math-and-bignum (math-norm-bignum (car qa))
(math-norm-bignum (car qb)))
512
math-bignum-digit-power-of-two
(logand (cdr qa) (cdr qb))))))
(defun calcFunc-or (a b &optional w) ; [I I I] [Public]
@ -324,11 +335,11 @@
(defun math-or-bignum (a b) ; [l l l]
(and (or a b)
(let ((qa (math-div-bignum-digit a 512))
(qb (math-div-bignum-digit b 512)))
(let ((qa (math-div-bignum-digit a math-bignum-digit-power-of-two))
(qb (math-div-bignum-digit b math-bignum-digit-power-of-two)))
(math-mul-bignum-digit (math-or-bignum (math-norm-bignum (car qa))
(math-norm-bignum (car qb)))
512
math-bignum-digit-power-of-two
(logior (cdr qa) (cdr qb))))))
(defun calcFunc-xor (a b &optional w) ; [I I I] [Public]
@ -351,11 +362,11 @@
(defun math-xor-bignum (a b) ; [l l l]
(and (or a b)
(let ((qa (math-div-bignum-digit a 512))
(qb (math-div-bignum-digit b 512)))
(let ((qa (math-div-bignum-digit a math-bignum-digit-power-of-two))
(qb (math-div-bignum-digit b math-bignum-digit-power-of-two)))
(math-mul-bignum-digit (math-xor-bignum (math-norm-bignum (car qa))
(math-norm-bignum (car qb)))
512
math-bignum-digit-power-of-two
(logxor (cdr qa) (cdr qb))))))
(defun calcFunc-diff (a b &optional w) ; [I I I] [Public]
@ -378,11 +389,11 @@
(defun math-diff-bignum (a b) ; [l l l]
(and a
(let ((qa (math-div-bignum-digit a 512))
(qb (math-div-bignum-digit b 512)))
(let ((qa (math-div-bignum-digit a math-bignum-digit-power-of-two))
(qb (math-div-bignum-digit b math-bignum-digit-power-of-two)))
(math-mul-bignum-digit (math-diff-bignum (math-norm-bignum (car qa))
(math-norm-bignum (car qb)))
512
math-bignum-digit-power-of-two
(logand (cdr qa) (lognot (cdr qb)))))))
(defun calcFunc-not (a &optional w) ; [I I] [Public]
@ -402,14 +413,15 @@
w))))))
(defun math-not-bignum (a w) ; [l l]
(let ((q (math-div-bignum-digit a 512)))
(if (<= w 9)
(let ((q (math-div-bignum-digit a math-bignum-digit-power-of-two)))
(if (<= w math-bignum-logb-digit-size)
(list (logand (lognot (cdr q))
(1- (lsh 1 w))))
(math-mul-bignum-digit (math-not-bignum (math-norm-bignum (car q))
(- w 9))
512
(logxor (cdr q) 511)))))
(- w math-bignum-logb-digit-size))
math-bignum-digit-power-of-two
(logxor (cdr q)
(1- math-bignum-digit-power-of-two))))))
(defun calcFunc-lsh (a &optional n w) ; [I I] [Public]
(setq a (math-trunc a)
@ -510,8 +522,8 @@
(math-sub a (math-power-of-2 (- w)))))
((Math-negp a)
(math-normalize (cons 'bigpos (math-binary-arg a w))))
((and (integerp a) (< a 1000000))
(if (>= w 20)
((and (integerp a) (< a math-small-integer-size))
(if (> w (logb math-small-integer-size))
a
(logand a (1- (lsh 1 w)))))
(t
@ -523,13 +535,13 @@
(defalias 'calcFunc-clip 'math-clip)
(defun math-clip-bignum (a w) ; [l l]
(let ((q (math-div-bignum-digit a 512)))
(if (<= w 9)
(let ((q (math-div-bignum-digit a math-bignum-digit-power-of-two)))
(if (<= w math-bignum-logb-digit-size)
(list (logand (cdr q)
(1- (lsh 1 w))))
(math-mul-bignum-digit (math-clip-bignum (math-norm-bignum (car q))
(- w 9))
512
(- w math-bignum-logb-digit-size))
math-bignum-digit-power-of-two
(cdr q)))))
(defvar math-max-digits-cache nil)

75
lisp/calc/calc-comb.el
View File

@ -294,6 +294,19 @@
;;; Factorial and related functions.
(defconst math-small-factorial-table
(eval-when-compile
(vector 1 1 2 6 24 120 720 5040 40320 362880 3628800 39916800
(math-read-number-simple "479001600")
(math-read-number-simple "6227020800")
(math-read-number-simple "87178291200")
(math-read-number-simple "1307674368000")
(math-read-number-simple "20922789888000")
(math-read-number-simple "355687428096000")
(math-read-number-simple "6402373705728000")
(math-read-number-simple "121645100408832000")
(math-read-number-simple "2432902008176640000"))))
(defun calcFunc-fact (n) ; [I I] [F F] [Public]
(let (temp)
(cond ((Math-integer-negp n)
@ -302,14 +315,7 @@
(math-reject-arg n 'range)))
((integerp n)
(if (<= n 20)
(aref '[1 1 2 6 24 120 720 5040 40320 362880
(bigpos 800 628 3) (bigpos 800 916 39)
(bigpos 600 1 479) (bigpos 800 20 227 6)
(bigpos 200 291 178 87) (bigpos 0 368 674 307 1)
(bigpos 0 888 789 922 20) (bigpos 0 96 428 687 355)
(bigpos 0 728 705 373 402 6)
(bigpos 0 832 408 100 645 121)
(bigpos 0 640 176 8 902 432 2)] n)
(aref math-small-factorial-table n)
(math-factorial-iter (1- n) 2 1)))
((and (math-messy-integerp n)
(Math-lessp n 100))
@ -551,9 +557,9 @@
nil
(if (Math-integerp var-RandSeed)
(let* ((seed (math-sub 161803 var-RandSeed))
(mj (1+ (math-mod seed '(bigpos 0 0 1))))
(mk (1+ (math-mod (math-quotient seed '(bigpos 0 0 1))
'(bigpos 0 0 1))))
(mj (1+ (math-mod seed 1000000)))
(mk (1+ (math-mod (math-quotient seed 1000000)
1000000)))
(i 0))
(setq math-random-table (cons 'vec (make-list 55 mj)))
(while (<= (setq i (1+ i)) 54)
@ -601,7 +607,8 @@
;;; Avoid various pitfalls that may lurk in the built-in (random) function!
;;; Shuffling algorithm from Numerical Recipes, section 7.1.
(defvar math-random-last)
(defun math-random-digit ()
(defun math-random-three-digit-number ()
"Return a random three digit number."
(let (i)
(or (and (boundp 'var-RandSeed) (eq var-RandSeed math-last-RandSeed))
(math-init-random-base))
@ -621,17 +628,17 @@
;;; Produce an N-digit random integer.
(defun math-random-digits (n)
(cond ((<= n 6)
(math-scale-right (+ (* (math-random-digit) 1000) (math-random-digit))
(- 6 n)))
(t (let* ((slop (% (- 900003 n) 3))
(i (/ (+ n slop) 3))
(digs nil))
(while (> i 0)
(setq digs (cons (math-random-digit) digs)
i (1- i)))
(math-normalize (math-scale-right (cons 'bigpos digs)
slop))))))
"Produce a random N digit integer."
(let* ((slop (% (- 3 (% n 3)) 3))
(i (/ (+ n slop) 3))
(rnum 0))
(while (> i 0)
(setq rnum
(math-add
(math-random-three-digit-number)
(math-mul rnum 1000)))
(setq i (1- i)))
(math-normalize (math-scale-right rnum slop))))
;;; Produce a uniformly-distributed random float 0 <= N < 1.
(defun math-random-float ()
@ -802,7 +809,7 @@
(error "Argument must be an integer"))
((Math-integer-negp n)
'(nil))
((Math-natnum-lessp n '(bigpos 0 0 8))
((Math-natnum-lessp n 8000000)
(setq n (math-fixnum n))
(let ((i -1) v)
(while (and (> (% n (setq v (aref math-primes-table
@ -815,15 +822,17 @@
((not (equal n (car math-prime-test-cache)))
(cond ((= (% (nth 1 n) 2) 0) '(nil 2))
((= (% (nth 1 n) 5) 0) '(nil 5))
(t (let ((dig (cdr n)) (sum 0))
(while dig
(if (cdr dig)
(setq sum (% (+ (+ sum (car dig))
(* (nth 1 dig) 1000))
111111)
dig (cdr (cdr dig)))
(setq sum (% (+ sum (car dig)) 111111)
dig nil)))
(t (let ((q n) (sum 0))
(while (not (eq q 0))
(setq sum (%
(+
sum
(calcFunc-mod
q 1000000))
111111))
(setq q
(math-quotient
q 1000000)))
(cond ((= (% sum 3) 0) '(nil 3))
((= (% sum 7) 0) '(nil 7))
((= (% sum 11) 0) '(nil 11))

2
lisp/calc/calc-embed.el
View File

@ -403,7 +403,7 @@
(let ((val (save-excursion
(set-buffer (aref info 1))
(let ((calc-language nil)
(math-expr-opers math-standard-opers))
(math-expr-opers (math-standard-ops)))
(math-read-expr str)))))
(if (eq (car-safe val) 'error)
(progn

46
lisp/calc/calc-ext.el
View File

@ -1878,8 +1878,19 @@ calc-kill calc-kill-region calc-yank))))
(last-prec (intern (concat (symbol-name name) "-last-prec")))
(last-val (intern (concat (symbol-name name) "-last"))))
(list 'progn
(list 'defvar cache-prec (if init (math-numdigs (nth 1 init)) -100))
(list 'defvar cache-val (list 'quote init))
; (list 'defvar cache-prec (if init (math-numdigs (nth 1 init)) -100))
(list 'defvar cache-prec
`(cond
((consp ,init) (math-numdigs (nth 1 ,init)))
(,init
(nth 1 (math-numdigs (eval ,init))))
(t
-100)))
(list 'defvar cache-val
`(cond
((consp ,init) ,init)
(,init (eval ,init))
(t ,init)))
(list 'defvar last-prec -100)
(list 'defvar last-val nil)
(list 'setq 'math-cache-list
@ -1914,7 +1925,12 @@ calc-kill calc-kill-region calc-yank))))
(put 'math-defcache 'lisp-indent-hook 2)
;;; Betcha didn't know that pi = 16 atan(1/5) - 4 atan(1/239). [F] [Public]
(math-defcache math-pi (float (bigpos 463 238 793 589 653 592 141 3) -21)
(defconst math-approx-pi
(eval-when-compile
(math-read-number-simple "3.141592653589793238463"))
"An approximation for pi.")
(math-defcache math-pi math-approx-pi
(math-add-float (math-mul-float '(float 16 0)
(math-arctan-raw '(float 2 -1)))
(math-mul-float '(float -4 0)
@ -1945,7 +1961,11 @@ calc-kill calc-kill-region calc-yank))))
(math-defcache math-sqrt-two-pi nil
(math-sqrt-float (math-two-pi)))
(math-defcache math-sqrt-e (float (bigpos 849 146 128 700 270 721 648 1) -21)
(defconst math-approx-sqrt-e
(eval-when-compile (math-read-number-simple "1.648721270700128146849"))
"An approximation for sqrt(3).")
(math-defcache math-sqrt-e math-approx-sqrt-e
(math-add-float '(float 1 0) (math-exp-minus-1-raw '(float 5 -1))))
(math-defcache math-e nil
@ -1955,10 +1975,14 @@ calc-kill calc-kill-region calc-yank))))
(math-mul-float (math-add-float (math-sqrt-raw '(float 5 0)) '(float 1 0))
'(float 5 -1)))
(math-defcache math-gamma-const nil
'(float (bigpos 495 467 917 632 470 369 709 646 776 267 677 848 348 672
057 988 235 399 359 593 421 310 024 824 900 120 065 606
328 015 649 156 772 5) -100))
(defconst math-approx-gamma-const
(eval-when-compile
(math-read-number-simple
"0.5772156649015328606065120900824024310421593359399235988057672348848677267776646709369470632917467495"))
"An approximation for gamma.")
(math-defcache math-gamma-const nil
math-approx-gamma-const)
(defun math-half-circle (symb)
(if (eq calc-angle-mode 'rad)
@ -2202,7 +2226,7 @@ calc-kill calc-kill-region calc-yank))))
(defun math-fixnum-big (a)
(if (cdr a)
(+ (car a) (* (math-fixnum-big (cdr a)) 1000))
(+ (car a) (* (math-fixnum-big (cdr a)) math-bignum-digit-size))
(car a)))
(defvar math-simplify-only nil)
@ -2960,7 +2984,7 @@ calc-kill calc-kill-region calc-yank))))
(defun math-read-plain-expr (exp-str &optional error-check)
(let* ((calc-language nil)
(math-expr-opers math-standard-opers)
(math-expr-opers (math-standard-ops))
(val (math-read-expr exp-str)))
(and error-check
(eq (car-safe val) 'error)
@ -3116,7 +3140,7 @@ calc-kill calc-kill-region calc-yank))))
(concat (substring (symbol-name (car a)) 9)
"(" (math-vector-to-string (nth 1 a) t) ")"))
(t
(let ((op (math-assq2 (car a) math-standard-opers)))
(let ((op (math-assq2 (car a) (math-standard-ops))))
(cond ((and op (= (length a) 3))
(if (> prec (min (nth 2 op) (nth 3 op)))
(concat "(" (math-format-flat-expr a 0) ")")

28
lisp/calc/calc-forms.el
View File

@ -544,6 +544,14 @@
(setcdr math-fd-dt nil))
fmt))))
(defconst math-julian-date-beginning '(float 17214235 -1)
"The beginning of the Julian calendar,
as measured in the number of days before January 1 of the year 1AD.")
(defconst math-julian-date-beginning-int 1721424
"The beginning of the Julian calendar,
as measured in the integer number of days before January 1 of the year 1AD.")
(defun math-format-date-part (x)
(cond ((stringp x)
x)
@ -558,9 +566,12 @@
((eq x 'n)
(math-format-number (math-floor math-fd-date)))
((eq x 'J)
(math-format-number (math-add math-fd-date '(float (bigpos 235 214 17) -1))))
(math-format-number
(math-add math-fd-date math-julian-date-beginning)))
((eq x 'j)
(math-format-number (math-add (math-floor math-fd-date) '(bigpos 424 721 1))))
(math-format-number (math-add
(math-floor math-fd-date)
math-julian-date-beginning-int)))
((eq x 'U)
(math-format-number (nth 1 (math-date-parts math-fd-date 719164))))
((progn
@ -935,9 +946,8 @@
0
(if (or (eq this 'j)
(math-integerp num))
'(bigpos 424 721 1)
'(float (bigpos 235 214 17)
-1))))
math-julian-date-beginning-int
math-julian-date-beginning)))
hour (or (nth 3 num) hour)
minute (or (nth 4 num) minute)
second (or (nth 5 num) second)
@ -1146,14 +1156,14 @@
(defun calcFunc-julian (date &optional zone)
(if (math-realp date)
(list 'date (if (math-integerp date)
(math-sub date '(bigpos 424 721 1))
(setq date (math-sub date '(float (bigpos 235 214 17) -1)))
(math-sub date math-julian-date-beginning-int)
(setq date (math-sub date math-julian-date-beginning))
(math-sub date (math-div (calcFunc-tzone zone date)
'(float 864 2)))))
(if (eq (car date) 'date)
(math-add (nth 1 date) (if (math-integerp (nth 1 date))
'(bigpos 424 721 1)
(math-add '(float (bigpos 235 214 17) -1)
math-julian-date-beginning-int
(math-add math-julian-date-beginning
(math-div (calcFunc-tzone zone date)
'(float 864 2)))))
(math-reject-arg date 'datep))))

233
lisp/calc/calc-funcs.el
View File

@ -147,7 +147,8 @@
(or (math-numberp x) (math-reject-arg x 'numberp))
(calcFunc-fact (math-add x -1)))
(defun math-gammap1-raw (x &optional fprec nfprec) ; compute gamma(1 + x)
(defun math-gammap1-raw (x &optional fprec nfprec)
"Compute gamma(1+X) to the appropriate precision."
(or fprec
(setq fprec (math-float calc-internal-prec)
nfprec (math-float (- calc-internal-prec))))
@ -567,42 +568,54 @@
((Math-lessp '(float 8 0) (math-abs-approx x))
(let* ((z (math-div '(float 8 0) x))
(y (math-sqr z))
(xx (math-add x '(float (bigneg 164 398 785) -9)))
(xx (math-add x
(eval-when-compile
(math-read-number-simple "-0.785398164"))))
(a1 (math-poly-eval y
'((float (bigpos 211 887 093 2) -16)
(float (bigneg 639 370 073 2) -15)
(float (bigpos 407 510 734 2) -14)
(float (bigneg 627 628 098 1) -12)
(float 1 0))))
(eval-when-compile
(list
(math-read-number-simple "0.0000002093887211")
(math-read-number-simple "-0.000002073370639")
(math-read-number-simple "0.00002734510407")
(math-read-number-simple "-0.001098628627")
'(float 1 0)))))
(a2 (math-poly-eval y
'((float (bigneg 152 935 934) -16)
(float (bigpos 161 095 621 7) -16)
(float (bigneg 651 147 911 6) -15)
(float (bigpos 765 488 430 1) -13)
(float (bigneg 995 499 562 1) -11))))
(eval-when-compile
(list
(math-read-number-simple "-0.0000000934935152")
(math-read-number-simple "0.0000007621095161")
(math-read-number-simple "-0.000006911147651")
(math-read-number-simple "0.0001430488765")
(math-read-number-simple "-0.01562499995")))))
(sc (math-sin-cos-raw xx)))
(if yflag
(setq sc (cons (math-neg (cdr sc)) (car sc))))
(math-mul (math-sqrt
(math-div '(float (bigpos 722 619 636) -9) x))
(math-div (eval-when-compile
(math-read-number-simple "0.636619722"))
x))
(math-sub (math-mul (cdr sc) a1)
(math-mul (car sc) (math-mul z a2))))))
(t
(let ((y (math-sqr x)))
(math-div (math-poly-eval y
'((float (bigneg 456 052 849 1) -7)
(float (bigpos 017 233 739 7) -5)
(float (bigneg 418 442 121 1) -2)
(float (bigpos 407 196 516 6) -1)
(float (bigneg 354 590 362 13) 0)
(float (bigpos 574 490 568 57) 0)))
(eval-when-compile
(list
(math-read-number-simple "-184.9052456")
(math-read-number-simple "77392.33017")
(math-read-number-simple "-11214424.18")
(math-read-number-simple "651619640.7")
(math-read-number-simple "-13362590354.0")
(math-read-number-simple "57568490574.0"))))
(math-poly-eval y
'((float 1 0)
(float (bigpos 712 532 678 2) -7)
(float (bigpos 853 264 927 5) -5)
(float (bigpos 718 680 494 9) -3)
(float (bigpos 985 532 029 1) 0)
(float (bigpos 411 490 568 57) 0))))))))
(eval-when-compile
(list
'(float 1 0)
(math-read-number-simple "267.8532712")
(math-read-number-simple "59272.64853")
(math-read-number-simple "9494680.718")
(math-read-number-simple "1029532985.0")
(math-read-number-simple "57568490411.0")))))))))
(defun math-besJ1 (x &optional yflag)
(cond ((and (math-negp (calcFunc-re x)) (not yflag))
@ -610,25 +623,33 @@
((Math-lessp '(float 8 0) (math-abs-approx x))
(let* ((z (math-div '(float 8 0) x))
(y (math-sqr z))
(xx (math-add x '(float (bigneg 491 194 356 2) -9)))
(xx (math-add x (eval-when-compile
(math-read-number-simple "-2.356194491"))))
(a1 (math-poly-eval y
'((float (bigneg 019 337 240) -15)
(float (bigpos 174 520 457 2) -15)
(float (bigneg 496 396 516 3) -14)
(float 183105 -8)
(float 1 0))))
(eval-when-compile
(list
(math-read-number-simple "-0.000000240337019")
(math-read-number-simple "0.000002457520174")
(math-read-number-simple "-0.00003516396496")
'(float 183105 -8)
'(float 1 0)))))
(a2 (math-poly-eval y
'((float (bigpos 412 787 105) -15)
(float (bigneg 987 228 88) -14)
(float (bigpos 096 199 449 8) -15)
(float (bigneg 873 690 002 2) -13)
(float (bigpos 995 499 687 4) -11))))
(eval-when-compile
(list
(math-read-number-simple "0.000000105787412")
(math-read-number-simple "-0.00000088228987")
(math-read-number-simple "0.000008449199096")
(math-read-number-simple "-0.0002002690873")
(math-read-number-simple "0.04687499995")))))
(sc (math-sin-cos-raw xx)))
(if yflag
(setq sc (cons (math-neg (cdr sc)) (car sc)))
(if (math-negp x)
(setq sc (cons (math-neg (car sc)) (math-neg (cdr sc))))))
(math-mul (math-sqrt (math-div '(float (bigpos 722 619 636) -9) x))
(math-mul (math-sqrt (math-div
(eval-when-compile
(math-read-number-simple "0.636619722"))
x))
(math-sub (math-mul (cdr sc) a1)
(math-mul (car sc) (math-mul z a2))))))
(t
@ -636,20 +657,23 @@
(math-mul
x
(math-div (math-poly-eval y
'((float (bigneg 606 036 016 3) -8)
(float (bigpos 826 044 157) -4)
(float (bigneg 439 611 972 2) -3)
(float (bigpos 531 968 423 2) -1)
(float (bigneg 235 059 895 7) 0)
(float (bigpos 232 614 362 72) 0)))
(eval-when-compile
(list
(math-read-number-simple "-30.16036606")
(math-read-number-simple "15704.4826")
(math-read-number-simple "-2972611.439")
(math-read-number-simple "242396853.1")
(math-read-number-simple "-7895059235.0")
(math-read-number-simple "72362614232.0"))))
(math-poly-eval y
'((float 1 0)
(float (bigpos 397 991 769 3) -7)
(float (bigpos 394 743 944 9) -5)
(float (bigpos 474 330 858 1) -2)
(float (bigpos 178 535 300 2) 0)
(float (bigpos 442 228 725 144)
0)))))))))
(eval-when-compile
(list
'(float 1 0)
(math-read-number-simple "376.9991397")
(math-read-number-simple "99447.43394")
(math-read-number-simple "18583304.74")
(math-read-number-simple "2300535178.0")
(math-read-number-simple "144725228442.0"))))))))))
(defun calcFunc-besY (v x)
(math-inexact-result)
@ -690,20 +714,25 @@
(let ((y (math-sqr x)))
(math-add
(math-div (math-poly-eval y
'((float (bigpos 733 622 284 2) -7)
(float (bigneg 757 792 632 8) -5)
(float (bigpos 129 988 087 1) -2)
(float (bigneg 036 598 123 5) -1)
(float (bigpos 065 834 062 7) 0)
(float (bigneg 389 821 957 2) 0)))
(eval-when-compile
(list
(math-read-number-simple "228.4622733")
(math-read-number-simple "-86327.92757")
(math-read-number-simple "10879881.29")
(math-read-number-simple "-512359803.6")
(math-read-number-simple "7062834065.0")
(math-read-number-simple "-2957821389.0"))))
(math-poly-eval y
'((float 1 0)
(float (bigpos 244 030 261 2) -7)
(float (bigpos 647 472 474) -4)
(float (bigpos 438 466 189 7) -3)
(float (bigpos 648 499 452 7) -1)
(float (bigpos 269 544 076 40) 0))))
(math-mul '(float (bigpos 772 619 636) -9)
(eval-when-compile
(list
'(float 1 0)
(math-read-number-simple "226.1030244")
(math-read-number-simple "47447.2647")
(math-read-number-simple "7189466.438")
(math-read-number-simple "745249964.8")
(math-read-number-simple "40076544269.0")))))
(math-mul (eval-when-compile
(math-read-number-simple "0.636619772"))
(math-mul (math-besJ0 x) (math-ln-raw x))))))
((math-negp (calcFunc-re x))
(math-add (math-besJ0 (math-neg x) t)
@ -719,22 +748,26 @@
(math-mul
x
(math-div (math-poly-eval y
'((float (bigpos 935 937 511 8) -6)
(float (bigneg 726 922 237 4) -3)
(float (bigpos 551 264 349 7) -1)
(float (bigneg 139 438 153 5) 1)
(float (bigpos 439 527 127) 4)
(float (bigneg 943 604 900 4) 3)))
(eval-when-compile
(list
(math-read-number-simple "8511.937935")
(math-read-number-simple "-4237922.726")
(math-read-number-simple "734926455.1")
(math-read-number-simple "-51534381390.0")
(math-read-number-simple "1275274390000.0")
(math-read-number-simple "-4900604943000.0"))))
(math-poly-eval y
'((float 1 0)
(float (bigpos 885 632 549 3) -7)
(float (bigpos 605 042 102) -3)
(float (bigpos 002 904 245 2) -2)
(float (bigpos 367 650 733 3) 0)
(float (bigpos 664 419 244 4) 2)
(float (bigpos 057 958 249) 5)))))
(math-mul '(float (bigpos 772 619 636) -9)
(math-sub (math-mul (math-besJ1 x) (math-ln-raw x))
(eval-when-compile
(list
'(float 1 0)
(math-read-number-simple "354.9632885")
(math-read-number-simple "102042.605")
(math-read-number-simple "22459040.02")
(math-read-number-simple "3733650367.0")
(math-read-number-simple "424441966400.0")
(math-read-number-simple "24995805700000.0"))))))
(math-mul (eval-when-compile (math-read-number-simple "0.636619772"))
(math-sub (math-mul (math-besJ1 x) (math-ln-raw x))
(math-div 1 x))))))
((math-negp (calcFunc-re x))
(math-neg
@ -799,16 +832,40 @@
(calcFunc-euler n '(float 5 -1)))
(calcFunc-euler n '(frac 1 2))))))
(defvar math-bernoulli-b-cache '((frac -174611
(bigpos 0 200 291 698 662 857 802))
(frac 43867 (bigpos 0 944 170 217 94 109 5))
(frac -3617 (bigpos 0 880 842 622 670 10))
(frac 1 (bigpos 600 249 724 74))
(frac -691 (bigpos 0 368 674 307 1))
(frac 1 (bigpos 160 900 47))
(frac -1 (bigpos 600 209 1))
(frac 1 30240) (frac -1 720)
(frac 1 12) 1 ))
(defvar math-bernoulli-b-cache
(eval-when-compile
(list
(list 'frac
-174611
(math-read-number-simple "802857662698291200000"))
(list 'frac
43867
(math-read-number-simple "5109094217170944000"))
(list 'frac
-3617
(math-read-number-simple "10670622842880000"))
(list 'frac
1
(math-read-number-simple "74724249600"))
(list 'frac
-691
(math-read-number-simple "1307674368000"))
(list 'frac
1
(math-read-number-simple "47900160"))
(list 'frac
-1
(math-read-number-simple "1209600"))
(list 'frac
1
30240)
(list 'frac
-1
720)
(list 'frac
1
12)
1 )))
(defvar math-bernoulli-B-cache '((frac -174611 330) (frac 43867 798)
(frac -3617 510) (frac 7 6) (frac -691 2730)

4
lisp/calc/calc-lang.el
View File

@ -35,7 +35,7 @@
;;; Alternate entry/display languages.
(defun calc-set-language (lang &optional option no-refresh)
(setq math-expr-opers (or (get lang 'math-oper-table) math-standard-opers)
(setq math-expr-opers (or (get lang 'math-oper-table) (math-standard-ops))
math-expr-function-mapping (get lang 'math-function-table)
math-expr-special-function-mapping (get lang 'math-special-function-table)
math-expr-variable-mapping (get lang 'math-variable-table)
@ -1225,7 +1225,7 @@
h (1+ v) (1+ h) math-rb-v2)
(string-match "<=\\|>=\\|\\+/-\\|!=\\|&&\\|||\\|:=\\|=>\\|." line h)
(assoc (math-match-substring line 0)
math-standard-opers)))
(math-standard-ops))))
(and (>= (nth 2 widest) prec)
(setq h (match-end 0)))
(and (not (eq (string-match ",\\|;\\|\\.\\.\\|)\\|\\]\\|:" line h)

25
lisp/calc/calc-math.el
View File

@ -310,15 +310,15 @@
(let* ((top (nthcdr (- len 2) a)))
(math-isqrt-bignum-iter
a
(math-scale-bignum-3
(math-scale-bignum-digit-size
(math-bignum-big
(1+ (math-isqrt-small
(+ (* (nth 1 top) 1000) (car top)))))
(+ (* (nth 1 top) math-bignum-digit-size) (car top)))))
(1- (/ len 2)))))
(let* ((top (nth (1- len) a)))
(math-isqrt-bignum-iter
a
(math-scale-bignum-3
(math-scale-bignum-digit-size
(list (1+ (math-isqrt-small top)))
(/ len 2)))))))
@ -341,14 +341,15 @@
(while (eq (car (setq a (cdr a))) 0))
(null a))))
(defun math-scale-bignum-3 (a n) ; [L L S]
(defun math-scale-bignum-digit-size (a n) ; [L L S]
(while (> n 0)
(setq a (cons 0 a)
n (1- n)))
a)
(defun math-isqrt-small (a) ; A > 0. [S S]
(let ((g (cond ((>= a 10000) 1000)
(let ((g (cond ((>= a 1000000) 10000)
((>= a 10000) 1000)
((>= a 100) 100)
(t 10)))
g2)
@ -1717,10 +1718,20 @@
sum
(math-lnp1-series nextsum (1+ n) nextx x))))
(math-defcache math-ln-10 (float (bigpos 018 684 045 994 092 585 302 2) -21)
(defconst math-approx-ln-10
(eval-when-compile
(math-read-number-simple "2.302585092994045684018"))
"An approximation for ln(10).")
(math-defcache math-ln-10 math-approx-ln-10
(math-ln-raw-2 '(float 1 1)))
(math-defcache math-ln-2 (float (bigpos 417 309 945 559 180 147 693) -21)
(defconst math-approx-ln-2
(eval-when-compile
(math-read-number-simple "0.693147180559945309417"))
"An approximation for ln(2).")
(math-defcache math-ln-2 math-approx-ln-2
(math-ln-raw-3 (math-float '(frac 1 3))))

2
lisp/calc/calc-misc.el
View File

@ -579,7 +579,7 @@ loaded and the keystroke automatically re-typed."
(defun math-div2-bignum (a) ; [l l]
(if (cdr a)
(cons (+ (/ (car a) 2) (* (% (nth 1 a) 2) 500))
(cons (+ (/ (car a) 2) (* (% (nth 1 a) 2) (/ math-bignum-digit-size 2)))
(math-div2-bignum (cdr a)))
(list (/ (car a) 2))))

6
lisp/calc/calc-poly.el
View File

@ -982,10 +982,16 @@
(defun math-padded-polynomial (expr var deg)
"Return a polynomial as list of coefficients.
If EXPR is of the form \"a + bx + cx^2 + ...\" in the variable VAR, return
the list (a b c ...) with at least DEG elements, else return NIL."
(let ((p (math-is-polynomial expr var deg)))
(append p (make-list (- deg (length p)) 0))))
(defun math-partial-fractions (r den var)
"Return R divided by DEN expressed in partial fractions of VAR.
All whole factors of DEN have already been split off from R.
If no partial fraction representation can be found, return nil."
(let* ((fden (calcFunc-factors den var))
(tdeg (math-polynomial-p den var))
(fp fden)

2
lisp/calc/calc-prog.el
View File

@ -568,7 +568,7 @@
(set-buffer calc-buf)
(let ((calc-user-parse-tables nil)
(calc-language nil)
(math-expr-opers math-standard-opers)
(math-expr-opers (math-standard-ops))
(calc-hashes-used 0))
(math-read-expr
(if (string-match ",[ \t]*\\'" str)

2
lisp/calc/calc-yank.el
View File

@ -559,7 +559,7 @@ To cancel the edit, simply kill the *Calc Edit* buffer."
(aset str pos ?\,)))
(switch-to-buffer calc-original-buffer)
(let ((vals (let ((calc-language nil)
(math-expr-opers math-standard-opers))
(math-expr-opers (math-standard-ops)))
(and (string-match "[^\n\t ]" str)
(math-read-exprs str)))))
(when (eq (car-safe vals) 'error)

258
lisp/calc/calc.el
View File

@ -401,6 +401,13 @@ This is not required to be present for user-written mode annotations."
:group 'calc
:type '(choice (string) (sexp)))
(defcustom calc-multiplication-has-precedence
t
"*If non-nil, multiplication has precedence over division
in normal mode."
:group 'calc
:type 'boolean)
(defvar calc-bug-address "jay.p.belanger@gmail.com"
"Address of the maintainer of Calc, for use by `report-calc-bug'.")
@ -2276,7 +2283,21 @@ See calc-keypad for details."
(defconst math-bignum-digit-length 4
; (truncate (/ (log10 (/ most-positive-fixnum 2)) 2))
"The length of a \"digit\" in Calc bignums.
If a big integer is of the form (bigpos N0 N1 ...), this is the
length of the allowable Emacs integers N0, N1,...
The value of 2*10^(2*MATH-BIGNUM-DIGIT-LENGTH) must be less than the
largest Emacs integer.")
(defconst math-bignum-digit-size
(expt 10 math-bignum-digit-length)
"An upper bound for the size of the \"digit\"s in Calc bignums.")
(defconst math-small-integer-size
(expt math-bignum-digit-size 2)
"An upper bound for the size of \"small integer\"s in Calc.")
;;;; Arithmetic routines.
@ -2285,11 +2306,17 @@ See calc-keypad for details."
;;; following forms:
;;;
;;; integer An integer. For normalized numbers, this format
;;; is used only for -999999 ... 999999.
;;; is used only for
;;; negative math-small-integer-size + 1 to
;;; math-small-integer-size - 1
;;;
;;; (bigpos N0 N1 N2 ...) A big positive integer, N0 + N1*1000 + N2*10^6 ...
;;; (bigneg N0 N1 N2 ...) A big negative integer, - N0 - N1*1000 ...
;;; Each digit N is in the range 0 ... 999.
;;; (bigpos N0 N1 N2 ...) A big positive integer,
;;; N0 + N1*math-bignum-digit-size
;;; + N2*(math-bignum-digit-size)^2 ...
;;; (bigneg N0 N1 N2 ...) A big negative integer,
;;; - N0 - N1*math-bignum-digit-size ...
;;; Each digit N is in the range
;;; 0 ... math-bignum-digit-size -1.
;;; Normalized, always at least three N present,
;;; and the most significant N is nonzero.
;;;
@ -2379,7 +2406,8 @@ See calc-keypad for details."
(cond
((not (consp math-normalize-a))
(if (integerp math-normalize-a)
(if (or (>= math-normalize-a 1000000) (<= math-normalize-a -1000000))
(if (or (>= math-normalize-a math-small-integer-size)
(<= math-normalize-a (- math-small-integer-size)))
(math-bignum math-normalize-a)
math-normalize-a)
math-normalize-a))
@ -2394,7 +2422,8 @@ See calc-keypad for details."
math-normalize-a
(cond
((cdr (cdr math-normalize-a)) (+ (nth 1 math-normalize-a)
(* (nth 2 math-normalize-a) 1000)))
(* (nth 2 math-normalize-a)
math-bignum-digit-size)))
((cdr math-normalize-a) (nth 1 math-normalize-a))
(t 0))))
((eq (car math-normalize-a) 'bigneg)
@ -2408,7 +2437,8 @@ See calc-keypad for details."
math-normalize-a
(cond
((cdr (cdr math-normalize-a)) (- (+ (nth 1 math-normalize-a)
(* (nth 2 math-normalize-a) 1000))))
(* (nth 2 math-normalize-a)
math-bignum-digit-size))))
((cdr math-normalize-a) (- (nth 1 math-normalize-a)))
(t 0))))
((eq (car math-normalize-a) 'float)
@ -2528,7 +2558,8 @@ See calc-keypad for details."
(defun math-bignum-big (a) ; [L s]
(if (= a 0)
nil
(cons (% a 1000) (math-bignum-big (/ a 1000)))))
(cons (% a math-bignum-digit-size)
(math-bignum-big (/ a math-bignum-digit-size)))))
;;; Build a normalized floating-point number. [F I S]
@ -2545,7 +2576,7 @@ See calc-keypad for details."
(progn
(while (= (car digs) 0)
(setq digs (cdr digs)
exp (+ exp 3)))
exp (+ exp math-bignum-digit-length)))
(while (= (% (car digs) 10) 0)
(setq digs (math-div10-bignum digs)
exp (1+ exp)))
@ -2563,7 +2594,8 @@ See calc-keypad for details."
(defun math-div10-bignum (a) ; [l l]
(if (cdr a)
(cons (+ (/ (car a) 10) (* (% (nth 1 a) 10) 100))
(cons (+ (/ (car a) 10) (* (% (nth 1 a) 10)
(expt 10 (1- math-bignum-digit-length))))
(math-div10-bignum (cdr a)))
(list (/ (car a) 10))))
@ -2594,7 +2626,7 @@ See calc-keypad for details."
(if (cdr a)
(let* ((len (1- (length a)))
(top (nth len a)))
(+ (* len 3) (cond ((>= top 100) 0) ((>= top 10) -1) (t -2))))
(+ (* (1- len) math-bignum-digit-length) (math-numdigs top)))
0)
(cond ((>= a 100) (+ (math-numdigs (/ a 1000)) 3))
((>= a 10) 2)
@ -2615,24 +2647,24 @@ See calc-keypad for details."
a
(if (consp a)
(cons (car a) (math-scale-left-bignum (cdr a) n))
(if (>= n 3)
(if (or (>= a 1000) (<= a -1000))
(if (>= n math-bignum-digit-length)
(if (or (>= a math-bignum-digit-size)
(<= a (- math-bignum-digit-size)))
(math-scale-left (math-bignum a) n)
(math-scale-left (* a 1000) (- n 3)))
(if (= n 2)
(if (or (>= a 10000) (<= a -10000))
(math-scale-left (math-bignum a) 2)
(* a 100))
(if (or (>= a 100000) (<= a -100000))
(math-scale-left (math-bignum a) 1)
(* a 10)))))))
(math-scale-left (* a math-bignum-digit-size)
(- n math-bignum-digit-length)))
(let ((sz (expt 10 (- (* 2 math-bignum-digit-length) n))))
(if (or (>= a sz) (<= a (- sz)))
(math-scale-left (math-bignum a) n)
(* a (expt 10 n))))))))
(defun math-scale-left-bignum (a n)
(if (>= n 3)
(if (>= n math-bignum-digit-length)
(while (>= (setq a (cons 0 a)
n (- n 3)) 3)))
n (- n math-bignum-digit-length))
math-bignum-digit-length)))
(if (> n 0)
(math-mul-bignum-digit a (if (= n 2) 100 10) 0)
(math-mul-bignum-digit a (expt 10 n) 0)
a))
(defun math-scale-right (a n) ; [i i S]
@ -2644,21 +2676,20 @@ See calc-keypad for details."
(if (= a 0)
0
(- (math-scale-right (- a) n)))
(if (>= n 3)
(while (and (> (setq a (/ a 1000)) 0)
(>= (setq n (- n 3)) 3))))
(if (= n 2)
(/ a 100)
(if (= n 1)
(/ a 10)
a))))))
(if (>= n math-bignum-digit-length)
(while (and (> (setq a (/ a math-bignum-digit-size)) 0)
(>= (setq n (- n math-bignum-digit-length))
math-bignum-digit-length))))
(if (> n 0)
(/ a (expt 10 n))
a)))))
(defun math-scale-right-bignum (a n) ; [L L S; l l S]
(if (>= n 3)
(setq a (nthcdr (/ n 3) a)
n (% n 3)))
(if (>= n math-bignum-digit-length)
(setq a (nthcdr (/ n math-bignum-digit-length) a)
n (% n math-bignum-digit-length)))
(if (> n 0)
(cdr (math-mul-bignum-digit a (if (= n 2) 10 100) 0))
(cdr (math-mul-bignum-digit a (expt 10 (- math-bignum-digit-length n)) 0))
a))
;;; Multiply (with rounding) the integer A by 10^N. [I i S]
@ -2668,16 +2699,18 @@ See calc-keypad for details."
((consp a)
(math-normalize
(cons (car a)
(let ((val (if (< n -3)
(math-scale-right-bignum (cdr a) (- -3 n))
(if (= n -2)
(math-mul-bignum-digit (cdr a) 10 0)
(if (= n -1)
(math-mul-bignum-digit (cdr a) 100 0)
(cdr a)))))) ; n = -3
(if (and val (>= (car val) 500))
(let ((val (if (< n (- math-bignum-digit-length))
(math-scale-right-bignum
(cdr a)
(- (- math-bignum-digit-length) n))
(if (< n 0)
(math-mul-bignum-digit
(cdr a)
(expt 10 (+ math-bignum-digit-length n)) 0)
(cdr a))))) ; n = -math-bignum-digit-length
(if (and val (>= (car val) (/ math-bignum-digit-size 2)))
(if (cdr val)
(if (eq (car (cdr val)) 999)
(if (eq (car (cdr val)) (1- math-bignum-digit-size))
(math-add-bignum (cdr val) '(1))
(cons (1+ (car (cdr val))) (cdr (cdr val))))
'(1))
@ -2696,7 +2729,7 @@ See calc-keypad for details."
(and (not (or (consp a) (consp b)))
(progn
(setq a (+ a b))
(if (or (<= a -1000000) (>= a 1000000))
(if (or (<= a (- math-small-integer-size)) (>= a math-small-integer-size))
(math-bignum a)
a)))
(and (Math-zerop a) (not (eq (car-safe a) 'mod))
@ -2745,21 +2778,22 @@ See calc-keypad for details."
(let* ((a (copy-sequence a)) (aa a) (carry nil) sum)
(while (and aa b)
(if carry
(if (< (setq sum (+ (car aa) (car b))) 999)
(if (< (setq sum (+ (car aa) (car b)))
(1- math-bignum-digit-size))
(progn
(setcar aa (1+ sum))
(setq carry nil))
(setcar aa (+ sum -999)))
(if (< (setq sum (+ (car aa) (car b))) 1000)
(setcar aa (- sum (1- math-bignum-digit-size))))
(if (< (setq sum (+ (car aa) (car b))) math-bignum-digit-size)
(setcar aa sum)
(setcar aa (+ sum -1000))
(setcar aa (- sum math-bignum-digit-size))
(setq carry t)))
(setq aa (cdr aa)
b (cdr b)))
(if carry
(if b
(nconc a (math-add-bignum b '(1)))
(while (eq (car aa) 999)
(while (eq (car aa) (1- math-bignum-digit-size))
(setcar aa 0)
(setq aa (cdr aa)))
(if aa
@ -2783,17 +2817,17 @@ See calc-keypad for details."
(progn
(setcar aa (1- diff))
(setq borrow nil))
(setcar aa (+ diff 999)))
(setcar aa (+ diff (1- math-bignum-digit-size))))
(if (>= (setq diff (- (car aa) (car b))) 0)
(setcar aa diff)
(setcar aa (+ diff 1000))
(setcar aa (+ diff math-bignum-digit-size))
(setq borrow t)))
(setq aa (cdr aa)
b (cdr b)))
(if borrow
(progn
(while (eq (car aa) 0)
(setcar aa 999)
(setcar aa (1- math-bignum-digit-size))
(setq aa (cdr aa)))
(if aa
(progn
@ -2833,7 +2867,7 @@ See calc-keypad for details."
(if (or (consp a) (consp b))
(math-add a (math-neg b))
(setq a (- a b))
(if (or (<= a -1000000) (>= a 1000000))
(if (or (<= a (- math-small-integer-size)) (>= a math-small-integer-size))
(math-bignum a)
a)))
@ -2860,7 +2894,8 @@ See calc-keypad for details."
(defun math-mul (a b)
(or
(and (not (consp a)) (not (consp b))
(< a 1000) (> a -1000) (< b 1000) (> b -1000)
(< a math-bignum-digit-size) (> a (- math-bignum-digit-size))
(< b math-bignum-digit-size) (> b (- math-bignum-digit-size))
(* a b))
(and (Math-zerop a) (not (eq (car-safe b) 'mod))
(if (Math-scalarp b)
@ -2929,14 +2964,14 @@ See calc-keypad for details."
aa a)
(while (progn
(setcar ss (% (setq prod (+ (+ (car ss) (* (car aa) d))
c)) 1000))
c)) math-bignum-digit-size))
(setq aa (cdr aa)))
(setq c (/ prod 1000)
(setq c (/ prod math-bignum-digit-size)
ss (or (cdr ss) (setcdr ss (list 0)))))
(if (>= prod 1000)
(if (>= prod math-bignum-digit-size)
(if (cdr ss)
(setcar (cdr ss) (+ (/ prod 1000) (car (cdr ss))))
(setcdr ss (list (/ prod 1000))))))
(setcar (cdr ss) (+ (/ prod math-bignum-digit-size) (car (cdr ss))))
(setcdr ss (list (/ prod math-bignum-digit-size))))))
sum)))
;;; Multiply digit list A by digit D. [L L D D; l l D D]
@ -2946,12 +2981,14 @@ See calc-keypad for details."
(and (= d 1) a)
(let* ((a (copy-sequence a)) (aa a) prod)
(while (progn
(setcar aa (% (setq prod (+ (* (car aa) d) c)) 1000))
(setcar aa
(% (setq prod (+ (* (car aa) d) c))
math-bignum-digit-size))
(cdr aa))
(setq aa (cdr aa)
c (/ prod 1000)))
(if (>= prod 1000)
(setcdr aa (list (/ prod 1000))))
c (/ prod math-bignum-digit-size)))
(if (>= prod math-bignum-digit-size)
(setcdr aa (list (/ prod math-bignum-digit-size))))
a))
(and (> c 0)
(list c))))
@ -2964,7 +3001,7 @@ See calc-keypad for details."
(if (eq b 0)
(math-reject-arg a "*Division by zero"))
(if (or (consp a) (consp b))
(if (and (natnump b) (< b 1000))
(if (and (natnump b) (< b math-bignum-digit-size))
(let ((res (math-div-bignum-digit (cdr a) b)))
(cons
(math-normalize (cons (car a) (car res)))
@ -2983,7 +3020,7 @@ See calc-keypad for details."
(if (= b 0)
(math-reject-arg a "*Division by zero")
(/ a b))
(if (and (natnump b) (< b 1000))
(if (and (natnump b) (< b math-bignum-digit-size))
(if (= b 0)
(math-reject-arg a "*Division by zero")
(math-normalize (cons (car a)
@ -2992,7 +3029,7 @@ See calc-keypad for details."
(or (consp b) (setq b (math-bignum b)))
(let* ((alen (1- (length a)))
(blen (1- (length b)))
(d (/ 1000 (1+ (nth (1- blen) (cdr b)))))
(d (/ math-bignum-digit-size (1+ (nth (1- blen) (cdr b)))))
(res (math-div-bignum-big (math-mul-bignum-digit (cdr a) d 0)
(math-mul-bignum-digit (cdr b) d 0)
alen blen)))
@ -3006,7 +3043,7 @@ See calc-keypad for details."
(if (cdr b)
(let* ((alen (length a))
(blen (length b))
(d (/ 1000 (1+ (nth (1- blen) b))))
(d (/ math-bignum-digit-size (1+ (nth (1- blen) b))))
(res (math-div-bignum-big (math-mul-bignum-digit a d 0)
(math-mul-bignum-digit b d 0)
alen blen)))
@ -3021,7 +3058,7 @@ See calc-keypad for details."
(defun math-div-bignum-digit (a b)
(if a
(let* ((res (math-div-bignum-digit (cdr a) b))
(num (+ (* (cdr res) 1000) (car a))))
(num (+ (* (cdr res) math-bignum-digit-size) (car a))))
(cons
(cons (/ num b) (car res))
(% num b)))
@ -3037,10 +3074,11 @@ See calc-keypad for details."
(cons (car res2) (car res))
(cdr res2)))))
(defun math-div-bignum-part (a b blen) ; a < b*1000 [D.l l L]
(let* ((num (+ (* (or (nth blen a) 0) 1000) (or (nth (1- blen) a) 0)))
(defun math-div-bignum-part (a b blen) ; a < b*math-bignum-digit-size [D.l l L]
(let* ((num (+ (* (or (nth blen a) 0) math-bignum-digit-size)
(or (nth (1- blen) a) 0)))
(den (nth (1- blen) b))
(guess (min (/ num den) 999)))
(guess (min (/ num den) (1- math-bignum-digit-size))))
(math-div-bignum-try a b (math-mul-bignum-digit b guess 0) guess)))
(defun math-div-bignum-try (a b c guess) ; [D.l l l D]
@ -3351,15 +3389,22 @@ See calc-keypad for details."
(if a
(let ((s ""))
(while (cdr (cdr a))
(setq s (concat (format "%06d" (+ (* (nth 1 a) 1000) (car a))) s)
(setq s (concat
(format
(concat "%0"
(number-to-string (* 2 math-bignum-digit-length))
"d")
(+ (* (nth 1 a) math-bignum-digit-size) (car a))) s)
a (cdr (cdr a))))
(concat (int-to-string (+ (* (or (nth 1 a) 0) 1000) (car a))) s))
(concat (int-to-string
(+ (* (or (nth 1 a) 0) math-bignum-digit-size) (car a))) s))
"0"))
;;; Parse a simple number in string form. [N X] [Public]
(defun math-read-number (s)
"Convert the string S into a Calc number."
(math-normalize
(cond
@ -3370,7 +3415,7 @@ See calc-keypad for details."
(> (length digs) 1)
(eq (aref digs 0) ?0))
(math-read-number (concat "8#" digs))
(if (<= (length digs) 6)
(if (<= (length digs) (* 2 math-bignum-digit-length))
(string-to-number digs)
(cons 'bigpos (math-read-bignum digs))))))
@ -3416,15 +3461,42 @@ See calc-keypad for details."
;; Syntax error!
(t nil))))
;;; Parse a very simple number, keeping all digits.
(defun math-read-number-simple (s)
"Convert the string S into a Calc number.
S is assumed to be a simple number (integer or float without an exponent)
and all digits are kept, regardless of Calc's current precision."
(cond
;; Integer
((string-match "^[0-9]+$" s)
(if (string-match "^\\(0+\\)" s)
(setq s (substring s (match-end 0))))
(if (<= (length s) (* 2 math-bignum-digit-length))
(string-to-number s)
(cons 'bigpos (math-read-bignum s))))
;; Minus sign
((string-match "^-[0-9]+$" s)
(if (<= (length s) (1+ (* 2 math-bignum-digit-length)))
(string-to-number s)
(cons 'bigneg (math-read-bignum (substring s 1)))))
;; Decimal point
((string-match "^\\(-?[0-9]*\\)\\.\\([0-9]*\\)$" s)
(let ((int (math-match-substring s 1))
(frac (math-match-substring s 2)))
(list 'float (math-read-number-simple (concat int frac))
(- (length frac)))))
;; Syntax error!
(t nil)))
(defun math-match-substring (s n)
(if (match-beginning n)
(substring s (match-beginning n) (match-end n))
""))
(defun math-read-bignum (s) ; [l X]
(if (> (length s) 3)
(cons (string-to-number (substring s -3))
(math-read-bignum (substring s 0 -3)))
(if (> (length s) math-bignum-digit-length)
(cons (string-to-number (substring s (- math-bignum-digit-length)))
(math-read-bignum (substring s 0 (- math-bignum-digit-length))))
(list (string-to-number s))))
@ -3467,8 +3539,6 @@ See calc-keypad for details."
( "!" calcFunc-fact 210 -1 )
( "^" ^ 201 200 )
( "**" ^ 201 200 )
( "*" * 196 195 )
( "2x" * 196 195 )
( "/" / 190 191 )
( "%" % 190 191 )
( "\\" calcFunc-idiv 190 191 )
@ -3492,7 +3562,31 @@ See calc-keypad for details."
( "::" calcFunc-condition 45 46 )
( "=>" calcFunc-evalto 40 41 )
( "=>" calcFunc-evalto 40 -1 )))
(defvar math-expr-opers math-standard-opers)
(defun math-standard-ops ()
(if calc-multiplication-has-precedence
(cons
'( "*" * 196 195 )
(cons
'( "2x" * 196 195 )
math-standard-opers))
(cons
'( "*" * 190 191 )
(cons
'( "2x" * 190 191 )
math-standard-opers))))
(defvar math-expr-opers (math-standard-ops))
(defun math-standard-ops-p ()
(let ((meo (caar math-expr-opers)))
(and (stringp meo)
(string= meo "*"))))
(defun math-expr-ops ()
(if (math-standard-ops-p)
(math-standard-ops)
math-expr-opers))
;;;###autoload
(defun calc-grab-region (top bot arg)

1
lisp/calc/calccomp.el
View File

@ -83,6 +83,7 @@
(defun math-compose-expr (a prec)
(let ((math-compose-level (1+ math-compose-level))
(math-expr-opers (math-expr-ops))
spfn)
(cond
((or (and (eq a math-comp-selected) a)

59
lisp/calculator.el
View File

@ -278,7 +278,7 @@ Examples:
("IC" acos (D (acos X)) x 6)
("IT" atan (D (atan X)) x 6)
("Q" sqrt sqrt x 7)
("^" ^ expt 2 7)
("^" ^ calculator-expt 2 7)
("!" ! calculator-fact x 7)
(";" 1/ (/ 1 X) 1 7)
("_" - - 1 8)
@ -596,7 +596,8 @@ specified, then it is fixed, otherwise it depends on this variable).
`+' and `-' can be used as either binary operators or prefix unary
operators. Numbers can be entered with exponential notation using `e',
except when using a non-decimal radix mode for input (in this case `e'
will be the hexadecimal digit).
will be the hexadecimal digit). If the result of a calculation is too
large (out of range for Emacs), the value of \"inf\" is returned.
Here are the editing keys:
* `RET' `=' evaluate the current expression
@ -1779,13 +1780,57 @@ To use this, apply a binary operator (evaluate it), then call this."
(car calculator-last-opXY) (nth 1 calculator-last-opXY) x))
x))
(defun calculator-integer-p (x)
"Non-nil if X is equal to an integer."
(condition-case nil
(= x (ftruncate x))
(error nil)))
(defun calculator-expt (x y)
"Compute X^Y, dealing with errors appropriately."
(condition-case
nil
(expt x y)
(domain-error 0.0e+NaN)
(range-error
(cond
((and (< x 1.0) (> x -1.0))
;; For small x, the range error comes from large y.
0.0)
((and (> x 0.0) (< y 0.0))
;; For large positive x and negative y, the range error
;; comes from large negative y.
0.0)
((and (> x 0.0) (> y 0.0))
;; For large positive x and positive y, the range error
;; comes from large y.
1.0e+INF)
;; For the rest, x must be large and negative.
;; The range errors come from large integer y.
((< y 0.0)
0.0)
((oddp (truncate y))
;; If y is odd
-1.0e+INF)
(t
;;
1.0e+INF)))
(error 0.0e+NaN)))
(defun calculator-fact (x)
"Simple factorial of X."
(let ((r (if (<= x 10) 1 1.0)))
(while (> x 0)
(setq r (* r (truncate x)))
(setq x (1- x)))
(+ 0.0 r)))
(if (and (>= x 0)
(calculator-integer-p x))
(if (= (calculator-expt (/ x 3.0) x) 1.0e+INF)
1.0e+INF
(let ((r (if (<= x 10) 1 1.0)))
(while (> x 0)
(setq r (* r (truncate x)))
(setq x (1- x)))
(+ 0.0 r)))
(if (= x 1.0e+INF)
x
0.0e+NaN)))
(defun calculator-truncate (n)
"Truncate N, return 0 in case of overflow."

1
lisp/calendar/cal-bahai.el
View File

@ -149,6 +149,7 @@ Defaults to today's date if DATE is not given."
(message "Baha'i date: %s"
(calendar-bahai-date-string (calendar-cursor-to-date t))))
;;;###autoload
(defun calendar-goto-bahai-date (date &optional noecho)
"Move cursor to Baha'i date DATE.
Echo Baha'i date unless NOECHO is t."

42
lisp/comint.el
View File

@ -333,12 +333,13 @@ This variable is buffer-local."
;; kinit prints a prompt like `Password for devnull@GNU.ORG: '.
;; ksu prints a prompt like `Kerberos password for devnull/root@GNU.ORG: '.
;; ssh-add prints a prompt like `Enter passphrase: '.
;; plink prints a prompt like `Passphrase for key "root@GNU.ORG": '.
;; Some implementations of passwd use "Password (again)" as the 2nd prompt.
(defcustom comint-password-prompt-regexp
"\\(\\([Oo]ld \\|[Nn]ew \\|'s \\|login \\|\
Kerberos \\|CVS \\|UNIX \\| SMB \\|^\\)\
\[Pp]assword\\( (again)\\)?\\|\
pass phrase\\|\\(Enter\\|Repeat\\|Bad\\) passphrase\\)\
pass phrase\\|\\(Enter \\|Repeat \\|Bad \\)?[Pp]assphrase\\)\
\\(?:, try again\\)?\\(?: for [^:]+\\)?:\\s *\\'"
"*Regexp matching prompts for passwords in the inferior process.
This is used by `comint-watch-for-password-prompt'."
@ -670,13 +671,13 @@ BUFFER can be either a buffer or the name of one."
"Make a Comint process NAME in BUFFER, running PROGRAM.
If BUFFER is nil, it defaults to NAME surrounded by `*'s.
PROGRAM should be either a string denoting an executable program to create
via `start-process', or a cons pair of the form (HOST . SERVICE) denoting a TCP
connection to be opened via `open-network-stream'. If there is already a
running process in that buffer, it is not restarted. Optional fourth arg
via `start-file-process', or a cons pair of the form (HOST . SERVICE) denoting
a TCP connection to be opened via `open-network-stream'. If there is already
a running process in that buffer, it is not restarted. Optional fourth arg
STARTFILE is the name of a file to send the contents of to the process.
If PROGRAM is a string, any more args are arguments to PROGRAM."
(or (fboundp 'start-process)
(or (fboundp 'start-file-process)
(error "Multi-processing is not supported for this system"))
(setq buffer (get-buffer-create (or buffer (concat "*" name "*"))))
;; If no process, or nuked process, crank up a new one and put buffer in
@ -693,9 +694,9 @@ If PROGRAM is a string, any more args are arguments to PROGRAM."
"Make a Comint process NAME in a buffer, running PROGRAM.
The name of the buffer is made by surrounding NAME with `*'s.
PROGRAM should be either a string denoting an executable program to create
via `start-process', or a cons pair of the form (HOST . SERVICE) denoting a TCP
connection to be opened via `open-network-stream'. If there is already a
running process in that buffer, it is not restarted. Optional third arg
via `start-file-process', or a cons pair of the form (HOST . SERVICE) denoting
a TCP connection to be opened via `open-network-stream'. If there is already
a running process in that buffer, it is not restarted. Optional third arg
STARTFILE is the name of a file to send the contents of the process to.
If PROGRAM is a string, any more args are arguments to PROGRAM."
@ -781,17 +782,17 @@ buffer. The hook `comint-exec-hook' is run after each exec."
;; If the command has slashes, make sure we
;; first look relative to the current directory.
(cons default-directory exec-path) exec-path)))
(setq proc (apply 'start-process name buffer command switches)))
(setq proc (apply 'start-file-process name buffer command switches)))
(let ((coding-systems (process-coding-system proc)))
(setq decoding (car coding-systems)
encoding (cdr coding-systems)))
;; If start-process decided to use some coding system for decoding
;; If start-file-process decided to use some coding system for decoding
;; data sent from the process and the coding system doesn't
;; specify EOL conversion, we had better convert CRLF to LF.
(if (vectorp (coding-system-eol-type decoding))
(setq decoding (coding-system-change-eol-conversion decoding 'dos)
changed t))
;; Even if start-process left the coding system for encoding data
;; Even if start-file-process left the coding system for encoding data
;; sent from the process undecided, we had better use the same one
;; as what we use for decoding. But, we should suppress EOL
;; conversion.
@ -1953,11 +1954,16 @@ If this takes us past the end of the current line, don't skip at all."
"Default function for sending to PROC input STRING.
This just sends STRING plus a newline. To override this,
set the hook `comint-input-sender'."
(comint-send-string proc string)
(if comint-input-sender-no-newline
(if (not (string-equal string ""))
(process-send-eof))
(comint-send-string proc "\n")))
(let ((send-string
(if comint-input-sender-no-newline
string
;; Sending as two separate strings does not work
;; on Windows, so concat the \n before sending.
(concat string "\n"))))
(comint-send-string proc send-string))
(if (and comint-input-sender-no-newline
(not (string-equal string "")))
(process-send-eof)))
(defun comint-line-beginning-position ()
"Return the buffer position of the beginning of the line, after any prompt.
@ -2805,7 +2811,7 @@ Returns t if successful."
(defun comint-dynamic-complete-as-filename ()
"Dynamically complete at point as a filename.
See `comint-dynamic-complete-filename'. Returns t if successful."
(let* ((completion-ignore-case (memq system-type '(ms-dos windows-nt cygwin)))
(let* ((completion-ignore-case read-file-name-completion-ignore-case)
(completion-ignored-extensions comint-completion-fignore)
;; If we bind this, it breaks remote directory tracking in rlogin.el.
;; I think it was originally bound to solve file completion problems,
@ -2934,7 +2940,7 @@ See also `comint-dynamic-complete-filename'."
(defun comint-dynamic-list-filename-completions ()
"List in help buffer possible completions of the filename at point."
(interactive)
(let* ((completion-ignore-case (memq system-type '(ms-dos windows-nt cygwin)))
(let* ((completion-ignore-case read-file-name-completion-ignore-case)
;; If we bind this, it breaks remote directory tracking in rlogin.el.
;; I think it was originally bound to solve file completion problems,
;; but subsequent changes may have made this unnecessary. sm.

54
lisp/complete.el
View File

@ -222,13 +222,6 @@ second TAB brings up the `*Completions*' buffer."
(remove-hook 'find-file-not-found-functions 'PC-look-for-include-file))
((not PC-disable-includes)
(add-hook 'find-file-not-found-functions 'PC-look-for-include-file)))
;; ... with some underhand redefining.
(cond ((not partial-completion-mode)
(ad-disable-advice 'read-file-name-internal 'around 'PC-include-file)
(ad-activate 'read-file-name-internal))
((not PC-disable-includes)
(ad-enable-advice 'read-file-name-internal 'around 'PC-include-file)
(ad-activate 'read-file-name-internal)))
;; Adjust the completion selection in *Completion* buffers to the way
;; we work. The default minibuffer completion code only completes the
;; text before point and leaves the text after point alone (new in
@ -335,14 +328,24 @@ See `PC-complete' for details."
(PC-do-complete-and-exit)))
(defun PC-do-complete-and-exit ()
(if (= (point-max) (minibuffer-prompt-end)) ; Duplicate the "bug" that Info-menu relies on...
(exit-minibuffer)
(cond
((= (point-max) (minibuffer-prompt-end))
;; Duplicate the "bug" that Info-menu relies on...
(exit-minibuffer))
((eq minibuffer-completion-confirm 'confirm-only)
(if (or (eq last-command this-command)
(test-completion (field-string)
minibuffer-completion-table
minibuffer-completion-predicate))
(exit-minibuffer)
(PC-temp-minibuffer-message " [Confirm]")))
(t
(let ((flag (PC-do-completion 'exit)))
(and flag
(if (or (eq flag 'complete)
(not minibuffer-completion-confirm))
(exit-minibuffer)
(PC-temp-minibuffer-message " [Confirm]"))))))
(PC-temp-minibuffer-message " [Confirm]")))))))
(defun PC-completion-help ()
@ -430,7 +433,9 @@ point-max (as is appropriate for completing a file name). If
GOTO-END is non-nil, however, it instead replaces up to END."
(or beg (setq beg (minibuffer-prompt-end)))
(or end (setq end (point-max)))
(let* ((table minibuffer-completion-table)
(let* ((table (if (eq minibuffer-completion-table 'read-file-name-internal)
'PC-read-file-name-internal
minibuffer-completion-table))
(pred minibuffer-completion-predicate)
(filename (funcall PC-completion-as-file-name-predicate))
(dirname nil) ; non-nil only if a filename is being completed
@ -523,11 +528,11 @@ GOTO-END is non-nil, however, it instead replaces up to END."
(insert str)
(setq end (+ beg (length str)))))
(if origstr
;; If the wildcards were introduced by us, it's possible
;; that read-file-name-internal (especially our
;; PC-include-file advice) can still find matches for the
;; original string even if we couldn't, so remove the
;; added wildcards.
;; If the wildcards were introduced by us, it's
;; possible that PC-read-file-name-internal can
;; still find matches for the original string
;; even if we couldn't, so remove the added
;; wildcards.
(setq str origstr)
(setq filename nil table nil pred nil)))))
@ -912,7 +917,7 @@ or properties are considered."
(point-min) t)
(+ (point) 2)
(point-min)))
(minibuffer-completion-table 'read-file-name-internal)
(minibuffer-completion-table 'PC-read-file-name-internal)
(minibuffer-completion-predicate "")
(PC-not-minibuffer t))
(goto-char end)
@ -1098,24 +1103,23 @@ absolute rather than relative to some directory on the SEARCH-PATH."
(setq sorted (cdr sorted)))
compressed))))
(defadvice read-file-name-internal (around PC-include-file disable)
(if (string-match "<\\([^\"<>]*\\)>?\\'" (ad-get-arg 0))
(let* ((string (ad-get-arg 0))
(action (ad-get-arg 2))
(name (match-string 1 string))
(defun PC-read-file-name-internal (string dir action)
"Extend `read-file-name-internal' to handle include files.
This is only used by "
(if (string-match "<\\([^\"<>]*\\)>?\\'" string)
(let* ((name (match-string 1 string))
(str2 (substring string (match-beginning 0)))
(completion-table
(mapcar (lambda (x)
(format (if (string-match "/\\'" x) "<%s" "<%s>") x))
(PC-include-file-all-completions
name (PC-include-file-path)))))
(setq ad-return-value
(cond
((not completion-table) nil)
((eq action 'lambda) (test-completion str2 completion-table nil))
((eq action nil) (PC-try-completion str2 completion-table nil))
((eq action t) (all-completions str2 completion-table nil)))))
ad-do-it))
((eq action t) (all-completions str2 completion-table nil))))
(read-file-name-internal string dir action)))
(provide 'complete)

560
lisp/cus-edit.el
View File

@ -755,52 +755,86 @@ groups after non-groups, if nil do not order groups at all."
;;; Custom Mode Commands.
(defvar custom-options nil
"Customization widgets in the current buffer.")
;; This variable is used by `custom-tool-bar-map', or directly by
;; `custom-buffer-create-internal' if the toolbar is not present and
;; `custom-buffer-verbose-help' is non-nil.
(defun Custom-set ()
"Set the current value of all edited settings in the buffer."
(interactive)
(let ((children custom-options))
(if (or (and (= 1 (length children))
(memq (widget-type (car children))
'(custom-variable custom-face)))
(y-or-n-p "Set all values according to this buffer? "))
(mapc (lambda (child)
(when (eq (widget-get child :custom-state) 'modified)
(widget-apply child :custom-set)))
children)
(message "Aborted"))))
(defvar custom-commands
'(("Set for current session" Custom-set t
"Apply all settings in this buffer to the current session"
"index")
("Save for future sessions" Custom-save
(or custom-file user-init-file)
"Apply all settings in this buffer and save them for future Emacs sessions."
"save")
("Undo edits" Custom-reset-current t
"Restore all settings in this buffer to reflect their current values."
"refresh")
("Reset to saved" Custom-reset-saved t
"Restore all settings in this buffer to their saved values (if any)."
"undo")
("Erase customizations" Custom-reset-standard
(or custom-file user-init-file)
"Un-customize all settings in this buffer and save them with standard values."
"delete")
("Help for Customize" Custom-help t
"Get help for using Customize."
"help")
("Exit" Custom-buffer-done t "Exit Customize." "exit")))
(defun Custom-save ()
"Set all edited settings, then save all settings that have been set.
If a setting was edited and set before, this saves it.
If a setting was merely edited before, this sets it then saves it."
(defun Custom-help ()
"Read the node on Easy Customization in the Emacs manual."
(interactive)
(let ((children custom-options))
(if (or (and (= 1 (length children))
(memq (widget-type (car children))
'(custom-variable custom-face)))
(yes-or-no-p "Save all settings in this buffer? "))
(progn
(mapc (lambda (child)
(when (memq (widget-get child :custom-state)
'(modified set changed rogue))
(widget-apply child :custom-save)))
children)
(custom-save-all))
(message "Aborted"))))
(info "(emacs)Easy Customization"))
(defvar custom-reset-menu
'(("Undo Edits" . Custom-reset-current)
("Reset to Saved" . Custom-reset-saved)
("Erase Customization (use standard values)" . Custom-reset-standard))
("Erase Customizations (use standard values)" . Custom-reset-standard))
"Alist of actions for the `Reset' button.
The key is a string containing the name of the action, the value is a
Lisp function taking the widget as an element which will be called
when the action is chosen.")
(defun custom-reset (event)
(defvar custom-options nil
"Customization widgets in the current buffer.")
(defun custom-command-apply (fun query &optional strong-query)
"Call function FUN on all widgets in `custom-options'.
If there is more than one widget, ask user for confirmation using
the query string QUERY, using `y-or-n-p' if STRONG-QUERY is nil,
and `yes-or-no-p' otherwise."
(if (or (and (= 1 (length custom-options))
(memq (widget-type (car custom-options))
'(custom-variable custom-face)))
(funcall (if strong-query 'yes-or-no-p 'y-or-n-p) query))
(progn (mapc fun custom-options) t)
(message "Aborted")
nil))
(defun Custom-set (&rest ignore)
"Set the current value of all edited settings in the buffer."
(interactive)
(custom-command-apply
(lambda (child)
(when (eq (widget-get child :custom-state) 'modified)
(widget-apply child :custom-set)))
"Set all values according to this buffer? "))
(defun Custom-save (&rest ignore)
"Set all edited settings, then save all settings that have been set.
If a setting was edited and set before, this saves it.
If a setting was merely edited before, this sets it then saves it."
(interactive)
(if (custom-command-apply
(lambda (child)
(when (memq (widget-get child :custom-state)
'(modified set changed rogue))
(widget-apply child :custom-save)))
"Save all settings in this buffer? " t)
(custom-save-all)))
(defun custom-reset (widget &optional event)
"Select item from reset menu."
(let* ((completion-ignore-case t)
(answer (widget-choose "Reset settings"
@ -812,33 +846,21 @@ when the action is chosen.")
(defun Custom-reset-current (&rest ignore)
"Reset all edited settings in the buffer to show their current values."
(interactive)
(let ((children custom-options))
(if (or (and (= 1 (length children))
(memq (widget-type (car children))
'(custom-variable custom-face)))
(y-or-n-p "Reset all settings' buffer text to show current values? "))
(mapc (lambda (widget)
(if (memq (widget-get widget :custom-state)
'(modified changed))
(widget-apply widget :custom-reset-current)))
children)
(message "Aborted"))))
(custom-command-apply
(lambda (widget)
(if (memq (widget-get widget :custom-state) '(modified changed))
(widget-apply widget :custom-reset-current)))
"Reset all settings' buffer text to show current values? "))
(defun Custom-reset-saved (&rest ignore)
"Reset all edited or set settings in the buffer to their saved value.
This also shows the saved values in the buffer."
(interactive)
(let ((children custom-options))
(if (or (and (= 1 (length children))
(memq (widget-type (car children))
'(custom-variable custom-face)))
(y-or-n-p "Reset all settings (current values and buffer text) to saved values? "))
(mapc (lambda (widget)
(if (memq (widget-get widget :custom-state)
'(modified set changed rogue))
(widget-apply widget :custom-reset-saved)))
children)
(message "Aborted"))))
(custom-command-apply
(lambda (widget)
(if (memq (widget-get widget :custom-state) '(modified set changed rogue))
(widget-apply widget :custom-reset-saved)))
"Reset all settings (current values and buffer text) to saved values? "))
(defun Custom-reset-standard (&rest ignore)
"Erase all customization (either current or saved) for the group members.
@ -846,20 +868,14 @@ The immediate result is to restore them to their standard values.
This operation eliminates any saved values for the group members,
making them as if they had never been customized at all."
(interactive)
(let ((children custom-options))
(if (or (and (= 1 (length children))
(memq (widget-type (car children))
'(custom-variable custom-face)))
(yes-or-no-p "Erase all customizations for settings in this buffer? "))
(mapc (lambda (widget)
(and (if (widget-get widget :custom-standard-value)
(widget-apply widget :custom-standard-value)
t)
(memq (widget-get widget :custom-state)
'(modified set changed saved rogue))
(widget-apply widget :custom-reset-standard)))
children)
(message "Aborted"))))
(custom-command-apply
(lambda (widget)
(and (or (null (widget-get widget :custom-standard-value))
(widget-apply widget :custom-standard-value))
(memq (widget-get widget :custom-state)
'(modified set changed saved rogue))
(widget-apply widget :custom-reset-standard)))
"Erase all customizations for settings in this buffer? " t))
;;; The Customize Commands
@ -888,9 +904,9 @@ it as the third element in the list."
(cond (prop
;; Use VAR's `variable-interactive' property
;; as an interactive spec for prompting.
(call-interactively (list 'lambda '(arg)
(list 'interactive prop)
'arg)))
(call-interactively `(lambda (arg)
(interactive ,prop)
arg)))
(type
(widget-prompt-value type
prompt
@ -1018,17 +1034,20 @@ then prompt for the MODE to customize."
;;;###autoload
(defun customize-group (group)
(defun customize-group (&optional group prompt-for-group other-window)
"Customize GROUP, which must be a customization group."
(interactive
(list (let ((completion-ignore-case t))
(completing-read "Customize group (default emacs): "
obarray
(lambda (symbol)
(or (and (get symbol 'custom-loads)
(not (get symbol 'custom-autoload)))
(get symbol 'custom-group)))
t))))
(interactive)
(and (null group)
(or prompt-for-group (called-interactively-p))
(let ((completion-ignore-case t))
(setq group
(completing-read "Customize group (default emacs): "
obarray
(lambda (symbol)
(or (and (get symbol 'custom-loads)
(not (get symbol 'custom-autoload)))
(get symbol 'custom-group)))
t))))
(when (stringp group)
(if (string-equal "" group)
(setq group 'emacs)
@ -1036,42 +1055,25 @@ then prompt for the MODE to customize."
(let ((name (format "*Customize Group: %s*"
(custom-unlispify-tag-name group))))
(if (get-buffer name)
(pop-to-buffer name)
(custom-buffer-create (list (list group 'custom-group))
name
(concat " for group "
(custom-unlispify-tag-name group))))))
(if other-window
(let ((pop-up-windows t)
(same-window-buffer-names nil)
(same-window-regexps nil))
(pop-to-buffer name))
(pop-to-buffer name))
(funcall (if other-window
'custom-buffer-create-other-window
'custom-buffer-create)
(list (list group 'custom-group))
name
(concat " for group "
(custom-unlispify-tag-name group))))))
;;;###autoload
(defun customize-group-other-window (group)
"Customize GROUP, which must be a customization group."
(interactive
(list (let ((completion-ignore-case t))
(completing-read "Customize group (default emacs): "
obarray
(lambda (symbol)
(or (and (get symbol 'custom-loads)
(not (get symbol 'custom-autoload)))
(get symbol 'custom-group)))
t))))
(when (stringp group)
(if (string-equal "" group)
(setq group 'emacs)
(setq group (intern group))))
(let ((name (format "*Customize Group: %s*"
(custom-unlispify-tag-name group))))
(if (get-buffer name)
(let (
;; Copied from `custom-buffer-create-other-window'.
(pop-up-windows t)
(same-window-buffer-names nil)
(same-window-regexps nil))
(pop-to-buffer name))
(custom-buffer-create-other-window
(list (list group 'custom-group))
name
(concat " for group "
(custom-unlispify-tag-name group))))))
(defun customize-group-other-window (&optional group)
"Customize GROUP, which must be a customization group, in another window."
(interactive)
(customize-group group t t))
;;;###autoload
(defalias 'customize-variable 'customize-option)
@ -1252,34 +1254,41 @@ Emacs that is associated with version VERSION of PACKAGE."
(< minor1 minor2)))))
;;;###autoload
(defun customize-face (&optional face)
(defun customize-face (&optional face prompt-for-face other-window)
"Customize FACE, which should be a face name or nil.
If FACE is nil, customize all faces. If FACE is actually a
face-alias, customize the face it is aliased to.
Interactively, when point is on text which has a face specified,
suggest to customize that face, if it's customizable."
(interactive
(list (read-face-name "Customize face" "all faces" t)))
(interactive)
(and (null face)
(or prompt-for-face (called-interactively-p))
(setq face (read-face-name "Customize face" "all faces" t)))
(if (member face '(nil ""))
(setq face (face-list)))
(if (and (listp face) (null (cdr face)))
(setq face (car face)))
(if (listp face)
(custom-buffer-create (custom-sort-items
(mapcar (lambda (s)
(list s 'custom-face))
face)
t nil)
"*Customize Faces*")
;; If FACE is actually an alias, customize the face it is aliased to.
(if (get face 'face-alias)
(setq face (get face 'face-alias)))
(unless (facep face)
(error "Invalid face %S" face))
(custom-buffer-create (list (list face 'custom-face))
(format "*Customize Face: %s*"
(custom-unlispify-tag-name face)))))
(let ((create-buffer-fn (if other-window
'custom-buffer-create-other-window
'custom-buffer-create)))
(if (listp face)
(funcall create-buffer-fn
(custom-sort-items
(mapcar (lambda (s)
(list s 'custom-face))
face)
t nil)
"*Customize Faces*")
;; If FACE is actually an alias, customize the face it is aliased to.
(if (get face 'face-alias)
(setq face (get face 'face-alias)))
(unless (facep face)
(error "Invalid face %S" face))
(funcall create-buffer-fn
(list (list face 'custom-face))
(format "*Customize Face: %s*"
(custom-unlispify-tag-name face))))))
;;;###autoload
(defun customize-face-other-window (&optional face)
@ -1288,28 +1297,8 @@ If FACE is actually a face-alias, customize the face it is aliased to.
Interactively, when point is on text which has a face specified,
suggest to customize that face, if it's customizable."
(interactive
(list (read-face-name "Customize face" "all faces" t)))
(if (member face '(nil ""))
(setq face (face-list)))
(if (and (listp face) (null (cdr face)))
(setq face (car face)))
(if (listp face)
(custom-buffer-create-other-window
(custom-sort-items
(mapcar (lambda (s)
(list s 'custom-face))
face)
t nil)
"*Customize Faces*")
(if (get face 'face-alias)
(setq face (get face 'face-alias)))
(unless (facep face)
(error "Invalid face %S" face))
(custom-buffer-create-other-window
(list (list face 'custom-face))
(format "*Customize Face: %s*"
(custom-unlispify-tag-name face)))))
(interactive)
(customize-face face t t))
(defalias 'customize-customized 'customize-unsaved)
@ -1541,96 +1530,60 @@ Otherwise use brackets."
(defun custom-buffer-create-internal (options &optional description)
(custom-mode)
(if custom-buffer-verbose-help
(progn
(widget-insert "This is a customization buffer")
(if description
(widget-insert description))
(widget-insert (format ".
%s buttons; type RET or click mouse-1 to actuate one.
Editing a setting changes only the text in the buffer."
(if custom-raised-buttons
"`Raised' text indicates"
"Square brackets indicate")))
(if init-file-user
(widget-insert "
Use the Save or Set buttons to set apply your changes.
Saving a change normally works by editing your Emacs ")
(widget-insert "
\nSince you started Emacs with `-q', you cannot save settings into
the Emacs "))
(widget-create 'custom-manual
:tag "init file"
"(emacs)Saving Customizations")
(widget-insert ".\nSee ")
(widget-create 'custom-manual
:tag "Help"
:help-echo "Read the online help."
"(emacs)Easy Customization")
(widget-insert " for more information.\n\n")
(widget-insert "Operate on all settings in this buffer that \
are not marked HIDDEN:\n "))
(widget-insert " "))
(widget-create 'push-button
:tag "Set for Current Session"
:help-echo "\
Make your editing in this buffer take effect for this session."
:action (lambda (widget &optional event)
(Custom-set)))
(if (not custom-buffer-verbose-help)
(progn
(widget-insert " ")
(widget-create 'custom-manual
:tag "Help"
:help-echo "Read the online help."
"(emacs)Easy Customization")))
(when (or custom-file user-init-file)
(widget-insert " ")
(widget-create 'push-button
:tag "Save for Future Sessions"
:help-echo "\
Make your editing in this buffer take effect for future Emacs sessions.
This updates your Emacs initialization file or creates a new one."
:action (lambda (widget &optional event)
(Custom-save))))
(if custom-reset-button-menu
(progn
(widget-insert " ")
(widget-create 'push-button
:tag "Reset buffer"
:help-echo "Show a menu with reset operations."
:mouse-down-action (lambda (&rest junk) t)
:action (lambda (widget &optional event)
(custom-reset event))))
(widget-insert "\n ")
(widget-create 'push-button
:tag "Undo Edits"
:help-echo "\
Reset all edited text in this buffer to reflect current values."
:action 'Custom-reset-current)
(widget-insert " ")
(widget-create 'push-button
:tag "Reset to Saved"
:help-echo "\
Reset all settings in this buffer to their saved values."
:action 'Custom-reset-saved)
(widget-insert " ")
(when (or custom-file user-init-file)
(widget-create 'push-button
:tag "Erase Customization"
:help-echo "\
Un-customize all settings in this buffer and save them with standard values."
:action 'Custom-reset-standard)))
(widget-insert " ")
(widget-create 'push-button
:tag "Finish"
:help-echo
(lambda (&rest ignore)
(if custom-buffer-done-kill
"Kill this buffer"
"Bury this buffer"))
:action #'Custom-buffer-done)
(widget-insert "\n\n")
(let ((init-file (or custom-file user-init-file)))
;; Insert verbose help at the top of the custom buffer.
(when custom-buffer-verbose-help
(widget-insert "Editing a setting changes only the text in this buffer."
(if init-file
"
To set apply your changes, use the Save or Set buttons.
Saving a change normally works by editing your init file."
"
Currently, these settings cannot be saved for future Emacs sessions,
possibly because you started Emacs with `-q'.")
"\nFor details, see ")
(widget-create 'custom-manual
:tag "Saving Customizations"
"(emacs)Saving Customizations")
(widget-insert " in the ")
(widget-create 'custom-manual
:tag "Emacs manual"
:help-echo "Read the Emacs manual."
"(emacs)Top")
(widget-insert "."))
;; Insert custom command buttons if the toolbar is not in use.
(widget-insert "\n")
(when (not (and tool-bar-mode (display-graphic-p)))
(if custom-buffer-verbose-help
(widget-insert "\n
Operate on all settings in this buffer that are not marked HIDDEN:\n"))
(let ((button (lambda (tag action active help icon)
(widget-insert " ")
(if (eval active)
(widget-create 'push-button :tag tag
:help-echo help :action action))))
(commands custom-commands))
(apply button (pop commands)) ; Set for current session
(apply button (pop commands)) ; Save for future sessions
(if custom-reset-button-menu
(progn
(widget-insert " ")
(widget-create 'push-button
:tag "Reset buffer"
:help-echo "Show a menu with reset operations."
:mouse-down-action 'ignore
:action 'custom-reset))
(widget-insert "\n")
(apply button (pop commands)) ; Undo edits
(apply button (pop commands)) ; Reset to saved
(apply button (pop commands)) ; Erase customization
(widget-insert " ")
(pop commands) ; Help (omitted)
(apply button (pop commands))))) ; Exit
(widget-insert "\n\n"))
;; Now populate the custom buffer.
(message "Creating customization items...")
(buffer-disable-undo)
(setq custom-options
@ -2431,13 +2384,13 @@ If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"."
(defface custom-variable-tag
`((((class color)
(background dark))
(:foreground "light blue" :weight bold :inherit variable-pitch))
(:foreground "light blue" :weight bold))
(((min-colors 88) (class color)
(background light))
(:foreground "blue1" :weight bold :inherit variable-pitch))
(:foreground "blue1" :weight bold))
(((class color)
(background light))
(:foreground "blue" :weight bold :inherit variable-pitch))
(:foreground "blue" :weight bold))
(t (:weight bold)))
"Face used for unpushable variable tags."
:group 'custom-faces)
@ -2629,8 +2582,8 @@ try matching its doc string against `custom-guess-doc-alist'."
(widget-put widget :custom-magic magic)
(push magic buttons))
(widget-put widget :buttons buttons)
(insert "\n")
;; Insert documentation.
(widget-put widget :documentation-indent 3)
(widget-add-documentation-string-button
widget :visibility-widget 'custom-visibility)
@ -3750,13 +3703,13 @@ and so forth. The remaining group tags are shown with `custom-group-tag'."
(defface custom-group-tag
`((((class color)
(background dark))
(:foreground "light blue" :weight bold :height 1.2))
(:foreground "light blue" :weight bold :height 1.2 :inherit variable-pitch))
(((min-colors 88) (class color)
(background light))
(:foreground "blue1" :weight bold :height 1.2))
(:foreground "blue1" :weight bold :height 1.2 :inherit variable-pitch))
(((class color)
(background light))
(:foreground "blue" :weight bold :height 1.2))
(:foreground "blue" :weight bold :height 1.2 :inherit variable-pitch))
(t (:weight bold)))
"Face used for low level group tags."
:group 'custom-faces)
@ -3900,28 +3853,22 @@ If GROUPS-ONLY non-nil, return only those members that are groups."
;; Nested style.
((eq state 'hidden)
;; Create level indicator.
(unless (eq custom-buffer-style 'links)
(insert-char ?\ (* custom-buffer-indent (1- level)))
(insert "-- "))
;; Create tag.
(let ((begin (point)))
(insert tag)
(widget-specify-sample widget begin (point)))
(insert " group: ")
;; Create link/visibility indicator.
(if (eq custom-buffer-style 'links)
(push (widget-create-child-and-convert
widget 'custom-group-link
:tag "Go to Group"
:tag tag
symbol)
buttons)
(insert-char ?\ (* custom-buffer-indent (1- level)))
(insert "-- ")
(push (widget-create-child-and-convert
widget 'custom-group-visibility
:help-echo "Show members of this group."
:action 'custom-toggle-parent
(not (eq state 'hidden)))
buttons))
(insert " \n")
(insert " : ")
;; Create magic button.
(let ((magic (widget-create-child-and-convert
widget 'custom-magic nil)))
@ -3949,9 +3896,9 @@ If GROUPS-ONLY non-nil, return only those members that are groups."
(insert "/- ")
;; Create tag.
(let ((start (point)))
(insert tag)
(insert tag " group: ")
(widget-specify-sample widget start (point)))
(insert " group: ")
(insert (widget-docstring widget))
;; Create visibility indicator.
(unless (eq custom-buffer-style 'links)
(insert "--------")
@ -4072,44 +4019,34 @@ Optional EVENT is the location for the menu."
(defun custom-group-set (widget)
"Set changes in all modified group members."
(let ((children (widget-get widget :children)))
(mapc (lambda (child)
(when (eq (widget-get child :custom-state) 'modified)
(widget-apply child :custom-set)))
children )))
(dolist (child (widget-get widget :children))
(when (eq (widget-get child :custom-state) 'modified)
(widget-apply child :custom-set))))
(defun custom-group-save (widget)
"Save all modified group members."
(let ((children (widget-get widget :children)))
(mapc (lambda (child)
(when (memq (widget-get child :custom-state) '(modified set))
(widget-apply child :custom-save)))
children )))
(dolist (child (children (widget-get widget :children)))
(when (memq (widget-get child :custom-state) '(modified set))
(widget-apply child :custom-save))))
(defun custom-group-reset-current (widget)
"Reset all modified group members."
(let ((children (widget-get widget :children)))
(mapc (lambda (child)
(when (eq (widget-get child :custom-state) 'modified)
(widget-apply child :custom-reset-current)))
children )))
(dolist (child (widget-get widget :children))
(when (eq (widget-get child :custom-state) 'modified)
(widget-apply child :custom-reset-current))))
(defun custom-group-reset-saved (widget)
"Reset all modified or set group members."
(let ((children (widget-get widget :children)))
(mapc (lambda (child)
(when (memq (widget-get child :custom-state) '(modified set))
(widget-apply child :custom-reset-saved)))
children )))
(dolist (child (widget-get widget :children))
(when (memq (widget-get child :custom-state) '(modified set))
(widget-apply child :custom-reset-saved))))
(defun custom-group-reset-standard (widget)
"Reset all modified, set, or saved group members."
(let ((children (widget-get widget :children)))
(mapc (lambda (child)
(when (memq (widget-get child :custom-state)
'(modified set saved))
(widget-apply child :custom-reset-standard)))
children )))
(dolist (child (widget-get widget :children))
(when (memq (widget-get child :custom-state)
'(modified set saved))
(widget-apply child :custom-reset-standard))))
(defun custom-group-state-update (widget)
"Update magic."
@ -4498,6 +4435,32 @@ The format is suitable for use with `easy-menu-define'."
(let ((menu (custom-menu-create ',symbol)))
(if (consp menu) (cdr menu) menu)))))
;;; Toolbar and menubar support
(easy-menu-define
Custom-mode-menu custom-mode-map
"Menu used in customization buffers."
(nconc (list "Custom"
(customize-menu-create 'customize))
(mapcar (lambda (arg)
(let ((tag (nth 0 arg))
(command (nth 1 arg))
(active (nth 2 arg))
(help (nth 3 arg)))
(vector tag command :active (eval active) :help help)))
custom-commands)))
(defvar tool-bar-map)
(defvar custom-tool-bar-map
(if (display-graphic-p)
(let ((map (make-sparse-keymap)))
(mapc
(lambda (arg)
(tool-bar-local-item-from-menu
(nth 1 arg) (nth 4 arg) map custom-mode-map))
custom-commands)
map)))
;;; The Custom Mode.
(defun Custom-no-edit (pos &optional event)
@ -4513,18 +4476,6 @@ The format is suitable for use with `easy-menu-define'."
(widget-apply-action button event)
(error "You can't edit this part of the Custom buffer"))))
(easy-menu-define Custom-mode-menu
custom-mode-map
"Menu used in customization buffers."
`("Custom"
,(customize-menu-create 'customize)
["Set" Custom-set t]
["Save" Custom-save t]
["Undo Edits" Custom-reset-current t]
["Reset to Saved" Custom-reset-saved t]
["Erase Customization" Custom-reset-standard t]
["Info" (info "(emacs)Easy Customization") t]))
(defvar custom-field-keymap
(let ((map (copy-keymap widget-field-keymap)))
(define-key map "\C-c\C-c" 'Custom-set)
@ -4581,6 +4532,7 @@ if that value is non-nil."
mode-name "Custom")
(use-local-map custom-mode-map)
(easy-menu-add Custom-mode-menu)
(set (make-local-variable 'tool-bar-map) custom-tool-bar-map)
(make-local-variable 'custom-options)
(make-local-variable 'custom-local-buffer)
(make-local-variable 'widget-documentation-face)

10
lisp/cus-start.el
View File

@ -122,8 +122,11 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of
:value (undecided . undecided)
(coding-system :tag "Decoding")
(coding-system :tag "Encoding"))
(coding-system :tag "Single coding system"
:value undecided)
(coding-system
:tag "Single coding system"
:value undecided
:match (lambda (widget value)
(and value (not (functionp value)))))
(function :value ignore))))
(selection-coding-system mule coding-system)
;; dired.c
@ -139,6 +142,9 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of
;; eval.c
(max-specpdl-size limits integer)
(max-lisp-eval-depth limits integer)
(max-mini-window-height limits
(choice (const :tag "quarter screen" nil)
number))
(stack-trace-on-error debug
(choice (const :tag "off")
(repeat :menu-tag "When"

12
lisp/desktop.el
View File

@ -626,9 +626,7 @@ is nil, ask the user where to save the desktop."
(setq desktop-dirname
(file-name-as-directory
(expand-file-name
(call-interactively
(lambda (dir)
(interactive "DDirectory for desktop file: ") dir))))))
(read-directory-name "Directory for desktop file: " nil nil t)))))
(condition-case err
(desktop-save desktop-dirname t)
(file-error
@ -654,7 +652,7 @@ is nil, ask the user where to save the desktop."
(set-buffer buffer)
(list
;; basic information
(desktop-file-name (buffer-file-name) dirname)
(desktop-file-name (buffer-file-name) desktop-dirname)
(buffer-name)
major-mode
;; minor modes
@ -675,7 +673,7 @@ is nil, ask the user where to save the desktop."
buffer-read-only
;; auxiliary information
(when (functionp desktop-save-buffer)
(funcall desktop-save-buffer dirname))
(funcall desktop-save-buffer desktop-dirname))
;; local variables
(let ((locals desktop-locals-to-save)
(loclist (buffer-local-variables))
@ -898,7 +896,7 @@ See also `desktop-base-file-name'."
(insert "\n " (desktop-value-to-string e)))
(insert ")\n\n")))
(setq default-directory dirname)
(setq default-directory desktop-dirname)
(let ((coding-system-for-write 'emacs-mule))
(write-region (point-min) (point-max) (desktop-full-file-name) nil 'nomessage))
;; We remember when it was modified (which is presumably just now).
@ -964,9 +962,9 @@ It returns t if a desktop file was loaded, nil otherwise."
(not (y-or-n-p (format "Warning: desktop file appears to be in use by PID %s.\n\
Using it may cause conflicts. Use it anyway? " owner)))))
(progn
(setq desktop-dirname nil)
(let ((default-directory desktop-dirname))
(run-hooks 'desktop-not-loaded-hook))
(setq desktop-dirname nil)
(message "Desktop file in use; not loaded."))
(desktop-lazy-abort)
;; Evaluate desktop buffer and remember when it was modified.

2
lisp/diff-mode.el
View File

@ -338,7 +338,7 @@ when editing big diffs)."
("^--- .+ ----$" . diff-hunk-header-face) ;context
("^[0-9,]+[acd][0-9,]+$" . diff-hunk-header-face) ;normal
("^---$" . diff-hunk-header-face) ;normal
("^\\(---\\|\\+\\+\\+\\|\\*\\*\\*\\) \\([^ \t]+\\)\\(.*[^*-]\\)?\n"
("^\\(---\\|\\+\\+\\+\\|\\*\\*\\*\\) \\([^\t\n]+\\)\\(.*[^*-]\\)?\n"
(0 diff-header-face) (2 diff-file-header-face prepend))
("^\\([-<]\\)\\(.*\n\\)"
(1 diff-indicator-removed-face) (2 diff-removed-face))

17
lisp/dired-aux.el
View File

@ -582,18 +582,6 @@ can be produced by `dired-get-marked-files', for example."
;; Return nil for sake of nconc in dired-bunch-files.
nil)
;; In Emacs 19 this will return program's exit status.
;; This is a separate function so that ange-ftp can redefine it.
(defun dired-call-process (program discard &rest arguments)
; "Run PROGRAM with output to current buffer unless DISCARD is t.
;Remaining arguments are strings passed as command arguments to PROGRAM."
;; Look for a handler for default-directory in case it is a remote file name.
(let ((handler
(find-file-name-handler (directory-file-name default-directory)
'dired-call-process)))
(if handler (apply handler 'dired-call-process
program discard arguments)
(apply 'call-process program nil (not discard) nil arguments))))
(defun dired-check-process (msg program &rest arguments)
; "Display MSG while running PROGRAM, and check for output.
@ -610,8 +598,7 @@ can be produced by `dired-get-marked-files', for example."
(set-buffer err-buffer)
(erase-buffer)
(setq default-directory dir ; caller's default-directory
err (not (eq 0
(apply (function dired-call-process) program nil arguments))))
err (not (eq 0 (apply 'process-file program nil t nil arguments))))
(if err
(progn
(dired-log (concat program " " (prin1-to-string arguments) "\n"))
@ -1203,7 +1190,7 @@ Special value `always' suppresses confirmation."
;; It is a symlink
(make-symbolic-link (car attrs) to ok-flag)
(copy-file from to ok-flag dired-copy-preserve-time))
(file-date-error
(file-date-error
(push (dired-make-relative from)
dired-create-files-failures)
(dired-log "Can't set date on %s:\n%s\n" from err))))))

2
lisp/dnd.el
View File

@ -149,7 +149,7 @@ Return nil if URI is not a local file."
"%[A-Fa-f0-9][A-Fa-f0-9]"
(lambda (arg)
(format "%c" (string-to-number (substring arg 1) 16)))
f nil t))
f t t))
(let* ((decoded-f (decode-coding-string
f
(or file-name-coding-system

2
lisp/emacs-lisp/advice.el
View File

@ -3759,7 +3759,7 @@ The syntax of `defadvice' is as follows:
\(defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...)
[DOCSTRING] [INTERACTIVE-FORM]
BODY... )
BODY...)
FUNCTION ::= Name of the function to be advised.
CLASS ::= `before' | `around' | `after' | `activation' | `deactivation'.

461
lisp/emacs-lisp/autoload.el
View File

@ -41,15 +41,19 @@
A `.el' file can set this in its local variables section to make its
autoloads go somewhere else. The autoload file is assumed to contain a
trailer starting with a FormFeed character.")
;;;###autoload
(put 'generated-autoload-file 'safe-local-variable 'stringp)
(defconst generate-autoload-cookie ";;;###autoload"
;; This feels like it should be a defconst, but MH-E sets it to
;; ";;;###mh-autoload" for the autoloads that are to go into mh-loaddefs.el.
(defvar generate-autoload-cookie ";;;###autoload"
"Magic comment indicating the following form should be autoloaded.
Used by \\[update-file-autoloads]. This string should be
meaningless to Lisp (e.g., a comment).
This string is used:
;;;###autoload
\;;;###autoload
\(defun function-to-be-autoloaded () ...)
If this string appears alone on a line, the following form will be
@ -65,6 +69,8 @@ that text will be copied verbatim to `generated-autoload-file'.")
(defconst generate-autoload-section-continuation ";;;;;; "
"String to add on each continuation of the section header form.")
(defvar autoload-modified-buffers) ;Dynamically scoped var.
(defun make-autoload (form file)
"Turn FORM into an autoload or defvar for source file FILE.
Returns nil if FORM is not a special autoload form (i.e. a function definition
@ -149,16 +155,14 @@ or macro definition or a defcustom)."
;; the doc-string in FORM.
;; Those properties are now set in lisp-mode.el.
(defun autoload-generated-file ()
(expand-file-name generated-autoload-file
;; File-local settings of generated-autoload-file should
;; be interpreted relative to the file's location,
;; of course.
(if (not (local-variable-p 'generated-autoload-file))
(expand-file-name "lisp" source-directory))))
(defun autoload-trim-file-name (file)
;; Returns a relative file path for FILE
;; starting from the directory that loaddefs.el is in.
;; That is normally a directory in load-path,
;; which means Emacs will be able to find FILE when it looks.
;; Any extra directory names here would prevent finding the file.
(setq file (expand-file-name file))
(file-relative-name file
(file-name-directory generated-autoload-file)))
(defun autoload-read-section-header ()
"Read a section header form.
@ -253,9 +257,7 @@ put the output in."
"Insert the section-header line,
which lists the file name and which functions are in it, etc."
(insert generate-autoload-section-header)
(prin1 (list 'autoloads autoloads load-name
(if (stringp file) (autoload-trim-file-name file) file)
time)
(prin1 (list 'autoloads autoloads load-name file time)
outbuf)
(terpri outbuf)
;; Break that line at spaces, to avoid very long lines.
@ -272,12 +274,14 @@ which lists the file name and which functions are in it, etc."
(defun autoload-find-file (file)
"Fetch file and put it in a temp buffer. Return the buffer."
;; It is faster to avoid visiting the file.
(setq file (expand-file-name file))
(with-current-buffer (get-buffer-create " *autoload-file*")
(kill-all-local-variables)
(erase-buffer)
(setq buffer-undo-list t
buffer-read-only nil)
(emacs-lisp-mode)
(setq default-directory (file-name-directory file))
(insert-file-contents file nil)
(let ((enable-local-variables :safe))
(hack-local-variables))
@ -286,6 +290,12 @@ which lists the file name and which functions are in it, etc."
(defvar no-update-autoloads nil
"File local variable to prevent scanning this file for autoload cookies.")
(defun autoload-file-load-name (file)
(let ((name (file-name-nondirectory file)))
(if (string-match "\\.elc?\\(\\.\\|\\'\\)" name)
(substring name 0 (match-beginning 0))
name)))
(defun generate-file-autoloads (file)
"Insert at point a loaddefs autoload section for FILE.
Autoloads are generated for defuns and defmacros in FILE
@ -294,100 +304,155 @@ If FILE is being visited in a buffer, the contents of the buffer
are used.
Return non-nil in the case where no autoloads were added at point."
(interactive "fGenerate autoloads for file: ")
(let ((outbuf (current-buffer))
(autoloads-done '())
(load-name (let ((name (file-name-nondirectory file)))
(if (string-match "\\.elc?\\(\\.\\|$\\)" name)
(substring name 0 (match-beginning 0))
name)))
(print-length nil)
(print-readably t) ; This does something in Lucid Emacs.
(float-output-format nil)
(done-any nil)
(visited (get-file-buffer file))
output-start)
(autoload-generate-file-autoloads file (current-buffer)))
;; If the autoload section we create here uses an absolute
;; file name for FILE in its header, and then Emacs is installed
;; under a different path on another system,
;; `update-autoloads-here' won't be able to find the files to be
;; autoloaded. So, if FILE is in the same directory or a
;; subdirectory of the current buffer's directory, we'll make it
;; relative to the current buffer's directory.
(setq file (expand-file-name file))
(let* ((source-truename (file-truename file))
(dir-truename (file-name-as-directory
(file-truename default-directory)))
(len (length dir-truename)))
(if (and (< len (length source-truename))
(string= dir-truename (substring source-truename 0 len)))
(setq file (substring source-truename len))))
;; When called from `generate-file-autoloads' we should ignore
;; `generated-autoload-file' altogether. When called from
;; `update-file-autoloads' we don't know `outbuf'. And when called from
;; `update-directory-autoloads' it's in between: we know the default
;; `outbuf' but we should obey any file-local setting of
;; `generated-autoload-file'.
(defun autoload-generate-file-autoloads (file &optional outbuf outfile)
"Insert an autoload section for FILE in the appropriate buffer.
Autoloads are generated for defuns and defmacros in FILE
marked by `generate-autoload-cookie' (which see).
If FILE is being visited in a buffer, the contents of the buffer are used.
OUTBUF is the buffer in which the autoload statements should be inserted.
If OUTBUF is nil, it will be determined by `autoload-generated-file'.
(with-current-buffer (or visited
;; It is faster to avoid visiting the file.
(autoload-find-file file))
;; Obey the no-update-autoloads file local variable.
(unless no-update-autoloads
(message "Generating autoloads for %s..." file)
(setq output-start (with-current-buffer outbuf (point)))
(save-excursion
(save-restriction
(widen)
(goto-char (point-min))
(while (not (eobp))
(skip-chars-forward " \t\n\f")
(cond
((looking-at (regexp-quote generate-autoload-cookie))
(search-forward generate-autoload-cookie)
(skip-chars-forward " \t")
(setq done-any t)
(if (eolp)
;; Read the next form and make an autoload.
(let* ((form (prog1 (read (current-buffer))
(or (bolp) (forward-line 1))))
(autoload (make-autoload form load-name)))
(if autoload
(push (nth 1 form) autoloads-done)
(setq autoload form))
(let ((autoload-print-form-outbuf outbuf))
(autoload-print-form autoload)))
If provided, OUTFILE is expected to be the file name of OUTBUF.
If OUTFILE is non-nil and FILE specifies a `generated-autoload-file'
different from OUTFILE, then OUTBUF is ignored.
;; Copy the rest of the line to the output.
(princ (buffer-substring
(progn
;; Back up over whitespace, to preserve it.
(skip-chars-backward " \f\t")
(if (= (char-after (1+ (point))) ? )
;; Eat one space.
(forward-char 1))
(point))
(progn (forward-line 1) (point)))
outbuf)))
((looking-at ";")
;; Don't read the comment.
(forward-line 1))
(t
(forward-sexp 1)
(forward-line 1))))))
Return non-nil iff FILE adds no autoloads to OUTFILE
\(or OUTBUF if OUTFILE is nil)."
(catch 'done
(let ((autoloads-done '())
(load-name (autoload-file-load-name file))
(print-length nil)
(print-readably t) ; This does something in Lucid Emacs.
(float-output-format nil)
(visited (get-file-buffer file))
(otherbuf nil)
(absfile (expand-file-name file))
relfile
;; nil until we found a cookie.
output-start)
(when done-any
(with-current-buffer outbuf
(save-excursion
;; Insert the section-header line which lists the file name
;; and which functions are in it, etc.
(goto-char output-start)
(autoload-insert-section-header
outbuf autoloads-done load-name file
(nth 5 (file-attributes file)))
(insert ";;; Generated autoloads from "
(autoload-trim-file-name file) "\n"))
(insert generate-autoload-section-trailer)))
(message "Generating autoloads for %s...done" file))
(or visited
;; We created this buffer, so we should kill it.
(kill-buffer (current-buffer))))
(not done-any)))
(with-current-buffer (or visited
;; It is faster to avoid visiting the file.
(autoload-find-file file))
;; Obey the no-update-autoloads file local variable.
(unless no-update-autoloads
(message "Generating autoloads for %s..." file)
(save-excursion
(save-restriction
(widen)
(goto-char (point-min))
(while (not (eobp))
(skip-chars-forward " \t\n\f")
(cond
((looking-at (regexp-quote generate-autoload-cookie))
;; If not done yet, figure out where to insert this text.
(unless output-start
(when (and outfile
(not (equal outfile (autoload-generated-file))))
;; A file-local setting of autoload-generated-file says
;; we should ignore OUTBUF.
(setq outbuf nil)
(setq otherbuf t))
(unless outbuf
(setq outbuf (autoload-find-destination absfile))
(unless outbuf
;; The file has autoload cookies, but they're
;; already up-to-date. If OUTFILE is nil, the
;; entries are in the expected OUTBUF, otherwise
;; they're elsewhere.
(throw 'done outfile)))
(with-current-buffer outbuf
(setq relfile (file-relative-name absfile))
(setq output-start (point)))
;; (message "file=%S, relfile=%S, dest=%S"
;; file relfile (autoload-generated-file))
)
(search-forward generate-autoload-cookie)
(skip-chars-forward " \t")
(if (eolp)
(condition-case err
;; Read the next form and make an autoload.
(let* ((form (prog1 (read (current-buffer))
(or (bolp) (forward-line 1))))
(autoload (make-autoload form load-name)))
(if autoload
(push (nth 1 form) autoloads-done)
(setq autoload form))
(let ((autoload-print-form-outbuf outbuf))
(autoload-print-form autoload)))
(error
(message "Error in %s: %S" file err)))
;; Copy the rest of the line to the output.
(princ (buffer-substring
(progn
;; Back up over whitespace, to preserve it.
(skip-chars-backward " \f\t")
(if (= (char-after (1+ (point))) ? )
;; Eat one space.
(forward-char 1))
(point))
(progn (forward-line 1) (point)))
outbuf)))
((looking-at ";")
;; Don't read the comment.
(forward-line 1))
(t
(forward-sexp 1)
(forward-line 1))))))
(when output-start
(let ((secondary-autoloads-file-buf
(if (local-variable-p 'generated-autoload-file)
(current-buffer))))
(with-current-buffer outbuf
(save-excursion
;; Insert the section-header line which lists the file name
;; and which functions are in it, etc.
(goto-char output-start)
(autoload-insert-section-header
outbuf autoloads-done load-name relfile
(if secondary-autoloads-file-buf
;; MD5 checksums are much better because they do not
;; change unless the file changes (so they'll be
;; equal on two different systems and will change
;; less often than time-stamps, thus leading to fewer
;; unneeded changes causing spurious conflicts), but
;; using time-stamps is a very useful optimization,
;; so we use time-stamps for the main autoloads file
;; (loaddefs.el) where we have special ways to
;; circumvent the "random change problem", and MD5
;; checksum in secondary autoload files where we do
;; not need the time-stamp optimization because it is
;; already provided by the primary autoloads file.
(md5 secondary-autoloads-file-buf
;; We'd really want to just use
;; `emacs-internal' instead.
nil nil 'emacs-mule-unix)
(nth 5 (file-attributes relfile))))
(insert ";;; Generated autoloads from " relfile "\n"))
(insert generate-autoload-section-trailer))))
(message "Generating autoloads for %s...done" file))
(or visited
;; We created this buffer, so we should kill it.
(kill-buffer (current-buffer))))
;; If the entries were added to some other buffer, then the file
;; doesn't add entries to OUTFILE.
(or (not output-start) otherbuf))))
(defun autoload-save-buffers ()
(while autoload-modified-buffers
(with-current-buffer (pop autoload-modified-buffers)
(save-buffer))))
;;;###autoload
(defun update-file-autoloads (file &optional save-after)
"Update the autoloads for FILE in `generated-autoload-file'
@ -397,80 +462,80 @@ save the buffer too.
Return FILE if there was no autoload cookie in it, else nil."
(interactive "fUpdate autoloads for file: \np")
(let ((load-name (let ((name (file-name-nondirectory file)))
(if (string-match "\\.elc?\\(\\.\\|$\\)" name)
(substring name 0 (match-beginning 0))
name)))
(found nil)
(existing-buffer (get-file-buffer file))
(no-autoloads nil))
(save-excursion
;; We want to get a value for generated-autoload-file from
;; the local variables section if it's there.
(if existing-buffer
(set-buffer existing-buffer))
;; We must read/write the file without any code conversion,
;; but still decode EOLs.
(let ((coding-system-for-read 'raw-text))
(set-buffer (find-file-noselect
(autoload-ensure-default-file
(expand-file-name generated-autoload-file
(expand-file-name "lisp"
source-directory)))))
;; This is to make generated-autoload-file have Unix EOLs, so
;; that it is portable to all platforms.
(setq buffer-file-coding-system 'raw-text-unix))
(or (> (buffer-size) 0)
(error "Autoloads file %s does not exist" buffer-file-name))
(or (file-writable-p buffer-file-name)
(error "Autoloads file %s is not writable" buffer-file-name))
(save-excursion
(save-restriction
(widen)
(goto-char (point-min))
;; Look for the section for LOAD-NAME.
(while (and (not found)
(search-forward generate-autoload-section-header nil t))
(let ((form (autoload-read-section-header)))
(cond ((string= (nth 2 form) load-name)
;; We found the section for this file.
;; Check if it is up to date.
(let ((begin (match-beginning 0))
(last-time (nth 4 form))
(file-time (nth 5 (file-attributes file))))
(if (and (or (null existing-buffer)
(not (buffer-modified-p existing-buffer)))
(listp last-time) (= (length last-time) 2)
(not (time-less-p last-time file-time)))
(progn
(if (interactive-p)
(message "\
Autoload section for %s is up to date."
file))
(setq found 'up-to-date))
(search-forward generate-autoload-section-trailer)
(delete-region begin (point))
(setq found t))))
((string< load-name (nth 2 form))
;; We've come to a section alphabetically later than
;; LOAD-NAME. We assume the file is in order and so
;; there must be no section for LOAD-NAME. We will
;; insert one before the section here.
(goto-char (match-beginning 0))
(setq found 'new)))))
(or found
(progn
(setq found 'new)
;; No later sections in the file. Put before the last page.
(goto-char (point-max))
(search-backward "\f" nil t)))
(or (eq found 'up-to-date)
(setq no-autoloads (generate-file-autoloads file)))))
(and save-after
(buffer-modified-p)
(save-buffer))
(let* ((autoload-modified-buffers nil)
(no-autoloads (autoload-generate-file-autoloads file)))
(if autoload-modified-buffers
(if save-after (autoload-save-buffers))
(if (interactive-p)
(message "Autoload section for %s is up to date." file)))
(if no-autoloads file)))
(if no-autoloads file))))
(defun autoload-find-destination (file)
"Find the destination point of the current buffer's autoloads.
FILE is the file name of the current buffer.
Returns a buffer whose point is placed at the requested location.
Returns nil if the file's autoloads are uptodate, otherwise
removes any prior now out-of-date autoload entries."
(catch 'up-to-date
(let* ((load-name (autoload-file-load-name file))
(buf (current-buffer))
(existing-buffer (if buffer-file-name buf))
(found nil))
(with-current-buffer
;; We must read/write the file without any code conversion,
;; but still decode EOLs.
(let ((coding-system-for-read 'raw-text))
(find-file-noselect
(autoload-ensure-default-file (autoload-generated-file))))
;; This is to make generated-autoload-file have Unix EOLs, so
;; that it is portable to all platforms.
(setq buffer-file-coding-system 'raw-text-unix)
(or (> (buffer-size) 0)
(error "Autoloads file %s does not exist" buffer-file-name))
(or (file-writable-p buffer-file-name)
(error "Autoloads file %s is not writable" buffer-file-name))
(widen)
(goto-char (point-min))
;; Look for the section for LOAD-NAME.
(while (and (not found)
(search-forward generate-autoload-section-header nil t))
(let ((form (autoload-read-section-header)))
(cond ((string= (nth 2 form) load-name)
;; We found the section for this file.
;; Check if it is up to date.
(let ((begin (match-beginning 0))
(last-time (nth 4 form))
(file-time (nth 5 (file-attributes file))))
(if (and (or (null existing-buffer)
(not (buffer-modified-p existing-buffer)))
(or
;; last-time is the time-stamp (specifying
;; the last time we looked at the file) and
;; the file hasn't been changed since.
(and (listp last-time) (= (length last-time) 2)
(not (time-less-p last-time file-time)))
;; last-time is an MD5 checksum instead.
(and (stringp last-time)
(equal last-time
(md5 buf nil nil 'emacs-mule)))))
(throw 'up-to-date nil)
(autoload-remove-section begin)
(setq found t))))
((string< load-name (nth 2 form))
;; We've come to a section alphabetically later than
;; LOAD-NAME. We assume the file is in order and so
;; there must be no section for LOAD-NAME. We will
;; insert one before the section here.
(goto-char (match-beginning 0))
(setq found t)))))
(or found
(progn
;; No later sections in the file. Put before the last page.
(goto-char (point-max))
(search-backward "\f" nil t)))
(unless (memq (current-buffer) autoload-modified-buffers)
(push (current-buffer) autoload-modified-buffers))
(current-buffer)))))
(defun autoload-remove-section (begin)
(goto-char begin)
@ -498,20 +563,21 @@ directory or directories specified."
(directory-files (expand-file-name dir)
t files-re))
dirs)))
(done ())
(this-time (current-time))
(no-autoloads nil) ;files with no autoload cookies.
(autoloads-file
(expand-file-name generated-autoload-file
(expand-file-name "lisp" source-directory)))
(top-dir (file-name-directory autoloads-file)))
;; Files with no autoload cookies or whose autoloads go to other
;; files because of file-local autoload-generated-file settings.
(no-autoloads nil)
(autoload-modified-buffers nil))
(with-current-buffer
(find-file-noselect (autoload-ensure-default-file autoloads-file))
(find-file-noselect
(autoload-ensure-default-file (autoload-generated-file)))
(save-excursion
;; Canonicalize file names and remove the autoload file itself.
(setq files (delete (autoload-trim-file-name buffer-file-name)
(mapcar 'autoload-trim-file-name files)))
(setq files (delete (file-relative-name buffer-file-name)
(mapcar 'file-relative-name files)))
(goto-char (point-min))
(while (search-forward generate-autoload-section-header nil t)
@ -531,19 +597,27 @@ directory or directories specified."
(push file no-autoloads)
(setq files (delete file files)))))))
((not (stringp file)))
((not (file-exists-p (expand-file-name file top-dir)))
;; Remove the obsolete section.
((or (not (file-exists-p file))
;; Remove duplicates as well, just in case.
(member file done))
;; Remove the obsolete section.
(autoload-remove-section (match-beginning 0)))
((equal (nth 4 form) (nth 5 (file-attributes file)))
((not (time-less-p (nth 4 form)
(nth 5 (file-attributes file))))
;; File hasn't changed.
nil)
(t
(update-file-autoloads file)))
(autoload-remove-section (match-beginning 0))
(if (autoload-generate-file-autoloads
file (current-buffer) buffer-file-name)
(push file no-autoloads))))
(push file done)
(setq files (delete file files)))))
;; Elements remaining in FILES have no existing autoload sections yet.
(setq no-autoloads
(append no-autoloads
(delq nil (mapcar 'update-file-autoloads files))))
(dolist (file files)
(if (autoload-generate-file-autoloads file nil buffer-file-name)
(push file no-autoloads)))
(when no-autoloads
;; Sort them for better readability.
(setq no-autoloads (sort no-autoloads 'string<))
@ -554,7 +628,10 @@ directory or directories specified."
(current-buffer) nil nil no-autoloads this-time)
(insert generate-autoload-section-trailer))
(save-buffer))))
(save-buffer)
;; In case autoload entries were added to other files because of
;; file-local autoload-generated-file settings.
(autoload-save-buffers))))
(define-obsolete-function-alias 'update-autoloads-from-directories
'update-directory-autoloads "22.1")

60
lisp/emacs-lisp/cl-extra.el
View File

@ -43,6 +43,7 @@
;;; Type coercion.
;;;###autoload
(defun coerce (x type)
"Coerce OBJECT to type TYPE.
TYPE is a Common Lisp type specifier.
@ -60,6 +61,7 @@ TYPE is a Common Lisp type specifier.
;;; Predicates.
;;;###autoload
(defun equalp (x y)
"Return t if two Lisp objects have similar structures and contents.
This is like `equal', except that it accepts numerically equal
@ -87,6 +89,7 @@ strings case-insensitively."
;;; Control structures.
;;;###autoload
(defun cl-mapcar-many (cl-func cl-seqs)
(if (cdr (cdr cl-seqs))
(let* ((cl-res nil)
@ -119,6 +122,7 @@ strings case-insensitively."
cl-res)))
(nreverse cl-res))))
;;;###autoload
(defun map (cl-type cl-func cl-seq &rest cl-rest)
"Map a FUNCTION across one or more SEQUENCEs, returning a sequence.
TYPE is the sequence type to return.
@ -126,6 +130,7 @@ TYPE is the sequence type to return.
(let ((cl-res (apply 'mapcar* cl-func cl-seq cl-rest)))
(and cl-type (coerce cl-res cl-type))))
;;;###autoload
(defun maplist (cl-func cl-list &rest cl-rest)
"Map FUNCTION to each sublist of LIST or LISTs.
Like `mapcar', except applies to lists and their cdr's rather than to
@ -154,6 +159,7 @@ the elements themselves.
cl-seq)
(mapc cl-func cl-seq)))
;;;###autoload
(defun mapl (cl-func cl-list &rest cl-rest)
"Like `maplist', but does not accumulate values returned by the function.
\n(fn FUNCTION LIST...)"
@ -163,16 +169,19 @@ the elements themselves.
(while cl-p (funcall cl-func cl-p) (setq cl-p (cdr cl-p)))))
cl-list)
;;;###autoload
(defun mapcan (cl-func cl-seq &rest cl-rest)
"Like `mapcar', but nconc's together the values returned by the function.
\n(fn FUNCTION SEQUENCE...)"
(apply 'nconc (apply 'mapcar* cl-func cl-seq cl-rest)))
;;;###autoload
(defun mapcon (cl-func cl-list &rest cl-rest)
"Like `maplist', but nconc's together the values returned by the function.
\n(fn FUNCTION LIST...)"
(apply 'nconc (apply 'maplist cl-func cl-list cl-rest)))
;;;###autoload
(defun some (cl-pred cl-seq &rest cl-rest)
"Return true if PREDICATE is true of any element of SEQ or SEQs.
If so, return the true (non-nil) value returned by PREDICATE.
@ -188,6 +197,7 @@ If so, return the true (non-nil) value returned by PREDICATE.
(while (and cl-seq (not (setq cl-x (funcall cl-pred (pop cl-seq))))))
cl-x)))
;;;###autoload
(defun every (cl-pred cl-seq &rest cl-rest)
"Return true if PREDICATE is true of every element of SEQ or SEQs.
\n(fn PREDICATE SEQ...)"
@ -201,19 +211,23 @@ If so, return the true (non-nil) value returned by PREDICATE.
(setq cl-seq (cdr cl-seq)))
(null cl-seq)))
;;;###autoload
(defun notany (cl-pred cl-seq &rest cl-rest)
"Return true if PREDICATE is false of every element of SEQ or SEQs.
\n(fn PREDICATE SEQ...)"
(not (apply 'some cl-pred cl-seq cl-rest)))
;;;###autoload
(defun notevery (cl-pred cl-seq &rest cl-rest)
"Return true if PREDICATE is false of some element of SEQ or SEQs.
\n(fn PREDICATE SEQ...)"
(not (apply 'every cl-pred cl-seq cl-rest)))
;;; Support for `loop'.
;;;###autoload
(defalias 'cl-map-keymap 'map-keymap)
;;;###autoload
(defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base)
(or cl-base
(setq cl-base (copy-sequence [0])))
@ -228,6 +242,7 @@ If so, return the true (non-nil) value returned by PREDICATE.
(funcall cl-func-rec cl-base cl-bind))))
cl-map))
;;;###autoload
(defun cl-map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end)
(or cl-what (setq cl-what (current-buffer)))
(if (bufferp cl-what)
@ -255,6 +270,7 @@ If so, return the true (non-nil) value returned by PREDICATE.
(funcall cl-func cl-start (min cl-next cl-end))
(setq cl-start cl-next)))))
;;;###autoload
(defun cl-map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg)
(or cl-buffer (setq cl-buffer (current-buffer)))
(if (fboundp 'overlay-lists)
@ -296,6 +312,7 @@ If so, return the true (non-nil) value returned by PREDICATE.
(set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))))
;;; Support for `setf'.
;;;###autoload
(defun cl-set-frame-visible-p (frame val)
(cond ((null val) (make-frame-invisible frame))
((eq val 'icon) (iconify-frame frame))
@ -304,6 +321,7 @@ If so, return the true (non-nil) value returned by PREDICATE.
;;; Support for `progv'.
(defvar cl-progv-save)
;;;###autoload
(defun cl-progv-before (syms values)
(while syms
(push (if (boundp (car syms))
@ -323,6 +341,7 @@ If so, return the true (non-nil) value returned by PREDICATE.
;;; Numbers.
;;;###autoload
(defun gcd (&rest args)
"Return the greatest common divisor of the arguments."
(let ((a (abs (or (pop args) 0))))
@ -331,6 +350,7 @@ If so, return the true (non-nil) value returned by PREDICATE.
(while (> b 0) (setq b (% a (setq a b))))))
a))
;;;###autoload
(defun lcm (&rest args)
"Return the least common multiple of the arguments."
(if (memq 0 args)
@ -341,6 +361,7 @@ If so, return the true (non-nil) value returned by PREDICATE.
(setq a (* (/ a (gcd a b)) b))))
a)))
;;;###autoload
(defun isqrt (x)
"Return the integer square root of the argument."
(if (and (integerp x) (> x 0))
@ -352,12 +373,14 @@ If so, return the true (non-nil) value returned by PREDICATE.
g)
(if (eq x 0) 0 (signal 'arith-error nil))))
;;;###autoload
(defun floor* (x &optional y)
"Return a list of the floor of X and the fractional part of X.
With two arguments, return floor and remainder of their quotient."
(let ((q (floor x y)))
(list q (- x (if y (* y q) q)))))
;;;###autoload
(defun ceiling* (x &optional y)
"Return a list of the ceiling of X and the fractional part of X.
With two arguments, return ceiling and remainder of their quotient."
@ -365,12 +388,14 @@ With two arguments, return ceiling and remainder of their quotient."
(if (= (car (cdr res)) 0) res
(list (1+ (car res)) (- (car (cdr res)) (or y 1))))))
;;;###autoload
(defun truncate* (x &optional y)
"Return a list of the integer part of X and the fractional part of X.
With two arguments, return truncation and remainder of their quotient."
(if (eq (>= x 0) (or (null y) (>= y 0)))
(floor* x y) (ceiling* x y)))
;;;###autoload
(defun round* (x &optional y)
"Return a list of X rounded to the nearest integer and the remainder.
With two arguments, return rounding and remainder of their quotient."
@ -389,14 +414,17 @@ With two arguments, return rounding and remainder of their quotient."
(let ((q (round x)))
(list q (- x q))))))
;;;###autoload
(defun mod* (x y)
"The remainder of X divided by Y, with the same sign as Y."
(nth 1 (floor* x y)))
;;;###autoload
(defun rem* (x y)
"The remainder of X divided by Y, with the same sign as X."
(nth 1 (truncate* x y)))
;;;###autoload
(defun signum (x)
"Return 1 if X is positive, -1 if negative, 0 if zero."
(cond ((> x 0) 1) ((< x 0) -1) (t 0)))
@ -405,6 +433,7 @@ With two arguments, return rounding and remainder of their quotient."
;; Random numbers.
(defvar *random-state*)
;;;###autoload
(defun random* (lim &optional state)
"Return a random nonnegative number less than LIM, an integer or float.
Optional second arg STATE is a random-state object."
@ -412,7 +441,7 @@ Optional second arg STATE is a random-state object."
;; Inspired by "ran3" from Numerical Recipes. Additive congruential method.
(let ((vec (aref state 3)))
(if (integerp vec)
(let ((i 0) (j (- 1357335 (% (abs vec) 1357333))) (k 1) ii)
(let ((i 0) (j (- 1357335 (% (abs vec) 1357333))) (k 1))
(aset state 3 (setq vec (make-vector 55 nil)))
(aset vec 0 j)
(while (> (setq i (% (+ i 21) 55)) 0)
@ -429,6 +458,7 @@ Optional second arg STATE is a random-state object."
(if (< (setq n (logand n mask)) lim) n (random* lim state))))
(* (/ n '8388608e0) lim)))))
;;;###autoload
(defun make-random-state (&optional state)
"Return a copy of random-state STATE, or of `*random-state*' if omitted.
If STATE is t, return a new state object seeded from the time of day."
@ -437,6 +467,7 @@ If STATE is t, return a new state object seeded from the time of day."
((integerp state) (vector 'cl-random-state-tag -1 30 state))
(t (make-random-state (cl-random-time)))))
;;;###autoload
(defun random-state-p (object)
"Return t if OBJECT is a random-state object."
(and (vectorp object) (= (length object) 4)
@ -460,6 +491,7 @@ If STATE is t, return a new state object seeded from the time of day."
(defvar float-epsilon)
(defvar float-negative-epsilon)
;;;###autoload
(defun cl-float-limits ()
(or most-positive-float (not (numberp '2e1))
(let ((x '2e0) y z)
@ -497,6 +529,7 @@ If STATE is t, return a new state object seeded from the time of day."
;;; Sequence functions.
;;;###autoload
(defun subseq (seq start &optional end)
"Return the subsequence of SEQ from START to END.
If END is omitted, it defaults to the length of the sequence.
@ -522,6 +555,7 @@ If START or END is negative, it counts from the end."
(setq i (1+ i) start (1+ start)))
res))))))
;;;###autoload
(defun concatenate (type &rest seqs)
"Concatenate, into a sequence of type TYPE, the argument SEQUENCEs.
\n(fn TYPE SEQUENCE...)"
@ -533,14 +567,17 @@ If START or END is negative, it counts from the end."
;;; List functions.
;;;###autoload
(defun revappend (x y)
"Equivalent to (append (reverse X) Y)."
(nconc (reverse x) y))
;;;###autoload
(defun nreconc (x y)
"Equivalent to (nconc (nreverse X) Y)."
(nconc (nreverse x) y))
;;;###autoload
(defun list-length (x)
"Return the length of list X. Return nil if list is circular."
(let ((n 0) (fast x) (slow x))
@ -548,6 +585,7 @@ If START or END is negative, it counts from the end."
(setq n (+ n 2) fast (cdr (cdr fast)) slow (cdr slow)))
(if fast (if (cdr fast) nil (1+ n)) n)))
;;;###autoload
(defun tailp (sublist list)
"Return true if SUBLIST is a tail of LIST."
(while (and (consp list) (not (eq sublist list)))
@ -559,6 +597,7 @@ If START or END is negative, it counts from the end."
;;; Property lists.
;;;###autoload
(defun get* (sym tag &optional def) ; See compiler macro in cl-macs.el
"Return the value of SYMBOL's PROPNAME property, or DEFAULT if none.
\n(fn SYMBOL PROPNAME &optional DEFAULT)"
@ -569,6 +608,7 @@ If START or END is negative, it counts from the end."
(setq plist (cdr (cdr plist))))
(if plist (car (cdr plist)) def)))))
;;;###autoload
(defun getf (plist tag &optional def)
"Search PROPLIST for property PROPNAME; return its value or DEFAULT.
PROPLIST is a list of the sort returned by `symbol-plist'.
@ -583,16 +623,19 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
(setq plist (cdr (cdr plist))))
(if plist (car (cdr plist)) def))))
;;;###autoload
(defun cl-set-getf (plist tag val)
(let ((p plist))
(while (and p (not (eq (car p) tag))) (setq p (cdr (cdr p))))
(if p (progn (setcar (cdr p) val) plist) (list* tag val plist))))
;;;###autoload
(defun cl-do-remf (plist tag)
(let ((p (cdr plist)))
(while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p))))
(and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t))))
;;;###autoload
(defun cl-remprop (sym tag)
"Remove from SYMBOL's plist the property PROPNAME and its value.
\n(fn SYMBOL PROPNAME)"
@ -600,6 +643,7 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
(if (and plist (eq tag (car plist)))
(progn (setplist sym (cdr (cdr plist))) t)
(cl-do-remf plist tag))))
;;;###autoload
(defalias 'remprop 'cl-remprop)
@ -616,14 +660,22 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
(defvar cl-builtin-clrhash (symbol-function 'clrhash))
(defvar cl-builtin-maphash (symbol-function 'maphash))
;;;###autoload
(defalias 'cl-gethash 'gethash)
;;;###autoload
(defalias 'cl-puthash 'puthash)
;;;###autoload
(defalias 'cl-remhash 'remhash)
;;;###autoload
(defalias 'cl-clrhash 'clrhash)
;;;###autoload
(defalias 'cl-maphash 'maphash)
;; These three actually didn't exist in Emacs-20.
;;;###autoload
(defalias 'cl-make-hash-table 'make-hash-table)
;;;###autoload
(defalias 'cl-hash-table-p 'hash-table-p)
;;;###autoload
(defalias 'cl-hash-table-count 'hash-table-count)
;;; Some debugging aids.
@ -672,6 +724,7 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
(defvar cl-macroexpand-cmacs nil)
(defvar cl-closure-vars nil)
;;;###autoload
(defun cl-macroexpand-all (form &optional env)
"Expand all macro calls through a Lisp FORM.
This also does some trivial optimizations to make the form prettier."
@ -753,6 +806,7 @@ This also does some trivial optimizations to make the form prettier."
(defun cl-macroexpand-body (body &optional env)
(mapcar (function (lambda (x) (cl-macroexpand-all x env))) body))
;;;###autoload
(defun cl-prettyexpand (form &optional full)
(message "Expanding...")
(let ((cl-macroexpand-cmacs full) (cl-compiling-file full)
@ -767,5 +821,9 @@ This also does some trivial optimizations to make the form prettier."
(run-hooks 'cl-extra-load-hook)
;; Local variables:
;; generated-autoload-file: "cl-loaddefs.el"
;; End:
;; arch-tag: bcd03437-0871-43fb-a8f1-ad0e0b5427ed
;;; cl-extra.el ends here

1234
lisp/emacs-lisp/cl-loaddefs.el Normal file
View File

File diff suppressed because it is too large Load Diff

77
lisp/emacs-lisp/cl-macs.el
View File

@ -58,8 +58,8 @@
(defvar cl-optimize-speed)
;;; This kludge allows macros which use cl-transform-function-property
;;; to be called at compile-time.
;; This kludge allows macros which use cl-transform-function-property
;; to be called at compile-time.
(require
(progn
@ -75,6 +75,7 @@
(defvar cl-old-bc-file-form nil)
;;;###autoload
(defun cl-compile-time-init ()
(run-hooks 'cl-hack-bytecomp-hook))
@ -165,6 +166,7 @@
;;; Symbols.
(defvar *gensym-counter*)
;;;###autoload
(defun gensym (&optional prefix)
"Generate a new uninterned symbol.
The name is made by appending a number to PREFIX, default \"G\"."
@ -174,6 +176,7 @@ The name is made by appending a number to PREFIX, default \"G\"."
(setq *gensym-counter* (1+ *gensym-counter*))))))
(make-symbol (format "%s%d" pfix num))))
;;;###autoload
(defun gentemp (&optional prefix)
"Generate a new interned symbol with a unique name.
The name is made by appending a number to PREFIX, default \"G\"."
@ -186,6 +189,7 @@ The name is made by appending a number to PREFIX, default \"G\"."
;;; Program structure.
;;;###autoload
(defmacro defun* (name args &rest body)
"Define NAME as a function.
Like normal `defun', except ARGLIST allows full Common Lisp conventions,
@ -196,6 +200,7 @@ and BODY is implicitly surrounded by (block NAME ...).
(form (list* 'defun name (cdr res))))
(if (car res) (list 'progn (car res) form) form)))
;;;###autoload
(defmacro defmacro* (name args &rest body)
"Define NAME as a macro.
Like normal `defmacro', except ARGLIST allows full Common Lisp conventions,
@ -206,6 +211,7 @@ and BODY is implicitly surrounded by (block NAME ...).
(form (list* 'defmacro name (cdr res))))
(if (car res) (list 'progn (car res) form) form)))
;;;###autoload
(defmacro function* (func)
"Introduce a function.
Like normal `function', except that if argument is a lambda form,
@ -422,6 +428,7 @@ its argument list allows full Common Lisp conventions."
(setq res (nconc res (cl-arglist-args arg))))))
(nconc res (and args (list args))))))
;;;###autoload
(defmacro destructuring-bind (args expr &rest body)
(let* ((bind-lets nil) (bind-forms nil) (bind-inits nil)
(bind-defs nil) (bind-block 'cl-none))
@ -435,6 +442,7 @@ its argument list allows full Common Lisp conventions."
(defvar cl-not-toplevel nil)
;;;###autoload
(defmacro eval-when (when &rest body)
"Control when BODY is evaluated.
If `compile' is in WHEN, BODY is evaluated when compiled at top-level.
@ -466,6 +474,7 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level.
form)))
(t (eval form) form)))
;;;###autoload
(defmacro load-time-value (form &optional read-only)
"Like `progn', but evaluates the body at load time.
The result of the body appears to the compiler as a quoted constant."
@ -488,6 +497,7 @@ The result of the body appears to the compiler as a quoted constant."
;;; Conditional control structures.
;;;###autoload
(defmacro case (expr &rest clauses)
"Eval EXPR and choose among clauses on that value.
Each clause looks like (KEYLIST BODY...). EXPR is evaluated and compared
@ -522,12 +532,14 @@ Key values are compared by `eql'.
(if (eq temp expr) body
(list 'let (list (list temp expr)) body))))
;;;###autoload
(defmacro ecase (expr &rest clauses)
"Like `case', but error if no case fits.
`otherwise'-clauses are not allowed.
\n(fn EXPR (KEYLIST BODY...)...)"
(list* 'case expr (append clauses '((ecase-error-flag)))))
;;;###autoload
(defmacro typecase (expr &rest clauses)
"Evals EXPR, chooses among clauses on that value.
Each clause looks like (TYPE BODY...). EXPR is evaluated and, if it
@ -554,6 +566,7 @@ final clause, and matches if no other keys match.
(if (eq temp expr) body
(list 'let (list (list temp expr)) body))))
;;;###autoload
(defmacro etypecase (expr &rest clauses)
"Like `typecase', but error if no case fits.
`otherwise'-clauses are not allowed.
@ -563,6 +576,7 @@ final clause, and matches if no other keys match.
;;; Blocks and exits.
;;;###autoload
(defmacro block (name &rest body)
"Define a lexically-scoped block named NAME.
NAME may be any symbol. Code inside the BODY forms can call `return-from'
@ -598,11 +612,13 @@ called from BODY."
(if cl-found (setcdr cl-found t)))
(byte-compile-normal-call (cons 'throw (cdr cl-form))))
;;;###autoload
(defmacro return (&optional result)
"Return from the block named nil.
This is equivalent to `(return-from nil RESULT)'."
(list 'return-from nil result))
;;;###autoload
(defmacro return-from (name &optional result)
"Return from the block named NAME.
This jump out to the innermost enclosing `(block NAME ...)' form,
@ -622,6 +638,7 @@ This is compatible with Common Lisp, but note that `defun' and
(defvar loop-result) (defvar loop-result-explicit)
(defvar loop-result-var) (defvar loop-steps) (defvar loop-symbol-macs)
;;;###autoload
(defmacro loop (&rest args)
"The Common Lisp `loop' macro.
Valid clauses are:
@ -1181,12 +1198,14 @@ Valid clauses are:
;;; Other iteration control structures.
;;;###autoload
(defmacro do (steps endtest &rest body)
"The Common Lisp `do' loop.
\(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)"
(cl-expand-do-loop steps endtest body nil))
;;;###autoload
(defmacro do* (steps endtest &rest body)
"The Common Lisp `do*' loop.
@ -1214,6 +1233,7 @@ Valid clauses are:
(apply 'append sets)))))))
(or (cdr endtest) '(nil)))))
;;;###autoload
(defmacro dolist (spec &rest body)
"Loop over a list.
Evaluate BODY with VAR bound to each `car' from LIST, in turn.
@ -1230,6 +1250,7 @@ Then evaluate RESULT to get return value, default nil.
(cons (list 'setq (car spec) nil) (cdr (cdr spec)))
'(nil))))))
;;;###autoload
(defmacro dotimes (spec &rest body)
"Loop a certain number of times.
Evaluate BODY with VAR bound to successive integers from 0, inclusive,
@ -1244,6 +1265,7 @@ nil.
(append body (list (list 'incf (car spec)))))
(or (cdr (cdr spec)) '(nil))))))
;;;###autoload
(defmacro do-symbols (spec &rest body)
"Loop over all symbols.
Evaluate BODY with VAR bound to each interned symbol, or to each symbol
@ -1258,12 +1280,14 @@ from OBARRAY.
(and (cadr spec) (list (cadr spec))))
(caddr spec))))
;;;###autoload
(defmacro do-all-symbols (spec &rest body)
(list* 'do-symbols (list (car spec) nil (cadr spec)) body))
;;; Assignments.
;;;###autoload
(defmacro psetq (&rest args)
"Set SYMs to the values VALs in parallel.
This is like `setq', except that all VAL forms are evaluated (in order)
@ -1275,6 +1299,7 @@ before assigning any symbols SYM to the corresponding values.
;;; Binding control structures.
;;;###autoload
(defmacro progv (symbols values &rest body)
"Bind SYMBOLS to VALUES dynamically in BODY.
The forms SYMBOLS and VALUES are evaluated, and must evaluate to lists.
@ -1288,6 +1313,7 @@ a `let' form, except that the list of symbols can be computed at run-time."
'(cl-progv-after))))
;;; This should really have some way to shadow 'byte-compile properties, etc.
;;;###autoload
(defmacro flet (bindings &rest body)
"Make temporary function definitions.
This is an analogue of `let' that operates on the function cell of FUNC
@ -1315,6 +1341,7 @@ go back to their previous definitions, or lack thereof).
bindings)
body))
;;;###autoload
(defmacro labels (bindings &rest body)
"Make temporary function bindings.
This is like `flet', except the bindings are lexical instead of dynamic.
@ -1339,6 +1366,7 @@ Unlike `flet', this macro is fully compliant with the Common Lisp standard.
;; The following ought to have a better definition for use with newer
;; byte compilers.
;;;###autoload
(defmacro macrolet (bindings &rest body)
"Make temporary macro definitions.
This is like `flet', but for macros instead of functions.
@ -1355,6 +1383,7 @@ This is like `flet', but for macros instead of functions.
(cons (list* name 'lambda (cdr res))
cl-macro-environment))))))
;;;###autoload
(defmacro symbol-macrolet (bindings &rest body)
"Make symbol macro definitions.
Within the body FORMs, references to the variable NAME will be replaced
@ -1371,6 +1400,7 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
cl-macro-environment)))))
(defvar cl-closure-vars nil)
;;;###autoload
(defmacro lexical-let (bindings &rest body)
"Like `let', but lexically scoped.
The main visible difference is that lambdas inside BODY will create
@ -1414,6 +1444,7 @@ lexical closures as in Common Lisp.
vars))
ebody))))
;;;###autoload
(defmacro lexical-let* (bindings &rest body)
"Like `let*', but lexically scoped.
The main visible difference is that lambdas inside BODY will create
@ -1434,6 +1465,7 @@ lexical closures as in Common Lisp.
;;; Multiple values.
;;;###autoload
(defmacro multiple-value-bind (vars form &rest body)
"Collect multiple return values.
FORM must return a list; the BODY is then executed with the first N elements
@ -1451,6 +1483,7 @@ a synonym for (list A B C).
vars))
body)))
;;;###autoload
(defmacro multiple-value-setq (vars form)
"Collect multiple return values.
FORM must return a list; the first N elements of this list are stored in
@ -1477,7 +1510,9 @@ values. For compatibility, (values A B C) is a synonym for (list A B C).
;;; Declarations.
;;;###autoload
(defmacro locally (&rest body) (cons 'progn body))
;;;###autoload
(defmacro the (type form) form)
(defvar cl-proclaim-history t) ; for future compilers
@ -1532,6 +1567,7 @@ values. For compatibility, (values A B C) is a synonym for (list A B C).
(while p (cl-do-proclaim (pop p) t))
(setq cl-proclaims-deferred nil))
;;;###autoload
(defmacro declare (&rest specs)
(if (cl-compiling-file)
(while specs
@ -1543,6 +1579,7 @@ values. For compatibility, (values A B C) is a synonym for (list A B C).
;;; Generalized variables.
;;;###autoload
(defmacro define-setf-method (func args &rest body)
"Define a `setf' method.
This method shows how to handle `setf's to places of the form (NAME ARGS...).
@ -1561,8 +1598,9 @@ form. See `defsetf' for a simpler way to define most setf-methods.
func 'setf-method (cons args body)))))
(defalias 'define-setf-expander 'define-setf-method)
;;;###autoload
(defmacro defsetf (func arg1 &rest args)
"(defsetf NAME FUNC): define a `setf' method.
"Define a `setf' method.
This macro is an easy-to-use substitute for `define-setf-method' that works
well for simple place forms. In the simple `defsetf' form, `setf's of
the form (setf (NAME ARGS...) VAL) are transformed to function or macro
@ -1836,6 +1874,7 @@ Example:
(list 'substring (nth 4 method) from-temp to-temp))))
;;; Getting and optimizing setf-methods.
;;;###autoload
(defun get-setf-method (place &optional env)
"Return a list of five values describing the setf-method for PLACE.
PLACE may be any Lisp form which can appear as the PLACE argument to
@ -1903,6 +1942,7 @@ a macro like `setf' or `incf'."
(not (eq (car-safe (symbol-function (car form))) 'macro))))
;;; The standard modify macros.
;;;###autoload
(defmacro setf (&rest args)
"Set each PLACE to the value of its VAL.
This is a generalized version of `setq'; the PLACEs may be symbolic
@ -1921,6 +1961,7 @@ The return value is the last VAL in the list.
(store (cl-setf-do-store (nth 1 method) (nth 1 args))))
(if (car method) (list 'let* (car method) store) store)))))
;;;###autoload
(defmacro psetf (&rest args)
"Set PLACEs to the values VALs in parallel.
This is like `setf', except that all VAL forms are evaluated (in order)
@ -1944,6 +1985,7 @@ before assigning any PLACEs to the corresponding values.
(setq expr (list 'setf (cadr args) (list 'prog1 (car args) expr))))
(list 'progn expr nil)))))
;;;###autoload
(defun cl-do-pop (place)
(if (cl-simple-expr-p place)
(list 'prog1 (list 'car place) (list 'setf place (list 'cdr place)))
@ -1956,6 +1998,7 @@ before assigning any PLACEs to the corresponding values.
(list 'car temp)
(cl-setf-do-store (nth 1 method) (list 'cdr temp)))))))
;;;###autoload
(defmacro remf (place tag)
"Remove TAG from property list PLACE.
PLACE may be a symbol, or any generalized variable allowed by `setf'.
@ -1976,6 +2019,7 @@ The form returns true if TAG was found and removed, nil otherwise."
t)
(list 'cl-do-remf tval ttag)))))
;;;###autoload
(defmacro shiftf (place &rest args)
"Shift left among PLACEs.
Example: (shiftf A B C) sets A to B, B to C, and returns the old A.
@ -1991,6 +2035,7 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'.
(prog1 ,(nth 2 method)
,(cl-setf-do-store (nth 1 method) `(shiftf ,@args))))))))
;;;###autoload
(defmacro rotatef (&rest args)
"Rotate left among PLACEs.
Example: (rotatef A B C) sets A to B, B to C, and C to A. It returns nil.
@ -2016,6 +2061,7 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'.
(list 'let* (append (car method) (list (list temp (nth 2 method))))
(cl-setf-do-store (nth 1 method) form) nil)))))
;;;###autoload
(defmacro letf (bindings &rest body)
"Temporarily bind to PLACEs.
This is the analogue of `let', but with generalized variables (in the
@ -2072,6 +2118,7 @@ the PLACE is not modified before executing BODY.
rev (cdr rev))))
(list* 'let* lets body))))
;;;###autoload
(defmacro letf* (bindings &rest body)
"Temporarily bind to PLACEs.
This is the analogue of `let*', but with generalized variables (in the
@ -2090,6 +2137,7 @@ the PLACE is not modified before executing BODY.
(setq body (list (list* 'letf (list (pop bindings)) body))))
(car body)))
;;;###autoload
(defmacro callf (func place &rest args)
"Set PLACE to (FUNC PLACE ARGS...).
FUNC should be an unquoted function name. PLACE may be a symbol,
@ -2104,6 +2152,7 @@ or any generalized variable allowed by `setf'.
(list* 'funcall (list 'function func)
rargs))))))
;;;###autoload
(defmacro callf2 (func arg1 place &rest args)
"Set PLACE to (FUNC ARG1 PLACE ARGS...).
Like `callf', but PLACE is the second argument of FUNC, not the first.
@ -2120,6 +2169,7 @@ Like `callf', but PLACE is the second argument of FUNC, not the first.
(list* 'funcall (list 'function func)
rargs)))))))
;;;###autoload
(defmacro define-modify-macro (name arglist func &optional doc)
"Define a `setf'-like modify macro.
If NAME is called, it combines its PLACE argument with the other arguments
@ -2134,6 +2184,7 @@ from ARGLIST using FUNC: (define-modify-macro incf (&optional (n 1)) +)"
;;; Structures.
;;;###autoload
(defmacro defstruct (struct &rest descs)
"Define a struct type.
This macro defines a new Lisp data type called NAME, which contains data
@ -2358,6 +2409,7 @@ copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors.
forms)
(cons 'progn (nreverse (cons (list 'quote name) forms)))))
;;;###autoload
(defun cl-struct-setf-expander (x name accessor pred-form pos)
(let* ((temp (make-symbol "--cl-x--")) (store (make-symbol "--cl-store--")))
(list (list temp) (list x) (list store)
@ -2426,11 +2478,13 @@ The type name can then be used in `typecase', `check-type', etc."
((eq (car type) 'satisfies) (list (cadr type) val))
(t (error "Bad type spec: %s" type)))))
;;;###autoload
(defun typep (object type) ; See compiler macro below.
"Check that OBJECT is of type TYPE.
TYPE is a Common Lisp-style type specifier."
(eval (cl-make-type-test 'object type)))
;;;###autoload
(defmacro check-type (form type &optional string)
"Verify that FORM is of type TYPE; signal an error if not.
STRING is an optional description of the desired type."
@ -2445,6 +2499,7 @@ STRING is an optional description of the desired type."
(if (eq temp form) (list 'progn body nil)
(list 'let (list (list temp form)) body nil)))))
;;;###autoload
(defmacro assert (form &optional show-args string &rest args)
"Verify that FORM returns non-nil; signal an error if not.
Second arg SHOW-ARGS means to include arguments of FORM in message.
@ -2466,6 +2521,7 @@ omitted, a default message listing FORM itself is used."
(list* 'list (list 'quote form) sargs))))
nil))))
;;;###autoload
(defmacro ignore-errors (&rest body)
"Execute BODY; if an error occurs, return nil.
Otherwise, return result of last form in BODY."
@ -2474,6 +2530,7 @@ Otherwise, return result of last form in BODY."
;;; Compiler macros.
;;;###autoload
(defmacro define-compiler-macro (func args &rest body)
"Define a compiler-only macro.
This is like `defmacro', but macro expansion occurs only if the call to
@ -2497,6 +2554,7 @@ and then returning foo."
(list 'put (list 'quote func) '(quote byte-compile)
'(quote cl-byte-compile-compiler-macro)))))
;;;###autoload
(defun compiler-macroexpand (form)
(while
(let ((func (car-safe form)) (handler nil))
@ -2552,9 +2610,9 @@ surrounded by (block NAME ...).
(if lets (list 'let lets body) body))))
;;; Compile-time optimizations for some functions defined in this package.
;;; Note that cl.el arranges to force cl-macs to be loaded at compile-time,
;;; mainly to make sure these macros will be present.
;; Compile-time optimizations for some functions defined in this package.
;; Note that cl.el arranges to force cl-macs to be loaded at compile-time,
;; mainly to make sure these macros will be present.
(put 'eql 'byte-compile nil)
(define-compiler-macro eql (&whole form a b)
@ -2665,9 +2723,10 @@ surrounded by (block NAME ...).
(run-hooks 'cl-macs-load-hook)
;;; Local variables:
;;; byte-compile-warnings: (redefine callargs free-vars unresolved obsolete noruntime)
;;; End:
;; Local variables:
;; byte-compile-warnings: (redefine callargs free-vars unresolved obsolete noruntime)
;; generated-autoload-file: "cl-loaddefs.el"
;; End:
;; arch-tag: afd947a6-b553-4df1-bba5-000be6388f46
;;; cl-macs.el ends here

64
lisp/emacs-lisp/cl-seq.el
View File

@ -125,6 +125,7 @@
(defvar cl-key)
;;;###autoload
(defun reduce (cl-func cl-seq &rest cl-keys)
"Reduce two-argument FUNCTION across SEQ.
\nKeywords supported: :start :end :from-end :initial-value :key
@ -145,6 +146,7 @@
(cl-check-key (pop cl-seq))))))
cl-accum)))
;;;###autoload
(defun fill (seq item &rest cl-keys)
"Fill the elements of SEQ with ITEM.
\nKeywords supported: :start :end
@ -164,6 +166,7 @@
(setq cl-start (1+ cl-start)))))
seq))
;;;###autoload
(defun replace (cl-seq1 cl-seq2 &rest cl-keys)
"Replace the elements of SEQ1 with the elements of SEQ2.
SEQ1 is destructively modified, then returned.
@ -206,6 +209,7 @@ SEQ1 is destructively modified, then returned.
(setq cl-start2 (1+ cl-start2) cl-start1 (1+ cl-start1))))))
cl-seq1))
;;;###autoload
(defun remove* (cl-item cl-seq &rest cl-keys)
"Remove all occurrences of ITEM in SEQ.
This is a non-destructive function; it makes a copy of SEQ if necessary
@ -251,6 +255,7 @@ to avoid corrupting the original SEQ.
cl-seq))
cl-seq)))))
;;;###autoload
(defun remove-if (cl-pred cl-list &rest cl-keys)
"Remove all items satisfying PREDICATE in SEQ.
This is a non-destructive function; it makes a copy of SEQ if necessary
@ -259,6 +264,7 @@ to avoid corrupting the original SEQ.
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'remove* nil cl-list :if cl-pred cl-keys))
;;;###autoload
(defun remove-if-not (cl-pred cl-list &rest cl-keys)
"Remove all items not satisfying PREDICATE in SEQ.
This is a non-destructive function; it makes a copy of SEQ if necessary
@ -267,6 +273,7 @@ to avoid corrupting the original SEQ.
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'remove* nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
(defun delete* (cl-item cl-seq &rest cl-keys)
"Remove all occurrences of ITEM in SEQ.
This is a destructive function; it reuses the storage of SEQ whenever possible.
@ -310,6 +317,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible.
cl-seq)
(apply 'remove* cl-item cl-seq cl-keys)))))
;;;###autoload
(defun delete-if (cl-pred cl-list &rest cl-keys)
"Remove all items satisfying PREDICATE in SEQ.
This is a destructive function; it reuses the storage of SEQ whenever possible.
@ -317,6 +325,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible.
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'delete* nil cl-list :if cl-pred cl-keys))
;;;###autoload
(defun delete-if-not (cl-pred cl-list &rest cl-keys)
"Remove all items not satisfying PREDICATE in SEQ.
This is a destructive function; it reuses the storage of SEQ whenever possible.
@ -324,12 +333,14 @@ This is a destructive function; it reuses the storage of SEQ whenever possible.
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'delete* nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
(defun remove-duplicates (cl-seq &rest cl-keys)
"Return a copy of SEQ with all duplicate elements removed.
\nKeywords supported: :test :test-not :key :start :end :from-end
\n(fn SEQ [KEYWORD VALUE]...)"
(cl-delete-duplicates cl-seq cl-keys t))
;;;###autoload
(defun delete-duplicates (cl-seq &rest cl-keys)
"Remove all duplicate elements from SEQ (destructively).
\nKeywords supported: :test :test-not :key :start :end :from-end
@ -376,6 +387,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible.
(let ((cl-res (cl-delete-duplicates (append cl-seq nil) cl-keys nil)))
(if (stringp cl-seq) (concat cl-res) (vconcat cl-res)))))
;;;###autoload
(defun substitute (cl-new cl-old cl-seq &rest cl-keys)
"Substitute NEW for OLD in SEQ.
This is a non-destructive function; it makes a copy of SEQ if necessary
@ -397,6 +409,7 @@ to avoid corrupting the original SEQ.
(apply 'nsubstitute cl-new cl-old cl-seq :count cl-count
:start cl-i cl-keys))))))
;;;###autoload
(defun substitute-if (cl-new cl-pred cl-list &rest cl-keys)
"Substitute NEW for all items satisfying PREDICATE in SEQ.
This is a non-destructive function; it makes a copy of SEQ if necessary
@ -405,6 +418,7 @@ to avoid corrupting the original SEQ.
\n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'substitute cl-new nil cl-list :if cl-pred cl-keys))
;;;###autoload
(defun substitute-if-not (cl-new cl-pred cl-list &rest cl-keys)
"Substitute NEW for all items not satisfying PREDICATE in SEQ.
This is a non-destructive function; it makes a copy of SEQ if necessary
@ -413,6 +427,7 @@ to avoid corrupting the original SEQ.
\n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'substitute cl-new nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
(defun nsubstitute (cl-new cl-old cl-seq &rest cl-keys)
"Substitute NEW for OLD in SEQ.
This is a destructive function; it reuses the storage of SEQ whenever possible.
@ -446,6 +461,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible.
(setq cl-start (1+ cl-start))))))
cl-seq))
;;;###autoload
(defun nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys)
"Substitute NEW for all items satisfying PREDICATE in SEQ.
This is a destructive function; it reuses the storage of SEQ whenever possible.
@ -453,6 +469,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible.
\n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'nsubstitute cl-new nil cl-list :if cl-pred cl-keys))
;;;###autoload
(defun nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys)
"Substitute NEW for all items not satisfying PREDICATE in SEQ.
This is a destructive function; it reuses the storage of SEQ whenever possible.
@ -460,6 +477,7 @@ This is a destructive function; it reuses the storage of SEQ whenever possible.
\n(fn NEW PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'nsubstitute cl-new nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
(defun find (cl-item cl-seq &rest cl-keys)
"Find the first occurrence of ITEM in SEQ.
Return the matching ITEM, or nil if not found.
@ -468,6 +486,7 @@ Return the matching ITEM, or nil if not found.
(let ((cl-pos (apply 'position cl-item cl-seq cl-keys)))
(and cl-pos (elt cl-seq cl-pos))))
;;;###autoload
(defun find-if (cl-pred cl-list &rest cl-keys)
"Find the first item satisfying PREDICATE in SEQ.
Return the matching item, or nil if not found.
@ -475,6 +494,7 @@ Return the matching item, or nil if not found.
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'find nil cl-list :if cl-pred cl-keys))
;;;###autoload
(defun find-if-not (cl-pred cl-list &rest cl-keys)
"Find the first item not satisfying PREDICATE in SEQ.
Return the matching item, or nil if not found.
@ -482,6 +502,7 @@ Return the matching item, or nil if not found.
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'find nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
(defun position (cl-item cl-seq &rest cl-keys)
"Find the first occurrence of ITEM in SEQ.
Return the index of the matching item, or nil if not found.
@ -512,6 +533,7 @@ Return the index of the matching item, or nil if not found.
(setq cl-start (1+ cl-start)))
(and (< cl-start cl-end) cl-start))))
;;;###autoload
(defun position-if (cl-pred cl-list &rest cl-keys)
"Find the first item satisfying PREDICATE in SEQ.
Return the index of the matching item, or nil if not found.
@ -519,6 +541,7 @@ Return the index of the matching item, or nil if not found.
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'position nil cl-list :if cl-pred cl-keys))
;;;###autoload
(defun position-if-not (cl-pred cl-list &rest cl-keys)
"Find the first item not satisfying PREDICATE in SEQ.
Return the index of the matching item, or nil if not found.
@ -526,6 +549,7 @@ Return the index of the matching item, or nil if not found.
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'position nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
(defun count (cl-item cl-seq &rest cl-keys)
"Count the number of occurrences of ITEM in SEQ.
\nKeywords supported: :test :test-not :key :start :end
@ -540,18 +564,21 @@ Return the index of the matching item, or nil if not found.
(setq cl-start (1+ cl-start)))
cl-count)))
;;;###autoload
(defun count-if (cl-pred cl-list &rest cl-keys)
"Count the number of items satisfying PREDICATE in SEQ.
\nKeywords supported: :key :start :end
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'count nil cl-list :if cl-pred cl-keys))
;;;###autoload
(defun count-if-not (cl-pred cl-list &rest cl-keys)
"Count the number of items not satisfying PREDICATE in SEQ.
\nKeywords supported: :key :start :end
\n(fn PREDICATE SEQ [KEYWORD VALUE]...)"
(apply 'count nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
(defun mismatch (cl-seq1 cl-seq2 &rest cl-keys)
"Compare SEQ1 with SEQ2, return index of first mismatching element.
Return nil if the sequences match. If one sequence is a prefix of the
@ -582,6 +609,7 @@ other, the return value indicates the end of the shorter sequence.
(and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2))
cl-start1)))))
;;;###autoload
(defun search (cl-seq1 cl-seq2 &rest cl-keys)
"Search for SEQ1 as a subsequence of SEQ2.
Return the index of the leftmost element of the first match found;
@ -608,6 +636,7 @@ return nil if there are no matches.
(if cl-from-end (setq cl-end2 cl-pos) (setq cl-start2 (1+ cl-pos))))
(and (< cl-start2 cl-end2) cl-pos)))))
;;;###autoload
(defun sort* (cl-seq cl-pred &rest cl-keys)
"Sort the argument SEQ according to PREDICATE.
This is a destructive function; it reuses the storage of SEQ if possible.
@ -622,6 +651,7 @@ This is a destructive function; it reuses the storage of SEQ if possible.
(funcall cl-pred (funcall cl-key cl-x)
(funcall cl-key cl-y)))))))))
;;;###autoload
(defun stable-sort (cl-seq cl-pred &rest cl-keys)
"Sort the argument SEQ stably according to PREDICATE.
This is a destructive function; it reuses the storage of SEQ if possible.
@ -629,6 +659,7 @@ This is a destructive function; it reuses the storage of SEQ if possible.
\n(fn SEQ PREDICATE [KEYWORD VALUE]...)"
(apply 'sort* cl-seq cl-pred cl-keys))
;;;###autoload
(defun merge (cl-type cl-seq1 cl-seq2 cl-pred &rest cl-keys)
"Destructively merge the two sequences to produce a new sequence.
TYPE is the sequence type to return, SEQ1 and SEQ2 are the two argument
@ -647,6 +678,7 @@ sequences, and PREDICATE is a `less-than' predicate on the elements.
(coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type))))
;;; See compiler macro in cl-macs.el
;;;###autoload
(defun member* (cl-item cl-list &rest cl-keys)
"Find the first occurrence of ITEM in LIST.
Return the sublist of LIST whose car is ITEM.
@ -661,6 +693,7 @@ Return the sublist of LIST whose car is ITEM.
(member cl-item cl-list)
(memq cl-item cl-list))))
;;;###autoload
(defun member-if (cl-pred cl-list &rest cl-keys)
"Find the first item satisfying PREDICATE in LIST.
Return the sublist of LIST whose car matches.
@ -668,6 +701,7 @@ Return the sublist of LIST whose car matches.
\n(fn PREDICATE LIST [KEYWORD VALUE]...)"
(apply 'member* nil cl-list :if cl-pred cl-keys))
;;;###autoload
(defun member-if-not (cl-pred cl-list &rest cl-keys)
"Find the first item not satisfying PREDICATE in LIST.
Return the sublist of LIST whose car matches.
@ -675,6 +709,7 @@ Return the sublist of LIST whose car matches.
\n(fn PREDICATE LIST [KEYWORD VALUE]...)"
(apply 'member* nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
(defun cl-adjoin (cl-item cl-list &rest cl-keys)
(if (cl-parsing-keywords (:key) t
(apply 'member* (cl-check-key cl-item) cl-list cl-keys))
@ -682,6 +717,7 @@ Return the sublist of LIST whose car matches.
(cons cl-item cl-list)))
;;; See compiler macro in cl-macs.el
;;;###autoload
(defun assoc* (cl-item cl-alist &rest cl-keys)
"Find the first item whose car matches ITEM in LIST.
\nKeywords supported: :test :test-not :key
@ -697,18 +733,21 @@ Return the sublist of LIST whose car matches.
(assoc cl-item cl-alist)
(assq cl-item cl-alist))))
;;;###autoload
(defun assoc-if (cl-pred cl-list &rest cl-keys)
"Find the first item whose car satisfies PREDICATE in LIST.
\nKeywords supported: :key
\n(fn PREDICATE LIST [KEYWORD VALUE]...)"
(apply 'assoc* nil cl-list :if cl-pred cl-keys))
;;;###autoload
(defun assoc-if-not (cl-pred cl-list &rest cl-keys)
"Find the first item whose car does not satisfy PREDICATE in LIST.
\nKeywords supported: :key
\n(fn PREDICATE LIST [KEYWORD VALUE]...)"
(apply 'assoc* nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
(defun rassoc* (cl-item cl-alist &rest cl-keys)
"Find the first item whose cdr matches ITEM in LIST.
\nKeywords supported: :test :test-not :key
@ -722,18 +761,21 @@ Return the sublist of LIST whose car matches.
(and cl-alist (car cl-alist)))
(rassq cl-item cl-alist)))
;;;###autoload
(defun rassoc-if (cl-pred cl-list &rest cl-keys)
"Find the first item whose cdr satisfies PREDICATE in LIST.
\nKeywords supported: :key
\n(fn PREDICATE LIST [KEYWORD VALUE]...)"
(apply 'rassoc* nil cl-list :if cl-pred cl-keys))
;;;###autoload
(defun rassoc-if-not (cl-pred cl-list &rest cl-keys)
"Find the first item whose cdr does not satisfy PREDICATE in LIST.
\nKeywords supported: :key
\n(fn PREDICATE LIST [KEYWORD VALUE]...)"
(apply 'rassoc* nil cl-list :if-not cl-pred cl-keys))
;;;###autoload
(defun union (cl-list1 cl-list2 &rest cl-keys)
"Combine LIST1 and LIST2 using a set-union operation.
The result list contains all items that appear in either LIST1 or LIST2.
@ -754,6 +796,7 @@ to avoid corrupting the original LIST1 and LIST2.
(pop cl-list2))
cl-list1)))
;;;###autoload
(defun nunion (cl-list1 cl-list2 &rest cl-keys)
"Combine LIST1 and LIST2 using a set-union operation.
The result list contains all items that appear in either LIST1 or LIST2.
@ -764,6 +807,7 @@ whenever possible.
(cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1)
(t (apply 'union cl-list1 cl-list2 cl-keys))))
;;;###autoload
(defun intersection (cl-list1 cl-list2 &rest cl-keys)
"Combine LIST1 and LIST2 using a set-intersection operation.
The result list contains all items that appear in both LIST1 and LIST2.
@ -786,6 +830,7 @@ to avoid corrupting the original LIST1 and LIST2.
(pop cl-list2))
cl-res)))))
;;;###autoload
(defun nintersection (cl-list1 cl-list2 &rest cl-keys)
"Combine LIST1 and LIST2 using a set-intersection operation.
The result list contains all items that appear in both LIST1 and LIST2.
@ -795,6 +840,7 @@ whenever possible.
\n(fn LIST1 LIST2 [KEYWORD VALUE]...)"
(and cl-list1 cl-list2 (apply 'intersection cl-list1 cl-list2 cl-keys)))
;;;###autoload
(defun set-difference (cl-list1 cl-list2 &rest cl-keys)
"Combine LIST1 and LIST2 using a set-difference operation.
The result list contains all items that appear in LIST1 but not LIST2.
@ -814,6 +860,7 @@ to avoid corrupting the original LIST1 and LIST2.
(pop cl-list1))
cl-res))))
;;;###autoload
(defun nset-difference (cl-list1 cl-list2 &rest cl-keys)
"Combine LIST1 and LIST2 using a set-difference operation.
The result list contains all items that appear in LIST1 but not LIST2.
@ -824,6 +871,7 @@ whenever possible.
(if (or (null cl-list1) (null cl-list2)) cl-list1
(apply 'set-difference cl-list1 cl-list2 cl-keys)))
;;;###autoload
(defun set-exclusive-or (cl-list1 cl-list2 &rest cl-keys)
"Combine LIST1 and LIST2 using a set-exclusive-or operation.
The result list contains all items that appear in exactly one of LIST1, LIST2.
@ -836,6 +884,7 @@ to avoid corrupting the original LIST1 and LIST2.
(t (append (apply 'set-difference cl-list1 cl-list2 cl-keys)
(apply 'set-difference cl-list2 cl-list1 cl-keys)))))
;;;###autoload
(defun nset-exclusive-or (cl-list1 cl-list2 &rest cl-keys)
"Combine LIST1 and LIST2 using a set-exclusive-or operation.
The result list contains all items that appear in exactly one of LIST1, LIST2.
@ -848,6 +897,7 @@ whenever possible.
(t (nconc (apply 'nset-difference cl-list1 cl-list2 cl-keys)
(apply 'nset-difference cl-list2 cl-list1 cl-keys)))))
;;;###autoload
(defun subsetp (cl-list1 cl-list2 &rest cl-keys)
"Return true if LIST1 is a subset of LIST2.
I.e., if every element of LIST1 also appears in LIST2.
@ -862,6 +912,7 @@ I.e., if every element of LIST1 also appears in LIST2.
(pop cl-list1))
(null cl-list1)))))
;;;###autoload
(defun subst-if (cl-new cl-pred cl-tree &rest cl-keys)
"Substitute NEW for elements matching PREDICATE in TREE (non-destructively).
Return a copy of TREE with all matching elements replaced by NEW.
@ -869,6 +920,7 @@ Return a copy of TREE with all matching elements replaced by NEW.
\n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)"
(apply 'sublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys))
;;;###autoload
(defun subst-if-not (cl-new cl-pred cl-tree &rest cl-keys)
"Substitute NEW for elts not matching PREDICATE in TREE (non-destructively).
Return a copy of TREE with all non-matching elements replaced by NEW.
@ -876,6 +928,7 @@ Return a copy of TREE with all non-matching elements replaced by NEW.
\n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)"
(apply 'sublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys))
;;;###autoload
(defun nsubst (cl-new cl-old cl-tree &rest cl-keys)
"Substitute NEW for OLD everywhere in TREE (destructively).
Any element of TREE which is `eql' to OLD is changed to NEW (via a call
@ -884,6 +937,7 @@ to `setcar').
\n(fn NEW OLD TREE [KEYWORD VALUE]...)"
(apply 'nsublis (list (cons cl-old cl-new)) cl-tree cl-keys))
;;;###autoload
(defun nsubst-if (cl-new cl-pred cl-tree &rest cl-keys)
"Substitute NEW for elements matching PREDICATE in TREE (destructively).
Any element of TREE which matches is changed to NEW (via a call to `setcar').
@ -891,6 +945,7 @@ Any element of TREE which matches is changed to NEW (via a call to `setcar').
\n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)"
(apply 'nsublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys))
;;;###autoload
(defun nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys)
"Substitute NEW for elements not matching PREDICATE in TREE (destructively).
Any element of TREE which matches is changed to NEW (via a call to `setcar').
@ -898,6 +953,7 @@ Any element of TREE which matches is changed to NEW (via a call to `setcar').
\n(fn NEW PREDICATE TREE [KEYWORD VALUE]...)"
(apply 'nsublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys))
;;;###autoload
(defun sublis (cl-alist cl-tree &rest cl-keys)
"Perform substitutions indicated by ALIST in TREE (non-destructively).
Return a copy of TREE with all matching elements replaced.
@ -920,6 +976,7 @@ Return a copy of TREE with all matching elements replaced.
(cons cl-a cl-d)))
cl-tree))))
;;;###autoload
(defun nsublis (cl-alist cl-tree &rest cl-keys)
"Perform substitutions indicated by ALIST in TREE (destructively).
Any matching element of TREE is changed via a call to `setcar'.
@ -944,6 +1001,7 @@ Any matching element of TREE is changed via a call to `setcar'.
(progn (setcdr cl-tree (cdr (car cl-p))) (setq cl-tree nil))
(setq cl-tree (cdr cl-tree))))))
;;;###autoload
(defun tree-equal (cl-x cl-y &rest cl-keys)
"Return t if trees TREE1 and TREE2 have `eql' leaves.
Atoms are compared by `eql'; cons cells are compared recursively.
@ -961,5 +1019,9 @@ Atoms are compared by `eql'; cons cells are compared recursively.
(run-hooks 'cl-seq-load-hook)
;;; arch-tag: ec1cc072-9006-4225-b6ba-d6b07ed1710c
;; Local variables:
;; generated-autoload-file: "cl-loaddefs.el"
;; End:
;; arch-tag: ec1cc072-9006-4225-b6ba-d6b07ed1710c
;;; cl-seq.el ends here

158
lisp/emacs-lisp/cl.el
View File

@ -113,8 +113,9 @@ a future Emacs interpreter will be able to use it.")
(defun cl-cannot-unload ()
(error "Cannot unload the feature `cl'"))
;;; Generalized variables. These macros are defined here so that they
;;; can safely be used in .emacs files.
;;; Generalized variables.
;; These macros are defined here so that they
;; can safely be used in .emacs files.
(defmacro incf (place &optional x)
"Increment PLACE by X (1 by default).
@ -185,8 +186,8 @@ an element already on the list.
;;; Control structures.
;;; These macros are so simple and so often-used that it's better to have
;;; them all the time than to load them from cl-macs.el.
;; These macros are so simple and so often-used that it's better to have
;; them all the time than to load them from cl-macs.el.
(defun cl-map-extents (&rest cl-args)
(apply 'cl-map-overlays cl-args))
@ -198,9 +199,10 @@ an element already on the list.
(defalias 'cl-block-throw 'throw)
;;; Multiple values. True multiple values are not supported, or even
;;; simulated. Instead, multiple-value-bind and friends simply expect
;;; the target form to return the values as a list.
;;; Multiple values.
;; True multiple values are not supported, or even
;; simulated. Instead, multiple-value-bind and friends simply expect
;; the target form to return the values as a list.
(defsubst values (&rest values)
"Return multiple values, Common Lisp style.
@ -321,7 +323,7 @@ always returns nil."
(defvar *random-state* (vector 'cl-random-state-tag -1 30 (cl-random-time)))
;;; The following are actually set by cl-float-limits.
;; The following are actually set by cl-float-limits.
(defconst most-positive-float nil)
(defconst most-negative-float nil)
(defconst least-positive-float nil)
@ -585,105 +587,55 @@ If ALIST is non-nil, the new pairs are prepended to it."
;;; Miscellaneous.
(defvar cl-fake-autoloads nil
"Non-nil means don't make CL functions autoload.")
;; Define data for indentation and edebug.
(dolist (entry
'(((defun* defmacro*) 2)
((function*) nil
(&or symbolp ([&optional 'macro] 'lambda (&rest sexp) &rest form)))
((eval-when) 1 (sexp &rest form))
((declare) nil (&rest sexp))
((the) 1 (sexp &rest form))
((case ecase typecase etypecase) 1 (form &rest (sexp &rest form)))
((block return-from) 1 (sexp &rest form))
((return) nil (&optional form))
((do do*) 2 ((&rest &or symbolp (symbolp &optional form form))
(form &rest form)
&rest form))
((do-symbols) 1 ((symbolp form &optional form form) &rest form))
((do-all-symbols) 1 ((symbolp form &optional form) &rest form))
((psetq setf psetf) nil edebug-setq-form)
((progv) 2 (&rest form))
((flet labels macrolet) 1
((&rest (sexp sexp &rest form)) &rest form))
((symbol-macrolet lexical-let lexical-let*) 1
((&rest &or symbolp (symbolp form)) &rest form))
((multiple-value-bind) 2 ((&rest symbolp) &rest form))
((multiple-value-setq) 1 ((&rest symbolp) &rest form))
((incf decf remf pushnew shiftf rotatef) nil (&rest form))
((letf letf*) 1 ((&rest (&rest form)) &rest form))
((callf destructuring-bind) 2 (sexp form &rest form))
((callf2) 3 (sexp form form &rest form))
((loop) nil (&rest &or symbolp form))
((ignore-errors) 0 (&rest form))))
(dolist (func (car entry))
(put func 'lisp-indent-function (nth 1 entry))
(put func 'lisp-indent-hook (nth 1 entry))
(or (get func 'edebug-form-spec)
(put func 'edebug-form-spec (nth 2 entry)))))
;;; Autoload the other portions of the package.
;; Autoload the other portions of the package.
;; We want to replace the basic versions of dolist, dotimes, declare below.
(fmakunbound 'dolist)
(fmakunbound 'dotimes)
(fmakunbound 'declare)
(mapcar (function
(lambda (set)
(let ((file (if cl-fake-autoloads "<none>" (car set))))
(mapcar (function
(lambda (func)
(autoload func (car set) nil nil (nth 1 set))))
(cddr set)))))
'(("cl-extra" nil
coerce equalp cl-map-keymap maplist mapc mapl mapcan mapcon
cl-map-keymap cl-map-keymap-recursively cl-map-intervals
cl-map-overlays cl-set-frame-visible-p cl-float-limits
gcd lcm isqrt floor* ceiling* truncate* round*
mod* rem* signum random* make-random-state random-state-p
subseq concatenate cl-mapcar-many map some every notany
notevery revappend nreconc list-length tailp copy-tree get* getf
cl-set-getf cl-do-remf remprop cl-make-hash-table cl-hash-lookup
cl-gethash cl-puthash cl-remhash cl-clrhash cl-maphash cl-hash-table-p
cl-hash-table-count cl-progv-before cl-prettyexpand
cl-macroexpand-all)
("cl-seq" nil
reduce fill replace remove* remove-if remove-if-not
delete* delete-if delete-if-not remove-duplicates
delete-duplicates substitute substitute-if substitute-if-not
nsubstitute nsubstitute-if nsubstitute-if-not find find-if
find-if-not position position-if position-if-not count count-if
count-if-not mismatch search sort* stable-sort merge member*
member-if member-if-not cl-adjoin assoc* assoc-if assoc-if-not
rassoc* rassoc-if rassoc-if-not union nunion intersection
nintersection set-difference nset-difference set-exclusive-or
nset-exclusive-or subsetp subst-if subst-if-not nsubst nsubst-if
nsubst-if-not sublis nsublis tree-equal)
("cl-macs" nil
gensym gentemp typep cl-do-pop get-setf-method
cl-struct-setf-expander compiler-macroexpand cl-compile-time-init)
("cl-macs" t
defun* defmacro* function* destructuring-bind eval-when
load-time-value case ecase typecase etypecase
block return return-from loop do do* dolist dotimes do-symbols
do-all-symbols psetq progv flet labels macrolet symbol-macrolet
lexical-let lexical-let* multiple-value-bind multiple-value-setq
locally the declare define-setf-method defsetf define-modify-macro
setf psetf remf shiftf rotatef letf letf* callf callf2 defstruct
check-type assert ignore-errors define-compiler-macro)))
(load "cl-loaddefs" nil 'quiet)
;;; Define data for indentation and edebug.
(mapcar (function
(lambda (entry)
(mapcar (function
(lambda (func)
(put func 'lisp-indent-function (nth 1 entry))
(put func 'lisp-indent-hook (nth 1 entry))
(or (get func 'edebug-form-spec)
(put func 'edebug-form-spec (nth 2 entry)))))
(car entry))))
'(((defun* defmacro*) 2)
((function*) nil
(&or symbolp ([&optional 'macro] 'lambda (&rest sexp) &rest form)))
((eval-when) 1 (sexp &rest form))
((declare) nil (&rest sexp))
((the) 1 (sexp &rest form))
((case ecase typecase etypecase) 1 (form &rest (sexp &rest form)))
((block return-from) 1 (sexp &rest form))
((return) nil (&optional form))
((do do*) 2 ((&rest &or symbolp (symbolp &optional form form))
(form &rest form)
&rest form))
((do-symbols) 1 ((symbolp form &optional form form) &rest form))
((do-all-symbols) 1 ((symbolp form &optional form) &rest form))
((psetq setf psetf) nil edebug-setq-form)
((progv) 2 (&rest form))
((flet labels macrolet) 1
((&rest (sexp sexp &rest form)) &rest form))
((symbol-macrolet lexical-let lexical-let*) 1
((&rest &or symbolp (symbolp form)) &rest form))
((multiple-value-bind) 2 ((&rest symbolp) &rest form))
((multiple-value-setq) 1 ((&rest symbolp) &rest form))
((incf decf remf pushnew shiftf rotatef) nil (&rest form))
((letf letf*) 1 ((&rest (&rest form)) &rest form))
((callf destructuring-bind) 2 (sexp form &rest form))
((callf2) 3 (sexp form form &rest form))
((loop) nil (&rest &or symbolp form))
((ignore-errors) 0 (&rest form))))
;;; This goes here so that cl-macs can find it if it loads right now.
;; This goes here so that cl-macs can find it if it loads right now.
(provide 'cl-19) ; usage: (require 'cl-19 "cl")
;;; Things to do after byte-compiler is loaded.
;;; As a side effect, we cause cl-macs to be loaded when compiling, so
;;; that the compiler-macros defined there will be present.
;; Things to do after byte-compiler is loaded.
;; As a side effect, we cause cl-macs to be loaded when compiling, so
;; that the compiler-macros defined there will be present.
(defvar cl-hacked-flag nil)
(defun cl-hack-byte-compiler ()
@ -692,15 +644,15 @@ If ALIST is non-nil, the new pairs are prepended to it."
(setq cl-hacked-flag t) ; Do it first, to prevent recursion.
(cl-compile-time-init)))) ; In cl-macs.el.
;;; Try it now in case the compiler has already been loaded.
;; Try it now in case the compiler has already been loaded.
(cl-hack-byte-compiler)
;;; Also make a hook in case compiler is loaded after this file.
;; Also make a hook in case compiler is loaded after this file.
(add-hook 'bytecomp-load-hook 'cl-hack-byte-compiler)
;;; The following ensures that packages which expect the old-style cl.el
;;; will be happy with this one.
;; The following ensures that packages which expect the old-style cl.el
;; will be happy with this one.
(provide 'cl)

2
lisp/emacs-lisp/copyright.el
View File

@ -79,7 +79,7 @@ When this is `function', only ask when called non-interactively."
;; when modifying this, also modify the comment generated by autoinsert.el
(defconst copyright-current-gpl-version "2"
(defconst copyright-current-gpl-version "3"
"String representing the current version of the GPL or nil.")
(defvar copyright-update t)

40
lisp/emacs-lisp/easymenu.el
View File

@ -152,6 +152,21 @@ A menu item can be a list with the same format as MENU. This is a submenu."
,(if symbol `(defvar ,symbol nil ,doc))
(easy-menu-do-define (quote ,symbol) ,maps ,doc ,menu)))
(defun easy-menu-binding (menu &optional item-name)
"Return a binding suitable to pass to `define-key'.
This is expected to be bound to a mouse event."
;; Under Emacs this is almost trivial, whereas under XEmacs this may
;; involve defining a function that calls popup-menu.
(let ((props (if (symbolp menu)
(prog1 (get menu 'menu-prop)
(setq menu (symbol-function menu))))))
(cons 'menu-item
(cons (or item-name
(if (keymapp menu)
(keymap-prompt menu))
"")
(cons menu props)))))
;;;###autoload
(defun easy-menu-do-define (symbol maps doc menu)
;; We can't do anything that might differ between Emacs dialects in
@ -173,15 +188,10 @@ A menu item can be a list with the same format as MENU. This is a submenu."
'identity)
(symbol-function ,symbol)))
,symbol)))))
(mapcar (lambda (map)
(define-key map (vector 'menu-bar (easy-menu-intern (car menu)))
(cons 'menu-item
(cons (car menu)
(if (not (symbolp keymap))
(list keymap)
(cons (symbol-function keymap)
(get keymap 'menu-prop)))))))
(if (keymapp maps) (list maps) maps))))
(dolist (map (if (keymapp maps) (list maps) maps))
(define-key map
(vector 'menu-bar (easy-menu-intern (car menu)))
(easy-menu-binding keymap (car menu))))))
(defun easy-menu-filter-return (menu &optional name)
"Convert MENU to the right thing to return from a menu filter.
@ -249,10 +259,6 @@ possibly preceded by keyword pairs as described in `easy-menu-define'."
(defvar easy-menu-button-prefix
'((radio . :radio) (toggle . :toggle)))
(defun easy-menu-do-add-item (menu item &optional before)
(setq item (easy-menu-convert-item item))
(easy-menu-define-key menu (easy-menu-intern (car item)) (cdr item) before))
(defvar easy-menu-converted-items-table (make-hash-table :test 'equal))
(defun easy-menu-convert-item (item)
@ -269,7 +275,7 @@ would always fail because the key is `equal' but not `eq'."
(defun easy-menu-convert-item-1 (item)
"Parse an item description and convert it to a menu keymap element.
ITEM defines an item as in `easy-menu-define'."
(let (name command label prop remove help)
(let (name command label prop remove)
(cond
((stringp item) ; An item or separator.
(setq label item))
@ -536,7 +542,8 @@ earlier by `easy-menu-define' or `easy-menu-create-menu'."
(setq item (symbol-value item))))
;; Item is a keymap, find the prompt string and use as item name.
(setq item (cons (keymap-prompt item) item)))
(easy-menu-do-add-item map item before)))
(setq item (easy-menu-convert-item item))
(easy-menu-define-key map (easy-menu-intern (car item)) (cdr item) before)))
(defun easy-menu-item-present-p (map path name)
"In submenu of MAP with path PATH, return non-nil iff item NAME is present.
@ -615,7 +622,8 @@ In some cases we use that to select between the local and global maps."
(catch 'found
(if (and map (symbolp map) (not (keymapp map)))
(setq map (symbol-value map)))
(let ((maps (if map (list map) (current-active-maps))))
(let ((maps (if map (if (keymapp map) (list map) map)
(current-active-maps))))
;; Look for PATH in each map.
(unless map (push 'menu-bar path))
(dolist (name path)

118
lisp/emacs-lisp/eldoc.el
View File

@ -124,8 +124,8 @@ directly. Instead, use `eldoc-add-command' and `eldoc-remove-command'.")
(defconst eldoc-last-data (make-vector 3 nil)
"Bookkeeping; elements are as follows:
0 - contains the last symbol read from the buffer.
1 - contains the string last displayed in the echo area for that
symbol, so it can be printed again if necessary without reconsing.
1 - contains the string last displayed in the echo area for variables,
or argument string for functions.
2 - 'function if function args, 'variable if variable documentation.")
(defvar eldoc-last-message nil)
@ -249,12 +249,16 @@ Emacs Lisp mode) that support Eldoc.")
(let* ((current-symbol (eldoc-current-symbol))
(current-fnsym (eldoc-fnsym-in-current-sexp))
(doc (cond
((eq current-symbol current-fnsym)
(or (eldoc-get-fnsym-args-string current-fnsym)
((null current-fnsym)
nil)
((eq current-symbol (car current-fnsym))
(or (apply 'eldoc-get-fnsym-args-string
current-fnsym)
(eldoc-get-var-docstring current-symbol)))
(t
(or (eldoc-get-var-docstring current-symbol)
(eldoc-get-fnsym-args-string current-fnsym))))))
(apply 'eldoc-get-fnsym-args-string
current-fnsym))))))
(eldoc-message doc))))
;; This is run from post-command-hook or some idle timer thing,
;; so we need to be careful that errors aren't ignored.
@ -263,24 +267,62 @@ Emacs Lisp mode) that support Eldoc.")
;; Return a string containing the function parameter list, or 1-line
;; docstring if function is a subr and no arglist is obtainable from the
;; docstring or elsewhere.
(defun eldoc-get-fnsym-args-string (sym)
(defun eldoc-get-fnsym-args-string (sym argument-index)
(let ((args nil)
(doc nil))
(cond ((not (and sym (symbolp sym) (fboundp sym))))
((and (eq sym (aref eldoc-last-data 0))
(eq 'function (aref eldoc-last-data 2)))
(setq doc (aref eldoc-last-data 1)))
(setq args (aref eldoc-last-data 1)))
((setq doc (help-split-fundoc (documentation sym t) sym))
(setq args (car doc))
(string-match "\\`[^ )]* ?" args)
(setq args (concat "(" (substring args (match-end 0)))))
(setq args (concat "(" (substring args (match-end 0))))
(eldoc-last-data-store sym args 'function))
(t
(setq args (eldoc-function-argstring sym))))
(cond (args
(setq doc (eldoc-docstring-format-sym-doc sym args))
(eldoc-last-data-store sym doc 'function)))
(when args
(setq doc (eldoc-highlight-function-argument sym args argument-index)))
doc))
;; Highlight argument INDEX in ARGS list for SYM.
(defun eldoc-highlight-function-argument (sym args index)
(let ((start nil)
(end 0)
(argument-face 'bold))
;; Find the current argument in the argument string. We need to
;; handle `&rest' and informal `...' properly.
;;
;; FIXME: What to do with optional arguments, like in
;; (defun NAME ARGLIST [DOCSTRING] BODY...) case?
;; The problem is there is no robust way to determine if
;; the current argument is indeed a docstring.
(while (>= index 1)
(if (string-match "[^ ()]+" args end)
(progn
(setq start (match-beginning 0)
end (match-end 0))
(let ((argument (match-string 0 args)))
(cond ((string= argument "&rest")
;; All the rest arguments are the same.
(setq index 1))
((string= argument "&optional"))
((string-match "\\.\\.\\.$" argument)
(setq index 0))
(t
(setq index (1- index))))))
(setq end (length args)
start (1- end)
argument-face 'font-lock-warning-face
index 0)))
(let ((doc args))
(when start
(setq doc (copy-sequence args))
(add-text-properties start end (list 'face argument-face) doc))
(setq doc (eldoc-docstring-format-sym-doc
sym doc 'font-lock-function-name-face))
doc)))
;; Return a string containing a brief (one-line) documentation string for
;; the variable.
(defun eldoc-get-var-docstring (sym)
@ -292,7 +334,8 @@ Emacs Lisp mode) that support Eldoc.")
(let ((doc (documentation-property sym 'variable-documentation t)))
(cond (doc
(setq doc (eldoc-docstring-format-sym-doc
sym (eldoc-docstring-first-line doc)))
sym (eldoc-docstring-first-line doc)
'font-lock-variable-name-face))
(eldoc-last-data-store sym doc 'variable)))
doc)))))
@ -316,7 +359,7 @@ Emacs Lisp mode) that support Eldoc.")
;; If the entire line cannot fit in the echo area, the symbol name may be
;; truncated or eliminated entirely from the output to make room for the
;; description.
(defun eldoc-docstring-format-sym-doc (sym doc)
(defun eldoc-docstring-format-sym-doc (sym doc face)
(save-match-data
(let* ((name (symbol-name sym))
(ea-multi eldoc-echo-area-use-multiline-p)
@ -328,7 +371,7 @@ Emacs Lisp mode) that support Eldoc.")
(cond ((or (<= strip 0)
(eq ea-multi t)
(and ea-multi (> (length doc) ea-width)))
(format "%s: %s" sym doc))
(format "%s: %s" (propertize name 'face face) doc))
((> (length doc) ea-width)
(substring (format "%s" doc) 0 ea-width))
((>= strip (length name))
@ -338,27 +381,44 @@ Emacs Lisp mode) that support Eldoc.")
;; than the beginning, since the former is more likely
;; to be unique given package namespace conventions.
(setq name (substring name strip))
(format "%s: %s" name doc))))))
(format "%s: %s" (propertize name 'face face) doc))))))
;; Return a list of current function name and argument index.
(defun eldoc-fnsym-in-current-sexp ()
(let ((p (point)))
(eldoc-beginning-of-sexp)
(prog1
;; Don't do anything if current word is inside a string.
(if (= (or (char-after (1- (point))) 0) ?\")
nil
(eldoc-current-symbol))
(goto-char p))))
(save-excursion
(let ((argument-index (1- (eldoc-beginning-of-sexp))))
;; If we are at the beginning of function name, this will be -1.
(when (< argument-index 0)
(setq argument-index 0))
;; Don't do anything if current word is inside a string.
(if (= (or (char-after (1- (point))) 0) ?\")
nil
(list (eldoc-current-symbol) argument-index)))))
;; Move to the beginnig of current sexp. Return the number of nested
;; sexp the point was over or after.
(defun eldoc-beginning-of-sexp ()
(let ((parse-sexp-ignore-comments t))
(let ((parse-sexp-ignore-comments t)
(num-skipped-sexps 0))
(condition-case err
(while (progn
(forward-sexp -1)
(or (= (char-before) ?\")
(> (point) (point-min)))))
(error nil))))
(progn
;; First account for the case the point is directly over a
;; beginning of a nested sexp.
(condition-case err
(let ((p (point)))
(forward-sexp -1)
(forward-sexp 1)
(when (< (point) p)
(setq num-skipped-sexps 1)))
(error))
(while
(let ((p (point)))
(forward-sexp -1)
(when (< (point) p)
(setq num-skipped-sexps (1+ num-skipped-sexps))))))
(error))
num-skipped-sexps))
;; returns nil unless current word is an interned symbol.
(defun eldoc-current-symbol ()

18
lisp/emacs-lisp/lisp-mode.el
View File

@ -628,13 +628,13 @@ this command arranges for all errors to enter the debugger."
(interactive "P")
(if (null eval-expression-debug-on-error)
(eval-last-sexp-1 eval-last-sexp-arg-internal)
(let ((old-value eval-last-sexp-fake-value) new-value value)
(let ((debug-on-error old-value))
(setq value (eval-last-sexp-1 eval-last-sexp-arg-internal))
(setq new-value debug-on-error))
(unless (eq old-value new-value)
(setq debug-on-error new-value))
value)))
(let ((value
(let ((debug-on-error eval-last-sexp-fake-value))
(cons (eval-last-sexp-1 eval-last-sexp-arg-internal)
debug-on-error))))
(unless (eq (cdr value) eval-last-sexp-fake-value)
(setq debug-on-error (cdr value)))
(car value))))
(defun eval-defun-1 (form)
"Treat some expressions specially.
@ -730,7 +730,9 @@ If the current defun is actually a call to `defvar' or `defcustom',
evaluating it this way resets the variable using its initial value
expression even if the variable already has some other value.
\(Normally `defvar' and `defcustom' do not alter the value if there
already is one.)
already is one.) In an analogous way, evaluating a `defface'
overrides any customizations of the face, so that it becomes
defined exactly as the `defface' expression says.
If `eval-expression-debug-on-error' is non-nil, which is the default,
this command arranges for all errors to enter the debugger.

2
lisp/emacs-lisp/rx.el
View File

@ -120,7 +120,7 @@
(| . or) ; SRE
(not-newline . ".")
(nonl . not-newline) ; SRE
(anything . ".\\|\n")
(anything . "\\(?:.\\|\n\\)")
(any . (rx-any 1 nil rx-check-any)) ; inconsistent with SRE
(in . any)
(char . any) ; sregex

6
lisp/ffap.el
View File

@ -1793,7 +1793,11 @@ ffap most of the time."
;; Extra complication for the temporary highlighting.
(unwind-protect
(ffap-read-file-or-url
(if ffap-url-regexp "Dired file or URL: " "Dired file: ")
(cond
((eq ffap-directory-finder 'list-directory)
"List directory (brief): ")
(ffap-url-regexp "Dired file or URL: ")
(t "Dired file: "))
(prog1
(setq guess (or guess
(let ((guess (ffap-guesser)))

46
lisp/files.el
View File

@ -162,7 +162,7 @@ The truename of a file is found by chasing all links
both at the file level and at the levels of the containing directories."
:type 'boolean
:group 'find-file)
(put 'find-file-visit-truename 'safe-local-variable 'boolean)
(put 'find-file-visit-truename 'safe-local-variable 'booleanp)
(defcustom revert-without-query nil
"Specify which files should be reverted without query.
@ -727,17 +727,23 @@ This is an interface to the function `load'."
(cons load-path (get-load-suffixes)))))
(load library))
(defun file-remote-p (file)
(defun file-remote-p (file &optional connected)
"Test whether FILE specifies a location on a remote system.
Return an identification of the system if the location is indeed
remote. The identification of the system may comprise a method
to access the system and its hostname, amongst other things.
For example, the filename \"/user@host:/foo\" specifies a location
on the system \"/user@host:\"."
on the system \"/user@host:\".
If CONNECTED is non-nil, the function returns an identification only
if FILE is located on a remote system, and a connection is established
to that remote system.
`file-remote-p' will never open a connection on its own."
(let ((handler (find-file-name-handler file 'file-remote-p)))
(if handler
(funcall handler 'file-remote-p file)
(funcall handler 'file-remote-p file connected)
nil)))
(defun file-local-copy (file)
@ -1051,6 +1057,12 @@ Recursive uses of the minibuffer will not be affected."
,@body)
(remove-hook 'minibuffer-setup-hook ,hook)))))
(defcustom find-file-confirm-nonexistent-file nil
"If non-nil, `find-file' requires confirmation before visiting a new file."
:group 'find-file
:version "23.1"
:type 'boolean)
(defun find-file-read-args (prompt mustmatch)
(list (let ((find-file-default
(and buffer-file-name
@ -1074,7 +1086,9 @@ suppress wildcard expansion by setting `find-file-wildcards' to nil.
To visit a file without any kind of conversion and without
automatically choosing a major mode, use \\[find-file-literally]."
(interactive (find-file-read-args "Find file: " nil))
(interactive
(find-file-read-args "Find file: "
(if find-file-confirm-nonexistent-file 'confirm-only)))
(let ((value (find-file-noselect filename nil nil wildcards)))
(if (listp value)
(mapcar 'switch-to-buffer (nreverse value))
@ -1091,7 +1105,9 @@ type M-n to pull it into the minibuffer.
Interactively, or if WILDCARDS is non-nil in a call from Lisp,
expand wildcards (if any) and visit multiple files."
(interactive (find-file-read-args "Find file in other window: " nil))
(interactive
(find-file-read-args "Find file in other window: "
(if find-file-confirm-nonexistent-file 'confirm-only)))
(let ((value (find-file-noselect filename nil nil wildcards)))
(if (listp value)
(progn
@ -1111,7 +1127,9 @@ type M-n to pull it into the minibuffer.
Interactively, or if WILDCARDS is non-nil in a call from Lisp,
expand wildcards (if any) and visit multiple files."
(interactive (find-file-read-args "Find file in other frame: " nil))
(interactive
(find-file-read-args "Find file in other frame: "
(if find-file-confirm-nonexistent-file 'confirm-only)))
(let ((value (find-file-noselect filename nil nil wildcards)))
(if (listp value)
(progn
@ -1134,7 +1152,9 @@ file names with wildcards."
"Edit file FILENAME but don't allow changes.
Like \\[find-file] but marks buffer as read-only.
Use \\[toggle-read-only] to permit editing."
(interactive (find-file-read-args "Find file read-only: " nil))
(interactive
(find-file-read-args "Find file read-only: "
(if find-file-confirm-nonexistent-file 'confirm-only)))
(unless (or (and wildcards find-file-wildcards
(not (string-match "\\`/:" filename))
(string-match "[[*?]" filename))
@ -1149,7 +1169,9 @@ Use \\[toggle-read-only] to permit editing."
"Edit file FILENAME in another window but don't allow changes.
Like \\[find-file-other-window] but marks buffer as read-only.
Use \\[toggle-read-only] to permit editing."
(interactive (find-file-read-args "Find file read-only other window: " nil))
(interactive
(find-file-read-args "Find file read-only other window: "
(if find-file-confirm-nonexistent-file 'confirm-only)))
(unless (or (and wildcards find-file-wildcards
(not (string-match "\\`/:" filename))
(string-match "[[*?]" filename))
@ -1164,7 +1186,9 @@ Use \\[toggle-read-only] to permit editing."
"Edit file FILENAME in another frame but don't allow changes.
Like \\[find-file-other-frame] but marks buffer as read-only.
Use \\[toggle-read-only] to permit editing."
(interactive (find-file-read-args "Find file read-only other frame: " nil))
(interactive
(find-file-read-args "Find file read-only other frame: "
(if find-file-confirm-nonexistent-file 'confirm-only)))
(unless (or (and wildcards find-file-wildcards
(not (string-match "\\`/:" filename))
(string-match "[[*?]" filename))
@ -4022,6 +4046,8 @@ or multiple mail buffers, etc."
(defun make-directory (dir &optional parents)
"Create the directory DIR and any nonexistent parent dirs.
If DIR already exists as a directory, do nothing.
Interactively, the default choice of directory to create
is the current default directory for file names.
That is useful when you have visited a file in a nonexistent directory.

168
lisp/follow.el
View File

@ -336,123 +336,45 @@ After that, changing the prefix key requires manipulating keymaps."
;; the look and feel of Follow mode.)
(define-key mainmap [remap end-of-buffer] 'follow-end-of-buffer)
;;
;; The menu.
;;
(if (not (featurep 'xemacs))
;;
;; Emacs
;;
(let ((menumap (funcall (symbol-function 'make-sparse-keymap)
"Follow"))
(count 0)
id)
(mapcar
(function
(lambda (item)
(setq id
(or (cdr item)
(progn
(setq count (+ count 1))
(intern (format "separator-%d" count)))))
(define-key menumap (vector id) item)
(or (eq id 'follow-mode)
(put id 'menu-enable 'follow-mode))))
;; In reverse order:
'(("Toggle Follow mode" . follow-mode)
("--")
("Recenter" . follow-recenter)
("--")
("Previous Window" . follow-previous-window)
("Next Windows" . follow-next-window)
("Last Window" . follow-last-window)
("First Window" . follow-first-window)
("--")
("Switch To Buffer (all windows)"
. follow-switch-to-buffer-all)
("Switch To Buffer" . follow-switch-to-buffer)
("--")
("Delete Other Windows and Split"
. follow-delete-other-windows-and-split)
("--")
("Scroll Down" . follow-scroll-down)
("Scroll Up" . follow-scroll-up)))
;; If there is a `tools' menu, we use it. However, we can't add a
;; minor-mode specific item to it (it's broken), so we make the
;; contents ghosted when not in use, and add ourselves to the
;; global map. If no `tools' menu is present, just make a
;; top-level menu visible when the mode is activated.
(let ((tools-map (lookup-key (current-global-map) [menu-bar tools]))
(last nil))
(if (sequencep tools-map)
(progn
;; Find the last entry in the menu and store it in `last'.
(mapcar (function
(lambda (x)
(setq last (or (cdr-safe
(cdr-safe
(cdr-safe x)))
last))))
tools-map)
(if last
(progn
(funcall (symbol-function 'define-key-after)
tools-map [separator-follow] '("--") last)
(funcall (symbol-function 'define-key-after)
tools-map [follow] (cons "Follow" menumap)
'separator-follow))
;; Didn't find the last item, Adding to the top of
;; tools. (This will probably never happend...)
(define-key (current-global-map) [menu-bar tools follow]
(cons "Follow" menumap))))
;; No tools menu, add "Follow" to the menubar.
(define-key mainmap [menu-bar follow]
(cons "Follow" menumap)))))
;;
;; XEmacs.
;;
;; place the menu in the `Tools' menu.
(let ((menu '("Follow"
:filter follow-menu-filter
["Scroll Up" follow-scroll-up t]
["Scroll Down" follow-scroll-down t]
["Delete Other Windows and Split"
follow-delete-other-windows-and-split t]
["Switch To Buffer" follow-switch-to-buffer t]
["Switch To Buffer (all windows)"
follow-switch-to-buffer-all t]
["First Window" follow-first-window t]
["Last Window" follow-last-window t]
["Next Windows" follow-next-window t]
["Previous Window" follow-previous-window t]
["Recenter" follow-recenter t]
["Deactivate" follow-mode t])))
;; Why not just `(set-buffer-menubar current-menubar)'? The
;; question is a very good question. The reason is that under
;; Emacs, neither `set-buffer-menubar' nor
;; `current-menubar' is defined, hence the byte-compiler will
;; warn.
(funcall (symbol-function 'set-buffer-menubar)
(symbol-value 'current-menubar))
(funcall (symbol-function 'add-submenu) '("Tools") menu))
;; When the mode is not activated, only one item is visible:
;; "Activate".
(defun follow-menu-filter (menu)
(if follow-mode
menu
'(["Activate " follow-mode t]))))
mainmap)
"Minor mode keymap for Follow mode.")
;; When the mode is not activated, only one item is visible to activate
;; the mode.
(defun follow-menu-filter (menu)
(if (bound-and-true-p 'follow-mode)
menu
'(["Follow mode " follow-mode
:style toggle :selected follow-mode])))
;; If there is a `tools' menu, we use it. However, we can't add a
;; minor-mode specific item to it (it's broken), so we make the
;; contents ghosted when not in use, and add ourselves to the
;; global map.
(easy-menu-add-item nil '("Tools")
'("Follow"
;; The Emacs code used to just grey out operations when follow-mode was
;; not enabled, whereas the XEmacs code used to remove it altogether.
;; Not sure which is preferable, but clearly the preference should not
;; depend on the flavor.
:filter follow-menu-filter
["Scroll Up" follow-scroll-up follow-mode]
["Scroll Down" follow-scroll-down follow-mode]
"--"
["Delete Other Windows and Split" follow-delete-other-windows-and-split follow-mode]
"--"
["Switch To Buffer" follow-switch-to-buffer follow-mode]
["Switch To Buffer (all windows)" follow-switch-to-buffer-all follow-mode]
"--"
["First Window" follow-first-window follow-mode]
["Last Window" follow-last-window follow-mode]
["Next Window" follow-next-window follow-mode]
["Previous Window" follow-previous-window follow-mode]
"--"
["Recenter" follow-recenter follow-mode]
"--"
["Follow mode" follow-mode :style toggle :selected follow-mode]))
;;}}}
(defcustom follow-mode-line-text " Follow"
@ -553,14 +475,12 @@ Used by `follow-window-size-change'.")
;;;###autoload
(defun turn-on-follow-mode ()
"Turn on Follow mode. Please see the function `follow-mode'."
(interactive)
(follow-mode 1))
;;;###autoload
(defun turn-off-follow-mode ()
"Turn off Follow mode. Please see the function `follow-mode'."
(interactive)
(follow-mode -1))
(put 'follow-mode 'permanent-local t)
@ -2084,8 +2004,8 @@ report this using the `report-emacs-bug' function."
(defun follow-window-size-change (frame)
"Redraw all windows in FRAME, when in Follow mode."
;; Below, we call `post-command-hook'. This makes sure that we
;; doesn't start a mutally recursive endless loop.
;; Below, we call `post-command-hook'. This makes sure that we
;; don't start a mutually recursive endless loop.
(if follow-inside-post-command-hook
nil
(let ((buffers '())
@ -2109,12 +2029,12 @@ report this using the `report-emacs-bug' function."
(setq windows (follow-all-followers win))
(if (memq orig-window windows)
(progn
;; Make sure we're redrawing around the
;; selected window.
;;
;; We must be really careful not to do this
;; when we are (indirectly) called by
;; `post-command-hook'.
;; Make sure we're redrawing around the
;; selected window.
;;
;; We must be really careful not to do this
;; when we are (indirectly) called by
;; `post-command-hook'.
(select-window orig-window)
(follow-post-command-hook)
(setq orig-window (selected-window)))

2
lisp/font-lock.el
View File

@ -2287,7 +2287,7 @@ other modes in which C preprocessor directives are used. e.g. `asm-mode' and
;; that do not occur in strings. The associated regexp matches one
;; of `\\\\' `\\(' `\\(?:' `\\|' `\\)'. `\\\\' has been included to
;; avoid highlighting, for example, `\\(' in `\\\\('.
(while (re-search-forward "\\(\\\\\\\\\\)\\(?:\\(\\\\\\\\\\)\\|\\((\\(?:\\?:\\)?\\|[|)]\\)\\)" bound t)
(while (re-search-forward "\\(\\\\\\\\\\)\\(?:\\(\\\\\\\\\\)\\|\\((\\(?:\\?[0-9]*:\\)?\\|[|)]\\)\\)" bound t)
(unless (match-beginning 2)
(let ((face (get-text-property (1- (point)) 'face)))
(when (or (and (listp face)

14
lisp/generic-x.el
View File

@ -26,7 +26,7 @@
;;; Commentary:
;;
;; This file contains a collection generic modes.
;; This file contains a collection of generic modes.
;;
;; INSTALLATION:
;;
@ -244,7 +244,7 @@ This hook will be installed if the variable
(memq system-type '(windows-nt ms-dos))
"*Non-nil means the modes in `generic-mswindows-modes' will be defined.
This is a list of MS-Windows specific generic modes. This variable
only effects the default value of `generic-extras-enable-list'."
only affects the default value of `generic-extras-enable-list'."
:group 'generic-x
:type 'boolean
:version "22.1")
@ -254,7 +254,7 @@ only effects the default value of `generic-extras-enable-list'."
(not (memq system-type '(windows-nt ms-dos)))
"*Non-nil means the modes in `generic-unix-modes' will be defined.
This is a list of Unix specific generic modes. This variable only
effects the default value of `generic-extras-enable-list'."
affects the default value of `generic-extras-enable-list'."
:group 'generic-x
:type 'boolean
:version "22.1")
@ -317,7 +317,7 @@ your changes into effect."
(2 font-lock-variable-name-face)))
'("access_log\\'")
nil
"Mode for Apache log files"))
"Mode for Apache log files."))
;;; Samba
(when (memq 'samba-generic-mode generic-extras-enable-list)
@ -522,7 +522,7 @@ like an INI file. You can add this hook to `find-file-hook'."
"Syntax table in use in `bat-generic-mode' buffers.")
(defvar bat-generic-mode-keymap (make-sparse-keymap)
"Keymap for bet-generic-mode.")
"Keymap for `bat-generic-mode'.")
(defun bat-generic-mode-compile ()
"Run the current BAT file in a compilation buffer."
@ -784,7 +784,7 @@ like an INI file. You can add this hook to `find-file-hook'."
(2 font-lock-constant-face)))
'("[mM][aA][nN][iI][fF][eE][sS][tT]\\.[mM][fF]\\'")
nil
"Mode for Java Manifest files"))
"Mode for Java Manifest files."))
;; Java properties files
(when (memq 'java-properties-generic-mode generic-extras-enable-list)
@ -1776,7 +1776,7 @@ like an INI file. You can add this hook to `find-file-hook'."
nil ;; no auto-mode-alist
;; '(show-tabs-generic-mode-hook-fun)
nil
"Generic mode to show tabs and trailing spaces"))
"Generic mode to show tabs and trailing spaces."))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DNS modes

39
lisp/gnus/ChangeLog
View File

@ -1,3 +1,42 @@
2007-07-14 David Kastrup <dak@gnu.org>
* gnus-art.el (gnus-mime-delete-part): Don't go through article-edit
finishing actions if we did not edit the article.
2007-07-13 Katsumi Yamaoka <yamaoka@jpl.org>
* gnus-srvr.el (gnus-server-agent-face, gnus-server-opened-face)
(gnus-server-closed-face, gnus-server-denied-face)
(gnus-server-offline-face): Remove variable.
(gnus-server-font-lock-keywords): Use faces that are not aliases.
* mm-util.el (mm-decode-coding-string, mm-encode-coding-string)
(mm-decode-coding-region, mm-encode-coding-region): Don't modify string
if the coding-system argument is nil for XEmacs.
* nnrss.el (nnrss-compatible-encoding-alist): Inherit the value of
mm-charset-override-alist.
* rfc2047.el: Don't require base64; require rfc2045 for the function
rfc2045-encode-string.
(rfc2047-encode-parameter): Use rfc2045-encode-string to quote or not
to quote the parameter value.
2007-07-04 Katsumi Yamaoka <yamaoka@jpl.org>
* gnus-sum.el (gnus-summary-catchup): Don't recognize cached articles
as unfetched articles.
2007-07-02 Reiner Steib <Reiner.Steib@gmx.de>
* gnus-start.el (gnus-level-unsubscribed): Improve doc string.
2007-06-26 Katsumi Yamaoka <yamaoka@jpl.org>
* gnus-art.el (gnus-article-summary-command-nosave)
(gnus-article-read-summary-keys): Don't set the 3rd arg of
pop-to-buffer for XEmacs.
2007-06-14 Katsumi Yamaoka <yamaoka@jpl.org>
* gnus-agent.el (gnus-agent-fetch-headers)

21
lisp/gnus/gnus-art.el
View File

@ -4408,11 +4408,11 @@ Deleting parts may malfunction or destroy the article; continue? ")
(gnus-summary-edit-article-done
,(or (mail-header-references gnus-current-headers) "")
,(gnus-group-read-only-p)
,gnus-summary-buffer no-highlight)))))
;; Not in `gnus-mime-save-part-and-strip':
(gnus-article-edit-done)
(gnus-summary-expand-window)
(gnus-summary-show-article))
,gnus-summary-buffer no-highlight))))
;; Not in `gnus-mime-save-part-and-strip':
(gnus-article-edit-done)
(gnus-summary-expand-window)
(gnus-summary-show-article)))
(defun gnus-mime-save-part ()
"Save the MIME part under point."
@ -5607,7 +5607,7 @@ not have a face in `gnus-article-boring-faces'."
"Execute the last keystroke in the summary buffer."
(interactive)
(let (func)
(pop-to-buffer gnus-article-current-summary nil 'norecord)
(pop-to-buffer gnus-article-current-summary nil (not (featurep 'xemacs)))
(setq func (lookup-key (current-local-map) (this-command-keys)))
(call-interactively func)))
@ -5646,7 +5646,8 @@ not have a face in `gnus-article-boring-faces'."
(member keys nosave-in-article))
(let (func)
(save-window-excursion
(pop-to-buffer gnus-article-current-summary nil 'norecord)
(pop-to-buffer gnus-article-current-summary
nil (not (featurep 'xemacs)))
;; We disable the pick minor mode commands.
(let (gnus-pick-mode)
(setq func (lookup-key (current-local-map) keys))))
@ -5658,14 +5659,16 @@ not have a face in `gnus-article-boring-faces'."
(call-interactively func)
(setq new-sum-point (point)))
(when (member keys nosave-but-article)
(pop-to-buffer gnus-article-buffer nil 'norecord)))
(pop-to-buffer gnus-article-buffer
nil (not (featurep 'xemacs)))))
;; These commands should restore window configuration.
(let ((obuf (current-buffer))
(owin (current-window-configuration))
(opoint (point))
win func in-buffer selected new-sum-start new-sum-hscroll)
(cond (not-restore-window
(pop-to-buffer gnus-article-current-summary nil 'norecord))
(pop-to-buffer gnus-article-current-summary
nil (not (featurep 'xemacs))))
((setq win (get-buffer-window gnus-article-current-summary))
(select-window win))
(t

41
lisp/gnus/gnus-srvr.el
View File

@ -214,43 +214,12 @@ If nil, a faster, but more primitive, buffer is used instead."
;; backward-compatibility alias
(put 'gnus-server-offline-face 'face-alias 'gnus-server-offline)
(defcustom gnus-server-agent-face 'gnus-server-agent
"Face name to use on AGENTIZED servers."
:version "22.1"
:group 'gnus-server-visual
:type 'face)
(defcustom gnus-server-opened-face 'gnus-server-opened
"Face name to use on OPENED servers."
:version "22.1"
:group 'gnus-server-visual
:type 'face)
(defcustom gnus-server-closed-face 'gnus-server-closed
"Face name to use on CLOSED servers."
:version "22.1"
:group 'gnus-server-visual
:type 'face)
(defcustom gnus-server-denied-face 'gnus-server-denied
"Face name to use on DENIED servers."
:version "22.1"
:group 'gnus-server-visual
:type 'face)
(defcustom gnus-server-offline-face 'gnus-server-offline
"Face name to use on OFFLINE servers."
:version "22.1"
:group 'gnus-server-visual
:type 'face)
(defvar gnus-server-font-lock-keywords
(list
'("(\\(agent\\))" 1 gnus-server-agent-face)
'("(\\(opened\\))" 1 gnus-server-opened-face)
'("(\\(closed\\))" 1 gnus-server-closed-face)
'("(\\(offline\\))" 1 gnus-server-offline-face)
'("(\\(denied\\))" 1 gnus-server-denied-face)))
'(("(\\(agent\\))" 1 gnus-server-agent)
("(\\(opened\\))" 1 gnus-server-opened)
("(\\(closed\\))" 1 gnus-server-closed)
("(\\(offline\\))" 1 gnus-server-offline)
("(\\(denied\\))" 1 gnus-server-denied)))
(defun gnus-server-mode ()
"Major mode for listing and editing servers.

9
lisp/gnus/gnus-start.el
View File

@ -178,8 +178,13 @@ properly with all servers."
(defconst gnus-level-unsubscribed 7
"Groups with levels less than or equal to this variable are unsubscribed.
Groups with levels less than `gnus-level-subscribed', which should be
less than this variable, are subscribed.")
Groups with levels less than `gnus-level-subscribed', which
should be less than this variable, are subscribed. Groups with
levels from `gnus-level-subscribed' (exclusive) upto this
variable (inclusive) are unsubscribed. See also
`gnus-level-zombie', `gnus-level-killed' and the Info node `Group
Levels' for details.")
(defconst gnus-level-zombie 8
"Groups with this level are zombie groups.")

3
lisp/gnus/gnus-sum.el
View File

@ -10514,7 +10514,8 @@ The number of articles marked as read is returned."
(gnus-sorted-nunion
(gnus-sorted-intersection gnus-newsgroup-unreads
gnus-newsgroup-downloadable)
gnus-newsgroup-unfetched)))
(gnus-sorted-difference gnus-newsgroup-unfetched
gnus-newsgroup-cached))))
;; We actually mark all articles as canceled, which we
;; have to do when using auto-expiry or adaptive scoring.
(gnus-summary-show-all-threads)

34
lisp/gnus/mm-util.el
View File

@ -36,11 +36,7 @@
(if (fboundp (car elem))
(defalias nfunc (car elem))
(defalias nfunc (cdr elem)))))
'((decode-coding-string . (lambda (s a) s))
(encode-coding-string . (lambda (s a) s))
(encode-coding-region . ignore)
(coding-system-list . ignore)
(decode-coding-region . ignore)
'((coding-system-list . ignore)
(char-int . identity)
(coding-system-equal . equal)
(annotationp . ignore)
@ -96,6 +92,34 @@
(insert-byte . insert-char)
(multibyte-char-to-unibyte . identity))))
(eval-and-compile
(if (featurep 'xemacs)
(if (featurep 'file-coding)
;; Don't modify string if CODING-SYSTEM is nil.
(progn
(defun mm-decode-coding-string (str coding-system)
(if coding-system
(decode-coding-string str coding-system)
str))
(defun mm-encode-coding-string (str coding-system)
(if coding-system
(encode-coding-string str coding-system)
str))
(defun mm-decode-coding-region (start end coding-system)
(if coding-system
(decode-coding-region start end coding-system)))
(defun mm-encode-coding-region (start end coding-system)
(if coding-system
(encode-coding-region start end coding-system))))
(defun mm-decode-coding-string (str coding-system) str)
(defun mm-encode-coding-string (str coding-system) str)
(defalias 'mm-decode-coding-region 'ignore)
(defalias 'mm-encode-coding-region 'ignore))
(defalias 'mm-decode-coding-string 'decode-coding-string)
(defalias 'mm-encode-coding-string 'encode-coding-string)
(defalias 'mm-decode-coding-region 'decode-coding-region)
(defalias 'mm-encode-coding-region 'encode-coding-region)))
(eval-and-compile
(cond
((fboundp 'replace-in-string)

7
lisp/gnus/nnrss.el
View File

@ -85,7 +85,12 @@ ARTICLE is the article number of the current headline.")
(defvar nnrss-file-coding-system mm-universal-coding-system
"Coding system used when reading and writing files.")
(defvar nnrss-compatible-encoding-alist '((iso-8859-1 . windows-1252))
(defvar nnrss-compatible-encoding-alist
(delq nil (mapcar (lambda (elem)
(if (and (mm-coding-system-p (car elem))
(mm-coding-system-p (cdr elem)))
elem))
mm-charset-override-alist))
"Alist of encodings and those supersets.
The cdr of each element is used to decode data if it is available when
the car is what the data specify as the encoding. Or, the car is used

11
lisp/gnus/rfc2047.el
View File

@ -55,7 +55,7 @@ Value is what BODY returns."
(require 'ietf-drums)
;; Fixme: Avoid this (used for mail-parse-charset) mm dependence on gnus.
(require 'mail-prsvr)
(require 'base64)
(require 'rfc2045) ;; rfc2045-encode-string
(autoload 'mm-body-7-or-8 "mm-bodies")
(eval-and-compile
@ -832,12 +832,9 @@ it, put the following line in your ~/.gnus.el file:
\(defalias 'mail-header-encode-parameter 'rfc2047-encode-parameter)
"
(let* ((rfc2047-encoding-type 'mime)
(rfc2047-encode-max-chars nil)
(string (rfc2047-encode-string value)))
(if (string-match (concat "[" ietf-drums-tspecials "]") string)
(format "%s=%S" param string)
(concat param "=" string))))
(let ((rfc2047-encoding-type 'mime)
(rfc2047-encode-max-chars nil))
(rfc2045-encode-string param (rfc2047-encode-string value))))
;;;
;;; Functions for decoding RFC2047 messages

13
lisp/help-mode.el
View File

@ -487,7 +487,7 @@ that."
;; Skip a single blank line.
(and (eolp) (forward-line))
(end-of-line)
(skip-chars-backward "^\t\n")
(skip-chars-backward "^ \t\n")
(if (and (>= (current-column) col)
(looking-at "\\(\\sw\\|-\\)+$"))
(let ((sym (intern-soft (match-string 0))))
@ -500,16 +500,19 @@ that."
(while (and (not (bobp)) (bolp))
(delete-char -1))
(insert "\n")
(when (or help-xref-stack help-xref-forward-stack)
(insert "\n"))
;; Make a back-reference in this buffer if appropriate.
(when help-xref-stack
(insert "\n")
(help-insert-xref-button help-back-label 'help-back
(current-buffer))
(insert "\t"))
(current-buffer)))
;; Make a forward-reference in this buffer if appropriate.
(when help-xref-forward-stack
(when help-xref-stack
(insert "\t"))
(help-insert-xref-button help-forward-label 'help-forward
(current-buffer))
(current-buffer)))
(when (or help-xref-stack help-xref-forward-stack)
(insert "\n")))
;; View mode steals RET from us.
(set (make-local-variable 'minor-mode-overriding-map-alist)

3
lisp/ido.el
View File

@ -3994,8 +3994,7 @@ For details of keybindings, see `ido-switch-buffer'."
(defun ido-find-file-in-dir (dir)
"Switch to another file starting from DIR."
(interactive "DDir: ")
(if (not (equal (substring dir -1) "/"))
(setq dir (concat dir "/")))
(setq dir (file-name-as-directory dir))
(ido-file-internal ido-default-file-method nil dir nil nil nil 'ignore))
;;;###autoload

1
lisp/isearch.el
View File

@ -1069,6 +1069,7 @@ If first char entered is \\[isearch-yank-word-or-char], then do word search inst
;; Reinvoke the pending search.
(isearch-search)
(isearch-push-state)
(isearch-update)
(if isearch-nonincremental
(progn

36
lisp/log-edit.el
View File

@ -590,25 +590,23 @@ The return value looks like this:
(LOGBUFFER (ENTRYSTART . ENTRYEND) ...)
where LOGBUFFER is the name of the ChangeLog buffer, and each
\(ENTRYSTART . ENTRYEND\) pair is a buffer region."
(save-excursion
(let ((changelog-file-name
(let ((default-directory
(file-name-directory (expand-file-name file)))
(visiting-buffer (find-buffer-visiting file)))
;; If there is a buffer visiting FILE, and it has a local
;; value for `change-log-default-name', use that.
(if (and visiting-buffer
(local-variable-p 'change-log-default-name
visiting-buffer))
(save-excursion
(set-buffer visiting-buffer)
change-log-default-name)
;; `find-change-log' uses `change-log-default-name' if set
;; and sets it before exiting, so we need to work around
;; that memoizing which is undesired here
(setq change-log-default-name nil)
(find-change-log)))))
(set-buffer (find-file-noselect changelog-file-name))
(let ((changelog-file-name
(let ((default-directory
(file-name-directory (expand-file-name file)))
(visiting-buffer (find-buffer-visiting file)))
;; If there is a buffer visiting FILE, and it has a local
;; value for `change-log-default-name', use that.
(if (and visiting-buffer
(local-variable-p 'change-log-default-name
visiting-buffer))
(with-current-buffer visiting-buffer
change-log-default-name)
;; `find-change-log' uses `change-log-default-name' if set
;; and sets it before exiting, so we need to work around
;; that memoizing which is undesired here
(setq change-log-default-name nil)
(find-change-log)))))
(with-current-buffer (find-file-noselect changelog-file-name)
(unless (eq major-mode 'change-log-mode) (change-log-mode))
(goto-char (point-min))
(if (looking-at "\\s-*\n") (goto-char (match-end 0)))

38
lisp/log-view.el
View File

@ -105,6 +105,20 @@
;; or a minor-mode-map with lower precedence than the local map.
:inherit (if (boundp 'cvs-mode-map) cvs-mode-map))
(easy-menu-define log-view-mode-menu log-view-mode-map
"Log-View Display Menu"
`("Log-View"
;; XXX Do we need menu entries for these?
;; ["Quit" quit-window]
;; ["Kill This Buffer" kill-this-buffer]
["Mark Log Entry for Diff" set-mark-command]
["Diff Revisions" log-view-diff]
["Visit Version" log-view-find-version]
["Next Log Entry" log-view-msg-next]
["Previous Log Entry" log-view-msg-prev]
["Next File" log-view-file-next]
["Previous File" log-view-file-prev]))
(defvar log-view-mode-hook nil
"Hook run at the end of `log-view-mode'.")
@ -128,13 +142,15 @@
(put 'log-view-message-face 'face-alias 'log-view-message)
(defvar log-view-message-face 'log-view-message)
(defconst log-view-file-re
(defvar log-view-file-re
(concat "^\\(?:Working file: \\(?1:.+\\)" ;RCS and CVS.
;; Subversion has no such thing??
"\\|\\(?:SCCS/s\\.\\|Changes to \\)\\(?1:.+\\):" ;SCCS and Darcs.
"\\)\n")) ;Include the \n for font-lock reasons.
"\\)\n") ;Include the \n for font-lock reasons.
"Regexp matching the text identifying the file.
The match group number 1 should match the file name itself.")
(defconst log-view-message-re
(defvar log-view-message-re
(concat "^\\(?:revision \\(?1:[.0-9]+\\)\\(?:\t.*\\)?" ; RCS and CVS.
"\\|r\\(?1:[0-9]+\\) | .* | .*" ; Subversion.
"\\|D \\(?1:[.0-9]+\\) .*" ; SCCS.
@ -147,13 +163,17 @@
(concat "\\|[^ \n].*[^0-9\n][0-9][0-9]:[0-9][0-9][^0-9\n].*[^ \n]"
;;Email of user and finally Msg, used as revision name.
" .*@.*\n\\(?: \\* \\(?1:.*\\)\\)?")
"\\)$"))
"\\)$")
"Regexp matching the text identifying a revision.
The match group number 1 should match the revision number itself.")
(defconst log-view-font-lock-keywords
`((,log-view-file-re
(1 (if (boundp 'cvs-filename-face) cvs-filename-face))
(0 log-view-file-face append))
(,log-view-message-re . log-view-message-face)))
(defvar log-view-font-lock-keywords
;; We use `eval' so as to use the buffer-local value of log-view-file-re
;; and log-view-message-re, if applicable.
'((eval . `(,log-view-file-re
(1 (if (boundp 'cvs-filename-face) cvs-filename-face))
(0 log-view-file-face append)))
(eval . `(,log-view-message-re . log-view-message-face))))
(defconst log-view-font-lock-defaults
'(log-view-font-lock-keywords t nil nil nil))

29
lisp/longlines.el
View File

@ -223,16 +223,18 @@ With optional argument ARG, make the hard newlines invisible again."
"Wrap each successive line, starting with the line before BEG.
Stop when we reach lines after END that don't need wrapping, or the
end of the buffer."
(setq longlines-wrap-point (point))
(goto-char beg)
(forward-line -1)
;; Two successful longlines-wrap-line's in a row mean successive
;; lines don't need wrapping.
(while (null (and (longlines-wrap-line)
(or (eobp)
(and (>= (point) end)
(longlines-wrap-line))))))
(goto-char longlines-wrap-point))
(let ((mod (buffer-modified-p)))
(setq longlines-wrap-point (point))
(goto-char beg)
(forward-line -1)
;; Two successful longlines-wrap-line's in a row mean successive
;; lines don't need wrapping.
(while (null (and (longlines-wrap-line)
(or (eobp)
(and (>= (point) end)
(longlines-wrap-line))))))
(goto-char longlines-wrap-point)
(set-buffer-modified-p mod)))
(defun longlines-wrap-line ()
"If the current line needs to be wrapped, wrap it and return nil.
@ -372,10 +374,9 @@ If automatic line wrapping is turned on, wrap the entire buffer."
(> (prefix-numeric-value arg) 0)
(not longlines-auto-wrap)))
(if arg
(let ((mod (buffer-modified-p)))
(progn
(setq longlines-auto-wrap t)
(longlines-wrap-region (point-min) (point-max))
(set-buffer-modified-p mod)
(message "Auto wrap enabled."))
(setq longlines-auto-wrap nil)
(message "Auto wrap disabled.")))
@ -410,9 +411,7 @@ This is called by `post-command-hook' after each command."
This is called by `window-configuration-change-hook'."
(when (/= fill-column (- (window-width) window-min-width))
(setq fill-column (- (window-width) window-min-width))
(let ((mod (buffer-modified-p)))
(longlines-wrap-region (point-min) (point-max))
(set-buffer-modified-p mod))))
(longlines-wrap-region (point-min) (point-max))))
;; Isearch

5
lisp/lpr.el
View File

@ -140,9 +140,10 @@ See definition of `print-region-1' for calling conventions."
;; Berkeley systems support -F, and GNU pr supports both -f and -F,
;; So it looks like -F is a better default.
(defcustom lpr-page-header-switches '("-h %s" "-F")
(defcustom lpr-page-header-switches '("-h" "%s" "-F")
"*List of strings to use as options for the page-header-generating program.
If `%s' appears in one of the strings, it is substituted by the page title.
If `%s' appears in any of the strings, it is substituted by the page title.
Note that for correct quoting, `%s' should normally be a separate element.
The variable `lpr-page-header-program' specifies the program to use."
:type '(repeat string)
:group 'lpr)

24
lisp/ls-lisp.el
View File

@ -216,6 +216,7 @@ that work are: A a c i r S s t u U X g G B C R and F partly."
;; We need the directory in order to find the right handler.
(let ((handler (find-file-name-handler (expand-file-name file)
'insert-directory))
(orig-file file)
wildcard-regexp)
(if handler
(funcall handler 'insert-directory file switches
@ -229,7 +230,10 @@ that work are: A a c i r S s t u U X g G B C R and F partly."
;; `ls' don't mind, we certainly do, because it makes us think
;; there is no wildcard, only a directory name.
(if (and ls-lisp-support-shell-wildcards
(string-match "[[?*]" file))
(string-match "[[?*]" file)
;; Prefer an existing file to wildcards, like
;; dired-noselect does.
(not (file-exists-p file)))
(progn
(or (not (eq (aref file (1- (length file))) ?/))
(setq file (substring file 0 (1- (length file)))))
@ -241,9 +245,21 @@ that work are: A a c i r S s t u U X g G B C R and F partly."
(file-name-nondirectory file))
file (file-name-directory file))
(if (memq ?B switches) (setq wildcard-regexp "[^~]\\'")))
(ls-lisp-insert-directory
file switches (ls-lisp-time-index switches)
wildcard-regexp full-directory-p)
(condition-case err
(ls-lisp-insert-directory
file switches (ls-lisp-time-index switches)
wildcard-regexp full-directory-p)
(invalid-regexp
;; Maybe they wanted a literal file that just happens to
;; use characters special to shell wildcards.
(if (equal (cadr err) "Unmatched [ or [^")
(progn
(setq wildcard-regexp (if (memq ?B switches) "[^~]\\'")
file (file-relative-name orig-file))
(ls-lisp-insert-directory
file switches (ls-lisp-time-index switches)
nil full-directory-p))
(signal (car err) (cdr err)))))
;; Try to insert the amount of free space.
(save-excursion
(goto-char (point-min))

15
lisp/makefile.w32-in
View File

@ -408,7 +408,7 @@ install:
- $(DEL) "$(INSTALL_DIR)/same-dir.tst"
echo SameDirTest > "$(INSTALL_DIR)/same-dir.tst"
#ifdef COPY_LISP_SOURCE
$(IFNOTSAMEDIR) $(CP_DIR) . "$(INSTALL_DIR)/lisp" $(ENDIF)
$(IFNOTSAMEDIR) $(MAKE) $(MFLAGS) install-lisp-$(SHELLTYPE) $(ENDIF)
#else
# $(IFNOTSAMEDIR) $(CP_DIR) *.elc "$(INSTALL_DIR)/lisp" $(ENDIF)
# $(IFNOTSAMEDIR) $(CP) cus-load.el "$(INSTALL_DIR)/lisp" $(ENDIF)
@ -425,6 +425,19 @@ install:
- $(DEL) ../same-dir.tst
- $(DEL) "$(INSTALL_DIR)/same-dir.tst"
# Need to copy *.el files first, to avoid "source file is newer" annoyance
# since cp does not preserve time stamps
install-lisp-SH:
cp -f *.el "$(INSTALL_DIR)/lisp"
for dir in $(WINS); do mkdir "$(INSTALL_DIR)/lisp/$$dir" && cp -f $$dir/*.el "$(INSTALL_DIR)/lisp/$$dir"; done
for dir in . $(WINS); do cp $$dir/*.elc "$(INSTALL_DIR)/lisp/$$dir"; done
install-lisp-CMD:
cp -f *.el "$(INSTALL_DIR)/lisp"
for %%f in ($(WINS)) do mkdir "$(INSTALL_DIR)/lisp/%%f"
for %%f in ($(WINS)) do cp -f %%f/*.el "$(INSTALL_DIR)/lisp/%%f"
for %%f in (. $(WINS)) do cp -f %%f/*.elc "$(INSTALL_DIR)/lisp/%%f"
#
# Maintenance
#

1
lisp/menu-bar.el
View File

@ -1161,6 +1161,7 @@ mail status in mode line"))
'("--"))
(defvar vc-menu-map (make-sparse-keymap "Version Control"))
(defalias 'vc-menu-map vc-menu-map)
(define-key menu-bar-tools-menu [pcl-cvs]
'(menu-item "PCL-CVS" cvs-global-menu))
(define-key menu-bar-tools-menu [vc]

5
lisp/mh-e/ChangeLog
View File

@ -1,3 +1,8 @@
2007-07-11 Bill Wohler <wohler@newt.com>
* mh-compat.el (mh-display-color-cells): Fix on XEmacs 21.5b28.
Thanks to Henrique Martins for the help (closes SF #1749774).
2007-06-06 Juanma Barranquero <lekktu@gmail.com>
* mh-mime.el (mh-mh-directive-present-p):

12
lisp/mh-e/mh-compat.el
View File

@ -77,13 +77,17 @@ introduced in Emacs 22."
'cancel-timer
'delete-itimer))
(defun-mh mh-display-color-cells display-color-cells (&optional display)
(defun mh-display-color-cells (&optional display)
"Return the number of color cells supported by DISPLAY.
This function is used by XEmacs to return 2 when
`device-color-cells' returns nil. This happens when compiling or
This function is used by XEmacs to return 2 when `device-color-cells'
or `display-color-cells' returns nil. This happens when compiling or
running on a tty and causes errors since `display-color-cells' is
expected to return an integer."
(or (device-color-cells display) 2))
(cond ((fboundp 'display-color-cells) ; GNU Emacs, XEmacs 21.5b28
(or (display-color-cells display) 2))
((fboundp 'device-color-cells) ; XEmacs 21.4
(or (device-color-cells display) 2))
(t 2)))
(defmacro mh-display-completion-list (completions &optional common-substring)
"Display the list of COMPLETIONS.

21
lisp/mouse.el
View File

@ -433,9 +433,8 @@ MODE-LINE-P non-nil means dragging a mode line; nil means a header line."
;; - there is a scroll-bar-movement event
;; (same as mouse movement for our purposes)
;; quit if
;; - there is a keyboard event or some other unknown event
;; unknown event.
(cond ((integerp event)
;; - there is a keyboard event or some other unknown event.
(cond ((not (consp event))
(setq done t))
((memq (car event) '(switch-frame select-window))
@ -443,7 +442,11 @@ MODE-LINE-P non-nil means dragging a mode line; nil means a header line."
((not (memq (car event) '(mouse-movement scroll-bar-movement)))
(when (consp event)
(push event unread-command-events))
;; Do not unread a drag-mouse-1 event since it will cause the
;; selection of the window above when dragging the modeline
;; above the selected window.
(unless (eq (car event) 'drag-mouse-1)
(push event unread-command-events)))
(setq done t))
((not (eq (car mouse) start-event-frame))
@ -498,7 +501,10 @@ MODE-LINE-P non-nil means dragging a mode line; nil means a header line."
(and (not should-enlarge-minibuffer)
(> growth 0)
mode-line-p
(/= top (nth 1 (window-edges)))))
(/= top
(nth 1 (window-edges
;; Choose right window.
start-event-window)))))
(set-window-configuration wconfig)))))))))
(defun mouse-drag-mode-line (start-event)
@ -1007,6 +1013,11 @@ should only be used by mouse-drag-region."
(overlay-start mouse-drag-overlay))
region-termination))
last-command this-command)
(when (eq transient-mark-mode 'identity)
;; Reset `transient-mark-mode' to avoid expanding the region
;; while scrolling (compare thread on "Erroneous selection
;; extension ..." on bug-gnu-emacs from 2007-06-10).
(setq transient-mark-mode nil))
(push-mark region-commencement t t)
(goto-char region-termination)
(if (not do-mouse-drag-region-post-process)

22
lisp/net/ange-ftp.el
View File

@ -4132,8 +4132,15 @@ directory, so that Emacs will know its current contents."
(format "Getting %s" fn1))
tmp1))))
(defun ange-ftp-file-remote-p (file)
(ange-ftp-replace-name-component file ""))
(defun ange-ftp-file-remote-p (file &optional connected)
(and (or (not connected)
(let* ((parsed (ange-ftp-ftp-name file))
(host (nth 0 parsed))
(user (nth 1 parsed))
(proc (get-process (ange-ftp-ftp-process-buffer host user))))
(and proc (processp proc)
(memq (process-status proc) '(run open)))))
(ange-ftp-replace-name-component file "")))
(defun ange-ftp-load (file &optional noerror nomessage nosuffix)
(if (ange-ftp-ftp-name file)
@ -4360,7 +4367,10 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
;; This returns nil for any file name as argument.
(put 'vc-registered 'ange-ftp 'null)
(put 'dired-call-process 'ange-ftp 'ange-ftp-dired-call-process)
;; We can handle process-file in a restricted way (just for chown).
;; Nothing possible for start-file-process.
(put 'process-file 'ange-ftp 'ange-ftp-process-file)
(put 'start-file-process 'ange-ftp 'ignore)
(put 'shell-command 'ange-ftp 'ange-ftp-shell-command)
;;; Define ways of getting at unmodified Emacs primitives,
@ -4523,8 +4533,8 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
;; default-directory is in ange-ftp syntax for remote file names.
(ange-ftp-real-shell-command command output-buffer error-buffer))))
;;; This is the handler for call-process.
(defun ange-ftp-dired-call-process (program discard &rest arguments)
;;; This is the handler for process-file.
(defun ange-ftp-process-file (program infile buffer display &rest arguments)
;; PROGRAM is always one of those below in the cond in dired.el.
;; The ARGUMENTS are (nearly) always files.
(if (ange-ftp-ftp-name default-directory)
@ -4544,7 +4554,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
1)
(error (insert (format "%s\n" (nth 1 oops)))
1))
(apply 'call-process program nil (not discard) nil arguments)))
(apply 'call-process program infile buffer display arguments)))
;; Handle an attempt to run chmod on a remote file
;; by using the ftp chmod command.

121
lisp/net/rcirc.el
View File

@ -55,7 +55,7 @@
:link '(custom-manual "(rcirc)")
:group 'applications)
(defcustom rcirc-connections
(defcustom rcirc-server-alist
'(("irc.freenode.net" :channels ("#rcirc")))
"An alist of IRC connections to establish when running `rcirc'.
Each element looks like (SERVER-NAME PARAMETERS).
@ -63,11 +63,36 @@ Each element looks like (SERVER-NAME PARAMETERS).
SERVER-NAME is a string describing the server to connect
to.
PARAMETERS is a plist of optional connection parameters. Valid
properties are: nick (a string), port (number or string),
user-name (string), full-name (string), and channels (list of
strings)."
:type '(alist :key-type string
The optional PARAMETERS come in pairs PARAMETER VALUE.
The following parameters are recognized:
`:nick'
VALUE must be a string. If absent, `rcirc-default-nick' is used
for this connection.
`:port'
VALUE must be a number or string. If absent,
`rcirc-default-port' is used.
`:user-name'
VALUE must be a string. If absent, `rcirc-default-user-name' is
used.
`:full-name'
VALUE must be a string. If absent, `rcirc-default-full-name' is
used.
`:channels'
VALUE must be a list of strings describing which channels to join
when connecting to this server. If absent, no channels will be
connected to automatically."
:type '(alist :key-type string
:value-type (plist :options ((nick string)
(port integer)
(user-name string)
@ -90,9 +115,9 @@ strings)."
:type 'string
:group 'rcirc)
(defcustom rcirc-default-user-full-name (if (string= (user-full-name) "")
rcirc-default-user-name
(user-full-name))
(defcustom rcirc-default-full-name (if (string= (user-full-name) "")
rcirc-default-user-name
(user-full-name))
"The full name sent to the server when connecting."
:type 'string
:group 'rcirc)
@ -335,19 +360,19 @@ and the cdr part is used for encoding."
;;;###autoload
(defun rcirc (arg)
"Connect to all servers in `rcirc-connections'.
"Connect to all servers in `rcirc-server-alist'.
Do not connect to a server if it is already connected.
If ARG is non-nil, instead prompt for connection parameters."
(interactive "P")
(if arg
(let* ((server (completing-read "IRC Server: "
rcirc-connections
(let* ((server (completing-read "IRC Server: "
rcirc-server-alist
nil nil
(caar rcirc-connections)))
(server-plist (cdr (assoc-string server rcirc-connections)))
(port (read-string "IRC Port: "
(caar rcirc-server-alist)))
(server-plist (cdr (assoc-string server rcirc-server-alist)))
(port (read-string "IRC Port: "
(number-to-string
(or (plist-get server-plist 'port)
rcirc-default-port))))
@ -356,25 +381,25 @@ If ARG is non-nil, instead prompt for connection parameters."
rcirc-default-nick)))
(channels (split-string
(read-string "IRC Channels: "
(mapconcat 'identity
(mapconcat 'identity
(plist-get server-plist
'channels)
" "))
"[, ]+" t)))
(rcirc-connect server port nick rcirc-default-user-name
rcirc-default-user-full-name
rcirc-default-full-name
channels))
;; connect to servers in `rcirc-connections'
;; connect to servers in `rcirc-server-alist'
(let (connected-servers)
(dolist (c rcirc-connections)
(dolist (c rcirc-server-alist)
(let ((server (car c))
(port (or (plist-get (cdr c) 'port) rcirc-default-port))
(nick (or (plist-get (cdr c) 'nick) rcirc-default-nick))
(user-name (or (plist-get (cdr c) 'user-name)
(nick (or (plist-get (cdr c) :nick) rcirc-default-nick))
(port (or (plist-get (cdr c) :port) rcirc-default-port))
(user-name (or (plist-get (cdr c) :user-name)
rcirc-default-user-name))
(full-name (or (plist-get (cdr c) 'full-name)
rcirc-default-user-full-name))
(channels (plist-get (cdr c) 'channels)))
(full-name (or (plist-get (cdr c) :full-name)
rcirc-default-full-name))
(channels (plist-get (cdr c) :channels)))
(when server
(let (connected)
(dolist (p (rcirc-process-list))
@ -382,9 +407,9 @@ If ARG is non-nil, instead prompt for connection parameters."
(setq connected p)))
(if (not connected)
(condition-case e
(rcirc-connect server port nick user-name
(rcirc-connect server port nick user-name
full-name channels)
(quit (message "Quit connecting to %s" server)))
(quit (message "Quit connecting to %s" server)))
(with-current-buffer (process-buffer connected)
(setq connected-servers
(cons (process-contact (get-buffer-process
@ -411,7 +436,7 @@ If ARG is non-nil, instead prompt for connection parameters."
(defvar rcirc-process nil)
;;;###autoload
(defun rcirc-connect (server &optional port nick user-name full-name
(defun rcirc-connect (server &optional port nick user-name full-name
startup-channels)
(save-excursion
(message "Connecting to %s..." server)
@ -423,7 +448,7 @@ If ARG is non-nil, instead prompt for connection parameters."
rcirc-default-port))
(nick (or nick rcirc-default-nick))
(user-name (or user-name rcirc-default-user-name))
(full-name (or full-name rcirc-default-user-full-name))
(full-name (or full-name rcirc-default-full-name))
(startup-channels startup-channels)
(process (make-network-process :name server :host server :service port-number)))
;; set up process
@ -494,7 +519,7 @@ last ping."
(mapc (lambda (process)
(with-rcirc-process-buffer process
(when (not rcirc-connecting)
(rcirc-send-string process
(rcirc-send-string process
(format "PRIVMSG %s :\C-aKEEPALIVE %f\C-a"
rcirc-nick
(time-to-seconds
@ -550,7 +575,7 @@ Functions are called with PROCESS and SENTINEL arguments.")
;; set rcirc-target to nil for each channel so cleanup
;; doesnt happen when we reconnect
(setq rcirc-target nil)
(setq mode-line-process ":disconnected")))
(setq mode-line-process ":disconnected")))
(defun rcirc-process-list ()
"Return a list of rcirc processes."
@ -590,7 +615,6 @@ Function is called with PROCESS, COMMAND, SENDER, ARGS and LINE.")
process))))))
(defun rcirc-delete-process (process)
(message "delete process %S" process)
(delete-process process))
(defvar rcirc-trap-errors-flag t)
@ -1162,7 +1186,7 @@ the of the following escape sequences replaced by the described values:
:value-type string)
:group 'rcirc)
(defcustom rcirc-omit-responses
(defcustom rcirc-omit-responses
'("JOIN" "PART" "QUIT")
"Responses which will be hidden when `rcirc-omit-mode' is enabled."
:type '(repeat string)
@ -1202,7 +1226,7 @@ is found by looking up RESPONSE in `rcirc-response-formats'."
(cond ((string= sender my-nick)
'rcirc-my-nick)
((and rcirc-bright-nicks
(string-match
(string-match
(regexp-opt rcirc-bright-nicks
'words)
sender))
@ -1262,11 +1286,12 @@ Logfiles are kept in `rcirc-log-directory'."
Format based on SENDER and RESPONSE. If ACTIVITY is non-nil,
record activity."
(or text (setq text ""))
(unless (or (member sender rcirc-ignore-list)
(member (with-syntax-table rcirc-nick-syntax-table
(when (string-match "^\\([^/]\\w*\\)[:,]" text)
(match-string 1 text)))
rcirc-ignore-list))
(unless (and (or (member sender rcirc-ignore-list)
(member (with-syntax-table rcirc-nick-syntax-table
(when (string-match "^\\([^/]\\w*\\)[:,]" text)
(match-string 1 text)))
rcirc-ignore-list))
(not (string= sender (rcirc-nick process))))
(let* ((buffer (rcirc-target-buffer process sender response target text))
(inhibit-read-only t))
(with-current-buffer buffer
@ -1291,12 +1316,12 @@ record activity."
(set-marker-insertion-type rcirc-prompt-end-marker t)
(let ((start (point)))
(insert (rcirc-format-response-string process sender response nil
(insert (rcirc-format-response-string process sender response nil
text)
(propertize "\n" 'hard t))
;; squeeze spaces out of text before rcirc-text
(fill-region fill-start
(fill-region fill-start
(1- (or (next-single-property-change fill-start
'rcirc-text)
rcirc-prompt-end-marker)))
@ -1549,7 +1574,7 @@ if NICK is also on `rcirc-ignore-list-automatic'."
(defun rcirc-omit-mode ()
"Toggle the Rcirc-Omit mode.
If enabled, \"uninteresting\" lines are not shown.
If enabled, \"uninteresting\" lines are not shown.
Uninteresting lines are those whose responses are listed in
`rcirc-omit-responses'."
(interactive)
@ -1635,7 +1660,7 @@ activity. Only run if the buffer is not visible and
(defun rcirc-clear-activity (buffer)
"Clear the BUFFER activity."
(setq rcirc-activity (delete buffer rcirc-activity))
(setq rcirc-activity (remove buffer rcirc-activity))
(with-current-buffer buffer
(setq rcirc-activity-types nil)))
@ -2065,7 +2090,7 @@ keywords when no KEYWORD is given."
rcirc-markup-keywords
rcirc-markup-bright-nicks
rcirc-markup-fill)
"List of functions used to manipulate text before it is printed.
Each function takes two arguments, SENDER, RESPONSE. The buffer
@ -2074,7 +2099,7 @@ beginning of the `rcirc-text' propertized text.")
(defun rcirc-markup-timestamp (sender response)
(goto-char (point-min))
(insert (rcirc-facify (format-time-string rcirc-time-format)
(insert (rcirc-facify (format-time-string rcirc-time-format)
'rcirc-timestamp)))
(defun rcirc-markup-attributes (sender response)
@ -2095,15 +2120,15 @@ beginning of the `rcirc-text' propertized text.")
(defun rcirc-markup-my-nick (sender response)
(with-syntax-table rcirc-nick-syntax-table
(while (re-search-forward (concat "\\b"
(regexp-quote (rcirc-nick
(while (re-search-forward (concat "\\b"
(regexp-quote (rcirc-nick
(rcirc-buffer-process)))
"\\b")
nil t)
(rcirc-add-face (match-beginning 0) (match-end 0)
'rcirc-nick-in-message)
(when (string= response "PRIVMSG")
(rcirc-add-face (point-min) (point-max)
(rcirc-add-face (point-min) (point-max)
'rcirc-nick-in-message-full-line)
(rcirc-record-activity (current-buffer) 'nick)))))

3
lisp/net/rcompile.el
View File

@ -188,8 +188,7 @@ See \\[compile]."
(when (featurep 'tramp)
(set (make-local-variable 'comint-file-name-prefix)
(funcall (symbol-function 'tramp-make-tramp-file-name)
nil ;; multi-method. To be removed with Tramp 2.1.
nil
nil ;; method.
remote-compile-user
remote-compile-host
""))))))

317
lisp/net/tramp-cache.el Normal file
View File

@ -0,0 +1,317 @@
;;; -*- mode: Emacs-Lisp; coding: iso-2022-7bit; -*-
;;; tramp-cache.el --- file information caching for Tramp
;; Copyright (C) 2000, 2005, 2006, 2007 by Free Software Foundation, Inc.
;; Author: Daniel Pittman <daniel@inanna.danann.net>
;; Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, processes
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, see
;; <http://www.gnu.org/licenses/>.
;;; Commentary:
;; An implementation of information caching for remote files.
;; Each connection, identified by a vector [method user host
;; localname] or by a process, has a unique cache. We distinguish 3
;; kind of caches, depending on the key:
;;
;; - localname is NIL. This are reusable properties. Examples:
;; "remote-shell" identifies the POSIX shell to be called on the
;; remote host, or "perl" is the command to be called on the remote
;; host, when starting a Perl script. These properties are saved in
;; the file `tramp-persistency-file-name'.
;;
;; - localname is a string. This are temporary properties, which are
;; related to the file localname is referring to. Examples:
;; "file-exists-p" is t or nile, depending on the file existence, or
;; "file-attributes" caches the result of the function
;; `file-attributes'.
;;
;; - The key is a process. This are temporary properties related to
;; an open connection. Examples: "scripts" keeps shell script
;; definitions already sent to the remote shell, "last-cmd-time" is
;; the time stamp a command has been sent to the remote process.
;;; Code:
;; Pacify byte-compiler.
(eval-when-compile
(require 'cl)
(autoload 'tramp-message "tramp")
(autoload 'tramp-tramp-file-p "tramp")
;; We cannot autoload macro `with-parsed-tramp-file-name', it
;; results in problems of byte-compiled code.
(autoload 'tramp-dissect-file-name "tramp")
(autoload 'tramp-file-name-method "tramp")
(autoload 'tramp-file-name-user "tramp")
(autoload 'tramp-file-name-host "tramp")
(autoload 'tramp-file-name-localname "tramp")
(autoload 'time-stamp-string "time-stamp"))
;;; -- Cache --
(defvar tramp-cache-data (make-hash-table :test 'equal)
"Hash table for remote files properties.")
(defcustom tramp-persistency-file-name
(cond
;; GNU Emacs.
((and (boundp 'user-emacs-directory)
(stringp (symbol-value 'user-emacs-directory))
(file-directory-p (symbol-value 'user-emacs-directory)))
(expand-file-name "tramp" (symbol-value 'user-emacs-directory)))
((and (not (featurep 'xemacs)) (file-directory-p "~/.emacs.d/"))
"~/.emacs.d/tramp")
;; XEmacs.
((and (boundp 'user-init-directory)
(stringp (symbol-value 'user-init-directory))
(file-directory-p (symbol-value 'user-init-directory)))
(expand-file-name "tramp" (symbol-value 'user-init-directory)))
((and (featurep 'xemacs) (file-directory-p "~/.xemacs/"))
"~/.xemacs/tramp")
;; For users without `~/.emacs.d/' or `~/.xemacs/'.
(t "~/.tramp"))
"File which keeps connection history for Tramp connections."
:group 'tramp
:type 'file)
(defun tramp-get-file-property (vec file property default)
"Get the PROPERTY of FILE from the cache context of VEC.
Returns DEFAULT if not set."
;; Unify localname.
(setq vec (copy-sequence vec))
(aset vec 3 (directory-file-name file))
(let* ((hash (or (gethash vec tramp-cache-data)
(puthash vec (make-hash-table :test 'equal)
tramp-cache-data)))
(value (if (hash-table-p hash)
(gethash property hash default)
default)))
(tramp-message vec 8 "%s %s %s" file property value)
value))
(defun tramp-set-file-property (vec file property value)
"Set the PROPERTY of FILE to VALUE, in the cache context of VEC.
Returns VALUE."
;; Unify localname.
(setq vec (copy-sequence vec))
(aset vec 3 (directory-file-name file))
(let ((hash (or (gethash vec tramp-cache-data)
(puthash vec (make-hash-table :test 'equal)
tramp-cache-data))))
(puthash property value hash)
(tramp-message vec 8 "%s %s %s" file property value)
value))
(defun tramp-flush-file-property (vec file)
"Remove all properties of FILE in the cache context of VEC."
;; Unify localname.
(setq vec (copy-sequence vec))
(aset vec 3 (directory-file-name file))
(tramp-message vec 8 "%s" file)
(remhash vec tramp-cache-data))
(defun tramp-flush-directory-property (vec directory)
"Remove all properties of DIRECTORY in the cache context of VEC.
Remove also properties of all files in subdirectories."
(let ((directory (directory-file-name directory)))
(tramp-message vec 8 "%s" directory)
(maphash
'(lambda (key value)
(when (and (stringp key)
(string-match directory (tramp-file-name-localname key)))
(remhash key tramp-cache-data)))
tramp-cache-data)))
(defun tramp-cache-print (table)
"Prints hash table TABLE."
(when (hash-table-p table)
(let (result tmp)
(maphash
'(lambda (key value)
(setq tmp (format
"(%s %s)"
(if (processp key)
(prin1-to-string (prin1-to-string key))
(prin1-to-string key))
(if (hash-table-p value)
(tramp-cache-print value)
(if (bufferp value)
(prin1-to-string (prin1-to-string value))
(prin1-to-string value))))
result (if result (concat result " " tmp) tmp)))
table)
result)))
;; Reverting or killing a buffer should also flush file properties.
;; They could have been changed outside Tramp.
(defun tramp-flush-file-function ()
"Flush all Tramp cache properties from buffer-file-name."
(let ((bfn (buffer-file-name)))
(when (and (stringp bfn) (tramp-tramp-file-p bfn))
(let* ((v (tramp-dissect-file-name bfn))
(localname (tramp-file-name-localname v)))
(tramp-flush-file-property v localname)))))
(add-hook 'before-revert-hook 'tramp-flush-file-function)
(add-hook 'kill-buffer-hook 'tramp-flush-file-function)
(add-hook 'tramp-cache-unload-hook
'(lambda ()
(remove-hook 'before-revert-hook
'tramp-flush-file-function)
(remove-hook 'kill-buffer-hook
'tramp-flush-file-function)))
;;; -- Properties --
(defun tramp-get-connection-property (key property default)
"Get the named PROPERTY for the connection.
KEY identifies the connection, it is either a process or a vector.
If the value is not set for the connection, returns DEFAULT."
;; Unify key by removing localname from vector. Work with a copy in
;; order to avoid side effects.
(when (vectorp key)
(setq key (copy-sequence key))
(aset key 3 nil))
(let* ((hash (gethash key tramp-cache-data))
(value (if (hash-table-p hash)
(gethash property hash default)
default)))
(tramp-message key 7 "%s %s" property value)
value))
(defun tramp-set-connection-property (key property value)
"Set the named PROPERTY of a connection to VALUE.
KEY identifies the connection, it is either a process or a vector.
PROPERTY is set persistent when KEY is a vector."
;; Unify key by removing localname from vector. Work with a copy in
;; order to avoid side effects.
(when (vectorp key)
(setq key (copy-sequence key))
(aset key 3 nil))
(let ((hash (or (gethash key tramp-cache-data)
(puthash key (make-hash-table :test 'equal)
tramp-cache-data))))
(puthash property value hash)
;; This function is called also during initialization of
;; tramp-cache.el. `tramp-message´ is not defined yet at this
;; time, so we ignore the corresponding error.
(condition-case nil
(tramp-message key 7 "%s %s" property value)
(error nil))
value))
(defun tramp-flush-connection-property (key event)
"Remove all properties identified by KEY.
KEY identifies the connection, it is either a process or a
vector. EVENT is not used, it is just applied because this
function is intended to run also as process sentinel."
;; Unify key by removing localname from vector. Work with a copy in
;; order to avoid side effects.
(when (vectorp key)
(setq key (copy-sequence key))
(aset key 3 nil))
; (tramp-message key 7 "%s" event)
(remhash key tramp-cache-data))
(defun tramp-dump-connection-properties ()
"Writes persistent connection properties into file
`tramp-persistency-file-name'."
;; We shouldn't fail, otherwise (X)Emacs might not be able to be closed.
(condition-case nil
(when (and (hash-table-p tramp-cache-data)
(not (zerop (hash-table-count tramp-cache-data)))
(stringp tramp-persistency-file-name))
(let ((cache (copy-hash-table tramp-cache-data)))
;; Remove temporary data.
(maphash
'(lambda (key value)
(if (and (vectorp key) (not (tramp-file-name-localname key)))
(progn
(remhash "process-name" value)
(remhash "process-buffer" value))
(remhash key cache)))
cache)
;; Dump it.
(with-temp-buffer
(insert
";; -*- emacs-lisp -*-"
;; `time-stamp-string' might not exist in all (X)Emacs flavors.
(condition-case nil
(progn
(format
" <%s %s>\n"
(time-stamp-string "%02y/%02m/%02d %02H:%02M:%02S")
tramp-persistency-file-name))
(error "\n"))
";; Tramp connection history. Don't change this file.\n"
";; You can delete it, forcing Tramp to reapply the checks.\n\n"
(with-output-to-string
(pp (read (format "(%s)" (tramp-cache-print cache))))))
(write-region
(point-min) (point-max) tramp-persistency-file-name))))
(error nil)))
(add-hook 'kill-emacs-hook 'tramp-dump-connection-properties)
(add-hook 'tramp-cache-unload-hook
'(lambda ()
(remove-hook 'kill-emacs-hook
'tramp-dump-connection-properties)))
(defun tramp-parse-connection-properties (method)
"Return a list of (user host) tuples allowed to access for METHOD.
This function is added always in `tramp-get-completion-function'
for all methods. Resulting data are derived from connection
history."
(let (res)
(maphash
'(lambda (key value)
(if (and (vectorp key)
(string-equal method (tramp-file-name-method key))
(not (tramp-file-name-localname key)))
(push (list (tramp-file-name-user key)
(tramp-file-name-host key))
res)))
tramp-cache-data)
res))
;; Read persistent connection history. Applied with
;; `load-in-progress', because it shall be evaluated only once.
(when load-in-progress
(condition-case err
(with-temp-buffer
(insert-file-contents tramp-persistency-file-name)
(let ((list (read (current-buffer)))
element key item)
(while (setq element (pop list))
(setq key (pop element))
(while (setq item (pop element))
(tramp-set-connection-property key (pop item) (car item))))))
(file-error
;; Most likely because the file doesn't exist yet. No message.
(clrhash tramp-cache-data))
(error
;; File is corrupted.
(message "%s" (error-message-string err))
(clrhash tramp-cache-data))))
(provide 'tramp-cache)
;; arch-tag: ee1739b7-7628-408c-9b96-d11a74b05d26
;;; tramp-cache.el ends here

1178
lisp/net/tramp-fish.el Normal file
View File

File diff suppressed because it is too large Load Diff

30
lisp/net/tramp-ftp.el
View File

@ -10,8 +10,8 @@
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; the Free Software Foundation; either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@ -19,9 +19,8 @@
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;; along with GNU Emacs; see the file COPYING. If not, see
;; <http://www.gnu.org/licenses/>.
;;; Commentary:
@ -110,10 +109,13 @@ present for backward compatibility."
(list "" "\\`\\(anonymous\\|ftp\\)\\'" tramp-ftp-method))
;; Add completion function for FTP method.
(unless (memq system-type '(windows-nt))
(tramp-set-completion-function
tramp-ftp-method
'((tramp-parse-netrc "~/.netrc"))))
(tramp-set-completion-function
tramp-ftp-method
'((tramp-parse-netrc "~/.netrc")))
;; If there is URL syntax, `substitute-in-file-name' needs special
;; handling.
(put 'substitute-in-file-name 'ange-ftp 'tramp-handle-substitute-in-file-name)
(defun tramp-ftp-file-name-handler (operation &rest args)
"Invoke the Ange-FTP handler for OPERATION.
@ -152,13 +154,7 @@ pass to the OPERATION."
(defun tramp-ftp-file-name-p (filename)
"Check if it's a filename that should be forwarded to Ange-FTP."
(let ((v (tramp-dissect-file-name filename)))
(string=
(tramp-find-method
(tramp-file-name-multi-method v)
(tramp-file-name-method v)
(tramp-file-name-user v)
(tramp-file-name-host v))
tramp-ftp-method)))
(string= (tramp-file-name-method v) tramp-ftp-method)))
(add-to-list 'tramp-foreign-file-name-handler-alist
(cons 'tramp-ftp-file-name-p 'tramp-ftp-file-name-handler))
@ -172,8 +168,6 @@ pass to the OPERATION."
;; pretended in `tramp-file-name-handler' otherwise.
;; Furthermore, there are no backup files on FTP hosts.
;; Worth further investigations.
;; * Map /multi:ssh:out@gate:ftp:kai@real.host:/path/to.file
;; on Ange-FTP gateways.
;;; arch-tag: 759fb338-5c63-4b99-bd36-b4d59db91cff
;;; tramp-ftp.el ends here

324
lisp/net/tramp-gw.el Normal file
View File

@ -0,0 +1,324 @@
;;; -*- coding: iso-8859-1; -*-
;;; tramp-gw.el --- Tramp utility functions for HTTP tunnels and SOCKS gateways
;; Copyright (C) 2007 Free Software Foundation, Inc.
;; Author: Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, processes
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, see
;; <http://www.gnu.org/licenses/>.
;;; Commentary:
;; Access functions for HTTP tunnels and SOCKS gateways from Tramp.
;; SOCKS functionality is implemented by socks.el from the w3 package.
;; HTTP tunnels are partly implemented in socks.el and url-http.el;
;; both implementations are not complete. Therefore, it is
;; implemented in this package.
;;; Code:
(require 'tramp)
;; Pacify byte-compiler
(eval-when-compile
(require 'cl)
(require 'custom))
;; Autoload the socks library. It is used only when we access a SOCKS server.
(autoload 'socks-open-network-stream "socks")
(defvar socks-username (user-login-name))
(defvar socks-server (list "Default server" "socks" 1080 5))
;; Avoid byte-compiler warnings if the byte-compiler supports this.
;; Currently, XEmacs supports this.
(eval-when-compile
(when (featurep 'xemacs)
(byte-compiler-options (warnings (- unused-vars)))))
;; Define HTTP tunnel method ...
(defvar tramp-gw-tunnel-method "tunnel"
"*Method to connect HTTP gateways.")
;; ... and port.
(defvar tramp-gw-default-tunnel-port 8080
"*Default port for HTTP gateways.")
;; Define SOCKS method ...
(defvar tramp-gw-socks-method "socks"
"*Method to connect SOCKS servers.")
;; ... and port.
(defvar tramp-gw-default-socks-port 1080
"*Default port for SOCKS servers.")
;; Add a default for `tramp-default-user-alist'. Default is the local user.
(add-to-list 'tramp-default-user-alist
`(,tramp-gw-tunnel-method nil ,(user-login-name)))
(add-to-list 'tramp-default-user-alist
`(,tramp-gw-socks-method nil ,(user-login-name)))
;; Internal file name functions and variables.
(defvar tramp-gw-vector nil
"Keeps the remote host identification. Needed for Tramp messages.")
(defvar tramp-gw-gw-vector nil
"Current gateway identification vector.")
(defvar tramp-gw-gw-proc nil
"Current gateway process.")
;; This variable keeps the listening process, in order to reuse it for
;; new processes.
(defvar tramp-gw-aux-proc nil
"Process listening on local port, as mediation between SSH and the gateway.")
(defun tramp-gw-gw-proc-sentinel (proc event)
"Delete auxiliary process when we are deleted."
(unless (memq (process-status proc) '(run open))
(tramp-message
tramp-gw-vector 4 "Deleting auxiliary process `%s'" tramp-gw-gw-proc)
(let* (tramp-verbose
(p (tramp-get-connection-property proc "process" nil)))
(when (processp p) (delete-process p)))))
(defun tramp-gw-aux-proc-sentinel (proc event)
"Activate the different filters for involved gateway and auxiliary processes."
(when (memq (process-status proc) '(run open))
;; A new process has been spawned from `tramp-gw-aux-proc'.
(tramp-message
tramp-gw-vector 4
"Opening auxiliary process `%s', speaking with process `%s'"
proc tramp-gw-gw-proc)
(tramp-set-process-query-on-exit-flag proc nil)
;; We don't want debug messages, because the corresponding debug
;; buffer might be undecided.
(let (tramp-verbose)
(tramp-set-connection-property tramp-gw-gw-proc "process" proc)
(tramp-set-connection-property proc "process" tramp-gw-gw-proc))
;; Set the process-filter functions for both processes.
(set-process-filter proc 'tramp-gw-process-filter)
(set-process-filter tramp-gw-gw-proc 'tramp-gw-process-filter)
;; There might be already some output from the gateway process.
(with-current-buffer (process-buffer tramp-gw-gw-proc)
(unless (= (point-min) (point-max))
(let ((s (buffer-string)))
(delete-region (point) (point-max))
(tramp-gw-process-filter tramp-gw-gw-proc s))))))
(defun tramp-gw-process-filter (proc string)
(let (tramp-verbose)
(process-send-string
(tramp-get-connection-property proc "process" nil) string)))
(defun tramp-gw-open-connection (vec gw-vec target-vec)
"Open a remote connection to VEC (see `tramp-file-name' structure).
Take GW-VEC as SOCKS or HTTP gateway, i.e. its method must be a
gateway method. TARGET-VEC identifies where to connect to via
the gateway, it can be different from VEC when there are more
hops to be applied.
It returns a string like \"localhost#port\", which must be used
instead of the host name declared in TARGET-VEC."
;; Remember vectors for property retrieval.
(setq tramp-gw-vector vec
tramp-gw-gw-vector gw-vec)
;; Start listening auxiliary process.
(unless (and (processp tramp-gw-aux-proc)
(memq (process-status tramp-gw-aux-proc) '(listen)))
(let ((aux-vec
(vector "aux" (tramp-file-name-user gw-vec)
(tramp-file-name-host gw-vec) nil)))
(setq tramp-gw-aux-proc
(make-network-process
:name (tramp-buffer-name aux-vec) :buffer nil :host 'local
:server t :noquery t :service t :coding 'binary))
(set-process-sentinel tramp-gw-aux-proc 'tramp-gw-aux-proc-sentinel)
(tramp-set-process-query-on-exit-flag tramp-gw-aux-proc nil)
(tramp-message
vec 4 "Opening auxiliary process `%s', listening on port %d"
tramp-gw-aux-proc (process-contact tramp-gw-aux-proc :service))))
(let* ((gw-method
(intern
(tramp-find-method
(tramp-file-name-method gw-vec)
(tramp-file-name-user gw-vec)
(tramp-file-name-host gw-vec))))
(socks-username
(tramp-find-user
(tramp-file-name-method gw-vec)
(tramp-file-name-user gw-vec)
(tramp-file-name-host gw-vec)))
;; Declare the SOCKS server to be used.
(socks-server
(list "Tramp tempory socks server list"
;; Host name.
(tramp-file-name-real-host gw-vec)
;; Port number.
(or (tramp-file-name-port gw-vec)
(case gw-method
(tunnel tramp-gw-default-tunnel-port)
(socks tramp-gw-default-socks-port)))
;; Type. We support only http and socks5, NO socks4.
;; 'http could be used when HTTP tunnel works in socks.el.
5))
;; The function to be called.
(socks-function
(case gw-method
(tunnel 'tramp-gw-open-network-stream)
(socks 'socks-open-network-stream)))
socks-noproxy)
;; Open SOCKS process.
(setq tramp-gw-gw-proc
(funcall
socks-function
(tramp-buffer-name gw-vec)
(tramp-get-buffer gw-vec)
(tramp-file-name-real-host target-vec)
(tramp-file-name-port target-vec)))
(set-process-sentinel tramp-gw-gw-proc 'tramp-gw-gw-proc-sentinel)
(tramp-set-process-query-on-exit-flag tramp-gw-gw-proc nil)
(tramp-message
vec 4 "Opened %s process `%s'"
(case gw-method ('tunnel "HTTP tunnel") ('socks "SOCKS"))
tramp-gw-gw-proc)
;; Return the new host for gateway access.
(format "localhost#%d" (process-contact tramp-gw-aux-proc :service))))
(defun tramp-gw-open-network-stream (name buffer host service)
"Open stream to proxy server HOST:SERVICE.
Resulting process has name NAME and buffer BUFFER. If
authentication is requested from proxy server, provide it."
(let ((command (format (concat
"CONNECT %s:%d HTTP/1.1\r\n"
"Host: %s:%d\r\n"
"Connection: keep-alive\r\n"
"User-Agent: Tramp/%s\r\n")
host service host service tramp-version))
(authentication "")
(first t)
found proc)
(while (not found)
;; Clean up.
(when (processp proc) (delete-process proc))
(with-current-buffer buffer (erase-buffer))
;; Open network stream.
(setq proc (open-network-stream
name buffer (nth 1 socks-server) (nth 2 socks-server)))
(set-process-coding-system proc 'binary 'binary)
(tramp-set-process-query-on-exit-flag proc nil)
;; Send CONNECT command.
(process-send-string proc (format "%s%s\r\n" command authentication))
(tramp-message
tramp-gw-vector 6 "\n%s"
(format
"%s%s\r\n" command
(replace-regexp-in-string ;; no password in trace!
"Basic [^\r\n]+" "Basic xxxxx" authentication t)))
(with-current-buffer buffer
;; Trap errors to be traced in the right trace buffer. Often,
;; proxies have a timeout of 60". We wait 65" in order to
;; receive an answer this case.
(condition-case nil
(let (tramp-verbose)
(tramp-wait-for-regexp proc 65 "\r?\n\r?\n"))
(error nil))
;; Check return code.
(goto-char (point-min))
(narrow-to-region
(point-min)
(or (search-forward-regexp "\r?\n\r?\n" nil t) (point-max)))
(tramp-message tramp-gw-vector 6 "\n%s" (buffer-string))
(goto-char (point-min))
(search-forward-regexp "^HTTP/[1-9]\\.[0-9]" nil t)
(case (condition-case nil (read (current-buffer)) (error))
;; Connected.
(200 (setq found t))
;; We need basic authentication.
(401 (setq authentication (tramp-gw-basic-authentication nil first)))
;; Target host not found.
(404 (tramp-error-with-buffer
(current-buffer) tramp-gw-vector 'file-error
"Host %s not found." host))
;; We need basic proxy authentication.
(407 (setq authentication (tramp-gw-basic-authentication t first)))
;; Connection failed.
(503 (tramp-error-with-buffer
(current-buffer) tramp-gw-vector 'file-error
"Connection to %s:%d failed." host service))
;; That doesn't work at all.
(t (tramp-error-with-buffer
(current-buffer) tramp-gw-vector 'file-error
"Access to HTTP server %s:%d failed."
(nth 1 socks-server) (nth 2 socks-server))))
;; Remove HTTP headers.
(delete-region (point-min) (point-max))
(widen)
(setq first nil)))
;; Return the process.
proc))
(defun tramp-gw-basic-authentication (proxy pw-cache)
"Return authentication header for CONNECT, based on server request.
PROXY is an indication whether we need a Proxy-Authorization header
or an Authorization header. If PW-CACHE is non-nil, check for
password in password cache. This is done for the first try only."
;; `tramp-current-*' must be set for `tramp-read-passwd' and
;; `tramp-clear-passwd'.
(let ((tramp-current-method (tramp-file-name-method tramp-gw-gw-vector))
(tramp-current-user (tramp-file-name-user tramp-gw-gw-vector))
(tramp-current-host (tramp-file-name-host tramp-gw-gw-vector)))
(unless pw-cache (tramp-clear-passwd))
;; We are already in the right buffer.
(tramp-message
tramp-gw-vector 5 "%s required"
(if proxy "Proxy authentication" "Authentication"))
;; Search for request header. We accept only basic authentication.
(goto-char (point-min))
(search-forward-regexp
"^\\(Proxy\\|WWW\\)-Authenticate:\\s-*Basic\\s-+realm=")
;; Return authentication string.
(format
"%s: Basic %s\r\n"
(if proxy "Proxy-Authorization" "Authorization")
(base64-encode-string
(format
"%s:%s"
socks-username
(tramp-read-passwd
proc
(format
"Password for %s@[%s]: " socks-username (read (current-buffer)))))))))
(provide 'tramp-gw)
;;; TODO:
;; * Provide descriptive Commentary.
;; * Enable it for several gateway processes in parallel.
;; arch-tag: 277e3a81-fdee-40cf-9e6b-59626292a5e0
;;; tramp-gw.el ends here

1009
lisp/net/tramp-smb.el
View File

File diff suppressed because it is too large Load Diff

138
lisp/net/tramp-util.el
View File

@ -1,138 +0,0 @@
;;; -*- coding: iso-2022-7bit; -*-
;;; tramp-util.el --- Misc utility functions to use with Tramp
;; Copyright (C) 2001, 2002, 2003, 2004, 2005,
;; 2006, 2007 Free Software Foundation, Inc.
;; Author: kai.grossjohann@gmx.net
;; Keywords: comm, extensions, processes
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; Some misc. utility functions that might go nicely with Tramp.
;; Mostly, these are kluges awaiting real solutions later on.
;;; Code:
(require 'compile)
(require 'tramp)
(add-hook 'tramp-util-unload-hook
'(lambda ()
(when (featurep 'tramp)
(unload-feature 'tramp 'force))))
;; Define a Tramp minor mode. It's intention is to redefine some keys for Tramp
;; specific functions, like compilation.
;; The key remapping works since Emacs 22 only. Unknown for XEmacs.
;; Pacify byte-compiler
(eval-when-compile
(unless (fboundp 'define-minor-mode)
(defalias 'define-minor-mode 'identity)
(defvar tramp-minor-mode))
(unless (featurep 'xemacs)
(defalias 'add-menu-button 'ignore)))
(defvar tramp-minor-mode-map (make-sparse-keymap)
"Keymap for Tramp minor mode.")
(define-minor-mode tramp-minor-mode "Tramp minor mode for utility functions."
:group 'tramp
:global nil
:init-value nil
:lighter " Tramp"
:keymap tramp-minor-mode-map
(setq tramp-minor-mode
(and tramp-minor-mode (tramp-tramp-file-p default-directory))))
(add-hook 'find-file-hooks 'tramp-minor-mode t)
(add-hook 'tramp-util-unload-hook
'(lambda ()
(remove-hook 'find-file-hooks 'tramp-minor-mode)))
(add-hook 'dired-mode-hook 'tramp-minor-mode t)
(add-hook 'tramp-util-unload-hook
'(lambda ()
(remove-hook 'dired-mode-hook 'tramp-minor-mode)))
(defun tramp-remap-command (old-command new-command)
"Replaces bindings of OLD-COMMAND by NEW-COMMAND.
If remapping functionality for keymaps is defined, this happens for all
bindings. Otherwise, only bindings active during invocation are taken
into account. XEmacs menubar bindings are not changed by this."
(if (functionp 'command-remapping)
;; Emacs 22
(eval
`(define-key tramp-minor-mode-map [remap ,old-command] new-command))
;; previous Emacs versions.
(mapcar
'(lambda (x)
(define-key tramp-minor-mode-map x new-command))
(where-is-internal old-command))))
(tramp-remap-command 'compile 'tramp-compile)
(tramp-remap-command 'recompile 'tramp-recompile)
;; XEmacs has an own mimic for menu entries
(when (fboundp 'add-menu-button)
(funcall 'add-menu-button
'("Tools" "Compile")
["Compile..."
(command-execute (if tramp-minor-mode 'tramp-compile 'compile))
:active (fboundp 'compile)])
(funcall 'add-menu-button
'("Tools" "Compile")
["Repeat Compilation"
(command-execute (if tramp-minor-mode 'tramp-recompile 'recompile))
:active (fboundp 'compile)]))
;; Utility functions.
(defun tramp-compile (command)
"Compile on remote host."
(interactive
(if (or compilation-read-command current-prefix-arg)
(list (read-from-minibuffer "Compile command: "
compile-command nil nil
'(compile-history . 1)))
(list compile-command)))
(setq compile-command command)
(save-some-buffers (not compilation-ask-about-save) nil)
(let ((d default-directory))
(save-excursion
(pop-to-buffer (get-buffer-create "*Compilation*") t)
(erase-buffer)
(setq default-directory d)))
(tramp-handle-shell-command command (get-buffer "*Compilation*"))
(pop-to-buffer (get-buffer "*Compilation*"))
(tramp-minor-mode 1)
(compilation-minor-mode 1))
(defun tramp-recompile ()
"Re-compile on remote host."
(interactive)
(save-some-buffers (not compilation-ask-about-save) nil)
(tramp-handle-shell-command compile-command (get-buffer "*Compilation*"))
(pop-to-buffer (get-buffer "*Compilation*"))
(tramp-minor-mode 1)
(compilation-minor-mode 1))
(provide 'tramp-util)
;;; arch-tag: 500f9992-a44e-46d0-83a7-980799251808
;;; tramp-util.el ends here

9
lisp/net/tramp-uu.el
View File

@ -9,8 +9,8 @@
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; the Free Software Foundation; either version 3 of the License, or
;; (at your option) any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@ -18,9 +18,8 @@
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;; along with GNU Emacs; see the file COPYING. If not, see
;; <http://www.gnu.org/licenses/>.
;;; Commentary:

536
lisp/net/tramp-vc.el
View File

@ -1,536 +0,0 @@
;;; tramp-vc.el --- Version control integration for TRAMP.el
;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007 Free Software Foundation, Inc.
;; Author: Daniel Pittman <daniel@danann.net>
;; Keywords: comm, processes
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; See the main module, 'tramp.el' for discussion of the purpose of TRAMP.
;; This module provides integration between remote files accessed by TRAMP and
;; the Emacs version control system.
;;; Code:
(require 'vc)
;; Old VC defines vc-rcs-release in vc.el, new VC requires extra module.
(unless (boundp 'vc-rcs-release)
(require 'vc-rcs))
(require 'tramp)
;; Avoid byte-compiler warnings if the byte-compiler supports this.
;; Currently, XEmacs supports this.
(eval-when-compile
(when (fboundp 'byte-compiler-options)
(let (unused-vars) ; Pacify Emacs byte-compiler
(defalias 'warnings 'identity) ; Pacify Emacs byte-compiler
(byte-compiler-options (warnings (- unused-vars))))))
;; -- vc --
;; This used to blow away the file-name-handler-alist and reinstall
;; TRAMP into it. This was intended to let VC work remotely. It didn't,
;; at least not in my XEmacs 21.2 install.
;;
;; In any case, tramp-run-real-handler now deals correctly with disabling
;; the things that should be, making this a no-op.
;;
;; I have removed it from the tramp-file-name-handler-alist because the
;; shortened version does nothing. This is for reference only now.
;;
;; Daniel Pittman <daniel@danann.net>
;;
;; (defun tramp-handle-vc-registered (file)
;; "Like `vc-registered' for tramp files."
;; (tramp-run-real-handler 'vc-registered (list file)))
;; `vc-do-command'
;; This function does not deal well with remote files, so we define
;; our own version and make a backup of the original function and
;; call our version for tramp files and the original version for
;; normal files.
;; The following function is pretty much copied from vc.el, but
;; the part that actually executes a command is changed.
;; CCC: this probably works for Emacs 21, too.
(defun tramp-vc-do-command (buffer okstatus command file last &rest flags)
"Like `vc-do-command' but invoked for tramp files.
See `vc-do-command' for more information."
(save-match-data
(and file (setq file (expand-file-name file)))
(if (not buffer) (setq buffer "*vc*"))
(if vc-command-messages
(message "Running `%s' on `%s'..." command file))
(let ((obuf (current-buffer)) (camefrom (current-buffer))
(squeezed nil)
(olddir default-directory)
vc-file status)
(let* ((v (tramp-dissect-file-name (expand-file-name file)))
(multi-method (tramp-file-name-multi-method v))
(method (tramp-file-name-method v))
(user (tramp-file-name-user v))
(host (tramp-file-name-host v))
(localname (tramp-file-name-localname v)))
(set-buffer (get-buffer-create buffer))
(set (make-local-variable 'vc-parent-buffer) camefrom)
(set (make-local-variable 'vc-parent-buffer-name)
(concat " from " (buffer-name camefrom)))
(setq default-directory olddir)
(erase-buffer)
(mapcar
(function
(lambda (s) (and s (setq squeezed (append squeezed (list s))))))
flags)
(if (and (eq last 'MASTER) file
(setq vc-file (vc-name file)))
(setq squeezed
(append squeezed
(list (tramp-file-name-localname
(tramp-dissect-file-name vc-file))))))
(if (and file (eq last 'WORKFILE))
(progn
(let* ((pwd (expand-file-name default-directory))
(preflen (length pwd)))
(if (string= (substring file 0 preflen) pwd)
(setq file (substring file preflen))))
(setq squeezed (append squeezed (list file)))))
;; Unless we (save-window-excursion) the layout of windows in
;; the current frame changes. This is painful, at best.
;;
;; As a point of note, (save-excursion) is still here only because
;; it preserves (point) in the current buffer. (save-window-excursion)
;; does not, at least under XEmacs 21.2.
;;
;; I trust that the FSF support this as well. I can't find useful
;; documentation to check :(
;;
;; Daniel Pittman <daniel@danann.net>
(save-excursion
(save-window-excursion
;; Actually execute remote command
;; `shell-command' cannot be used; it isn't magic in XEmacs.
(tramp-handle-shell-command
(mapconcat 'tramp-shell-quote-argument
(cons command squeezed) " ") t)
;;(tramp-wait-for-output)
;; Get status from command
(tramp-send-command multi-method method user host "echo $?")
(tramp-wait-for-output)
;; Make sure to get status from last line of output.
(goto-char (point-max)) (forward-line -1)
(setq status (read (current-buffer)))
(message "Command %s returned status %d." command status)))
(goto-char (point-max))
(set-buffer-modified-p nil)
(forward-line -1)
(if (or (not (integerp status))
(and (integerp okstatus) (< okstatus status)))
(progn
(pop-to-buffer buffer)
(goto-char (point-min))
(shrink-window-if-larger-than-buffer)
(error "Running `%s'...FAILED (%s)" command
(if (integerp status)
(format "status %d" status)
status))
)
(if vc-command-messages
(message "Running %s...OK" command))
)
(set-buffer obuf)
status))
))
;; Following code snarfed from Emacs 21 vc.el and slightly tweaked.
(defun tramp-vc-do-command-new (buffer okstatus command file &rest flags)
"Like `vc-do-command' but for TRAMP files.
This function is for the new VC which comes with Emacs 21.
Since TRAMP doesn't do async commands yet, this function doesn't, either."
(and file (setq file (expand-file-name file)))
(if vc-command-messages
(message "Running %s on %s..." command file))
(save-current-buffer
(unless (eq buffer t)
; Pacify byte-compiler
(funcall (symbol-function 'vc-setup-buffer) buffer))
(let ((squeezed nil)
(inhibit-read-only t)
(status 0))
(let* ((v (when file (tramp-dissect-file-name file)))
(multi-method (when file (tramp-file-name-multi-method v)))
(method (when file (tramp-file-name-method v)))
(user (when file (tramp-file-name-user v)))
(host (when file (tramp-file-name-host v)))
(localname (when file (tramp-file-name-localname v))))
(setq squeezed (delq nil (copy-sequence flags)))
(when file
(setq squeezed (append squeezed (list (file-relative-name
file default-directory)))))
(let ((w32-quote-process-args t))
(when (eq okstatus 'async)
(message "Tramp doesn't do async commands, running synchronously."))
;; `shell-command' cannot be used; it isn't magic in XEmacs.
(setq status (tramp-handle-shell-command
(mapconcat 'tramp-shell-quote-argument
(cons command squeezed) " ") t))
(when (or (not (integerp status))
(and (integerp okstatus) (< okstatus status)))
(pop-to-buffer (current-buffer))
(goto-char (point-min))
(shrink-window-if-larger-than-buffer)
(error "Running %s...FAILED (%s)" command
(if (integerp status) (format "status %d" status) status))))
(if vc-command-messages
(message "Running %s...OK" command))
; Pacify byte-compiler
(funcall (symbol-function 'vc-exec-after)
`(run-hook-with-args
'vc-post-command-functions ',command ',localname ',flags))
status))))
;; The context for a VC command is the current buffer.
;; That makes a test on the buffers file more reliable than a test on the
;; arguments.
;; This is needed to handle remote VC correctly - else we test against the
;; local VC system and get things wrong...
;; Daniel Pittman <daniel@danann.net>
;;-(if (fboundp 'vc-call-backend)
;;- () ;; This is the new VC for which we don't have an appropriate advice yet
;;-)
(unless (fboundp 'process-file)
(if (fboundp 'vc-call-backend)
(defadvice vc-do-command
(around tramp-advice-vc-do-command
(buffer okstatus command file &rest flags)
activate)
"Invoke tramp-vc-do-command for tramp files."
(let ((file (symbol-value 'file))) ;pacify byte-compiler
(if (or (and (stringp file) (tramp-tramp-file-p file))
(and (buffer-file-name) (tramp-tramp-file-p (buffer-file-name))))
(setq ad-return-value
(apply 'tramp-vc-do-command-new buffer okstatus command
file ;(or file (buffer-file-name))
flags))
ad-do-it)))
(defadvice vc-do-command
(around tramp-advice-vc-do-command
(buffer okstatus command file last &rest flags)
activate)
"Invoke tramp-vc-do-command for tramp files."
(let ((file (symbol-value 'file))) ;pacify byte-compiler
(if (or (and (stringp file) (tramp-tramp-file-p file))
(and (buffer-file-name) (tramp-tramp-file-p (buffer-file-name))))
(setq ad-return-value
(apply 'tramp-vc-do-command buffer okstatus command
(or file (buffer-file-name)) last flags))
ad-do-it))))
(add-hook 'tramp-unload-hook
'(lambda () (ad-unadvise 'vc-do-command))))
;; XEmacs uses this to do some of its work. Like vc-do-command, we
;; need to enhance it to make VC work via TRAMP-mode.
;;
;; Like the previous function, this is a cut-and-paste job from the VC
;; file. It's based on the vc-do-command code.
;; CCC: this isn't used in Emacs 21, so do as before.
(defun tramp-vc-simple-command (okstatus command file &rest args)
;; Simple version of vc-do-command, for use in vc-hooks only.
;; Don't switch to the *vc-info* buffer before running the
;; command, because that would change its default directory
(save-match-data
(let* ((v (tramp-dissect-file-name (expand-file-name file)))
(multi-method (tramp-file-name-multi-method v))
(method (tramp-file-name-method v))
(user (tramp-file-name-user v))
(host (tramp-file-name-host v))
(localname (tramp-file-name-localname v)))
(save-excursion (set-buffer (get-buffer-create "*vc-info*"))
(erase-buffer))
(let ((exec-path (append vc-path exec-path)) exec-status
;; Add vc-path to PATH for the execution of this command.
(process-environment
(cons (concat "PATH=" (getenv "PATH")
path-separator
(mapconcat 'identity vc-path path-separator))
process-environment)))
;; Call the actual process. See tramp-vc-do-command for discussion of
;; why this does both (save-window-excursion) and (save-excursion).
;;
;; As a note, I don't think that the process-environment stuff above
;; has any effect on the remote system. This is a hard one though as
;; there is no real reason to expect local and remote paths to be
;; identical...
;;
;; Daniel Pittman <daniel@danann.net>
(save-excursion
(save-window-excursion
;; Actually execute remote command
;; `shell-command' cannot be used; it isn't magic in XEmacs.
(tramp-handle-shell-command
(mapconcat 'tramp-shell-quote-argument
(append (list command) args (list localname)) " ")
(get-buffer-create"*vc-info*"))
;(tramp-wait-for-output)
;; Get status from command
(tramp-send-command multi-method method user host "echo $?")
(tramp-wait-for-output)
(setq exec-status (read (current-buffer)))
(message "Command %s returned status %d." command exec-status)))
;; Maybe okstatus can be `async' here. But then, maybe the
;; async thing is new in Emacs 21, but this function is only
;; used in Emacs 20.
(cond ((> exec-status okstatus)
(switch-to-buffer (get-file-buffer file))
(shrink-window-if-larger-than-buffer
(display-buffer "*vc-info*"))
(error "Couldn't find version control information")))
exec-status))))
;; This function does not exist any more in Emacs-21's VC
(defadvice vc-simple-command
(around tramp-advice-vc-simple-command
(okstatus command file &rest args)
activate)
"Invoke tramp-vc-simple-command for tramp files."
(let ((file (symbol-value 'file))) ;pacify byte-compiler
(if (or (and (stringp file) (tramp-tramp-file-p file))
(and (buffer-file-name) (tramp-tramp-file-p (buffer-file-name))))
(setq ad-return-value
(apply 'tramp-vc-simple-command okstatus command
(or file (buffer-file-name)) args))
ad-do-it)))
(add-hook 'tramp-unload-hook
'(lambda () (ad-unadvise 'vc-simple-command)))
;; `vc-workfile-unchanged-p'
;; This function does not deal well with remote files, so we do the
;; same as for `vc-do-command'.
;; `vc-workfile-unchanged-p' checks the modification time, we cannot
;; do that for remote files, so here's a version which relies on diff.
;; CCC: this one probably works for Emacs 21, too.
(defun tramp-vc-workfile-unchanged-p
(filename &optional want-differences-if-changed)
(if (fboundp 'vc-backend-diff)
;; Old VC. Call `vc-backend-diff'.
(let ((status (funcall (symbol-function 'vc-backend-diff)
filename nil nil
(not want-differences-if-changed))))
(zerop status))
;; New VC. Call `vc-default-workfile-unchanged-p'.
(funcall (symbol-function 'vc-default-workfile-unchanged-p)
(vc-backend filename) filename)))
(defadvice vc-workfile-unchanged-p
(around tramp-advice-vc-workfile-unchanged-p
(filename &optional want-differences-if-changed)
activate)
"Invoke tramp-vc-workfile-unchanged-p for tramp files."
(if (and (stringp filename)
(tramp-tramp-file-p filename)
(not
(let ((v (tramp-dissect-file-name filename)))
;; The following check is probably to test whether
;; file-attributes returns correct last modification
;; times. This check needs to be changed.
(tramp-get-remote-perl (tramp-file-name-multi-method v)
(tramp-file-name-method v)
(tramp-file-name-user v)
(tramp-file-name-host v)))))
(setq ad-return-value
(tramp-vc-workfile-unchanged-p filename want-differences-if-changed))
ad-do-it))
(add-hook 'tramp-unload-hook
'(lambda () (ad-unadvise 'vc-workfile-unchanged-p)))
;; Redefine a function from vc.el -- allow tramp files.
;; `save-match-data' seems not to be required -- it isn't in
;; the original version, either.
;; CCC: this might need some work -- how does the Emacs 21 version
;; work, anyway? Does it work over ange-ftp? Hm.
(if (not (fboundp 'vc-backend-checkout))
() ;; our replacement won't work and is unnecessary anyway
(defun vc-checkout (filename &optional writable rev)
"Retrieve a copy of the latest version of the given file."
;; If ftp is on this system and the name matches the ange-ftp format
;; for a remote file, the user is trying something that won't work.
(funcall (symbol-function 'vc-backend-checkout) filename writable rev)
(vc-resynch-buffer filename t t))
)
;; Do we need to advise the vc-user-login-name function anyway?
;; This will return the correct login name for the owner of a
;; file. It does not deal with the default remote user name...
;;
;; That is, when vc calls (vc-user-login-name), we return the
;; local login name, something that may be different to the remote
;; default.
;;
;; The remote VC operations will occur as the user that we logged
;; in with however - not always the same as the local user.
;;
;; In the end, I did advise the function. This is because, well,
;; the thing didn't work right otherwise ;)
;;
;; Daniel Pittman <daniel@danann.net>
(defun tramp-handle-vc-user-login-name (&optional uid)
"Return the default user name on the remote machine.
Whenever VC calls this function, `file' is bound to the file name
in question. If no uid is provided or the uid is equal to the uid
owning the file, then we return the user name given in the file name.
This should only be called when `file' is bound to the
filename we are thinking about..."
;; Pacify byte-compiler; this symbol is bound in the calling
;; function. CCC: Maybe it would be better to move the
;; boundness-checking into this function?
(let* ((file (symbol-value 'file))
(remote-uid
;; With Emacs 22, `file-attributes' has got an optional parameter
;; ID-FORMAT. Handle this case backwards compatible.
(if (and (functionp 'subr-arity)
(= 2 (cdr (funcall (symbol-function 'subr-arity)
(symbol-function 'file-attributes)))))
(nth 2 (file-attributes file 'integer))
(nth 2 (file-attributes file)))))
(if (and uid (/= uid remote-uid))
(error "tramp-handle-vc-user-login-name cannot map a uid to a name")
(let* ((v (tramp-dissect-file-name (expand-file-name file)))
(u (tramp-file-name-user v)))
(cond ((stringp u) u)
((vectorp u) (elt u (1- (length u))))
((null u) (user-login-name))
(t (error "tramp-handle-vc-user-login-name cannot cope!")))))))
;; The following defadvice is no longer necessary after changes in VC
;; on 2006-01-25, Andre.
(unless (fboundp 'process-file)
(defadvice vc-user-login-name
(around tramp-vc-user-login-name activate)
"Support for files on remote machines accessed by TRAMP."
;; We rely on the fact that `file' is bound when this is called.
;; This appears to be the case everywhere in vc.el and vc-hooks.el
;; as of Emacs 20.5.
;;
;; With Emacs 22, the definition of `vc-user-login-name' has been
;; changed. It doesn't need to be adviced any longer.
(let ((file (when (boundp 'file)
(symbol-value 'file)))) ;pacify byte-compiler
(or (and (stringp file)
(tramp-tramp-file-p file) ; tramp file
(setq ad-return-value
(save-match-data
(tramp-handle-vc-user-login-name uid)))) ; get the owner name
ad-do-it))) ; else call the original
(add-hook 'tramp-unload-hook
'(lambda () (ad-unadvise 'vc-user-login-name))))
;; Determine the name of the user owning a file.
(defun tramp-file-owner (filename)
"Return who owns FILE (user name, as a string)."
(let ((v (tramp-dissect-file-name
(expand-file-name filename))))
(if (not (file-exists-p filename))
nil ; file cannot be opened
;; file exists, find out stuff
(save-excursion
(tramp-send-command
(tramp-file-name-multi-method v) (tramp-file-name-method v)
(tramp-file-name-user v) (tramp-file-name-host v)
(format "%s -Lld %s"
(tramp-get-ls-command (tramp-file-name-multi-method v)
(tramp-file-name-method v)
(tramp-file-name-user v)
(tramp-file-name-host v))
(tramp-shell-quote-argument (tramp-file-name-localname v))))
(tramp-wait-for-output)
;; parse `ls -l' output ...
;; ... file mode flags
(read (current-buffer))
;; ... number links
(read (current-buffer))
;; ... uid (as a string)
(symbol-name (read (current-buffer)))))))
;; Wire ourselves into the VC infrastructure...
;; This function does not exist any more in Emacs-21's VC
;; CCC: it appears that no substitute is needed for Emacs 21.
(defadvice vc-file-owner
(around tramp-vc-file-owner activate)
"Support for files on remote machines accessed by TRAMP."
(let ((filename (ad-get-arg 0)))
(or (and (tramp-file-name-p filename) ; tramp file
(setq ad-return-value
(save-match-data
(tramp-file-owner filename)))) ; get the owner name
ad-do-it))) ; else call the original
(add-hook 'tramp-unload-hook
'(lambda () (ad-unadvise 'vc-file-owner)))
;; We need to make the version control software backend version
;; information local to the current buffer. This is because each TRAMP
;; buffer can (theoretically) have a different VC version and I am
;; *way* too lazy to try and push the correct value into each new
;; buffer.
;;
;; Remote VC costs will just have to be paid, at least for the moment.
;; Well, at least, they will right until I feel guilty about doing a
;; botch job here and fix it. :/
;;
;; Daniel Pittman <daniel@danann.net>
;; CCC: this is probably still needed for Emacs 21.
(defun tramp-vc-setup-for-remote ()
"Make the backend release variables buffer local.
This makes remote VC work correctly at the cost of some processing time."
(when (and (buffer-file-name)
(tramp-tramp-file-p (buffer-file-name)))
(make-local-variable 'vc-rcs-release)
(setq vc-rcs-release nil)))
(add-hook 'find-file-hooks 'tramp-vc-setup-for-remote t)
(add-hook 'tramp-unload-hook
'(lambda ()
(remove-hook 'find-file-hooks 'tramp-vc-setup-for-remote)))
;; No need to load this again if anyone asks.
(provide 'tramp-vc)
;;; arch-tag: 27cc42ce-da19-468d-ad5c-a2690558db60
;;; tramp-vc.el ends here

8478
lisp/net/tramp.el
View File

File diff suppressed because it is too large Load Diff

18
lisp/net/trampver.el
View File

@ -11,8 +11,8 @@
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; the Free Software Foundation; either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@ -20,22 +20,26 @@
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;; along with GNU Emacs; see the file COPYING. If not, see
;; <http://www.gnu.org/licenses/>.
;;; Code:
;; In the Tramp CVS repository, the version numer and the bug report address
;; are auto-frobbed from configure.ac, so you should edit that file and run
;; "autoconf && ./configure" to change them.
;; "autoconf && ./configure" to change them. (X)Emacs version check is defined
;; in macro AC_EMACS_INFO of aclocal.m4; should be changed only there.
(defconst tramp-version "2.0.56"
(defconst tramp-version "2.1.10-pre"
"This version of Tramp.")
(defconst tramp-bug-report-address "tramp-devel@gnu.org"
"Email address to send bug reports to.")
;; Check for (X)Emacs version.
(let ((x (if (or (< emacs-major-version 21) (and (featurep 'xemacs) (< emacs-minor-version 4))) (format "Tramp 2.1.10-pre is not fit for %s" (when (string-match "^.*$" (emacs-version)) (match-string 0 (emacs-version)))) "ok")))
(unless (string-match "\\`ok\\'" x) (error x)))
(provide 'trampver)
;;; arch-tag: 443576ca-f8f1-4bb1-addc-5c70861e93b1

5
lisp/novice.el
View File

@ -88,8 +88,9 @@ n to cancel--don't try the command, and it remains disabled.
SPC to try the command just this once, but leave it disabled.
! to try it, and enable all disabled commands for this session only.")
(save-excursion
(set-buffer standard-output)
(help-mode)))
(set-buffer standard-output)
(help-mode)))
(fit-window-to-buffer (get-buffer-window "*Disabled Command*"))
(message "Type y, n, ! or SPC (the space bar): ")
(let ((cursor-in-echo-area t))
(while (progn (setq char (read-event))

1
lisp/pcomplete.el
View File

@ -711,6 +711,7 @@ If PREDICATE is non-nil, it will also be used to refine the match
If no directory information can be extracted from the completed
component, `default-directory' is used as the basis for completion."
(let* ((name (substitute-env-vars pcomplete-stub))
(completion-ignore-case pcomplete-ignore-case)
(default-directory (expand-file-name
(or (file-name-directory name)
default-directory)))

4
lisp/pcvs-info.el
View File

@ -85,9 +85,9 @@ to confuse some users sometimes."
(defface cvs-unknown
'((((class color) (background dark))
(:foreground "red"))
(:foreground "red1"))
(((class color) (background light))
(:foreground "red"))
(:foreground "red1"))
(t (:slant italic)))
"PCL-CVS face used to highlight unknown file status."
:group 'pcl-cvs)

31
lisp/pcvs-util.el
View File

@ -186,35 +186,6 @@ arguments. If ARGS is not a list, no argument will be passed."
"Tell whether STR1 is a prefix of STR2."
(eq t (compare-strings str2 nil (length str1) str1 nil nil)))
;; (string->strings (strings->string X)) == X
(defun cvs-strings->string (strings &optional separator)
"Concatenate the STRINGS, adding the SEPARATOR (default \" \").
This tries to quote the strings to avoid ambiguity such that
(cvs-string->strings (cvs-strings->string strs)) == strs
Only some SEPARATORs will work properly."
(let ((sep (or separator " ")))
(mapconcat
(lambda (str)
(if (string-match "[\\\"]" str)
(concat "\"" (replace-regexp-in-string "[\\\"]" "\\\\\\&" str) "\"")
str))
strings sep)))
;; (string->strings (strings->string X)) == X
(defun cvs-string->strings (string &optional separator)
"Split the STRING into a list of strings.
It understands elisp style quoting within STRING such that
(cvs-string->strings (cvs-strings->string strs)) == strs
The SEPARATOR regexp defaults to \"\\s-+\"."
(let ((sep (or separator "\\s-+"))
(i (string-match "[\"]" string)))
(if (null i) (split-string string sep t) ; no quoting: easy
(append (unless (eq i 0) (split-string (substring string 0 i) sep t))
(let ((rfs (read-from-string string i)))
(cons (car rfs)
(cvs-string->strings (substring string (cdr rfs))
sep)))))))
;;;;
;;;; file names
;;;;
@ -240,7 +211,7 @@ The SEPARATOR regexp defaults to \"\\s-+\"."
(defconst cvs-qtypedesc-string1 (cvs-qtypedesc-create 'identity 'identity t))
(defconst cvs-qtypedesc-string (cvs-qtypedesc-create 'identity 'identity))
(defconst cvs-qtypedesc-strings
(cvs-qtypedesc-create 'cvs-string->strings 'cvs-strings->string nil))
(cvs-qtypedesc-create 'string->strings 'strings->string nil))
(defun cvs-query-read (default prompt qtypedesc &optional hist-sym)
(let* ((qtypedesc (or qtypedesc cvs-qtypedesc-strings))

10
lisp/pcvs.el
View File

@ -182,7 +182,7 @@
(when (re-search-forward
(concat "^" cmd "\\(\\s-+\\(.*\\)\\)?$") nil t)
(let* ((sym (intern (concat "cvs-" cmd "-flags")))
(val (cvs-string->strings (or (match-string 2) ""))))
(val (string->strings (or (match-string 2) ""))))
(cvs-flags-set sym 0 val))))
;; ensure that cvs doesn't have -q or -Q
(cvs-flags-set 'cvs-cvs-flags 0
@ -607,7 +607,7 @@ If non-nil, NEW means to create a new buffer no matter what."
(t arg)))
args)))
(concat cvs-program " "
(cvs-strings->string
(strings->string
(append (cvs-flags-query 'cvs-cvs-flags nil 'noquery)
(if cvs-cvsroot (list "-d" cvs-cvsroot))
args
@ -936,7 +936,7 @@ With a prefix argument, prompt for cvs FLAGS to use."
(let ((root (cvs-get-cvsroot)))
(if (or (null root) current-prefix-arg)
(setq root (read-string "CVS Root: ")))
(list (cvs-string->strings (read-string "Module(s): " (cvs-get-module)))
(list (string->strings (read-string "Module(s): " (cvs-get-module)))
(read-directory-name "CVS Checkout Directory: "
nil default-directory nil)
(cvs-add-branch-prefix
@ -959,7 +959,7 @@ The files are stored to DIR."
(if branch (format " (branch: %s)" branch)
""))))
(list (read-directory-name prompt nil default-directory nil))))
(let ((modules (cvs-string->strings (cvs-get-module)))
(let ((modules (string->strings (cvs-get-module)))
(flags (cvs-add-branch-prefix
(cvs-flags-query 'cvs-checkout-flags "cvs checkout flags")))
(cvs-cvsroot (cvs-get-cvsroot)))
@ -2244,7 +2244,7 @@ With prefix argument, prompt for cvs flags."
(let* ((args (append constant-args arg-list)))
(insert (format "=== %s %s\n\n"
program (cvs-strings->string args)))
program (strings->string args)))
;; FIXME: return the exit status?
(apply 'call-process program nil t t args)

10
lisp/progmodes/cc-mode.el
View File

@ -790,7 +790,8 @@ compatible with old code; callers should always specify it."
;; If the buffer specifies `mode' or `eval' in its File Local Variable list
;; or on the first line, remove all occurrences. See
;; `c-postprocess-file-styles' for justification. There is no need to save
;; point here, or even bother too much about the buffer contents.
;; point here, or even bother too much about the buffer contents. However,
;; DON'T mess up the kill-ring.
;;
;; Most of the code here is derived from Emacs 21.3's `hack-local-variables'
;; in files.el.
@ -819,8 +820,8 @@ compatible with old code; callers should always specify it."
(regexp-quote suffix)
"$")
nil t)
(beginning-of-line)
(delete-region (point) (progn (end-of-line) (point)))))
(forward-line 0)
(delete-region (point) (progn (forward-line) (point)))))
;; Delete the first line, if we've got one, in case it contains a mode spec.
(unless (and lv-point
@ -828,7 +829,8 @@ compatible with old code; callers should always specify it."
(forward-line 0)
(bobp)))
(goto-char (point-min))
(delete-region (point) (progn (end-of-line) (point))))))
(unless (eobp)
(delete-region (point) (progn (forward-line) (point)))))))
(defun c-postprocess-file-styles ()
"Function that post processes relevant file local variables in CC Mode.

136
lisp/progmodes/compile.el
View File

@ -87,13 +87,13 @@
;;;###autoload
(defcustom compilation-mode-hook nil
"*List of hook functions run by `compilation-mode' (see `run-mode-hooks')."
"List of hook functions run by `compilation-mode' (see `run-mode-hooks')."
:type 'hook
:group 'compilation)
;;;###autoload
(defcustom compilation-window-height nil
"*Number of lines in a compilation window. If nil, use Emacs default."
"Number of lines in a compilation window. If nil, use Emacs default."
:type '(choice (const :tag "Default" nil)
integer)
:group 'compilation)
@ -442,7 +442,7 @@ Highlight entire line if t; don't highlight source lines if nil.")
"Overlay used to temporarily highlight compilation matches.")
(defcustom compilation-error-screen-columns t
"*If non-nil, column numbers in error messages are screen columns.
"If non-nil, column numbers in error messages are screen columns.
Otherwise they are interpreted as character positions, with
each character occupying one column.
The default is to use screen columns, which requires that the compilation
@ -453,21 +453,21 @@ especially the TAB character."
:version "20.4")
(defcustom compilation-read-command t
"*Non-nil means \\[compile] reads the compilation command to use.
"Non-nil means \\[compile] reads the compilation command to use.
Otherwise, \\[compile] just uses the value of `compile-command'."
:type 'boolean
:group 'compilation)
;;;###autoload
(defcustom compilation-ask-about-save t
"*Non-nil means \\[compile] asks which buffers to save before compiling.
"Non-nil means \\[compile] asks which buffers to save before compiling.
Otherwise, it saves all modified buffers without asking."
:type 'boolean
:group 'compilation)
;;;###autoload
(defcustom compilation-search-path '(nil)
"*List of directories to search for source files named in error messages.
"List of directories to search for source files named in error messages.
Elements should be directory names, not file names of directories.
The value nil as an element means to try the default directory."
:type '(repeat (choice (const :tag "Default" nil)
@ -476,7 +476,7 @@ The value nil as an element means to try the default directory."
;;;###autoload
(defcustom compile-command "make -k "
"*Last shell command used to do a compilation; default for next compilation.
"Last shell command used to do a compilation; default for next compilation.
Sometimes it is useful for files to supply local values for this variable.
You might also use mode hooks to specify it in certain modes, like this:
@ -494,7 +494,7 @@ You might also use mode hooks to specify it in certain modes, like this:
;;;###autoload
(defcustom compilation-disable-input nil
"*If non-nil, send end-of-file as compilation process input.
"If non-nil, send end-of-file as compilation process input.
This only affects platforms that support asynchronous processes (see
`start-process'); synchronous compilation processes never accept input."
:type 'boolean
@ -605,6 +605,14 @@ Faces `compilation-error-face', `compilation-warning-face',
(defvar compilation-error-list nil)
(defvar compilation-old-error-list nil)
(defcustom compilation-auto-jump-to-first-error nil
"If non-nil, automatically jump to the first error after `compile'."
:type 'boolean)
(defvar compilation-auto-jump-to-next nil
"If non-nil, automatically jump to the next error encountered.")
(make-variable-buffer-local 'compilation-auto-jump-to-next)
(defun compilation-face (type)
(or (and (car type) (match-end (car type)) compilation-warning-face)
(and (cdr type) (match-end (cdr type)) compilation-info-face)
@ -652,13 +660,18 @@ Faces `compilation-error-face', `compilation-warning-face',
l2
(setcdr l1 (cons (list ,key) l2)))))))
(defun compilation-auto-jump (buffer pos)
(with-current-buffer buffer
(goto-char pos)
(compile-goto-error)))
;; This function is the central driver, called when font-locking to gather
;; all information needed to later jump to corresponding source code.
;; Return a property list with all meta information on this error location.
(defun compilation-error-properties (file line end-line col end-col type fmt)
(unless (< (next-single-property-change (match-beginning 0) 'directory nil (point))
(unless (< (next-single-property-change (match-beginning 0)
'directory nil (point))
(point))
(if file
(if (functionp file)
@ -710,6 +723,13 @@ Faces `compilation-error-face', `compilation-warning-face',
(setq type (or (and (car type) (match-end (car type)) 1)
(and (cdr type) (match-end (cdr type)) 0)
2)))
(when (and compilation-auto-jump-to-next
(>= type compilation-skip-threshold))
(kill-local-variable 'compilation-auto-jump-to-next)
(run-with-timer 0 nil 'compilation-auto-jump
(current-buffer) (match-beginning 0)))
(compilation-internal-error-properties file line end-line col end-col type fmt)))
(defun compilation-move-to-column (col screen)
@ -932,7 +952,7 @@ original use. Otherwise, recompile using `compile-command'."
`(,(eval compile-command))))))
(defcustom compilation-scroll-output nil
"*Non-nil to scroll the *compilation* buffer window as output appears.
"Non-nil to scroll the *compilation* buffer window as output appears.
Setting it causes the Compilation mode commands to put point at the
end of their output window so that the end of the output is always
@ -1026,8 +1046,9 @@ Returns the compilation buffer created."
;; Clear out the compilation buffer.
(let ((inhibit-read-only t)
(default-directory thisdir))
;; Then evaluate a cd command if any, but don't perform it yet, else start-command
;; would do it again through the shell: (cd "..") AND sh -c "cd ..; make"
;; Then evaluate a cd command if any, but don't perform it yet, else
;; start-command would do it again through the shell: (cd "..") AND
;; sh -c "cd ..; make"
(cd (if (string-match "^\\s *cd\\(?:\\s +\\(\\S +?\\)\\)?\\s *[;&\n]" command)
(if (match-end 1)
(substitute-env-vars (match-string 1 command))
@ -1043,6 +1064,8 @@ Returns the compilation buffer created."
(if highlight-regexp
(set (make-local-variable 'compilation-highlight-regexp)
highlight-regexp))
(if compilation-auto-jump-to-first-error
(set (make-local-variable 'compilation-auto-jump-to-next) t))
;; Output a mode setter, for saving and later reloading this buffer.
(insert "-*- mode: " name-of-mode
"; default-directory: " (prin1-to-string default-directory)
@ -1075,7 +1098,8 @@ Returns the compilation buffer created."
(unless (getenv "EMACS")
(list "EMACS=t"))
(list "INSIDE_EMACS=t")
(copy-sequence process-environment))))
(copy-sequence process-environment)))
(start-process (symbol-function 'start-process)))
(set (make-local-variable 'compilation-arguments)
(list command mode name-function highlight-regexp))
(set (make-local-variable 'revert-buffer-function)
@ -1091,53 +1115,39 @@ Returns the compilation buffer created."
(funcall compilation-process-setup-function))
(compilation-set-window-height outwin)
;; Start the compilation.
(if (fboundp 'start-process)
(let ((proc (if (eq mode t)
(get-buffer-process
(with-no-warnings
(comint-exec outbuf (downcase mode-name)
shell-file-name nil `("-c" ,command))))
(start-process-shell-command (downcase mode-name)
outbuf command))))
;; Make the buffer's mode line show process state.
(setq mode-line-process '(":%s"))
(set-process-sentinel proc 'compilation-sentinel)
(set-process-filter proc 'compilation-filter)
(set-marker (process-mark proc) (point) outbuf)
(when compilation-disable-input
(condition-case nil
(process-send-eof proc)
;; The process may have exited already.
(error nil)))
(setq compilation-in-progress
(cons proc compilation-in-progress)))
;; No asynchronous processes available.
(message "Executing `%s'..." command)
;; Fake modeline display as if `start-process' were run.
(setq mode-line-process ":run")
(force-mode-line-update)
(sit-for 0) ; Force redisplay
(let* ((buffer-read-only nil) ; call-process needs to modify outbuf
(status (call-process shell-file-name nil outbuf nil "-c"
command)))
(cond ((numberp status)
(compilation-handle-exit 'exit status
(if (zerop status)
"finished\n"
(format "\
exited abnormally with code %d\n"
status))))
((stringp status)
(compilation-handle-exit 'signal status
(concat status "\n")))
(t
(compilation-handle-exit 'bizarre status status))))
;; Without async subprocesses, the buffer is not yet
;; fontified, so fontify it now.
(let ((font-lock-verbose nil)) ; shut up font-lock messages
(font-lock-fontify-buffer))
(set-buffer-modified-p nil)
(message "Executing `%s'...done" command)))
(let ((proc
(if (eq mode t)
;; comint uses `start-file-process'.
(get-buffer-process
(with-no-warnings
(comint-exec outbuf (downcase mode-name)
shell-file-name nil `("-c" ,command))))
;; Redefine temporarily `start-process' in order to
;; handle remote compilation.
(fset 'start-process
(lambda (name buffer program &rest program-args)
(apply
(if (file-remote-p default-directory)
'start-file-process
start-process)
name buffer program program-args)))
(unwind-protect
(start-process-shell-command (downcase mode-name)
outbuf command)
;; Unwindform: Reset original definition of `start-process'.
(fset 'start-process start-process)))))
;; Make the buffer's mode line show process state.
(setq mode-line-process '(":%s"))
(set-process-sentinel proc 'compilation-sentinel)
(set-process-filter proc 'compilation-filter)
(set-marker (process-mark proc) (point) outbuf)
(when compilation-disable-input
(condition-case nil
(process-send-eof proc)
;; The process may have exited already.
(error nil)))
(setq compilation-in-progress
(cons proc compilation-in-progress))))
;; Now finally cd to where the shell started make/grep/...
(setq default-directory thisdir))
(if (buffer-local-value 'compilation-scroll-output outbuf)
@ -1258,7 +1268,7 @@ exited abnormally with code %d\n"
"*If non-nil, skip multiple error messages for the same source location.")
(defcustom compilation-skip-threshold 1
"*Compilation motion commands skip less important messages.
"Compilation motion commands skip less important messages.
The value can be either 2 -- skip anything less than error, 1 --
skip anything less than warning or 0 -- don't skip any messages.
Note that all messages not positively identified as warning or
@ -1270,7 +1280,7 @@ info, are considered errors."
:version "22.1")
(defcustom compilation-skip-visited nil
"*Compilation motion commands skip visited messages if this is t.
"Compilation motion commands skip visited messages if this is t.
Visited messages are ones for which the file, line and column have been jumped
to from the current content in the current compilation buffer, even if it was
from a different message."
@ -1371,6 +1381,8 @@ Optional argument MINOR indicates this is called from
;; with the next-error function in simple.el, and it's only
;; coincidentally named similarly to compilation-next-error.
(setq next-error-function 'compilation-next-error-function)
(set (make-local-variable 'comint-file-name-prefix)
(or (file-remote-p default-directory) ""))
(set (make-local-variable 'font-lock-extra-managed-props)
'(directory message help-echo mouse-face debug))
(set (make-local-variable 'compilation-locs)

Some files were not shown because too many files have changed in this diff Show More