mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-11-29 07:58:28 +00:00
Code Issues Releases Activity

Merge from emacs--devo--0

Browse Source 
Patches applied:

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

   - Update from CVS

Revision: emacs@sv.gnu.org/emacs--unicode--0--patch-227
This commit is contained in:
Miles Bader 2007-07-09 08:00:55 +00:00
commit 1011c48763
121 changed files with 10123 additions and 2582 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

236
configure vendored
View File

@ -686,6 +686,7 @@ ALSA_LIBS
CFLAGS_SOUND
SET_MAKE
XMKMF
HAVE_XSERVER
GTK_CFLAGS
GTK_LIBS
XFT_CFLAGS
@ -1345,7 +1346,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-freetype use -lfreetype for local fonts support
--with-xft use -lXft for anti aliased fonts
@ -9614,6 +9615,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
@ -14270,83 +14333,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
@ -14410,16 +14396,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
@ -24601,6 +24664,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
@ -24628,6 +24692,12 @@ lispdir!$lispdir$ac_delim
locallisppath!$locallisppath$ac_delim
lisppath!$lisppath$ac_delim
x_default_search_path!$x_default_search_path$ac_delim
etcdir!$etcdir$ac_delim
archlibdir!$archlibdir$ac_delim
bitmapdir!$bitmapdir$ac_delim
gamedir!$gamedir$ac_delim
gameuser!$gameuser$ac_delim
c_switch_system!$c_switch_system$ac_delim
_ACEOF
if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 97; then
@ -24669,12 +24739,6 @@ _ACEOF
ac_delim='%!_!# '
for ac_last_try in false false false false false :; do
cat >conf$$subs.sed <<_ACEOF
etcdir!$etcdir$ac_delim
archlibdir!$archlibdir$ac_delim
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
LD_SWITCH_X_SITE!$LD_SWITCH_X_SITE$ac_delim
LD_SWITCH_X_SITE_AUX!$LD_SWITCH_X_SITE_AUX$ac_delim

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(freetype,
@ -1901,6 +1901,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
@ -2593,24 +2609,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

16
etc/ChangeLog
View File

@ -1,3 +1,19 @@
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.

41
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.
@ -68,8 +77,23 @@ highlighting, and help echoing in the minibuffer.
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.
* Changes in Emacs 23.1 on non-free operating systems
@ -77,9 +101,15 @@ considered for update.
* Incompatible Lisp Changes in Emacs 23.1
+++
** The function `dired-call-process' has been removed.
* Lisp Changes in Emacs 23.1
** 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 +121,11 @@ 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'.
* New Packages for Lisp Programming in Emacs 23.1

14
etc/NEWS.22
View File

@ -50,8 +50,14 @@ to be scrolled horizontally or vertically instead.
** 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 +265,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.

14
etc/orgcard.tex
View File

@ -1,5 +1,5 @@
% Reference Card for Org Mode
\def\orgversionnumber{4.77}
\def\orgversionnumber{5.01}
\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 '}
@ -617,7 +621,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}

799
lisp/ChangeLog
View File

@ -1,14 +1,140 @@
2007-07-08 Chong Yidong <cyd@stupidchicken.com>
2007-07-08 Martin Rudalics <rudalics@gmx.at>
* longlines.el (longlines-wrap-region): Avoid marking buffer as
modified.
(longlines-auto-wrap, longlines-window-change-function): Remove
unnecessary calls to set-buffer-modified-p.
* novice.el (disabled-command-function): Fit window to buffer to
make last line visible.
Reported by Stephen Berman <Stephen.Berman at gmx.net>.
* mouse.el (mouse-drag-track): Reset transient-mark-mode to nil
when handling the terminating event.
2007-07-07 Jay Belanger <jay.p.belanger@gmail.com>
* calc/calc.el (math-read-number-simple): Remove leading 0s.
(math-bignum-digit-length): Change to optimal value.
* calc/calc-bin.el (math-bignum-logb-digit-size)
(math-bignum-digit-power-of-two): Evaluate when compiled.
* calc/calc-comb.el (math-small-factorial-table)
(math-init-random-base,math-prime-test): Remove unnecessary calls
to `math-read-number-simple'.
* calc/calc-ext.el (math-approx-pi,math-approx-sqrt-e)
(math-approx-gamma-const): Add docstrings.
* calc/calc-forms.el (math-julian-date-beginning)
(math-julian-date-beginning-int) New constants.
(math-format-date-part,math-parse-standard-date,calcFunc-julian):
Use the new constants.
* calc/calc-funcs.el (math-gammap1-raw): Add docstring.
* calc/calc-math.el (math-approx-ln-10,math-approx-ln-2): Add docstrings.
2007-07-07 Tom Tromey <tromey@redhat.com>
* vc.el (vc-annotate): Jump to line and output message only after the
process is really all done.
2007-07-07 Stefan Monnier <monnier@iro.umontreal.ca>
* vc.el (vc-exec-after): Don't move point from the sentinel.
Forcefully read all the remaining text in the pipe upon process exit.
(vc-annotate-display-autoscale, vc-annotate-lines):
Don't stop at the first unrecognized line.
(vc-annotate-display-select): Run autoscale after the process is done
since it depends on the whole result.
2007-07-07 Eli Zaretskii <eliz@gnu.org>
* term/w32-win.el (menu-bar-open): New function.
Bind <f10> to it.
2007-07-07 Michael Albinus <michael.albinus@gmx.de>
* simple.el (start-file-process): New defun.
2007-07-07 Stefan Monnier <monnier@iro.umontreal.ca>
* files.el (find-file-confirm-nonexistent-file): Rename from
find-file-confirm-inexistent-file. Update users.
* emacs-lisp/autoload.el (autoload-find-destination): Understand a new
format of autoload block where the file's time-stamp is replaced by its
MD5 checksum.
(autoload-generate-file-autoloads): Use MD5 checksum instead of
time-stamp for secondary autoloads files.
(update-directory-autoloads): Remove duplicate entries.
Use time-less-p for time-stamps, as done in autoload-find-destination.
2007-07-07 Jay Belanger <jay.p.belanger@gmail.com>
* calc/calc.el (math-read-number): Replace number by variable.
(math-read-number-simple): Properly parse small integers.
2007-07-07 Dan Nicolaescu <dann@ics.uci.edu>
* vc.el: Fix doc for the checkout function.
2007-07-06 Dan Nicolaescu <dann@ics.uci.edu>
* vc-hg.el (vc-hg-root): New function.
(vc-hg-registered): Use it.
(vc-hg-diff-tree): New defalias.
(vc-hg-responsible-p): Likewise.
(vc-hg-checkout): Comment out, not needed.
(vc-hg-delete-file, vc-hg-rename-file, vc-hg-could-register)
(vc-hg-find-version, vc-hg-next-version): New functions.
2007-07-06 Andreas Schwab <schwab@suse.de>
* emacs-lisp/lisp-mode.el (eval-last-sexp): Avoid introducing any
dynamic bindings around the evaluation of the expression.
Reported by Jay Belanger <jay.p.belanger@gmail.com>.
2007-07-06 Stefan Monnier <monnier@iro.umontreal.ca>
* autorevert.el (auto-revert-tail-handler): Use inhibit-read-only.
Run before-revert-hook. Suggested by Denis Bueno <denbuen@sandia.gov>.
Use run-hooks rather than run-mode-hooks.
2007-07-05 Jay Belanger <jay.p.belanger@gmail.com>
* calc/calc-comb.el (math-random-digit): Rename to
`math-random-three-digit-number'.
(math-random-digits): Don't depend on representation of integer.
* calc/calc-bin.el (math-bignum-logb-digit-size)
(math-bignum-digit-power-of-two): New constants.
(math-and-bignum,math-or-bignum,math-xor-bignum,math-diff-bignum)
(math-not-bignum,math-clip-bignum): Use the constants
`math-bignum-digit-power-of-two' and `math-bignum-logb-digit-size'
instead of their values.
(math-clip): Use math-small-integer-size instead of its value.
* calc/calc.el (math-add-bignum): Replace number by constant.
2007-07-05 Chong Yidong <cyd@stupidchicken.com>
* wid-edit.el (widget-documentation-string-value-create): Insert
spaces for indentation.
* wid-edit.el (widget-documentation-string-value-create):
Insert indentation spaces.
2007-07-05 Thien-Thi Nguyen <ttn@gnuvola.org>
* emacs-lisp/byte-opt.el: Revert last change.
2007-07-05 Dan Nicolaescu <dann@ics.uci.edu>
* vc-hooks.el (vc-handled-backends): Add HG.
* vc-hg.el (vc-handled-backends): Remove, done in vc-hooks.el now.
2007-07-05 Stefan Monnier <monnier@iro.umontreal.ca>
* complete.el (PC-do-complete-and-exit): Add support for the new
`confirm-only' confirmation mode.
2007-07-05 Chong Yidong <cyd@stupidchicken.com>
* cus-edit.el (custom-commands): New variable.
(custom-tool-bar-map): New variable. Initialize using
@ -35,6 +161,633 @@
(custom-group-reset-current, custom-group-reset-saved)
(custom-group-reset-standard): Minor cleanup.
2007-07-05 Thien-Thi Nguyen <ttn@gnuvola.org>
* Makefile.in (bootstrap-prepare): When copying from
ldefs-boot.el, make sure loaddefs.el is writeable.
(bootstrap-prepare): Make $(lisp)/ps-print.el
and $(lisp)/emacs-lisp/cl-loaddefs.el writable, as well.
2007-07-05 Dan Nicolaescu <dann@ics.uci.edu>
* vc-hg.el (vc-hg-internal-status): Inline in `vc-hg-state', the
only caller, and delete.
(vc-hg-state): Deal with exceptions and only parse the output on
successful return.
(vc-hg-internal-log): Inline in `vc-hg-workfile-version', the only
caller, and delete.
(vc-hg-workfile-version): Deal with exceptions and only parse the
output on successful return.
(vc-hg-revert): New function.
2007-07-04 Jay Belanger <jay.p.belanger@gmail.com>
* calculator.el (calculator-expt): Use more cases to determine
the value.
2007-07-03 Jay Belanger <jay.p.belanger@gmail.com>
* calculator.el (calculator-expt, calculator-integer-p):
New functions.
(calculator-fact): Check to see if the factorial will be too
large before computing it.
(calculator-initial-operators): Use `calculator-expt' to
compute "^".
(calculator-mode): Mention that results which are too large
will return inf.
* calc/calc-comb.el (math-small-factorial-table): Replace list
by vector.
2007-07-03 David Kastrup <dak@gnu.org>
* shell.el: On request of the authors, remove their addresses for
the sake of bug reports, and add the developer list address as
maintainer information.
2007-07-03 Richard Stallman <rms@gnu.org>
* files.el (make-directory): Doc fix.
(find-file-confirm-inexistent-file): Make it a defcustom.
Make nil the default.
2007-07-02 Richard Stallman <rms@gnu.org>
* startup.el (command-line): Set buffer-offer-save in *scratch*
and enable auto-save in it.
2007-07-02 Carsten Dominik <dominik@science.uva.nl>
* textmodes/org.el (orgstruct-mode-map): New variable.
(orgstruct-mode): New minor mode.
(turn-on-orgstruct, orgstruct-error, orgstruct-setup)
(orgstruct-make-binding, org-context-p, org-get-local-variables)
(org-run-like-in-org-mode): New functions.
(org-cycle-list-bullet): New command.
(org-special-properties, org-property-start-re)
(org-property-end-re): New constants.
(org-with-point-at): New macro.
(org-get-property-block, org-entry-properties, org-entry-get)
(org-entry-delete, org-entry-get-with-inheritance)
(org-entry-put, org-buffer-property-keys): New functions.
(org-insert-property-drawer): New command.
(org-entry-property-inherited-from): New variable.
(org-column): New face.
(org-column-overlays, org-current-columns-fmt)
(org-current-columns-maxwidths, org-column-map): New variables.
(org-column-menu): New menu.
(org-new-column-overlay, org-overlay-columns)
(org-overlay-columns-title, org-remove-column-overlays)
(org-column-show-value, org-column-quit, org-column-edit): New
functions.
(org-columns, org-agenda-columns): New commands.
(org-get-columns-autowidth-alist): New functions.
(org-properties): New customize group.
(org-default-columns-format): New option.
(org-priority): Realign tags after changing priority.
(org-preserve-lc): New macro.
(org-update-checkbox-count): Catch case when there is no headline.
(org-agenda-quit): Remove any column overlays.
(org-beginning-of-item-list): Fixed bug when non-item line is
indented too deep.
(org-cached-props): New variable.
(org-cached-entry-get): New function.
(org-make-tags-matcher): Handle property matches.
(org-table-recalculate): Swap evaluation order: Field formula
first, then column formulas, but don't allow them to overwrite the
field formulas.
(org-table-eval-formula): New argument untouchable.
(org-table-put-field-property): New function.
2007-07-02 Martin Rudalics <rudalics@gmx.at>
* help-mode.el (help-make-xrefs): Skip spaces too when
skipping tabs.
* ffap.el (dired-at-point-prompter): Improve prompt in
list-directory case.
2007-07-01 Richard Stallman <rms@gnu.org>
* cus-start.el (max-mini-window-height): Added.
2007-07-01 Sean O'Rourke <sorourke@cs.ucsd.edu> (tiny change)
* complete.el (partial-completion-mode): Remove advice of
read-file-name-internal.
(PC-do-completion): Rebind minibuffer-completion-table.
(PC-read-file-name-internal): New function doing what
read-file-name-internal advice did.
2007-07-01 Paul Pogonyshev <pogonyshev@gmx.net>
* emacs-lisp/byte-opt.el: Set `binding-is-magic'
property on a few symbols.
(byte-compile-side-effect-free-dynamically-safe-ops): New defconst.
(byte-optimize-lapcode): Remove bindings that are not referenced
and certainly will not effect through dynamic scoping.
2007-07-01 Stefan Monnier <monnier@iro.umontreal.ca>
* files.el (find-file-confirm-inexistent-file): New var.
(find-file, find-file-other-window, find-file-other-frame)
(find-file-read-only, find-file-read-only-other-window)
(find-file-read-only-other-frame): Use it.
2007-06-30 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/rx.el (rx-constituents): Fix up `anything'.
2007-06-29 Juanma Barranquero <lekktu@gmail.com>
* generic-x.el (generic-define-mswindows-modes)
(generic-define-unix-modes, apache-log-generic-mode)
(bat-generic-mode-keymap, java-manifest-generic-mode)
(show-tabs-generic-mode): Fix typos in docstrings.
2007-06-29 Ryan Yeske <rcyeske@gmail.com>
* net/rcirc.el (rcirc-server-alist): Rename from rcirc-connections.
(rcirc-default-full-name): Rename from rcirc-default-user-full-name.
(rcirc-clear-activity): Make sure RCIRC-ACTIVITY isn't modified.
(rcirc-print): Never ignore messages from ourself.
2007-06-29 Stefan Monnier <monnier@iro.umontreal.ca>
* font-lock.el (lisp-font-lock-keywords-2): Recognize the new \(?1:..\)
syntax as well. Reported by Juri Linkov <juri@jurta.org>.
2007-06-28 Jan Dj,Ad(Brv <jan.h.d@swipnet.se>
* dnd.el (dnd-get-local-file-name): Set fixcase to t in call to
replace-regexp-in-string.
2007-06-28 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/cl.el: Set edebug and indentation before loading
cl-loaddefs.el so that its use of dolist doesn't load cl-macs.
2007-06-28 Andreas Schwab <schwab@suse.de>
* Makefile.in ($(lisp)/mh-e/mh-loaddefs.el): Depend on
$(lisp)/subdirs.el.
2007-06-28 Juanma Barranquero <lekktu@gmail.com>
* speedbar.el (speedbar-handle-delete-frame): Don't try to delete
the speedbar frame if nil; that deletes the current frame or
causes an error if it is the only frame.
Reported by Angelo Graziosi <Angelo.Graziosi@roma1.infn.it>.
2007-06-28 Kevin Ryde <user42@zip.com.au>
* textmodes/nroff-mode.el: Groff \# comments.
(nroff-mode-syntax-table): \# comment intro,
plain # as punct per global table.
(nroff-font-lock-keywords): Add # as a single char escape.
(nroff-mode): In comment-start-skip, match \#.
2007-06-28 Stefan Monnier <monnier@iro.umontreal.ca>
* vc-bzr.el (vc-functions): Clear up the cache when reloading the file.
(vc-bzr-workfile-version, vc-bzr-could-register): Don't hardcode
point-min == 1.
2007-06-28 Nick Roberts <nickrob@snap.net.nz>
* pcvs-util.el (cvs-strings->string, cvs-string->strings):
Rename and move to...
* subr.el (strings->string, string->strings): ...here.
* pcvs.el (cvs-reread-cvsrc, cvs-header-msg, cvs-checkout)
(cvs-mode-checkout, cvs-execute-single-file): Use new function names.
* progmodes/gud.el (gud-common-init): Call string->strings instead
of split-string.
2007-06-27 Michael Albinus <michael.albinus@gmx.de>
* dired-aux.el: Remove `dired-call-process'.
(dired-check-process): Call `process-file'.
* wdired.el (wdired-do-perm-changes): Call `process-file'.
* net/ange-ftp.el (ange-ftp-dired-call-process): Reimplement it as
`ange-ftp-process-file'.
2007-06-27 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/cl.el: Use cl-loaddefs.el rather than manual autoloads.
* emacs-lisp/cl-extra.el:
* emacs-lisp/cl-seq.el:
* emacs-lisp/cl-macs.el: Set generated-autoload-file to cl-loaddefs.el.
Add autoload cookies on all defs autoloaded manually in cl.el.
* emacs-lisp/cl-loaddefs.el: New file.
* textmodes/texinfmt.el (texinfo-raisesections-alist)
(texinfo-lowersections-alist): Merge definition and declaration.
(texinfo-start-of-header, texinfo-end-of-header): Remove.
(texinfo-format-syntax-table): Merge init into declaration.
(texinfo-format-parse-line-args, texinfo-format-parse-args)
(texinfo-format-parse-defun-args, texinfo-format-node)
(texinfo-push-stack, texinfo-multitable-widths)
(texinfo-define-info-enclosure, texinfo-alias)
(texinfo-format-defindex, batch-texinfo-format): Use push.
(texinfo-footnote-number): Remove duplicate declaration.
* ps-print.el: Update with auto-generated autoloads.
* ps-mule.el: Set generated-autoload-file to "ps-print.el".
2007-06-26 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/autoload.el (autoload-generated-file): Interpret names
relative to current dir for file-local settings.
(autoload-generate-file-autoloads): Add `outfile' arg.
(update-directory-autoloads): Use it to directly call
autoload-generate-file-autoloads instead of going through
update-file-autoloads so we avoid redundant searches and so we can know
the set of buffers changed so we can save them all.
* emacs-lisp/autoload.el (autoload-find-destination): Return nil
rather than throwing `up-to-date'.
(autoload-generate-file-autoloads): Adjust correspondingly.
(update-file-autoloads): Be careful to let-bind
autoload-modified-buffers and adjust to new calling conventions.
(autoload-modified-buffers): Make it a dynamically scoped var.
(update-directory-autoloads): Use file-relative-name instead of
autoload-trim-file-name.
(autoload-insert-section-header): Don't use autoload-trim-file-name
since the file is already relative now.
(autoload-trim-file-name): Remove.
* vc-arch.el (vc-arch-add-tagline): Do a slightly cleaner job.
(vc-arch-complete, vc-arch--version-completion-table)
(vc-arch-revision-completion-table): New functions to provide
completion of revision names.
(vc-arch-trim-find-least-useful-rev, vc-arch-trim-make-sentinel)
(vc-arch-trim-one-revlib, vc-arch-trim-revlib): New functions
to let the user trim the revlib.
* vc.el: Add new VC operation `revision-completion-table'.
(vc-default-revision-completion-table): New function.
(vc-version-diff, vc-version-other-window): Use it to provide
completion of revision names if the backend provides it.
* log-edit.el (log-edit-changelog-entries): Use with-current-buffer.
* vc-svn.el (vc-svn-repository-hostname): Adjust to non-XML format
of newer .svn/entries.
2007-06-25 David Kastrup <dak@gnu.org>
* calc/calc-poly.el (math-padded-polynomial)
(math-partial-fractions): Add some function comments.
2007-06-25 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/autoload.el (autoload-generate-file-autoloads):
Make `outbuf' optional.
(update-file-autoloads): Use it.
2007-06-25 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/autoload.el (autoload-modified-buffers): New var.
(autoload-find-destination): Keep it uptodate.
(autoload-save-buffers): New fun.
(update-file-autoloads): Use it. Re-add the "up to date" message.
* emacs-lisp/autoload.el: Refactor for upcoming changes.
(autoload-find-destination): New function extracted from
update-file-autoloads.
(update-file-autoloads): Use it.
(autoload-generate-file-autoloads): New function extracted from
generate-file-autoloads. Use file-relative-name. Delay computation of
output-start to the first cookie. Remove done-any, replaced by
output-start.
(generate-file-autoloads): Use it.
2007-06-24 Jay Belanger <jay.p.belanger@gmail.com>
* calc/calc-comb.el (math-init-random-base, math-prime-test):
Use math-read-number-simple to insert constants.
(math-prime-test): Redo calculation of sum.
* calc/calc-misc.el (math-div2-bignum): Use math-bignum-digit-size.
* calc/calc-math.el (math-scale-bignum-digit-size): Rename from
math-scale-bignum-3.
(math-isqrt-bignum): Use math-scale-bignum-digit-size and
math-bignum-digit-size.
(math-isqrt-small): Add another possible initial guess.
2007-06-23 Roland Winkler <Roland.Winkler@physik.uni-erlangen.de>
* textmodes/bibtex.el (bibtex-entry-format): New options
`whitespace', `braces', and `string'.
(bibtex-field-braces-alist, bibtex-field-strings-alist)
(bibtex-field-braces-opt, bibtex-field-strings-opt)
(bibtex-cite-matcher-alist): New variables.
(bibtex-font-lock-keywords): Use bibtex-cite-matcher-alist.
(bibtex-flash-head): Use blink-matching-delay.
(bibtex-insert-kill, bibtex-mark-entry): Use push-mark.
(bibtex-format-entry, bibtex-reformat): Handle new options of
bibtex-entry-format.
(bibtex-field-re-init, bibtex-font-lock-cite, bibtex-dist):
New functions.
(bibtex-complete-internal): Do not display messages while
minibuffer is used. Do not leave around a completions buffer
that is out of date.
(bibtex-copy-summary-as-kill): New optional arg.
(bibtex-font-lock-url): New optional arg no-button.
(bibtex-find-crossref): Use `bibtex-cite-matcher-alist'.
(bibtex-url): Allow multiple URLs per entry.
2007-06-23 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/autoload.el (autoload-generated-file): New function.
(update-file-autoloads, update-directory-autoloads): Use it.
(autoload-file-load-name): New function.
(generate-file-autoloads, update-file-autoloads): Use it.
(autoload-find-file): Accept non-absolute argument. Set default-dir.
(generate-file-autoloads): If the autoloaded form is malformed,
indicate the problem with a warning instead of aborting.
2007-06-23 Thien-Thi Nguyen <ttn@gnuvola.org>
* simple.el (next-error-recenter): Accept `(4)' as well;
also, specify `integer' instead of `number'.
2007-06-23 Eli Zaretskii <eliz@gnu.org>
* ls-lisp.el (insert-directory): If an invalid regexp error is
thrown, try using FILE as a literal file name, not a wildcard.
2007-06-23 Juanma Barranquero <lekktu@gmail.com>
* ruler-mode.el (ruler-mode): Prevent clobbering the original
`header-line-format' when reentering ruler mode.
2007-06-23 Eli Zaretskii <eliz@gnu.org>
* ls-lisp.el (insert-directory): Don't treat FILE as a wildcard if
FILE exists as a file.
2007-06-22 Jay Belanger <jay.p.belanger@gmail.com>
* calc/calc.el (math-bignum-digit-length)
(math-bignum-digit-size, math-small-integer-size):
New constants.
(math-normalize, math-bignum-big, math-make-float)
(math-div10-bignum, math-scale-left, math-scale-left-bignum)
(math-scale-right, math-scale-right-bignum, math-scale-rounding)
(math-add, math-add-bignum, math-sub-bignum, math-sub, math-mul)
(math-mul-bignum, math-mul-bignum-digit, math-idivmod)
(math-quotient, math-div-bignum, math-div-bignum-digit)
(math-div-bignum-part, math-format-bignum-decimal)
(math-read-bignum): Use math-bignum-digit-length,
math-bignum-digit-size and math-small-integer-size.
* calc/calc-ext.el (math-fixnum-big): Use the variable
math-bignum-digit-size.
2007-06-23 Dan Nicolaescu <dann@ics.uci.edu>
* log-view.el (log-view-mode-menu): New menu.
2007-06-22 Stefan Monnier <monnier@iro.umontreal.ca>
* diff-mode.el (diff-font-lock-keywords): Fix M. Kifer's last change
differently.
* vc-hg.el (vc-hg-registered): Add an autoloaded version.
(vc-hg-log-view-mode): Use log-view-font-lock-keywords.
2007-06-22 Dan Nicolaescu <dann@ics.uci.edu>
* vc-hg.el (vc-hg-print-log): Insert the file name.
(vc-hg-log-view-mode): Fontify the file name.
2007-06-22 Jay Belanger <jay.p.belanger@gmail.com>
* calc/calc-forms.el (math-format-date-part, calc-parse-standard-date)
(calcFunc-julian): Fix incorrect number used in calculations.
2007-06-22 Thien-Thi Nguyen <ttn@gnuvola.org>
* simple.el (next-error-recenter): New defcustom.
(next-error, next-error-internal): Recenter if specified,
immediately prior to running `next-error-hook'.
* progmodes/hideshow.el (hs-show-block): Use line-end-position.
(hs-hide-block-at-point, hs-hide-comment-region): Likewise.
* progmodes/hideshow.el (hs-hide-all): Use progress reporter.
2007-06-22 Jay Belanger <jay.p.belanger@gmail.com>
* calc/calc-comb.el (math-small-factorial-table): New variable.
(calcFunc-fact): Use `math-small-factorial-table'.
* calc/calc-ext.el (math-defcache): Allow forms to evaluate
initial values.
(math-approx-pi, math-approx-sqrt-e, math-approx-gamma-const):
New variables to use in caches.
* calc/calc-forms.el (math-format-date-part, math-parse-standard-date)
(calcFunc-julian): Use `math-read-number-simple' to insert bignums.
* calc/calc-func.el (math-besJ0, math-besJ1, math-besY0, math-besY1)
(math-bernoulli-b-cache): Use math-read-number-simple to insert
bignums.
* calc/calc-math.el (math-approx-ln-10, math-approx-ln-2):
New variables to use in caches.
2007-06-22 Dan Nicolaescu <dann@ics.uci.edu>
* vc-bzr.el (vc-bzr-log-view-mode): Add + to the email address regexp.
* vc-hg.el (vc-hg-log-view-mode): New mode.
2007-06-21 Jay Belanger <jay.p.belanger@gmail.com>
* calc/calc.el (math-read-number-simple): New function.
2007-06-21 Stefan Monnier <monnier@iro.umontreal.ca>
* vera-mode.el (vera-mode): Fix `commend-end-skip' setting.
(vera-font-lock-match-item): Fix doc string.
(vera-in-comment-p): Remove unused function.
(vera-skip-forward-literal, vera-skip-backward-literal): Improve code,
use `syntax-ppss'.
(vera-forward-syntactic-ws): Fix argument order.
(vera-prepare-search): Use `with-syntax-table'.
(vera-indent-line): Fix doc string.
(vera-electric-tab): Fix doc string.
(vera-expand-abbrev): Define alias instead of using `fset'.
(vera-comment-uncomment-region): Use `comment-start-skip'.
2007-06-21 Carsten Dominik <dominik@science.uva.nl>
* textmodes/org.el (org-export-with-footnotes): New option.
(org-export-as-html): Fix replacement bug for XEmacs.
(org-agenda-default-appointment-duration): New option.
2007-06-21 Dan Nicolaescu <dann@ics.uci.edu>
* vc-hg.el: Add to do items.
(vc-hg-diff): Add support for comparing different revisions.
(vc-hg-diff, vc-hg-annotate-command, vc-hg-annotate-time)
(vc-hg-annotate-extract-revision-at-line)
(vc-hg-previous-version, vc-hg-checkin): New functions.
(vc-hg-annotate-re): New constant.
2007-06-20 Jay Belanger <jay.p.belanger@gmail.com>
* calc/calc.el (math-standard-ops): Fix precedence of multiplication.
2007-06-20 Stefan Monnier <monnier@iro.umontreal.ca>
* log-view.el (log-view-font-lock-keywords): Use `eval' to consult the
buffer-local value of log-view-*-re if applicable.
* vc-bzr.el (vc-bzr-dir-state): Use setq rather than set.
Use vc-bzr-command rather than the ill defined vc-bzr-command*.
(vc-bzr-command*): Remove both (incompatible) versions.
(vc-bzr-do-command*): Remove.
(vc-bzr-with-process-environment, vc-bzr-std-process-invocation):
Remove by folding into its only caller vc-bzr-command.
(vc-bzr-command): Always set the environment, even when ineffective.
(vc-bzr-version): Minor fix up.
(vc-bzr-admin-dirname): New var.
(vc-bzr-bzr-dir): Remove.
(vc-bzr-root-dir): New fun.
(vc-bzr-registered): Use it. Add an autoloaded version.
(vc-bzr-responsible-p): Use vc-bzr-root-dir as well.
(vc-bzr-view-log-function): Remove.
(vc-bzr-log-view-mode): New major mode to replace it.
(vc-bzr-print-log): Only activate the old hack if needed.
* vc.el (vc-default-log-view-mode): New function.
(vc-print-log): Add new `log-view-mode' VC operation.
2007-06-20 Juanma Barranquero <lekktu@gmail.com>
* ido.el (ido-find-file-in-dir): Don't signal an error for
empty directories.
* add-log.el (change-log-mode): Set `show-trailing-whitespace'.
* desktop.el (desktop-read): Run `desktop-not-loaded-hook' in the
directory where the desktop file was found, as the docstring says.
(desktop-kill): Use `read-directory-name'.
2007-06-20 Alan Mackenzie <acm@muc.de>
* progmodes/cc-mode.el (c-remove-any-local-eval-or-mode-variables):
When removing lines, also remove the \n. Correction of patch of
2007-04-21.
2007-06-20 Martin Rudalics <rudalics@gmx.at>
* mouse.el (mouse-drag-mode-line-1): Quit mouse tracking when
event is not a cons cell. Do not unread drag-mouse-1 events.
Select right window in check whether space was stolen from
window above.
* help-mode.el (help-make-xrefs): Adjust position of new forward
button.
2007-06-20 Riccardo Murri <riccardo.murri@gmail.com>
* vc-bzr.el (vc-bzr-with-process-environment)
(vc-bzr-std-process-invocation): New macros.
(vc-bzr-command, vc-bzr-command*): Use them.
(vc-bzr-with-c-locale): Remove.
(vc-bzr-dir-state): Replace its use with vc-bzr-command.
(vc-bzr-buffer-nonblank-p): New function.
(vc-bzr-state-words): New const.
(vc-bzr-state): Look for `bzr status` keywords in output.
Display everything else as a warning message to the user.
Fix status report with bzr >= 0.15.
2007-06-20 Dan Nicolaescu <dann@ics.uci.edu>
* vc-hg.el (vc-hg-global-switches): Simplify.
(vc-hg-state): Handle more states.
(vc-hg-diff): Fix doc-string.
(vc-hg-register): New function.
(vc-hg-checkout): Likewise.
2007-06-20 Reto Zimmermann <reto@gnu.org>
* progmodes/vera-mode.el: New file.
2007-06-19 Jay Belanger <jay.p.belanger@gmail.com>
* calc/calc.el (calc-multiplication-has-precendence):
New variable.
(math-standard-ops, math-standard-ops-p, math-expr-ops):
New functions.
(math-expr-opers): Define using math-standard-ops rather than
math-standard-opers.
* calc/calc-aent.el (calc-do-calc-eval): Let math-expr-opers
equal the function math-standard-ops rather than the variable
math-standard-opers.
(calc-algebraic-entry): Let math-expr-opers equal
math-standard-ops or math-expr-ops, as appropriate.
(math-expr-read-level, math-read-factor): Let math-expr-opers
equal math-expr-ops.
* calc/calc-embed.el (calc-embedded-finish-edit):
Let math-expr-opers equal the function math-standard-ops
rather than the variable math-standard-opers.
* calc/calc-ext.el (math-read-plain-expr)
(math-format-flat-expr-fancy): Let math-expr-opers equal the
function math-standard-ops rather than the variable
math-standard-opers.
* calc/calc-lang.el (calc-set-language, math-read-big-rec):
Let math-expr-opers equal the function math-standard-ops rather
than the variable math-standard-opers.
* calc/calc-prog.el (calc-read-parse-table): Let math-expr-opers
equal the function math-standard-ops rather than the variable
math-standard-opers.
* calc/calc-yank.el (calc-finish-stack-edit): Let math-expr-opers
equal the function math-standard-ops rather than the variable
math-standard-opers.
* calc/calccomp.el (math-compose-expr): Let math-expr-opers equal
math-expr-ops.
2007-06-19 Ivan Kanis <apple@kanis.eu>
* vc-hg.el: New file.
2007-06-18 Stefan Monnier <monnier@iro.umontreal.ca>
* progmodes/sh-script.el (sh-font-lock-paren): Mark the relevant text
with font-lock-multiline.
2007-06-17 Glenn Morris <rgm@gnu.org>
* lpr.el (lpr-page-header-switches): Move %s to separate element
for correct quoting. Doc fix.
2007-06-17 Stefan Monnier <monnier@iro.umontreal.ca>
* textmodes/sgml-mode.el (sgml-xml-guess): Return the result rather
than setting sgml-xml-mode.
(sgml-mode, html-mode): Set sgml-xml-mode.
(sgml-skip-tag-backward): Tell if we skipped over matched tags.
(sgml-skip-tag-backward, sgml-electric-tag-pair-overlays): New var.
(sgml-electric-tag-pair-before-change-function)
(sgml-electric-tag-pair-flush-overlays): New functions.
(sgml-electric-tag-pair-mode): New minor mode.
(sgml-font-lock-keywords-2, sgml-get-context, sgml-unclosed-tag-p)
(sgml-calculate-indent): Use assoc-string.
2007-06-16 Karl Fogel <kfogel@red-bean.com>
* thingatpt.el (thing-at-point-email-regexp): Don't require two
@ -51,16 +804,15 @@
2007-06-15 Masatake YAMATO <jet@gyve.org>
* vc-bzr.el (vc-bzr-root): Cache the output of shell command
execution.
* vc-bzr.el (vc-bzr-root): Cache the output of shell command execution.
* vc.el (vc-dired-hook): Check the backend returned from
`vc-responsible-backend' can really handle `subdir'.
2007-06-15 Chong Yidong <cyd@stupidchicken.com>
* wid-edit.el (widget-add-documentation-string-button): Fix
handling of documentation indent.
* wid-edit.el (widget-add-documentation-string-button):
Fix handling of documentation indent.
2007-06-15 Miles Bader <miles@fencepost.gnu.org>
@ -84,8 +836,8 @@
(custom-variable-value-create, custom-face-value-create)
(custom-visibility): New widget.
(custom-visibility): New face.
(custom-group-value-create): Call
widget-add-documentation-string-button, using `custom-visibility'.
(custom-group-value-create):
Call widget-add-documentation-string-button, using `custom-visibility'.
2007-06-14 Stefan Monnier <monnier@iro.umontreal.ca>
@ -97,8 +849,8 @@
2007-06-14 Michael Kifer <kifer@cs.stonybrook.edu>
* viper.el (viper-describe-key-ad, viper-describe-key-briefly-ad):
different advices for Emacs and XEmacs. Compile them conditionally.
(viper-version): belated version change.
Different advices for Emacs and XEmacs. Compile them conditionally.
(viper-version): Belated version change.
2007-06-14 Juanma Barranquero <lekktu@gmail.com>
@ -193,6 +945,11 @@
* vc-arch.el (vc-arch-command): Remove bzr. It's a different program.
2007-06-13 Michael Kifer <kifer@cs.stonybrook.edu>
* ediff-ptch.el (ediff-context-diff-label-regexp): Partially undo
previous change.
2007-06-12 Tom Tromey <tromey@redhat.com>
* subr.el (user-emacs-directory): New defconst.
@ -297,7 +1054,7 @@
(desktop-kill): Tell `desktop-save' that this is the last save.
Release the lock afterwards.
(desktop-buffer-info): New function.
(desktop-save): Use it. Run `desktop-save-hook' where the doc
(desktop-save): Use it. Run `desktop-save-hook' where the doc
says to. Detect conflicts, and manage the lock.
(desktop-read): Detect conflicts. Manage the lock.
@ -307,7 +1064,7 @@
* emulation/tpu-edt.el (tpu-gold-map): Rename from GOLD-map.
(tpu-lucid-emacs-p): Remove. Use (featurep 'xemacs) instead.
(CSI-map, GOLD-CSI-map, GOLD-SS3-map, SS3-map): Delete vars.
(CSI-map, GOLD-CSI-map, GOLD-SS3-map, SS3-map): Delete vars.
(tpu-gold-map, tpu-global-map): Add all the SS3 and CSI bindings, using
keysyms rather than byte sequences.
(tpu-copy-keyfile): Don't force the user to use tpu-mapper.el.
@ -506,9 +1263,9 @@
(org-table-use-standard-references, org-disputed-keys)
(org-export-skip-text-before-1st-heading, org-agenda-with-colors)
(org-agenda-export-html-style): New option.
(org-allow-auto-repeat, org-agenda-remove-tags-when-in-prefix)
(org-allow-auto-repeat, org-agenda-remove-tags-when-in-prefix)
(org-CUA-compatible): Option removed.
(org-agenda-structure, org-sexp-date): New face.
(org-agenda-structure, org-sexp-date): New face.
(org-todo-keywords-for-agenda, org-not-done-keywords)
(org-planning-or-clock-line-re, org-agenda-name)
(org-table-colgroup-info, org-todo-sets)
@ -524,7 +1281,7 @@
(org-repeat-re, org-todo-kwd-max-priority)
(org-version, org-done-string)
(org-table-clean-did-remove-column-1, org-disputed-keys):
Remove Variables.
Remove variables.
(org-table-translate-regexp, org-repeat-re, org-version): New consts.
(org-ts-lengths): Constant removed.
(org-follow-gnus-link): Don't ask how many articles to read.
@ -681,7 +1438,7 @@
2007-05-25 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/derived.el (define-derived-mode): Remove bogus
compatibiity code.
compatibility code.
* emacs-lisp/copyright.el (copyright-names-regexp): New var.
(copyright-update-year): Use it.

39
lisp/ChangeLog.12
View File

@ -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).
@ -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;
@ -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'.
@ -24608,7 +24608,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)
@ -25816,8 +25816,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.
@ -27755,7 +27754,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 `::'.
@ -32740,7 +32739,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

@ -241,7 +241,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." >> $@
@ -277,6 +277,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 \
@ -284,6 +287,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)

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

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."

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)

3
lisp/cus-start.el
View File

@ -142,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"

6
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
@ -965,9 +963,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))))))

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

@ -41,15 +41,18 @@
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.")
(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 +68,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 +154,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 +256,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 +273,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 +289,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 +303,152 @@ 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 nil nil 'emacs-mule)
(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 +458,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)
@ -499,19 +560,19 @@ directory or directories specified."
t files-re))
dirs)))
(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 +592,26 @@ 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)))
((not (and (file-exists-p file)
;; Remove duplicates as well, just in case.
(member file files)))
;; 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))))
(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 +622,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

1235
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")
;;; 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)

14
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.

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)))

32
lisp/files.el
View File

@ -1051,6 +1051,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 +1080,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 +1099,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 +1121,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 +1146,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 +1163,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 +1180,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))
@ -4021,6 +4039,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.

2
lisp/font-lock.el
View File

@ -2288,7 +2288,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

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

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))

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))

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)

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

@ -4360,7 +4360,7 @@ 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)
(put 'process-file 'ange-ftp 'ange-ftp-process-file)
(put 'shell-command 'ange-ftp 'ange-ftp-shell-command)
;;; Define ways of getting at unmodified Emacs primitives,
@ -4523,8 +4523,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 +4544,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)))))

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))

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.

2
lisp/progmodes/gud.el
View File

@ -2462,7 +2462,7 @@ comint mode, which see."
;; for local variables in the debugger buffer.
(defun gud-common-init (command-line massage-args marker-filter
&optional find-file)
(let* ((words (split-string command-line))
(let* ((words (string->strings command-line))
(program (car words))
(dir default-directory)
;; Extract the file name from WORDS

25
lisp/progmodes/hideshow.el
View File

@ -508,8 +508,8 @@ Original match data is restored upon return."
(defun hs-hide-comment-region (beg end &optional repos-end)
"Hide a region from BEG to END, marking it as a comment.
Optional arg REPOS-END means reposition at end."
(let ((beg-eol (progn (goto-char beg) (end-of-line) (point)))
(end-eol (progn (goto-char end) (end-of-line) (point))))
(let ((beg-eol (progn (goto-char beg) (line-end-position)))
(end-eol (progn (goto-char end) (line-end-position))))
(hs-discard-overlays beg-eol end-eol)
(hs-make-overlay beg-eol end-eol 'comment beg end))
(goto-char (if repos-end end beg)))
@ -536,8 +536,7 @@ and then further adjusted to be at the end of the line."
'identity)
pure-p))
;; whatever the adjustment, we move to eol
(end-of-line)
(point)))
(line-end-position)))
(q
;; `q' is the point at the end of the block
(progn (hs-forward-sexp mdata 1)
@ -705,7 +704,7 @@ and `case-fold-search' are both t."
(if (and c-reg (nth 0 c-reg))
;; point is inside a comment, and that comment is hidable
(goto-char (nth 0 c-reg))
(end-of-line)
(end-of-line)
(when (and (not c-reg)
(hs-find-block-beginning)
(looking-at hs-block-start-regexp))
@ -734,12 +733,12 @@ Move point to the beginning of the line, and run the normal hook
If `hs-hide-comments-when-hiding-all' is non-nil, also hide the comments."
(interactive)
(hs-life-goes-on
(message "Hiding all blocks ...")
(save-excursion
(unless hs-allow-nesting
(hs-discard-overlays (point-min) (point-max)))
(goto-char (point-min))
(let ((count 0)
(let ((spew (make-progress-reporter "Hiding all blocks..."
(point-min) (point-max)))
(re (concat "\\("
hs-block-start-regexp
"\\)"
@ -765,9 +764,9 @@ If `hs-hide-comments-when-hiding-all' is non-nil, also hide the comments."
(if (> (count-lines (car c-reg) (nth 1 c-reg)) 1)
(hs-hide-block-at-point t c-reg)
(goto-char (nth 1 c-reg))))))
(message "Hiding ... %d" (setq count (1+ count))))))
(progress-reporter-update spew (point)))
(progress-reporter-done spew)))
(beginning-of-line)
(message "Hiding all blocks ... done")
(run-hooks 'hs-hide-hook)))
(defun hs-show-all ()
@ -806,7 +805,7 @@ See documentation for functions `hs-hide-block' and `run-hooks'."
(hs-life-goes-on
(or
;; first see if we have something at the end of the line
(let ((ov (hs-overlay-at (save-excursion (end-of-line) (point))))
(let ((ov (hs-overlay-at (line-end-position)))
(here (point)))
(when ov
(goto-char
@ -906,9 +905,9 @@ Key bindings:
(progn
(hs-grok-mode-type)
;; Turn off this mode if we change major modes.
(add-hook 'change-major-mode-hook
'turn-off-hideshow
nil t)
(add-hook 'change-major-mode-hook
'turn-off-hideshow
nil t)
(easy-menu-add hs-minor-mode-menu)
(set (make-local-variable 'line-move-ignore-invisible) t)
(add-to-invisibility-spec '(hs . t)))

27
lisp/progmodes/sh-script.el
View File

@ -171,10 +171,6 @@
;; disadvantages:
;; 1. We need to scan the buffer to find which ")" symbols belong to a
;; case alternative, to find any here documents, and handle "$#".
;; 2. Setting the text property makes the buffer modified. If the
;; buffer is read-only buffer we have to cheat and bypass the read-only
;; status. This is for cases where the buffer started read-only buffer
;; but the user issued `toggle-read-only'.
;;
;; Bugs
;; ----
@ -183,6 +179,16 @@
;;
;; - `sh-learn-buffer-indent' is extremely slow.
;;
;; - "case $x in y) echo ;; esac)" the last ) is mis-identified as being
;; part of a case-pattern. You need to add a semi-colon after "esac" to
;; coerce sh-script into doing the right thing.
;;
;; - "echo $z in ps | head)" the last ) is mis-identified as being part of
;; a case-pattern. You need to put the "in" between quotes to coerce
;; sh-script into doing the right thing.
;;
;; - A line starting with "}>foo" is not indented like "} >foo".
;;
;; Richard Sharman <rsharman@pobox.com> June 1999.
;;; Code:
@ -1052,7 +1058,18 @@ subshells can nest."
(backward-char 1))
(when (eq (char-before) ?|)
(backward-char 1) t)))
(when (save-excursion (backward-char 2) (looking-at ";;\\|in"))
;; FIXME: ";; esac )" is a case that looks like a case-pattern but it's
;; really just a close paren after a case statement. I.e. if we skipped
;; over `esac' just now, we're not looking at a case-pattern.
(when (progn (backward-char 2)
(if (> start (line-end-position))
(put-text-property (point) (1+ start)
'font-lock-multiline t))
;; FIXME: The `in' may just be a random argument to
;; a normal command rather than the real `in' keyword.
;; I.e. we should look back to try and find the
;; corresponding `case'.
(looking-at ";;\\|in"))
sh-st-punc)))
(defun sh-font-lock-backslash-quote ()

1487
lisp/progmodes/vera-mode.el Normal file
View File

File diff suppressed because it is too large Load Diff

6
lisp/ps-mule.el
View File

@ -1233,5 +1233,9 @@ V%s 0 /%s-latin1 /%s Latin1Encoding put\n"
(provide 'ps-mule)
;;; arch-tag: bca017b2-66a7-4e59-8584-103e749eadbe
;; Local Variables:
;; generated-autoload-file: "ps-print.el"
;; End:
;; arch-tag: bca017b2-66a7-4e59-8584-103e749eadbe
;;; ps-mule.el ends here

127
lisp/ps-print.el
View File

@ -3638,7 +3638,7 @@ The table depends on the current ps-print setup."
;; ps-page-dimensions-database
;; ps-font-info-database
;;; ps-print - end of settings\n")
\;;; ps-print - end of settings\n")
"\n")))
@ -6466,24 +6466,129 @@ If FACE is not a valid face name, use default face."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; To make this file smaller, some commands go in a separate file.
;; But autoload them here to make the separation invisible.
;;;### (autoloads (ps-mule-begin-page ps-mule-begin-job ps-mule-encode-header-string
;;;;;; ps-mule-initialize ps-mule-plot-composition ps-mule-plot-string
;;;;;; ps-mule-set-ascii-font ps-mule-prepare-ascii-font ps-multibyte-buffer)
;;;;;; "ps-mule" "ps-mule.el" "464a9fb9d59f7561a46bcd5ca87d85db")
;;; Generated autoloads from ps-mule.el
(autoload 'ps-mule-initialize "ps-mule"
"Initialize global data for printing multi-byte characters.")
(defvar ps-multibyte-buffer nil "\
*Specifies the multi-byte buffer handling.
(autoload 'ps-mule-begin-job "ps-mule"
"Start printing job for multi-byte chars between FROM and TO.
This checks if all multi-byte characters in the region are printable or not.")
Valid values are:
(autoload 'ps-mule-begin-page "ps-mule"
"Initialize multi-byte charset for printing current page.")
nil This is the value to use the default settings which
is by default for printing buffer with only ASCII
and Latin characters. The default setting can be
changed by setting the variable
`ps-mule-font-info-database-default' differently.
The initial value of this variable is
`ps-mule-font-info-database-latin' (see
documentation).
(autoload 'ps-mule-end-job "ps-mule"
"Finish printing job for multi-byte chars.")
`non-latin-printer' This is the value to use when you have a Japanese
or Korean PostScript printer and want to print
buffer with ASCII, Latin-1, Japanese (JISX0208 and
JISX0201-Kana) and Korean characters. At present,
it was not tested the Korean characters printing.
If you have a korean PostScript printer, please,
test it.
`bdf-font' This is the value to use when you want to print
buffer with BDF fonts. BDF fonts include both latin
and non-latin fonts. BDF (Bitmap Distribution
Format) is a format used for distributing X's font
source file. BDF fonts are included in
`intlfonts-1.2' which is a collection of X11 fonts
for all characters supported by Emacs. In order to
use this value, be sure to have installed
`intlfonts-1.2' and set the variable
`bdf-directory-list' appropriately (see ps-bdf.el for
documentation of this variable).
`bdf-font-except-latin' This is like `bdf-font' except that it is used
PostScript default fonts to print ASCII and Latin-1
characters. This is convenient when you want or
need to use both latin and non-latin characters on
the same buffer. See `ps-font-family',
`ps-header-font-family' and `ps-font-info-database'.
Any other value is treated as nil.")
(custom-autoload (quote ps-multibyte-buffer) "ps-mule" t)
(autoload (quote ps-mule-prepare-ascii-font) "ps-mule" "\
Setup special ASCII font for STRING.
STRING should contain only ASCII characters.
\(fn STRING)" nil nil)
(autoload (quote ps-mule-set-ascii-font) "ps-mule" "\
Not documented
\(fn)" nil nil)
(autoload (quote ps-mule-plot-string) "ps-mule" "\
Generate PostScript code for plotting characters in the region FROM and TO.
It is assumed that all characters in this region belong to the same charset.
Optional argument BG-COLOR specifies background color.
Returns the value:
(ENDPOS . RUN-WIDTH)
Where ENDPOS is the end position of the sequence and RUN-WIDTH is the width of
the sequence.
\(fn FROM TO &optional BG-COLOR)" nil nil)
(autoload (quote ps-mule-plot-composition) "ps-mule" "\
Generate PostScript code for plotting composition in the region FROM and TO.
It is assumed that all characters in this region belong to the same
composition.
Optional argument BG-COLOR specifies background color.
Returns the value:
(ENDPOS . RUN-WIDTH)
Where ENDPOS is the end position of the sequence and RUN-WIDTH is the width of
the sequence.
\(fn FROM TO &optional BG-COLOR)" nil nil)
(autoload (quote ps-mule-initialize) "ps-mule" "\
Initialize global data for printing multi-byte characters.
\(fn)" nil nil)
(autoload (quote ps-mule-encode-header-string) "ps-mule" "\
Generate PostScript code for ploting STRING by font FONTTAG.
FONTTAG should be a string \"/h0\" or \"/h1\".
\(fn STRING FONTTAG)" nil nil)
(autoload (quote ps-mule-begin-job) "ps-mule" "\
Start printing job for multi-byte chars between FROM and TO.
This checks if all multi-byte characters in the region are printable or not.
\(fn FROM TO)" nil nil)
(autoload (quote ps-mule-begin-page) "ps-mule" "\
Not documented
\(fn)" nil nil)
;;;***
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(provide 'ps-print)
;;; arch-tag: fb06a585-1112-4206-885d-a57d95d50579
;; arch-tag: fb06a585-1112-4206-885d-a57d95d50579
;;; ps-print.el ends here

5
lisp/ruler-mode.el
View File

@ -29,7 +29,7 @@
;;; Commentary:
;; This library provides a minor mode to display a ruler in the header
;; line. It works only on Emacs 21.
;; line. It works from Emacs 21 onwards.
;;
;; You can use the mouse to change the `fill-column' `comment-column',
;; `goal-column', `window-margins' and `tab-stop-list' settings:
@ -561,7 +561,8 @@ Call `ruler-mode-ruler-function' to compute the ruler value.")
(progn
;; When `ruler-mode' is on save previous header line format
;; and install the ruler header line format.
(when (local-variable-p 'header-line-format)
(when (and (local-variable-p 'header-line-format)
(not (local-variable-p 'ruler-mode-header-line-format-old)))
(set (make-local-variable 'ruler-mode-header-line-format-old)
header-line-format))
(setq header-line-format ruler-mode-header-line-format)

7
lisp/shell.el
View File

@ -5,7 +5,7 @@
;; Author: Olin Shivers <shivers@cs.cmu.edu>
;; Simon Marshall <simon@gnu.org>
;; Maintainer: FSF
;; Maintainer: FSF <emacs-devel@gnu.org>
;; Keywords: processes
;; This file is part of GNU Emacs.
@ -27,11 +27,6 @@
;;; Commentary:
;; Please send me bug reports, bug fixes, and extensions, so that I can
;; merge them into the master source.
;; - Olin Shivers (shivers@cs.cmu.edu)
;; - Simon Marshall (simon@gnu.org)
;; This file defines a shell-in-a-buffer package (shell mode) built on
;; top of comint mode. This is actually cmushell with things renamed
;; to replace its counterpart in Emacs 18. cmushell is more

33
lisp/simple.el
View File

@ -156,6 +156,15 @@ If `fringe-arrow', indicate the locus by the fringe arrow."
:group 'next-error
:version "22.1")
(defcustom next-error-recenter nil
"*Display the line in the visited source file recentered as specified.
If non-nil, the value is passed directly to `recenter'."
:type '(choice (integer :tag "Line to recenter to")
(const :tag "Center of window" (4))
(const :tag "No recentering" nil))
:group 'next-error
:version "23.1")
(defcustom next-error-hook nil
"*List of hook functions run by `next-error' after visiting source file."
:type 'hook
@ -305,6 +314,8 @@ See variables `compilation-parse-errors-function' and
;; we know here that next-error-function is a valid symbol we can funcall
(with-current-buffer next-error-last-buffer
(funcall next-error-function (prefix-numeric-value arg) reset)
(when next-error-recenter
(recenter next-error-recenter))
(run-hooks 'next-error-hook))))
(defun next-error-internal ()
@ -313,6 +324,8 @@ See variables `compilation-parse-errors-function' and
;; we know here that next-error-function is a valid symbol we can funcall
(with-current-buffer next-error-last-buffer
(funcall next-error-function 0 nil)
(when next-error-recenter
(recenter next-error-recenter))
(run-hooks 'next-error-hook)))
(defalias 'goto-next-locus 'next-error)
@ -2189,6 +2202,18 @@ value passed."
(when stderr-file (delete-file stderr-file))
(when lc (delete-file lc)))))
(defun start-file-process (name buffer program &rest program-args)
"Start a program in a subprocess. Return the process object for it.
Similar to `start-process', but may invoke a file handler based on
`default-directory'. The current working directory of the
subprocess is `default-directory'.
PROGRAM and PROGRAM-ARGS might be file names. They are not
objects of file handler invocation."
(let ((fh (find-file-name-handler default-directory 'start-file-process)))
(if fh (apply fh 'start-file-process name buffer program program-args)
(apply 'start-process name buffer program program-args))))
(defvar universal-argument-map
@ -5246,10 +5271,10 @@ PREFIX is the string that represents this modifier in an event type symbol."
;;;; Keypad support.
;;; Make the keypad keys act like ordinary typing keys. If people add
;;; bindings for the function key symbols, then those bindings will
;;; override these, so this shouldn't interfere with any existing
;;; bindings.
;; Make the keypad keys act like ordinary typing keys. If people add
;; bindings for the function key symbols, then those bindings will
;; override these, so this shouldn't interfere with any existing
;; bindings.
;; Also tell read-char how to handle these keys.
(mapc

40
lisp/speedbar.el
View File

@ -10,7 +10,7 @@
"The current version of speedbar.")
(defvar speedbar-incompatible-version "0.14beta4"
"This version of speedbar is incompatible with this version.
Due to massive API changes (removing the use of the word PATH)
Due to massive API changes (removing the use of the word PATH)
this version is not backward compatible to 0.14 or earlier.")
;; This file is part of GNU Emacs.
@ -915,7 +915,7 @@ This basically creates a sparse keymap, and makes its parent be
(looking-at "[0-9]+: *\\[[+-]\\] [^ \n]+ \\*?[!#]$"))]
)
"Additional menu items while in file-mode.")
(defvar speedbar-easymenu-definition-trailer
(append
(if (and (featurep 'custom) (fboundp 'custom-declare-variable))
@ -958,13 +958,13 @@ directories.")
(defalias 'speedbar-make-overlay
(if (featurep 'xemacs) 'make-extent 'make-overlay))
(defalias 'speedbar-overlay-put
(defalias 'speedbar-overlay-put
(if (featurep 'xemacs) 'set-extent-property 'overlay-put))
(defalias 'speedbar-delete-overlay
(defalias 'speedbar-delete-overlay
(if (featurep 'xemacs) 'delete-extent 'delete-overlay))
(defalias 'speedbar-mode-line-update
(defalias 'speedbar-mode-line-update
(if (featurep 'xemacs) 'redraw-modeline 'force-mode-line-update))
;;; Mode definitions/ user commands
@ -1053,10 +1053,10 @@ supported at a time.
"Handle a delete frame event E.
If the deleted frame is the frame SPEEDBAR is attached to,
we need to delete speedbar also."
(let ((frame-to-be-deleted (car (car (cdr e)))))
(if (eq frame-to-be-deleted dframe-attached-frame)
(delete-frame speedbar-frame)))
)
(when (and speedbar-frame
(eq (car (car (cdr e))) ;; frame to be deleted
dframe-attached-frame))
(delete-frame speedbar-frame)))
;;;###autoload
(defun speedbar-get-focus ()
@ -1158,7 +1158,7 @@ return true without a query."
;; Backwards compatibility
(defalias 'speedbar-with-attached-buffer 'dframe-with-attached-buffer)
(defalias 'speedbar-maybee-jump-to-attached-frame 'dframe-maybee-jump-to-attached-frame)
(defun speedbar-set-mode-line-format ()
"Set the format of the mode line based on the current speedbar environment.
This gives visual indications of what is up. It EXPECTS the speedbar
@ -2055,7 +2055,7 @@ position to insert a new item, and that the new item will end with a CR."
(if tag-button-function 'speedbar-highlight-face nil)
tag-button-function tag-button-data))
))
(defun speedbar-change-expand-button-char (char)
"Change the expansion button character to CHAR for the current line."
(save-excursion
@ -2100,7 +2100,7 @@ cell of the form ( 'DIRLIST . 'FILELIST )."
(defun speedbar-default-directory-list (directory index)
"Insert files for DIRECTORY with level INDEX at point."
(speedbar-insert-files-at-point
(speedbar-insert-files-at-point
(speedbar-file-lists directory) index)
(speedbar-reset-scanners)
(if (= index 0)
@ -2454,7 +2454,7 @@ name will have the function FIND-FUN and not token."
(speedbar-insert-generic-list indent lst
'speedbar-tag-expand
'speedbar-tag-find))
(defun speedbar-insert-etags-list (indent lst)
"At level INDENT, insert the etags generated LST."
(speedbar-insert-generic-list indent lst
@ -2729,7 +2729,7 @@ If new functions are added, their state needs to be updated here."
"Go to the line where FILE is."
(set-buffer speedbar-buffer)
(goto-char (point-min))
(let ((m nil))
(while (and (setq m (re-search-forward
@ -3220,7 +3220,7 @@ directory with these items. This function is replaceable in
(widen)
(let ((rf (speedbar-fetch-replacement-function 'speedbar-line-directory)))
(if rf (funcall rf depth) default-directory))))
(defun speedbar-files-line-directory (&optional depth)
"Retrieve the directoryname associated with the current line.
This may require traversing backwards from DEPTH and combining the default
@ -3305,12 +3305,12 @@ With universal argument ARG, flush cached data."
(forward-char -2)
(speedbar-do-function-pointer))
(error (speedbar-position-cursor-on-line)))))
(defun speedbar-flush-expand-line ()
"Expand the line under the cursor and flush any cached information."
(interactive)
(speedbar-expand-line 1))
(defun speedbar-contract-line ()
"Contract the line under the cursor."
(interactive)
@ -3559,11 +3559,11 @@ This assumes that the cursor is on a file, or tag of a file which the user is
interested in."
(save-selected-window
(select-window (get-buffer-window speedbar-buffer t))
(set-buffer speedbar-buffer)
(if (<= (count-lines (point-min) (point-max))
(1- (window-height (selected-window))))
;; whole buffer fits

5
lisp/startup.el
View File

@ -1056,7 +1056,10 @@ or `CVS', and any subdirectory that contains a file named `.nosearch'."
(if (get-buffer "*scratch*")
(with-current-buffer "*scratch*"
(if (eq major-mode 'fundamental-mode)
(funcall initial-major-mode))))
(funcall initial-major-mode))
;; Don't lose text that users type in *scratch*.
(setq buffer-offer-save t)
(auto-save-mode 1)))
;; Load library for our terminal type.
;; User init file can set term-file-prefix to nil to prevent this.

30
lisp/subr.el
View File

@ -2768,6 +2768,36 @@ Modifies the match data; use `save-match-data' if necessary."
(cons (substring string start)
list)))
(nreverse list)))
;; (string->strings (strings->string X)) == X
(defun strings->string (strings &optional separator)
"Concatenate the STRINGS, adding the SEPARATOR (default \" \").
This tries to quote the strings to avoid ambiguity such that
(string->strings (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 string->strings (string &optional separator)
"Split the STRING into a list of strings.
It understands elisp style quoting within STRING such that
(string->strings (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)
(string->strings (substring string (cdr rfs))
sep)))))))
;;;; Replacement in strings.

14
lisp/term/w32-win.el
View File

@ -1041,8 +1041,18 @@ XConsortium: rgb.txt,v 10.41 94/02/20 18:39:36 rws Exp")
;;; make f10 activate the real menubar rather than the mini-buffer menu
;;; navigation feature.
(global-set-key [f10] (lambda ()
(interactive) (w32-send-sys-command ?\xf100)))
(defun menu-bar-open (&optional frame)
"Start key navigation of the menu bar in FRAME.
This initially activates the first menu-bar item, and you can then navigate
with the arrow keys, select a menu entry with the Return key or cancel with
the Escape key. If FRAME has no menu bar, this function does nothing.
If FRAME is nil or not given, use the selected frame."
(interactive "i")
(w32-send-sys-command ?\xf100 frame))
;
(global-set-key [f10] 'menu-bar-open)
(substitute-key-definition 'suspend-emacs 'iconify-or-deiconify-frame
global-map)

508
lisp/textmodes/bibtex.el
View File

@ -34,7 +34,7 @@
;; Major mode for editing and validating BibTeX files.
;; Usage:
;; See documentation for function bibtex-mode or type "\M-x describe-mode"
;; See documentation for `bibtex-mode' or type "M-x describe-mode"
;; when you are in BibTeX mode.
;; Todo:
@ -112,6 +112,7 @@ required-fields Signal an error if a required field is missing.
numerical-fields Delete delimiters around numeral fields.
page-dashes Change double dashes in page field to single dash
(for scribe compatibility).
whitespace Delete whitespace at the beginning and end of fields.
inherit-booktitle If entry contains a crossref field and the booktitle
field is empty, set the booktitle field to the content
of the title field of the crossreferenced entry.
@ -123,6 +124,10 @@ last-comma Add or delete comma on end of last field in entry,
delimiters Change delimiters according to variables
`bibtex-field-delimiters' and `bibtex-entry-delimiters'.
unify-case Change case of entry and field names.
braces Enclose parts of field entries by braces according to
`bibtex-field-braces-alist'.
strings Replace parts of field entries by string constants
according to `bibtex-field-strings-alist'.
The value t means do all of the above formatting actions.
The value nil means do no formatting at all."
@ -134,11 +139,35 @@ The value nil means do no formatting at all."
(const required-fields)
(const numerical-fields)
(const page-dashes)
(const whitespace)
(const inherit-booktitle)
(const realign)
(const last-comma)
(const delimiters)
(const unify-case))))
(const unify-case)
(const braces)
(const strings))))
(defcustom bibtex-field-braces-alist nil
"Alist of field regexps that \\[bibtex-clean-entry] encloses by braces.
Each element has the form (FIELDS REGEXP), where FIELDS is a list
of BibTeX field names and REGEXP is a regexp.
Whitespace in REGEXP will be replaced by \"[ \\t\\n]+\"."
:group 'bibtex
:type '(repeat (list (repeat (string :tag "field name"))
(choice (regexp :tag "regexp")
(sexp :tag "sexp")))))
(defcustom bibtex-field-strings-alist nil
"Alist of regexps that \\[bibtex-clean-entry] replaces by string constants.
Each element has the form (FIELDS REGEXP TO-STR), where FIELDS is a list
of BibTeX field names. In FIELDS search for REGEXP, which are replaced
by the BibTeX string constant TO-STR.
Whitespace in REGEXP will be replaced by \"[ \\t\\n]+\"."
:group 'bibtex
:type '(repeat (list (repeat (string :tag "field name"))
(regexp :tag "From regexp")
(regexp :tag "To string constant"))))
(defcustom bibtex-clean-entry-hook nil
"List of functions to call when entry has been cleaned.
@ -899,6 +928,17 @@ The following is a complex example, see http://link.aps.org/linkfaq.html.
(function :tag "Filter"))))))))
(put 'bibtex-generate-url-list 'risky-local-variable t)
(defcustom bibtex-cite-matcher-alist
'(("\\\\cite[ \t\n]*{\\([^}]+\\)}" . 1))
"Alist of rules to identify cited keys in a BibTeX entry.
Each rule should be of the form (REGEXP . SUBEXP), where SUBEXP
specifies which parenthesized expression in REGEXP is a cited key.
Case is significant.
Used by `bibtex-find-crossref' and for font-locking."
:group 'bibtex
:type '(repeat (cons (regexp :tag "Regexp")
(integer :tag "Number"))))
(defcustom bibtex-expand-strings nil
"If non-nil, expand strings when extracting the content of a BibTeX field."
:group 'bibtex
@ -1070,6 +1110,17 @@ The following is a complex example, see http://link.aps.org/linkfaq.html.
;; Internal Variables
(defvar bibtex-field-braces-opt nil
"Optimized value of `bibtex-field-braces-alist'.
Created by `bibtex-field-re-init'.
It is a an alist with elements (FIELD . REGEXP).")
(defvar bibtex-field-strings-opt nil
"Optimized value of `bibtex-field-strings-alist'.
Created by `bibtex-field-re-init'.
It is a an alist with elements (FIELD RULE1 RULE2 ...),
where each RULE is (REGEXP . TO-STR).")
(defvar bibtex-pop-previous-search-point nil
"Next point where `bibtex-pop-previous' starts looking for a similar entry.")
@ -1215,7 +1266,11 @@ The CDRs of the elements are t for header keys and nil for crossref keys.")
(,(concat "^[ \t]*\\(" bibtex-field-name "\\)[ \t]*=")
1 font-lock-variable-name-face)
;; url
(bibtex-font-lock-url) (bibtex-font-lock-crossref))
(bibtex-font-lock-url) (bibtex-font-lock-crossref)
;; cite
,@(mapcar (lambda (matcher)
`((lambda (bound) (bibtex-font-lock-cite ',matcher bound))))
bibtex-cite-matcher-alist))
"*Default expressions to highlight in BibTeX mode.")
(defvar bibtex-font-lock-url-regexp
@ -1223,7 +1278,7 @@ The CDRs of the elements are t for header keys and nil for crossref keys.")
(concat "^[ \t]*"
(regexp-opt (delete-dups (mapcar 'caar bibtex-generate-url-list)) t)
"[ \t]*=[ \t]*")
"Regexp for `bibtex-font-lock-url'.")
"Regexp for `bibtex-font-lock-url' derived from `bibtex-generate-url-list'.")
(defvar bibtex-string-empty-key nil
"If non-nil, `bibtex-parse-string' accepts empty key.")
@ -1553,7 +1608,7 @@ If EMPTY-KEY is non-nil, key may be empty. Do not move point."
bounds))))
(defun bibtex-reference-key-in-string (bounds)
"Return the key part of a BibTeX string defined via BOUNDS"
"Return the key part of a BibTeX string defined via BOUNDS."
(buffer-substring-no-properties (nth 1 (car bounds))
(nth 2 (car bounds))))
@ -1626,8 +1681,8 @@ of the entry, see regexp `bibtex-entry-head'."
(if (save-excursion
(goto-char (match-end bibtex-type-in-head))
(looking-at "[ \t]*("))
",?[ \t\n]*)" ;; entry opened with `('
",?[ \t\n]*}")) ;; entry opened with `{'
",?[ \t\n]*)" ; entry opened with `('
",?[ \t\n]*}")) ; entry opened with `{'
bounds)
(skip-chars-forward " \t\n")
;; loop over all BibTeX fields
@ -1736,7 +1791,7 @@ If FLAG is nil, a message is echoed if point was incremented at least
(< (point) pnt))
(goto-char (match-beginning bibtex-type-in-head))
(if (pos-visible-in-window-p (point))
(sit-for 1)
(sit-for blink-matching-delay)
(message "%s%s" prompt (buffer-substring-no-properties
(point) (match-end bibtex-key-in-head))))))))
@ -1801,21 +1856,19 @@ Optional arg BEG is beginning of entry."
"Reinsert the Nth stretch of killed BibTeX text (field or entry).
Optional arg COMMA is as in `bibtex-enclosing-field'."
(unless bibtex-last-kill-command (error "BibTeX kill ring is empty"))
(let ((fun (lambda (kryp kr) ;; adapted from `current-kill'
(let ((fun (lambda (kryp kr) ; adapted from `current-kill'
(car (set kryp (nthcdr (mod (- n (length (eval kryp)))
(length kr)) kr))))))
(if (eq bibtex-last-kill-command 'field)
(progn
;; insert past the current field
(goto-char (bibtex-end-of-field (bibtex-enclosing-field comma)))
(set-mark (point))
(message "Mark set")
(push-mark)
(bibtex-make-field (funcall fun 'bibtex-field-kill-ring-yank-pointer
bibtex-field-kill-ring) t nil t))
;; insert past the current entry
(bibtex-skip-to-valid-entry)
(set-mark (point))
(message "Mark set")
(push-mark)
(insert (funcall fun 'bibtex-entry-kill-ring-yank-pointer
bibtex-entry-kill-ring)))))
@ -1835,6 +1888,15 @@ Formats current entry according to variable `bibtex-entry-format'."
crossref-key bounds alternatives-there non-empty-alternative
entry-list req-field-list field-list)
;; Initialize `bibtex-field-braces-opt' and `bibtex-field-strings-opt'
;; if necessary.
(unless bibtex-field-braces-opt
(setq bibtex-field-braces-opt
(bibtex-field-re-init bibtex-field-braces-alist 'braces)))
(unless bibtex-field-strings-opt
(setq bibtex-field-strings-opt
(bibtex-field-re-init bibtex-field-strings-alist 'strings)))
;; identify entry type
(goto-char (point-min))
(or (re-search-forward bibtex-entry-type nil t)
@ -1904,7 +1966,7 @@ Formats current entry according to variable `bibtex-entry-format'."
deleted)
;; We have more elegant high-level functions for several
;; tasks done by bibtex-format-entry. However, they contain
;; tasks done by `bibtex-format-entry'. However, they contain
;; quite some redundancy compared with what we need to do
;; anyway. So for speed-up we avoid using them.
@ -1957,6 +2019,59 @@ Formats current entry according to variable `bibtex-entry-format'."
"\\([\"{][0-9]+\\)[ \t\n]*--?[ \t\n]*\\([0-9]+[\"}]\\)")))
(replace-match "\\1-\\2"))
;; remove whitespace at beginning and end of field
(when (memq 'whitespace format)
(goto-char beg-text)
(if (looking-at "\\([{\"]\\)[ \t\n]+")
(replace-match "\\1"))
(goto-char end-text)
(if (looking-back "[ \t\n]+\\([}\"]\\)" beg-text t)
(replace-match "\\1")))
;; enclose field text by braces according to
;; `bibtex-field-braces-alist'.
(let (case-fold-search temp) ; Case-sensitive search
(when (and (memq 'braces format)
(setq temp (cdr (assoc-string field-name
bibtex-field-braces-opt t))))
(goto-char beg-text)
(while (re-search-forward temp end-text t)
(let ((beg (match-beginning 0))
(bounds (bibtex-find-text-internal nil t)))
(unless (or (nth 4 bounds) ; string constant
;; match already surrounded by braces
;; (braces are inside field delimiters)
(and (< (point) (1- (nth 2 bounds)))
(< (1+ (nth 1 bounds)) beg)
(looking-at "}")
(save-excursion (goto-char (1- beg))
(looking-at "{"))))
(insert "}")
(goto-char beg)
(insert "{")))))
;; replace field text by BibTeX string constants according to
;; `bibtex-field-strings-alist'.
(when (and (memq 'strings format)
(setq temp (cdr (assoc-string field-name
bibtex-field-strings-opt t))))
(goto-char beg-text)
(dolist (re temp)
(while (re-search-forward (car re) end-text t)
(let ((bounds (save-match-data
(bibtex-find-text-internal nil t))))
(unless (nth 4 bounds)
;; if match not at right subfield boundary...
(if (< (match-end 0) (1- (nth 2 bounds)))
(insert " # " (bibtex-field-left-delimiter))
(delete-char 1))
(replace-match (cdr re))
(goto-char (match-beginning 0))
;; if match not at left subfield boundary...
(if (< (1+ (nth 1 bounds)) (match-beginning 0))
(insert (bibtex-field-right-delimiter) " # ")
(delete-backward-char 1))))))))
;; use book title of crossref'd entry
(if (and (memq 'inherit-booktitle format)
empty-field
@ -2047,6 +2162,31 @@ Formats current entry according to variable `bibtex-entry-format'."
(if (memq 'realign format)
(bibtex-fill-entry))))))
(defun bibtex-field-re-init (regexp-alist type)
"Calculate optimized value for bibtex-regexp-TYPE-opt.
This value is based on bibtex-regexp-TYPE-alist. TYPE is 'braces or 'strings.
Return optimized value to be used by `bibtex-format-entry'."
(setq regexp-alist
(mapcar (lambda (e)
(list (car e)
(replace-regexp-in-string "[ \t\n]+" "[ \t\n]+" (nth 1 e))
(nth 2 e))) ; nil for 'braces'.
regexp-alist))
(let (opt-list)
;; Loop over field names
(dolist (field (delete-dups (apply 'append (mapcar 'car regexp-alist))))
(let (rules)
;; Collect all matches we have for this field name
(dolist (e regexp-alist)
(if (assoc-string field (car e) t)
(push (cons (nth 1 e) (nth 2 e)) rules)))
(if (eq type 'braces)
;; concatenate all regexps to a single regexp
(setq rules (concat "\\(?:" (mapconcat 'car rules "\\|") "\\)")))
;; create list of replacement rules.
(push (cons field rules) opt-list)))
opt-list))
(defun bibtex-autokey-abbrev (string len)
"Return an abbreviation of STRING with at least LEN characters.
@ -2099,7 +2239,7 @@ and `bibtex-autokey-names-stretch'."
(<= (length name-list)
(+ bibtex-autokey-names
bibtex-autokey-names-stretch)))
;; Take bibtex-autokey-names elements from beginning of name-list
;; Take `bibtex-autokey-names' elements from beginning of name-list
(setq name-list (nreverse (nthcdr (- (length name-list)
bibtex-autokey-names)
(nreverse name-list)))
@ -2161,7 +2301,7 @@ Return the result as a string"
(setq word (match-string 0 titlestring)
titlestring (substring titlestring (match-end 0)))
;; Ignore words matched by one of the elements of
;; bibtex-autokey-titleword-ignore
;; `bibtex-autokey-titleword-ignore'
(unless (let ((lst bibtex-autokey-titleword-ignore))
(while (and lst
(not (string-match (concat "\\`\\(?:" (car lst)
@ -2173,9 +2313,9 @@ Return the result as a string"
(<= counter bibtex-autokey-titlewords))
(push word titlewords)
(push word titlewords-extra))))
;; Obey bibtex-autokey-titlewords-stretch:
;; Obey `bibtex-autokey-titlewords-stretch':
;; If by now we have processed all words in titlestring, we include
;; titlewords-extra in titlewords. Otherwise, we ignore titlewords-extra.
;; titlewords-extra in titlewords. Otherwise, we ignore titlewords-extra.
(unless (string-match "\\b\\w+" titlestring)
(setq titlewords (append titlewords-extra titlewords)))
(mapconcat 'bibtex-autokey-demangle-title (nreverse titlewords)
@ -2343,7 +2483,7 @@ for parsing BibTeX keys. If parsing fails, try to set this variable to nil."
(push (cons key t) ref-keys)))))))
(let (;; ignore @String entries because they are handled
;; separately by bibtex-parse-strings
;; separately by `bibtex-parse-strings'
(bibtex-sort-ignore-string-entries t)
bounds)
(bibtex-map-entries
@ -2399,7 +2539,7 @@ Return alist of strings if parsing was completed, `aborted' otherwise."
(setq bibtex-strings strings))))))
(defun bibtex-strings ()
"Return `bibtex-strings'. Initialize this variable if necessary."
"Return `bibtex-strings'. Initialize this variable if necessary."
(if (listp bibtex-strings) bibtex-strings
(bibtex-parse-strings (bibtex-string-files-init))))
@ -2456,10 +2596,10 @@ Parsing initializes `bibtex-reference-keys' and `bibtex-strings'."
bibtex-buffer-last-parsed-tick)))
(save-restriction
(widen)
;; Output no progress messages in bibtex-parse-keys
;; because when in y-or-n-p that can hide the question.
;; Output no progress messages in `bibtex-parse-keys'
;; because when in `y-or-n-p' that can hide the question.
(if (and (listp (bibtex-parse-keys t))
;; update bibtex-strings
;; update `bibtex-strings'
(listp (bibtex-parse-strings strings-init t)))
;; remember that parsing was successful
@ -2519,28 +2659,35 @@ already set."
COMPLETIONS is an alist of strings. If point is not after the part
of a word, all strings are listed. Return completion."
;; Return value is used by cleanup functions.
;; Code inspired by `lisp-complete-symbol'.
(let* ((case-fold-search t)
(beg (save-excursion
(re-search-backward "[ \t{\"]")
(forward-char)
(point)))
(end (point))
(part-of-word (buffer-substring-no-properties beg end))
(completion (try-completion part-of-word completions)))
(pattern (buffer-substring-no-properties beg end))
(completion (try-completion pattern completions)))
(cond ((not completion)
(error "Can't find completion for `%s'" part-of-word))
(error "Can't find completion for `%s'" pattern))
((eq completion t)
part-of-word)
((not (string= part-of-word completion))
pattern)
((not (string= pattern completion))
(delete-region beg end)
(insert completion)
;; Don't leave around a completions buffer that's out of date.
(let ((win (get-buffer-window "*Completions*" 0)))
(if win (with-selected-window win (bury-buffer))))
completion)
(t
(message "Making completion list...")
(with-output-to-temp-buffer "*Completions*"
(display-completion-list (all-completions part-of-word completions)
part-of-word))
(message "Making completion list...done")
(let ((minibuf-is-in-use
(eq (minibuffer-window) (selected-window))))
(unless minibuf-is-in-use (message "Making completion list..."))
(with-output-to-temp-buffer "*Completions*"
(display-completion-list
(sort (all-completions pattern completions) 'string<) pattern))
(unless minibuf-is-in-use
(message "Making completion list...done")))
nil))))
(defun bibtex-complete-string-cleanup (str compl)
@ -2562,20 +2709,25 @@ Use `bibtex-summary-function' to generate summary."
(bibtex-find-entry key t))
(message "Ref: %s" (funcall bibtex-summary-function)))))
(defun bibtex-copy-summary-as-kill ()
(defun bibtex-copy-summary-as-kill (&optional arg)
"Push summery of current BibTeX entry to kill ring.
Use `bibtex-summary-function' to generate summary."
(interactive)
(save-excursion
(bibtex-beginning-of-entry)
(if (looking-at bibtex-entry-maybe-empty-head)
(kill-new (message "%s" (funcall bibtex-summary-function)))
(error "No entry found"))))
Use `bibtex-summary-function' to generate summary.
If prefix ARG is non-nil push BibTeX entry's URL to kill ring
that is generated by calling `bibtex-url'."
(interactive "P")
(if arg (let ((url (bibtex-url nil t)))
(if url (kill-new (message "%s" url))
(message "No URL known")))
(save-excursion
(bibtex-beginning-of-entry)
(if (looking-at bibtex-entry-maybe-empty-head)
(kill-new (message "%s" (funcall bibtex-summary-function)))
(error "No entry found")))))
(defun bibtex-summary ()
"Return summary of current BibTeX entry.
Used as default value of `bibtex-summary-function'."
;; It would be neat to customize this function. How?
;; It would be neat to make this function customizable. How?
(if (looking-at bibtex-entry-maybe-empty-head)
(let* ((bibtex-autokey-name-case-convert-function 'identity)
(bibtex-autokey-name-length 'infty)
@ -2664,16 +2816,17 @@ begins at the beginning of a line. We use this function for font-locking."
(unless (looking-at field-reg)
(re-search-backward field-reg nil t))))
(defun bibtex-font-lock-url (bound)
"Font-lock for URLs. BOUND limits the search."
(defun bibtex-font-lock-url (bound &optional no-button)
"Font-lock for URLs. BOUND limits the search.
If NO-BUTTON is non-nil do not generate buttons."
(let ((case-fold-search t)
(pnt (point))
field bounds start end found)
name bounds start end found)
(bibtex-beginning-of-field)
(while (and (not found)
(<= (point) bound)
(prog1 (re-search-forward bibtex-font-lock-url-regexp bound t)
(setq field (match-string-no-properties 1)))
(setq name (match-string-no-properties 1)))
(setq bounds (bibtex-parse-field-text))
(progn
(setq start (car bounds) end (nth 1 bounds))
@ -2682,17 +2835,18 @@ begins at the beginning of a line. We use this function for font-locking."
(setq end (1- end)))
(if (memq (char-after start) '(?\{ ?\"))
(setq start (1+ start)))
(>= bound start)))
(let ((lst bibtex-generate-url-list) url)
(goto-char start)
(while (and (not found)
(setq url (car (pop lst))))
(setq found (and (bibtex-string= field (car url))
(re-search-forward (cdr url) end t)
(>= (match-beginning 0) pnt)))))
(goto-char end))
(if found (bibtex-button (match-beginning 0) (match-end 0)
'bibtex-url (match-beginning 0)))
(if (< start pnt) (setq start (min pnt end)))
(<= start bound)))
(if (<= pnt start)
(let ((lst bibtex-generate-url-list) url)
(while (and (not found) (setq url (car (pop lst))))
(goto-char start)
(setq found (and (bibtex-string= name (car url))
(re-search-forward (cdr url) end t))))))
(unless found (goto-char end)))
(if (and found (not no-button))
(bibtex-button (match-beginning 0) (match-end 0)
'bibtex-url (match-beginning 0)))
found))
(defun bibtex-font-lock-crossref (bound)
@ -2713,6 +2867,19 @@ begins at the beginning of a line. We use this function for font-locking."
start t))
found))
(defun bibtex-font-lock-cite (matcher bound)
"Font-lock for cited keys.
MATCHER identifies the cited key, see `bibtex-cite-matcher-alist'.
BOUND limits the search."
(let (case-fold-search)
(if (re-search-forward (car matcher) bound t)
(let ((start (match-beginning (cdr matcher)))
(end (match-end (cdr matcher))))
(bibtex-button start end 'bibtex-find-crossref
(buffer-substring-no-properties start end)
start t t)
t))))
(defun bibtex-button-action (button)
"Call BUTTON's BibTeX function."
(apply (button-get button 'bibtex-function)
@ -2831,7 +2998,7 @@ if that value is non-nil.
(list (list nil bibtex-entry-head bibtex-key-in-head))
imenu-case-fold-search t)
(make-local-variable 'choose-completion-string-functions)
;; XEmacs needs easy-menu-add, Emacs does not care
;; XEmacs needs `easy-menu-add', Emacs does not care
(easy-menu-add bibtex-edit-menu)
(easy-menu-add bibtex-entry-menu)
(run-mode-hooks 'bibtex-mode-hook))
@ -3125,7 +3292,7 @@ Return the new location of point."
(goto-char (bibtex-end-of-string bounds)))
((looking-at bibtex-any-valid-entry-type)
;; Parsing of entry failed
(error "Syntactically incorrect BibTeX entry starts here."))
(error "Syntactically incorrect BibTeX entry starts here"))
(t (if (interactive-p) (message "Not on a known BibTeX entry."))
(goto-char pnt)))
(point)))
@ -3163,7 +3330,7 @@ Otherwise display the beginning of entry."
(defun bibtex-mark-entry ()
"Put mark at beginning, point at end of current BibTeX entry."
(interactive)
(set-mark (bibtex-beginning-of-entry))
(push-mark (bibtex-beginning-of-entry))
(bibtex-end-of-entry))
(defun bibtex-count-entries (&optional count-string-entries)
@ -3227,6 +3394,7 @@ of the head of the entry found. Return nil if no entry found."
(list key nil entry-name))))))
(defun bibtex-init-sort-entry-class-alist ()
"Initialize `bibtex-sort-entry-class-alist' (buffer-local)."
(unless (local-variable-p 'bibtex-sort-entry-class-alist)
(set (make-local-variable 'bibtex-sort-entry-class-alist)
(let ((i -1) alist)
@ -3283,27 +3451,49 @@ are ignored."
nil ; ENDKEY function
'bibtex-lessp)) ; PREDICATE
(defun bibtex-find-crossref (crossref-key &optional pnt split)
(defun bibtex-find-crossref (crossref-key &optional pnt split noerror)
"Move point to the beginning of BibTeX entry CROSSREF-KEY.
If `bibtex-files' is non-nil, search all these files.
Otherwise the search is limited to the current buffer.
Return position of entry if CROSSREF-KEY is found or nil otherwise.
If CROSSREF-KEY is in the same buffer like current entry but before it
an error is signaled. Optional arg PNT is the position of the referencing
entry. It defaults to position of point. If optional arg SPLIT is non-nil,
split window so that both the referencing and the crossrefed entry are
displayed.
If called interactively, CROSSREF-KEY defaults to crossref key of current
entry and SPLIT is t."
an error is signaled. If NOERRER is non-nil this error is suppressed.
Optional arg PNT is the position of the referencing entry. It defaults
to position of point. If optional arg SPLIT is non-nil, split window
so that both the referencing and the crossrefed entry are displayed.
If called interactively, CROSSREF-KEY defaults to either the crossref key
of current entry or a key matched by `bibtex-cite-matcher-alist',
whatever is nearer to the position of point. SPLIT is t. NOERROR is nil
for a crossref key, t otherwise."
(interactive
(let ((crossref-key
(save-excursion
(bibtex-beginning-of-entry)
(let ((bounds (bibtex-search-forward-field "crossref" t)))
(if bounds
(bibtex-text-in-field-bounds bounds t))))))
(list (bibtex-read-key "Find crossref key: " crossref-key t)
(point) t)))
(save-excursion
(let* ((pnt (point))
(_ (bibtex-beginning-of-entry))
(end (cdr (bibtex-valid-entry t)))
(_ (unless end (error "Not inside valid entry")))
(beg (match-end 0)) ; set by `bibtex-valid-entry'
(bounds (bibtex-search-forward-field "crossref" end))
case-fold-search best temp crossref-key)
(if bounds
(setq crossref-key (bibtex-text-in-field-bounds bounds t)
best (cons (bibtex-dist pnt (bibtex-end-of-field bounds)
(bibtex-start-of-field bounds))
crossref-key)))
(dolist (matcher bibtex-cite-matcher-alist)
(goto-char beg)
(while (re-search-forward (car matcher) end t)
(setq temp (bibtex-dist pnt (match-end (cdr matcher))
(match-beginning (cdr matcher))))
;; Accept the key closest to the position of point.
(if (or (not best) (< temp (car best)))
(setq best (cons temp (match-string-no-properties
(cdr matcher)))))))
(goto-char pnt)
(setq temp (bibtex-read-key "Find crossref key: " (cdr best) t))
(list temp (point) t (not (and crossref-key
(string= temp crossref-key)))))))
(let (buffer pos eqb)
(save-excursion
(setq pos (bibtex-find-entry crossref-key t)
@ -3314,13 +3504,15 @@ entry and SPLIT is t."
(split ; called (quasi) interactively
(unless pnt (setq pnt (point)))
(goto-char pnt)
(if eqb (select-window (split-window))
(pop-to-buffer buffer))
(goto-char pos)
(bibtex-reposition-window)
(beginning-of-line)
(if (and eqb (> pnt pos))
(error "The referencing entry must precede the crossrefed entry!")))
(if (and eqb (= pos (save-excursion (bibtex-beginning-of-entry))))
(message "Key `%s' is current entry" crossref-key)
(if eqb (select-window (split-window))
(pop-to-buffer buffer))
(goto-char pos)
(bibtex-reposition-window)
(beginning-of-line)
(if (and eqb (> pnt pos) (not noerror))
(error "The referencing entry must precede the crossrefed entry!"))))
;; `bibtex-find-crossref' is called noninteractively during
;; clean-up of an entry. Then it is not possible to check
;; whether the current entry and the crossrefed entry have
@ -3329,6 +3521,12 @@ entry and SPLIT is t."
(t (set-buffer buffer) (goto-char pos)))
pos))
(defun bibtex-dist (pos beg end)
"Return distance between POS and region delimited by BEG and END."
(cond ((and (<= beg pos) (<= pos end)) 0)
((< pos beg) (- beg pos))
(t (- pos end))))
(defun bibtex-find-entry (key &optional global start display)
"Move point to the beginning of BibTeX entry named KEY.
Return position of entry if KEY is found or nil if not found.
@ -3394,7 +3592,7 @@ Return t if preparation was successful or nil if entry KEY already exists."
;; if key-exist is non-nil due to the previous cond clause
;; then point will be at beginning of entry named key.
(key-exist)
(t ; bibtex-maintain-sorted-entries is non-nil
(t ; `bibtex-maintain-sorted-entries' is non-nil
(let* ((case-fold-search t)
(left (save-excursion (bibtex-beginning-of-first-entry)))
(bounds (save-excursion (goto-char (point-max))
@ -3576,7 +3774,7 @@ Return t if test was successful, nil otherwise."
(delete-region (point-min) (point-max))
(insert "BibTeX mode command `bibtex-validate'\n"
(if syntax-error
"Maybe undetected errors due to syntax errors. Correct and validate again.\n"
"Maybe undetected errors due to syntax errors. Correct and validate again.\n"
"\n"))
(dolist (err error-list)
(insert (format "%s:%d: %s\n" file (car err) (cdr err))))
@ -3737,7 +3935,7 @@ Optional arg COMMA is as in `bibtex-enclosing-field'."
end-text (or (match-end bibtex-key-in-head)
(match-end 0))
end end-text
no-sub t) ;; subfields do not make sense
no-sub t) ; subfields do not make sense
(setq failure t)))
(t (setq failure t)))
(when (and subfield (not failure))
@ -3926,8 +4124,8 @@ begin on separate lines prior to calling `bibtex-clean-entry' or if
Don't call `bibtex-clean-entry' on @Preamble entries.
At end of the cleaning process, the functions in
`bibtex-clean-entry-hook' are called with region narrowed to entry."
;; Opt. arg called-by-reformat is t if bibtex-clean-entry
;; is called by bibtex-reformat
;; Opt. arg CALLED-BY-REFORMAT is t if `bibtex-clean-entry'
;; is called by `bibtex-reformat'
(interactive "P")
(let ((case-fold-search t)
(start (bibtex-beginning-of-entry))
@ -3946,7 +4144,7 @@ At end of the cleaning process, the functions in
;; set key
(when (or new-key (not key))
(setq key (bibtex-generate-autokey))
;; Sometimes bibtex-generate-autokey returns an empty string
;; Sometimes `bibtex-generate-autokey' returns an empty string
(if (or bibtex-autokey-edit-before-use (string= "" key))
(setq key (if (eq entry-type 'string)
(bibtex-read-string-key key)
@ -4027,7 +4225,7 @@ If optional arg MOVE is non-nil move point to end of field."
(if (not justify)
(goto-char (bibtex-start-of-text-in-field bounds))
(goto-char (bibtex-start-of-field bounds))
(forward-char) ;; leading comma
(forward-char) ; leading comma
(bibtex-delete-whitespace)
(open-line 1)
(forward-char)
@ -4045,7 +4243,7 @@ If optional arg MOVE is non-nil move point to end of field."
(if bibtex-align-at-equal-sign
(insert " ")
(indent-to-column bibtex-text-indentation)))
;; Paragraphs within fields are not preserved. Bother?
;; Paragraphs within fields are not preserved. Bother?
(fill-region-as-paragraph (line-beginning-position) end-field
default-justification nil (point))
(if move (goto-char end-field))))
@ -4130,15 +4328,19 @@ If mark is active reformat entries in region, if not in whole buffer."
(,(concat (if bibtex-comma-after-last-field "Insert" "Remove")
" comma at end of entry? ") . 'last-comma)
("Replace double page dashes by single ones? " . 'page-dashes)
("Delete whitespace at the beginning and end of fields? " . 'whitespace)
("Inherit booktitle? " . 'inherit-booktitle)
("Force delimiters? " . 'delimiters)
("Unify case of entry types and field names? " . 'unify-case))))))
("Unify case of entry types and field names? " . 'unify-case)
("Enclose parts of field entries by braces? " . 'braces)
("Replace parts of field entries by string constants? " . 'strings))))))
;; Do not include required-fields because `bibtex-reformat'
;; cannot handle the error messages of `bibtex-format-entry'.
;; Use `bibtex-validate' to check for required fields.
((eq t bibtex-entry-format)
'(realign opts-or-alts numerical-fields delimiters
last-comma page-dashes unify-case inherit-booktitle))
last-comma page-dashes unify-case inherit-booktitle
whitespace braces strings))
(t
(remove 'required-fields (push 'realign bibtex-entry-format)))))
(reformat-reference-keys
@ -4178,7 +4380,7 @@ entries from minibuffer."
(message "Starting to validate buffer...")
(sit-for 1 nil t)
(bibtex-realign)
(deactivate-mark) ; So bibtex-validate works on the whole buffer.
(deactivate-mark) ; So `bibtex-validate' works on the whole buffer.
(if (not (let (bibtex-maintain-sorted-entries)
(bibtex-validate)))
(message "Correct errors and call `bibtex-convert-alien' again")
@ -4186,7 +4388,7 @@ entries from minibuffer."
(sit-for 2 nil t)
(bibtex-reformat read-options)
(goto-char (point-max))
(message "Buffer is now parsable. Please save it.")))
(message "Buffer is now parsable. Please save it.")))
(defun bibtex-complete ()
"Complete word fragment before point according to context.
@ -4249,7 +4451,7 @@ An error is signaled if point is outside key or BibTeX field."
;;
;; If we quit the *Completions* buffer without requesting
;; a completion, `choose-completion-string-functions' is still
;; non-nil. Therefore, `choose-completion-string-functions' is
;; non-nil. Therefore, `choose-completion-string-functions' is
;; always set (either to non-nil or nil) when a new completion
;; is requested.
(let (completion-ignore-case)
@ -4276,7 +4478,7 @@ An error is signaled if point is outside key or BibTeX field."
(setq choose-completion-string-functions nil)
(choose-completion-string choice buffer base-size)
(bibtex-complete-string-cleanup choice ',compl)
t)) ; needed by choose-completion-string-functions
t)) ; needed by `choose-completion-string-functions'
(bibtex-complete-string-cleanup (bibtex-complete-internal compl)
compl)))
@ -4391,44 +4593,94 @@ An error is signaled if point is outside key or BibTeX field."
"Browse a URL for the BibTeX entry at point.
Optional POS is the location of the BibTeX entry.
The URL is generated using the schemes defined in `bibtex-generate-url-list'
\(see there\). Then the URL is passed to `browse-url' unless NO-BROWSE is nil.
\(see there\). If multiple schemes match for this entry, or the same scheme
matches more than once, use the one for which the first step's match is the
closest to POS. The URL is passed to `browse-url' unless NO-BROWSE is t.
Return the URL or nil if none can be generated."
(interactive)
(unless pos (setq pos (point)))
(save-excursion
(if pos (goto-char pos))
(goto-char pos)
(bibtex-beginning-of-entry)
;; Always remove field delimiters
(let ((fields-alist (bibtex-parse-entry t))
(let ((end (save-excursion (bibtex-end-of-entry)))
(fields-alist (save-excursion (bibtex-parse-entry t)))
;; Always ignore case,
(case-fold-search t)
(lst bibtex-generate-url-list)
field url scheme obj fmt)
(while (setq scheme (pop lst))
(when (and (setq field (cdr (assoc-string (caar scheme)
fields-alist t)))
(string-match (cdar scheme) field))
(setq lst nil
scheme (cdr scheme)
url (if (null scheme) (match-string 0 field)
(if (stringp (car scheme))
(setq fmt (pop scheme)))
(dolist (step scheme)
(setq field (cdr (assoc-string (car step) fields-alist t)))
(if (string-match (nth 1 step) field)
(push (cond ((functionp (nth 2 step))
(funcall (nth 2 step) field))
((numberp (nth 2 step))
(match-string (nth 2 step) field))
(t
(replace-match (nth 2 step) t nil field)))
obj)
;; If the scheme is set up correctly,
;; we should never reach this point
(error "Match failed: %s" field)))
(if fmt (apply 'format fmt (nreverse obj))
(apply 'concat (nreverse obj)))))
(if (interactive-p) (message "%s" url))
(unless no-browse (browse-url url))))
text url scheme obj fmt fl-match step)
;; The return value of `bibtex-parse-entry' (i.e., FIELDS-ALIST)
;; is always used to generate the URL. However, if the BibTeX
;; entry contains more than one URL, we have multiple matches
;; for the first step defining the generation of the URL.
;; Therefore, we try to initiate the generation of the URL
;; based on the match of `bibtex-font-lock-url' that is the
;; closest to POS. If that fails (no match found) we try to
;; initiate the generation of the URL based on the properly
;; concatenated CONTENT of the field as returned by
;; `bibtex-text-in-field-bounds'. The latter approach can
;; differ from the former because `bibtex-font-lock-url' uses
;; the buffer itself.
(while (bibtex-font-lock-url end t)
(push (list (bibtex-dist pos (match-beginning 0) (match-end 0))
(match-beginning 0)
(buffer-substring-no-properties
(match-beginning 0) (match-end 0)))
fl-match)
;; `bibtex-font-lock-url' moves point to end of match.
(forward-char))
(when fl-match
(setq fl-match (car (sort fl-match (lambda (x y) (< (car x) (car y))))))
(goto-char (nth 1 fl-match))
(bibtex-beginning-of-field) (re-search-backward ",")
(let* ((bounds (bibtex-parse-field))
(name (bibtex-name-in-field bounds))
(content (bibtex-text-in-field-bounds bounds t))
(lst bibtex-generate-url-list))
;; This match can fail when CONTENT differs from text in buffer.
(when (string-match (regexp-quote (nth 2 fl-match)) content)
;; TEXT is the part of CONTENT that starts with the match
;; of `bibtex-font-lock-url' we are looking for.
(setq text (substring content (match-beginning 0)))
(while (and (not url) (setq scheme (pop lst)))
;; Verify the match of `bibtex-font-lock-url' by
;; comparing with TEXT.
(when (and (bibtex-string= (caar scheme) name)
(string-match (cdar scheme) text))
(setq url t scheme (cdr scheme)))))))
;; If the match of `bibtex-font-lock-url' was not approved
;; parse FIELDS-ALIST, i.e., the output of `bibtex-parse-entry'.
(unless url
(let ((lst bibtex-generate-url-list))
(while (and (not url) (setq scheme (pop lst)))
(when (and (setq text (cdr (assoc-string (caar scheme)
fields-alist t)))
(string-match (cdar scheme) text))
(setq url t scheme (cdr scheme))))))
(when url
(setq url (if (null scheme) (match-string 0 text)
(if (stringp (car scheme))
(setq fmt (pop scheme)))
(dotimes (i (length scheme))
(setq step (nth i scheme))
;; The first step shall use TEXT as obtained earlier.
(unless (= i 0)
(setq text (cdr (assoc-string (car step) fields-alist t))))
(if (string-match (nth 1 step) text)
(push (cond ((functionp (nth 2 step))
(funcall (nth 2 step) text))
((numberp (nth 2 step))
(match-string (nth 2 step) text))
(t
(replace-match (nth 2 step) t nil text)))
obj)
;; If SCHEME is set up correctly,
;; we should never reach this point
(error "Match failed: %s" text)))
(if fmt (apply 'format fmt (nreverse obj))
(apply 'concat (nreverse obj)))))
(if (interactive-p) (message "%s" url))
(unless no-browse (browse-url url)))
(if (and (not url) (interactive-p)) (message "No URL known."))
url)))

6
lisp/textmodes/nroff-mode.el
View File

@ -66,6 +66,8 @@
;; ' used otherwise).
(modify-syntax-entry ?\" "\" 2" st)
;; Comments are delimited by \" and newline.
;; And in groff also \# to newline.
(modify-syntax-entry ?# ". 2" st)
(modify-syntax-entry ?\\ "\\ 1" st)
(modify-syntax-entry ?\n ">" st)
st)
@ -92,7 +94,7 @@
(mapconcat 'identity
'("[f*n]*\\[.+?]" ; some groff extensions
"(.." ; two chars after (
"[^(\"]" ; single char escape
"[^(\"#]" ; single char escape
) "\\|")
"\\)")
)
@ -127,7 +129,7 @@ closing requests for requests that are used in matched pairs."
(concat "[.']\\|" paragraph-separate))
;; comment syntax added by mit-erl!gildea 18 Apr 86
(set (make-local-variable 'comment-start) "\\\" ")
(set (make-local-variable 'comment-start-skip) "\\\\\"[ \t]*")
(set (make-local-variable 'comment-start-skip) "\\\\[\"#][ \t]*")
(set (make-local-variable 'comment-column) 24)
(set (make-local-variable 'comment-indent-function) 'nroff-comment-indent)
(set (make-local-variable 'imenu-generic-expression) nroff-imenu-expression))

2017
lisp/textmodes/org.el
View File

File diff suppressed because it is too large Load Diff

144
lisp/textmodes/sgml-mode.el
View File

@ -279,8 +279,8 @@ Any terminating `>' or `/' is not matched.")
. (cons (concat "<"
(regexp-opt (mapcar 'car sgml-tag-face-alist) t)
"\\([ \t][^>]*\\)?>\\([^<]+\\)</\\1>")
'(3 (cdr (assoc (downcase (match-string 1))
sgml-tag-face-alist)) prepend))))))
'(3 (cdr (assoc-string (match-string 1) sgml-tag-face-alist t))
prepend))))))
;; for font-lock, but must be defvar'ed after
;; sgml-font-lock-keywords-1 and sgml-font-lock-keywords-2 above
@ -366,20 +366,19 @@ a DOCTYPE or an XML declaration."
"List of tags whose !ELEMENT definition says the end-tag is optional.")
(defun sgml-xml-guess ()
"Guess whether the current buffer is XML."
"Guess whether the current buffer is XML. Return non-nil if so."
(save-excursion
(goto-char (point-min))
(when (or (string= "xml" (file-name-extension (or buffer-file-name "")))
(looking-at "\\s-*<\\?xml")
(when (re-search-forward
(eval-when-compile
(or (string= "xml" (file-name-extension (or buffer-file-name "")))
(looking-at "\\s-*<\\?xml")
(when (re-search-forward
(eval-when-compile
(mapconcat 'identity
'("<!DOCTYPE" "\\(\\w+\\)" "\\(\\w+\\)"
"\"\\([^\"]+\\)\"" "\"\\([^\"]+\\)\"")
"\\s-+"))
nil t)
(string-match "X\\(HT\\)?ML" (match-string 3))))
(set (make-local-variable 'sgml-xml-mode) t))))
"\"\\([^\"]+\\)\"" "\"\\([^\"]+\\)\"")
"\\s-+"))
nil t)
(string-match "X\\(HT\\)?ML" (match-string 3))))))
(defvar v2) ; free for skeleton
@ -407,7 +406,7 @@ a DOCTYPE or an XML declaration."
(eq (char-before) ?<))))
;;;###autoload
(define-derived-mode sgml-mode text-mode "SGML"
(define-derived-mode sgml-mode text-mode '(sgml-xml-mode "XML" "SGML")
"Major mode for editing SGML documents.
Makes > match <.
Keys <, &, SPC within <>, \", / and ' can be electric depending on
@ -459,9 +458,9 @@ Do \\[describe-key] on the following bindings to discover what they do.
. sgml-font-lock-syntactic-keywords)))
(set (make-local-variable 'facemenu-add-face-function)
'sgml-mode-facemenu-add-face-function)
(sgml-xml-guess)
(set (make-local-variable 'sgml-xml-mode) (sgml-xml-guess))
(if sgml-xml-mode
(setq mode-name "XML")
()
(set (make-local-variable 'skeleton-transformation-function)
sgml-transformation-function))
;; This will allow existing comments within declarations to be
@ -734,22 +733,93 @@ With prefix argument, only self insert."
(defun sgml-skip-tag-backward (arg)
"Skip to beginning of tag or matching opening tag if present.
With prefix argument ARG, repeat this ARG times."
With prefix argument ARG, repeat this ARG times.
Return non-nil if we skipped over matched tags."
(interactive "p")
;; FIXME: use sgml-get-context or something similar.
(while (>= arg 1)
(search-backward "<" nil t)
(if (looking-at "</\\([^ \n\t>]+\\)")
;; end tag, skip any nested pairs
(let ((case-fold-search t)
(re (concat "</?" (regexp-quote (match-string 1))
;; Ignore empty tags like <foo/>.
"\\([^>]*[^/>]\\)?>")))
(while (and (re-search-backward re nil t)
(eq (char-after (1+ (point))) ?/))
(forward-char 1)
(sgml-skip-tag-backward 1))))
(setq arg (1- arg))))
(let ((return t))
(while (>= arg 1)
(search-backward "<" nil t)
(if (looking-at "</\\([^ \n\t>]+\\)")
;; end tag, skip any nested pairs
(let ((case-fold-search t)
(re (concat "</?" (regexp-quote (match-string 1))
;; Ignore empty tags like <foo/>.
"\\([^>]*[^/>]\\)?>")))
(while (and (re-search-backward re nil t)
(eq (char-after (1+ (point))) ?/))
(forward-char 1)
(sgml-skip-tag-backward 1)))
(setq return nil))
(setq arg (1- arg)))
return))
(defvar sgml-electric-tag-pair-overlays nil)
(defvar sgml-electric-tag-pair-timer nil)
(defun sgml-electric-tag-pair-before-change-function (beg end)
(condition-case err
(save-excursion
(goto-char end)
(skip-chars-backward "[:alnum:]-_.:")
(if (and ;; (<= (point) beg) ; This poses problems for downcase-word.
(or (eq (char-before) ?<)
(and (eq (char-before) ?/)
(eq (char-before (1- (point))) ?<)))
(null (get-char-property (point) 'text-clones)))
(let* ((endp (eq (char-before) ?/))
(cl-start (point))
(cl-end (progn (skip-chars-forward "[:alnum:]-_.:") (point)))
(match
(if endp
(when (sgml-skip-tag-backward 1) (forward-char 1) t)
(with-syntax-table sgml-tag-syntax-table
(up-list -1)
(when (sgml-skip-tag-forward 1)
(backward-sexp 1)
(forward-char 2)
t))))
(clones (get-char-property (point) 'text-clones)))
(when (and match
(/= cl-end cl-start)
(equal (buffer-substring cl-start cl-end)
(buffer-substring (point)
(save-excursion
(skip-chars-forward "[:alnum:]-_.:")
(point))))
(or (not endp) (eq (char-after cl-end) ?>)))
(when clones
(message "sgml-electric-tag-pair-before-change-function: deleting old OLs")
(mapc 'delete-overlay clones))
(message "sgml-electric-tag-pair-before-change-function: new clone")
(text-clone-create cl-start cl-end 'spread "[[:alnum:]-_.:]+")
(setq sgml-electric-tag-pair-overlays
(append (get-char-property (point) 'text-clones)
sgml-electric-tag-pair-overlays))))))
(scan-error nil)
(error (message "Error in sgml-electric-pair-mode: %s" err))))
(defun sgml-electric-tag-pair-flush-overlays ()
(while sgml-electric-tag-pair-overlays
(delete-overlay (pop sgml-electric-tag-pair-overlays))))
(define-minor-mode sgml-electric-tag-pair-mode
"Automatically update the closing tag when editing the opening one."
:lighter "/e"
(if sgml-electric-tag-pair-mode
(progn
(add-hook 'before-change-functions
'sgml-electric-tag-pair-before-change-function
nil t)
(unless sgml-electric-tag-pair-timer
(setq sgml-electric-tag-pair-timer
(run-with-idle-timer 5 'repeat 'sgml-electric-tag-pair-flush-overlays))))
(remove-hook 'before-change-functions
'sgml-electric-tag-pair-before-change-function
t)
;; We leave the timer running for other buffers.
))
(defun sgml-skip-tag-forward (arg)
"Skip to end of tag or matching closing tag if present.
@ -1218,7 +1288,7 @@ not the case, the first tag returned is the one inside which we are."
((eq (sgml-tag-type tag-info) 'open)
(cond
((null stack)
(if (member-ignore-case (sgml-tag-name tag-info) ignore)
(if (assoc-string (sgml-tag-name tag-info) ignore t)
;; There was an implicit end-tag.
nil
(push tag-info context)
@ -1303,12 +1373,13 @@ the current start-tag or the current comment or the current cdata, ..."
(defun sgml-empty-tag-p (tag-name)
"Return non-nil if TAG-NAME is an implicitly empty tag."
(and (not sgml-xml-mode)
(member-ignore-case tag-name sgml-empty-tags)))
(assoc-string tag-name sgml-empty-tags 'ignore-case)))
(defun sgml-unclosed-tag-p (tag-name)
"Return non-nil if TAG-NAME is a tag for which an end-tag is optional."
(and (not sgml-xml-mode)
(member-ignore-case tag-name sgml-unclosed-tags)))
(assoc-string tag-name sgml-unclosed-tags 'ignore-case)))
(defun sgml-calculate-indent (&optional lcon)
"Calculate the column to which this line should be indented.
@ -1374,8 +1445,8 @@ LCON is the lexical context, if any."
(let* ((here (point))
(unclosed (and ;; (not sgml-xml-mode)
(looking-at sgml-tag-name-re)
(member-ignore-case (match-string 1)
sgml-unclosed-tags)
(assoc-string (match-string 1)
sgml-unclosed-tags 'ignore-case)
(match-string 1)))
(context
;; If possible, align on the previous non-empty text line.
@ -1813,11 +1884,11 @@ This takes effect when first loading the library.")
("ul" . "Unordered list")
("var" . "Math variable face")
("wbr" . "Enable <br> within <nobr>"))
"*Value of `sgml-tag-help' for HTML mode.")
"*Value of `sgml-tag-help' for HTML mode.")
;;;###autoload
(define-derived-mode html-mode sgml-mode "HTML"
(define-derived-mode html-mode sgml-mode '(sgml-xml-mode "XHTML" "HTML")
"Major mode based on SGML mode for editing HTML documents.
This allows inserting skeleton constructs used in hypertext documents with
completion. See below for an introduction to HTML. Use
@ -1871,7 +1942,6 @@ To work around that, do:
outline-level (lambda ()
(char-before (match-end 0))))
(setq imenu-create-index-function 'html-imenu-index)
(when sgml-xml-mode (setq mode-name "XHTML"))
(set (make-local-variable 'sgml-empty-tags)
;; From HTML-4.01's loose.dtd, parsed with `sgml-parse-dtd',
;; plus manual addition of "wbr".

248
lisp/textmodes/texinfmt.el
View File

@ -57,8 +57,6 @@ If optional argument HERE is non-nil, insert info at point."
(require 'texinfo) ; So `texinfo-footnote-style' is defined.
(require 'texnfo-upd) ; So `texinfo-section-types-regexp' is defined.
(defvar texinfo-format-syntax-table nil)
(defvar texinfo-vindex)
(defvar texinfo-findex)
(defvar texinfo-cindex)
@ -81,27 +79,80 @@ If optional argument HERE is non-nil, insert info at point."
(defvar texinfo-short-index-format-cmds-alist)
(defvar texinfo-format-filename)
(defvar texinfo-footnote-number)
(defvar texinfo-start-of-header)
(defvar texinfo-end-of-header)
(defvar texinfo-raisesections-alist)
(defvar texinfo-lowersections-alist)
(defvar texinfo-raisesections-alist
'((@chapter . @chapter) ; Cannot go higher
(@unnumbered . @unnumbered)
(@centerchap . @unnumbered)
(@majorheading . @majorheading)
(@chapheading . @chapheading)
(@appendix . @appendix)
(@section . @chapter)
(@unnumberedsec . @unnumbered)
(@heading . @chapheading)
(@appendixsec . @appendix)
(@subsection . @section)
(@unnumberedsubsec . @unnumberedsec)
(@subheading . @heading)
(@appendixsubsec . @appendixsec)
(@subsubsection . @subsection)
(@unnumberedsubsubsec . @unnumberedsubsec)
(@subsubheading . @subheading)
(@appendixsubsubsec . @appendixsubsec))
"*An alist of next higher levels for chapters, sections, etc...
For example, section to chapter, subsection to section.
Used by `texinfo-raise-lower-sections'.
The keys specify types of section; the values correspond to the next
higher types.")
(defvar texinfo-lowersections-alist
'((@chapter . @section)
(@unnumbered . @unnumberedsec)
(@centerchap . @unnumberedsec)
(@majorheading . @heading)
(@chapheading . @heading)
(@appendix . @appendixsec)
(@section . @subsection)
(@unnumberedsec . @unnumberedsubsec)
(@heading . @subheading)
(@appendixsec . @appendixsubsec)
(@subsection . @subsubsection)
(@unnumberedsubsec . @unnumberedsubsubsec)
(@subheading . @subsubheading)
(@appendixsubsec . @appendixsubsubsec)
(@subsubsection . @subsubsection) ; Cannot go lower.
(@unnumberedsubsubsec . @unnumberedsubsubsec)
(@subsubheading . @subsubheading)
(@appendixsubsubsec . @appendixsubsubsec))
"*An alist of next lower levels for chapters, sections, etc...
For example, chapter to section, section to subsection.
Used by `texinfo-raise-lower-sections'.
The keys specify types of section; the values correspond to the next
lower types.")
;;; Syntax table
(if texinfo-format-syntax-table
nil
(setq texinfo-format-syntax-table (make-syntax-table))
(modify-syntax-entry ?\" " " texinfo-format-syntax-table)
(modify-syntax-entry ?\\ " " texinfo-format-syntax-table)
(modify-syntax-entry ?@ "\\" texinfo-format-syntax-table)
(modify-syntax-entry ?\^q "\\" texinfo-format-syntax-table)
(modify-syntax-entry ?\[ "." texinfo-format-syntax-table)
(modify-syntax-entry ?\] "." texinfo-format-syntax-table)
(modify-syntax-entry ?\( "." texinfo-format-syntax-table)
(modify-syntax-entry ?\) "." texinfo-format-syntax-table)
(modify-syntax-entry ?{ "(}" texinfo-format-syntax-table)
(modify-syntax-entry ?} "){" texinfo-format-syntax-table)
(modify-syntax-entry ?\' "." texinfo-format-syntax-table))
(defvar texinfo-format-syntax-table
(let ((st (make-syntax-table)))
(modify-syntax-entry ?\" " " st)
(modify-syntax-entry ?\\ " " st)
(modify-syntax-entry ?@ "\\" st)
(modify-syntax-entry ?\^q "\\" st)
(modify-syntax-entry ?\[ "." st)
(modify-syntax-entry ?\] "." st)
(modify-syntax-entry ?\( "." st)
(modify-syntax-entry ?\) "." st)
(modify-syntax-entry ?{ "(}" st)
(modify-syntax-entry ?} "){" st)
(modify-syntax-entry ?\' "." st)
st))
;;; Top level buffer and region formatting functions
@ -113,8 +164,8 @@ The Info file output is generated in a buffer visiting the Info file
name specified in the @setfilename command.
Non-nil argument (prefix, if interactive) means don't make tag table
and don't split the file if large. You can use Info-tagify and
Info-split to do these manually."
and don't split the file if large. You can use `Info-tagify' and
`Info-split' to do these manually."
(interactive "P")
(let ((lastmessage "Formatting Info file...")
(coding-system-for-write buffer-file-coding-system))
@ -329,7 +380,7 @@ is automatically removed when the Info file is created. The original
Texinfo source buffer is not changed.
Non-nil argument (prefix, if interactive) means don't split the file
if large. You can use Info-split to do this manually."
if large. You can use `Info-split' to do this manually."
(interactive "P")
(let ((temp-buffer (concat "*--" (buffer-name) "--temporary-buffer*" )))
(message "First updating nodes and menus, then creating Info file.")
@ -764,64 +815,6 @@ commands."
(setq count (1+ count)))
(kill-word 1)
(insert (symbol-name new-level))))))))))
(defvar texinfo-raisesections-alist
'((@chapter . @chapter) ; Cannot go higher
(@unnumbered . @unnumbered)
(@centerchap . @unnumbered)
(@majorheading . @majorheading)
(@chapheading . @chapheading)
(@appendix . @appendix)
(@section . @chapter)
(@unnumberedsec . @unnumbered)
(@heading . @chapheading)
(@appendixsec . @appendix)
(@subsection . @section)
(@unnumberedsubsec . @unnumberedsec)
(@subheading . @heading)
(@appendixsubsec . @appendixsec)
(@subsubsection . @subsection)
(@unnumberedsubsubsec . @unnumberedsubsec)
(@subsubheading . @subheading)
(@appendixsubsubsec . @appendixsubsec))
"*An alist of next higher levels for chapters, sections. etc.
For example, section to chapter, subsection to section.
Used by `texinfo-raise-lower-sections'.
The keys specify types of section; the values correspond to the next
higher types.")
(defvar texinfo-lowersections-alist
'((@chapter . @section)
(@unnumbered . @unnumberedsec)
(@centerchap . @unnumberedsec)
(@majorheading . @heading)
(@chapheading . @heading)
(@appendix . @appendixsec)
(@section . @subsection)
(@unnumberedsec . @unnumberedsubsec)
(@heading . @subheading)
(@appendixsec . @appendixsubsec)
(@subsection . @subsubsection)
(@unnumberedsubsec . @unnumberedsubsubsec)
(@subheading . @subsubheading)
(@appendixsubsec . @appendixsubsubsec)
(@subsubsection . @subsubsection) ; Cannot go lower.
(@unnumberedsubsubsec . @unnumberedsubsubsec)
(@subsubheading . @subsubheading)
(@appendixsubsubsec . @appendixsubsubsec))
"*An alist of next lower levels for chapters, sections. etc.
For example, chapter to section, section to subsection.
Used by `texinfo-raise-lower-sections'.
The keys specify types of section; the values correspond to the next
lower types.")
;;; Perform those texinfo-to-info conversions that apply to the whole input
;;; uniformly.
@ -1077,8 +1070,8 @@ Leave point after argument."
(forward-char -1)
(skip-chars-backward " ")
(setq end (point))
(setq args (cons (if (> end beg) (buffer-substring-no-properties beg end))
args))
(push (if (> end beg) (buffer-substring-no-properties beg end))
args)
(goto-char next)
(skip-chars-forward " "))
(if (eolp) (forward-char 1))
@ -1110,8 +1103,8 @@ Leave point after argument."
(goto-char beg)
(while (search-forward "\n" end t)
(replace-match " "))))
(setq args (cons (if (> end beg) (buffer-substring-no-properties beg end))
args))
(push (if (> end beg) (buffer-substring-no-properties beg end))
args)
(goto-char next))
;;(if (eolp) (forward-char 1))
(setq texinfo-command-end (point))
@ -1140,7 +1133,7 @@ Leave point after argument."
(re-search-forward "[\n ]")
(forward-char -1)
(setq end (point))))
(setq args (cons (buffer-substring-no-properties beg end) args))
(push (buffer-substring-no-properties beg end) args)
(skip-chars-forward " "))
(forward-char 1)
(nreverse args))))
@ -1184,7 +1177,7 @@ Leave point after argument."
(let ((tem (if texinfo-fold-nodename-case (downcase name) name)))
(if (assoc tem texinfo-node-names)
(error "Duplicate node name: %s" name)
(setq texinfo-node-names (cons (list tem) texinfo-node-names))))
(push (list tem) texinfo-node-names)))
(setq texinfo-footnote-number 0)
;; insert "\n\^_" unconditionally since this is what info is looking for
(insert "\n\^_\nFile: " texinfo-format-filename
@ -1494,8 +1487,6 @@ If used within a line, follow `@br' with braces."
Argument is either end or separate."
(setq texinfo-footnote-style (texinfo-parse-arg-discard)))
(defvar texinfo-footnote-number)
(put 'footnote 'texinfo-format 'texinfo-format-footnote)
(defun texinfo-format-footnote ()
"Format a footnote in either end of node or separate node style.
@ -1601,9 +1592,8 @@ Used by @refill indenting command to avoid indenting within lists, etc.")
(defun texinfo-push-stack (check arg)
(setq texinfo-stack-depth (1+ texinfo-stack-depth))
(setq texinfo-stack
(cons (list check arg texinfo-command-start)
texinfo-stack)))
(push (list check arg texinfo-command-start)
texinfo-stack))
(defun texinfo-pop-stack (check)
(setq texinfo-stack-depth (1- texinfo-stack-depth))
@ -1974,7 +1964,7 @@ Or else:
@end multitable
where the fractions specify the width of each column as a percent
of the current width of the text (i.e., of the fill-column).
of the current width of the text (i.e., of the `fill-column').
Long lines of text are filled within columns.
@ -2028,12 +2018,10 @@ commands that are defined in texinfo.tex for printed output.
((looking-at "@columnfractions")
(forward-word 1)
(while (not (eolp))
(setq texinfo-multitable-width-list
(cons
(truncate
(1-
(* fill-column (read (get-buffer (current-buffer))))))
texinfo-multitable-width-list))))
(push (truncate
(1-
(* fill-column (read (get-buffer (current-buffer))))))
texinfo-multitable-width-list)))
;;
;; Case 2: {Column 1 template} {Column 2} {Column 3 example}
((looking-at "{")
@ -2044,9 +2032,8 @@ commands that are defined in texinfo.tex for printed output.
(end-of-template
;; forward-sexp works with braces in Texinfo mode
(progn (forward-sexp 1) (1- (point)))))
(setq texinfo-multitable-width-list
(cons (- end-of-template start-of-template)
texinfo-multitable-width-list))
(push (- end-of-template start-of-template)
texinfo-multitable-width-list)
;; Remove carriage return from within a template, if any.
;; This helps those those who want to use more than
;; one line's worth of words in @multitable line.
@ -2417,13 +2404,11 @@ Use only the FILENAME arg; for Info, ignore the other arguments to @image."
(beginning-delimiter (or (nth 1 args) ""))
(end-delimiter (or (nth 2 args) "")))
(texinfo-discard-command)
(setq texinfo-enclosure-list
(cons
(list command-name
(list
beginning-delimiter
end-delimiter))
texinfo-enclosure-list))))
(push (list command-name
(list
beginning-delimiter
end-delimiter))
texinfo-enclosure-list)))
;;; @alias
@ -2436,12 +2421,10 @@ Use only the FILENAME arg; for Info, ignore the other arguments to @image."
(save-excursion (end-of-line) (setq texinfo-command-end (point)))
(if (not (looking-at "\\([^=]+\\)=\\(.*\\)"))
(error "Invalid alias command")
(setq texinfo-alias-list
(cons
(cons
(match-string-no-properties 1)
(match-string-no-properties 2))
texinfo-alias-list))
(push (cons
(match-string-no-properties 1)
(match-string-no-properties 2))
texinfo-alias-list)
(texinfo-discard-command))
)
)
@ -2570,8 +2553,7 @@ If used within a line, follow `@bullet' with braces."
"lisp\\|"
"smalllisp"
"\\)")
"Regexp specifying environments in which @kbd does not put `...'
around argument.")
"Regexp matching environments in which @kbd does not put `...' around arg.")
(defvar texinfo-format-kbd-end-regexp
(concat
@ -2584,7 +2566,7 @@ If used within a line, follow `@bullet' with braces."
"smalllisp"
"\\)")
"Regexp specifying end of environments in which @kbd does not put `...'
around argument. (See `texinfo-format-kbd-regexp')")
around argument. (See `texinfo-format-kbd-regexp')")
(put 'kbd 'texinfo-format 'texinfo-format-kbd)
(defun texinfo-format-kbd ()
@ -2793,8 +2775,8 @@ If used within a line, follow `@minus' with braces."
;;; Refilling and indenting: @refill, @paragraphindent, @noindent
;;; Indent only those paragraphs that are refilled as a result of an
;;; @refill command.
;; Indent only those paragraphs that are refilled as a result of an
;; @refill command.
;; * If the value is `asis', do not change the existing indentation at
;; the starts of paragraphs.
@ -2804,8 +2786,8 @@ If used within a line, follow `@minus' with braces."
;; * If the value is greater than zero, indent each paragraph by that
;; number of spaces.
;;; But do not refill paragraphs with an @refill command that are
;;; preceded by @noindent or are part of a table, list, or deffn.
;; But do not refill paragraphs with an @refill command that are
;; preceded by @noindent or are part of a table, list, or deffn.
(defvar texinfo-paragraph-indent "asis"
"Number of spaces for @refill to indent a paragraph; else to leave as is.")
@ -2822,7 +2804,7 @@ Default is to leave the number of spaces as is."
(put 'refill 'texinfo-format 'texinfo-format-refill)
(defun texinfo-format-refill ()
"Refill paragraph. Also, indent first line as set by @paragraphindent.
"Refill paragraph. Also, indent first line as set by @paragraphindent.
Default is to leave paragraph indentation as is."
(texinfo-discard-command)
(let ((position (point-marker)))
@ -2941,11 +2923,9 @@ Default is to leave paragraph indentation as is."
;; eg: "aa" . texinfo-aaindex
(or (assoc index-name texinfo-indexvar-alist)
(setq texinfo-indexvar-alist
(cons
(cons index-name
index-alist-name)
texinfo-indexvar-alist)))
(push (cons index-name
index-alist-name)
texinfo-indexvar-alist))
(fset index-formatting-command
(list 'lambda 'nil
@ -4024,7 +4004,7 @@ The command `@value{foo}' expands to the value."
(put 'ifset 'texinfo-end 'texinfo-discard-command)
(put 'ifset 'texinfo-format 'texinfo-if-set)
(defun texinfo-if-set ()
"If set, continue formatting; else do not format region up to @end ifset"
"If set, continue formatting; else do not format region up to @end ifset."
(let ((arg (texinfo-parse-arg-discard)))
(cond
((eq (get (car (read-from-string arg)) 'texinfo-whether-setp)
@ -4045,7 +4025,7 @@ The command `@value{foo}' expands to the value."
(put 'ifclear 'texinfo-end 'texinfo-discard-command)
(put 'ifclear 'texinfo-format 'texinfo-if-clear)
(defun texinfo-if-clear ()
"If clear, continue formatting; if set, do not format up to @end ifset"
"If clear, continue formatting; if set, do not format up to @end ifset."
(let ((arg (texinfo-parse-arg-discard)))
(cond
((eq (get (car (read-from-string arg)) 'texinfo-whether-setp)
@ -4291,7 +4271,7 @@ the @ifeq command."
;;; Batch formatting
(defun batch-texinfo-format ()
"Runs texinfo-format-buffer on the files remaining on the command line.
"Run `texinfo-format-buffer' on the files remaining on the command line.
Must be used only with -batch, and kills Emacs on completion.
Each file will be processed even if an error occurred previously.
For example, invoke
@ -4317,8 +4297,8 @@ For example, invoke
(nconc (directory-files file)
(cdr command-line-args-left))))
(t
(setq files (cons file files)
command-line-args-left (cdr command-line-args-left)))))
(push file files)
(setq command-line-args-left (cdr command-line-args-left)))))
(while files
(setq file (car files)
files (cdr files))
@ -4354,5 +4334,5 @@ For example, invoke
;;; Place `provide' at end of file.
(provide 'texinfmt)
;;; arch-tag: 1e8d9a2d-bca0-40a0-ac6c-dab01bc6f725
;; arch-tag: 1e8d9a2d-bca0-40a0-ac6c-dab01bc6f725
;;; texinfmt.el ends here

136
lisp/vc-arch.el
View File

@ -83,7 +83,10 @@
(comment-normalize-vars)
(goto-char (point-max))
(forward-comment -1)
(unless (bolp) (insert "\n"))
(skip-chars-forward " \t\n")
(cond
((not (bolp)) (insert "\n\n"))
((not (eq ?\n (char-before (1- (point))))) (insert "\n")))
(let ((beg (point))
(idfile (and buffer-file-name
(expand-file-name
@ -419,6 +422,137 @@ Return non-nil if FILE is unchanged."
(defun vc-arch-init-version () nil)
;;; Completion of versions and revisions.
(defun vc-arch-complete (table string pred action)
(assert (not (functionp table)))
(cond
((null action) (try-completion string table pred))
((eq action t) (all-completions string table pred))
(t (test-completion string table pred))))
(defun vc-arch--version-completion-table (root string)
(delq nil
(mapcar
(lambda (d)
(when (string-match "/\\([^/]+\\)/\\([^/]+\\)\\'" d)
(concat (match-string 2 d) "/" (match-string 1 d))))
(let ((default-directory root))
(file-expand-wildcards
(concat "*/*/"
(if (string-match "/" string)
(concat (substring string (match-end 0))
"*/" (substring string 0 (match-beginning 0)))
(concat "*/" string))
"*"))))))
(defun vc-arch-revision-completion-table (file)
(lexical-let ((file file))
(lambda (string pred action)
;; FIXME: complete revision patches as well.
(let ((root (expand-file-name "{arch}" (vc-arch-root file))))
(vc-arch-complete
(vc-arch--version-completion-table root string)
string pred action)))))
;;; Trimming revision libraries.
;; This code is not directly related to VC and there are many variants of
;; this functionality available as scripts, but I like this version better,
;; so maybe others will like it too.
(defun vc-arch-trim-find-least-useful-rev (revs)
(let* ((first (pop revs))
(second (pop revs))
(third (pop revs))
;; We try to give more importance to recent revisions. The idea is
;; that it's OK if checking out a revision 1000-patch-old is ten
;; times slower than checking out a revision 100-patch-old. But at
;; the same time a 2-patch-old rev isn't really ten times more
;; important than a 20-patch-old, so we use an arbitrary constant
;; "100" to reduce this effect for recent revisions. Making this
;; constant a float has the side effect of causing the subsequent
;; computations to be done as floats as well.
(max (+ 100.0 (car (or (car (last revs)) third))))
(cost (lambda () (/ (- (car third) (car first)) (- max (car second)))))
(minrev second)
(mincost (funcall cost)))
(while revs
(setq first second)
(setq second third)
(setq third (pop revs))
(when (< (funcall cost) mincost)
(setq minrev second)
(setq mincost (funcall cost))))
minrev))
(defun vc-arch-trim-make-sentinel (revs)
(if (null revs) (lambda (proc msg) (message "VC-Arch trimming ... done"))
`(lambda (proc msg)
(message "VC-Arch trimming %s..." ',(file-name-nondirectory (car revs)))
(rename-file ,(car revs) ,(concat (car revs) "*rm*"))
(setq proc (start-process "vc-arch-trim" nil
"rm" "-rf" ',(concat (car revs) "*rm*")))
(set-process-sentinel proc (vc-arch-trim-make-sentinel ',(cdr revs))))))
(defun vc-arch-trim-one-revlib (dir)
"Delete half of the revisions in the revision library."
(interactive "Ddirectory: ")
(let ((revs
(sort (delq nil
(mapcar
(lambda (f)
(when (string-match "-\\([0-9]+\\)\\'" f)
(cons (string-to-number (match-string 1 f)) f)))
(directory-files dir nil nil 'nosort)))
'car-less-than-car))
(subdirs nil))
(when (cddr revs)
(dotimes (i (/ (length revs) 2))
(let ((minrev (vc-arch-trim-find-least-useful-rev revs)))
(setq revs (delq minrev revs))
(push minrev subdirs)))
(funcall (vc-arch-trim-make-sentinel
(mapcar (lambda (x) (expand-file-name (cdr x) dir)) subdirs))
nil nil))))
(defun vc-arch-trim-revlib ()
"Delete half of the revisions in the revision library."
(interactive)
(let ((rl-dir (with-output-to-string
(call-process vc-arch-command nil standard-output nil
"my-revision-library"))))
(while (string-match "\\(.*\\)\n" rl-dir)
(let ((dir (match-string 1 rl-dir)))
(setq rl-dir
(if (and (file-directory-p dir) (file-writable-p dir))
dir
(substring rl-dir (match-end 0))))))
(unless (file-writable-p rl-dir)
(error "No writable revlib directory found"))
(message "Revlib at %s" rl-dir)
(let* ((archives (directory-files rl-dir 'full "[^.]\\|..."))
(categories
(apply 'append
(mapcar (lambda (dir)
(when (file-directory-p dir)
(directory-files dir 'full "[^.]\\|...")))
archives)))
(branches
(apply 'append
(mapcar (lambda (dir)
(when (file-directory-p dir)
(directory-files dir 'full "[^.]\\|...")))
categories)))
(versions
(apply 'append
(mapcar (lambda (dir)
(when (file-directory-p dir)
(directory-files dir 'full "--.*--")))
branches))))
(mapc 'vc-arch-trim-one-revlib versions))
))
;;; Less obvious implementations.
(defun vc-arch-find-version (file rev buffer)

352
lisp/vc-bzr.el
View File

@ -10,7 +10,7 @@
;; Author: Dave Love <fx@gnu.org>, Riccardo Murri <riccardo.murri@gmail.com>
;; Keywords: tools
;; Created: Sept 2006
;; Version: 2007-01-17
;; Version: 2007-05-24
;; URL: http://launchpad.net/vc-bzr
;; This file is free software; you can redistribute it and/or modify
@ -36,38 +36,53 @@
;; See <URL:http://bazaar-vcs.org/> concerning bzr.
;; Load this library to register bzr support in VC. The support is
;; preliminary and incomplete, adapted from my darcs version. Lightly
;; exercised with bzr 0.8 and Emacs 21, and bzr 0.11 on Emacs 22. See
;; various Fixmes below.
;; Load this library to register bzr support in VC. It covers basic VC
;; functionality, but was only lightly exercised with a few Emacs/bzr
;; version combinations, namely those current on the authors' PCs.
;; See various Fixmes below.
;; This should be suitable for direct inclusion in Emacs if someone
;; can persuade rms.
;; Known bugs
;; ==========
;; When edititing a symlink and *both* the symlink and its target
;; are bzr-versioned, `vc-bzr` presently runs `bzr status` on the
;; symlink, thereby not detecting whether the actual contents
;; (that is, the target contents) are changed.
;; See https://bugs.launchpad.net/vc-bzr/+bug/116607
;; For an up-to-date list of bugs, please see:
;; https://bugs.launchpad.net/vc-bzr/+bugs
;;; Code:
(eval-when-compile
(require 'cl)
(require 'vc)) ; for vc-exec-after
;; Clear up the cache to force vc-call to check again and discover
;; new functions when we reload this file.
(put 'BZR 'vc-functions nil)
(defgroup vc-bzr nil
"VC bzr backend."
;; :version "22"
:group 'vc)
(defcustom vc-bzr-program "bzr"
"*Name of the bzr command (excluding any arguments)."
"Name of the bzr command (excluding any arguments)."
:group 'vc-bzr
:type 'string)
;; Fixme: there's probably no call for this.
(defcustom vc-bzr-program-args nil
"*List of global arguments to pass to `vc-bzr-program'."
"List of global arguments to pass to `vc-bzr-program'."
:group 'vc-bzr
:type '(repeat string))
(defcustom vc-bzr-diff-switches nil
"*String/list of strings specifying extra switches for bzr diff under VC."
"String/list of strings specifying extra switches for bzr diff under VC."
:type '(choice (const :tag "None" nil)
(string :tag "Argument String")
(repeat :tag "Argument List" :value ("") string))
@ -81,76 +96,42 @@
"Return a three-numeric element list with components of the bzr version.
This is of the form (X Y Z) for revision X.Y.Z. The elements are zero
if running `vc-bzr-program' doesn't produce the expected output."
(if vc-bzr-version
vc-bzr-version
(let ((s (shell-command-to-string
(concat (shell-quote-argument vc-bzr-program) " --version"))))
(if (string-match "\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)$" s)
(setq vc-bzr-version (list (string-to-number (match-string 1 s))
(string-to-number (match-string 2 s))
(string-to-number (match-string 3 s))))
'(0 0 0)))))
(or vc-bzr-version
(setq vc-bzr-version
(let ((s (shell-command-to-string
(concat (shell-quote-argument vc-bzr-program)
" --version"))))
(if (string-match "\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)$" s)
(list (string-to-number (match-string 1 s))
(string-to-number (match-string 2 s))
(string-to-number (match-string 3 s)))
'(0 0 0))))))
(defun vc-bzr-at-least-version (vers)
"Return t if the bzr command reports being a least version VERS.
First argument VERS is a list of the form (X Y Z), as returned by `vc-bzr-version'."
(version-list-<= vers (vc-bzr-version)))
;; XXX: vc-do-command is tailored for RCS and assumes that command-line
;; options precede the file name (ci -something file); with bzr, we need
; to pass options *after* the subcommand, e.g. bzr ls --versioned.
(defun vc-bzr-do-command* (buffer okstatus command &rest args)
"Execute bzr COMMAND, notifying user and checking for errors.
This is a wrapper around `vc-do-command', which see for detailed
explanation of arguments BUFFER, OKSTATUS and COMMAND.
If the optional list of ARGS is present, its elements are
appended to the command line, in the order given.
Unlike `vc-do-command', this has no way of telling which elements
in ARGS are file names and which are command-line options, so be
sure to pass absolute file names if needed. On the other hand,
you can mix options and file names in any order."
(apply 'vc-do-command buffer okstatus command nil args))
(cond
((vc-bzr-at-least-version '(0 9))
;; since v0.9, bzr supports removing the progress indicators
;; by setting environment variable BZR_PROGRESS_BAR to "none".
(defun vc-bzr-command (bzr-command buffer okstatus file &rest args)
"Wrapper round `vc-do-command' using `vc-bzr-program' as COMMAND.
;; since v0.9, bzr supports removing the progress indicators
;; by setting environment variable BZR_PROGRESS_BAR to "none".
(defun vc-bzr-command (bzr-command buffer okstatus file &rest args)
"Wrapper round `vc-do-command' using `vc-bzr-program' as COMMAND.
Invoke the bzr command adding `BZR_PROGRESS_BAR=none' to the environment."
(let ((process-environment (cons "BZR_PROGRESS_BAR=none" process-environment)))
(apply 'vc-do-command buffer okstatus vc-bzr-program
file bzr-command (append vc-bzr-program-args args))))
(defun vc-bzr-command* (bzr-command buffer okstatus file &rest args)
"Wrapper round `vc-bzr-do-command*' using `vc-bzr-program' as COMMAND.
Invoke the bzr command adding `BZR_PROGRESS_BAR=none' to the environment.
First argument BZR-COMMAND is passed as the first optional argument to
`vc-bzr-do-command*'."
(let ((process-environment (cons "BZR_PROGRESS_BAR=none" process-environment)))
(apply 'vc-bzr-do-command* buffer okstatus vc-bzr-program
bzr-command (append vc-bzr-program-args args)))))
(t
;; for older versions, we fall back to washing the log buffer
;; when all output has been gathered.
(defun vc-bzr-command (command buffer okstatus file &rest args)
"Wrapper round `vc-do-command' using `vc-bzr-program' as COMMAND."
;; Note: The ^Ms from the progress-indicator stuff that bzr prints
;; on stderr cause auto-detection of a mac coding system on the
;; stream for async output. bzr ought to be fixed to be able to
;; suppress this. See also `vc-bzr-post-command-function'. (We
;; can't sink the stderr output in `vc-do-command'.)
(let ((process-environment
(list* "BZR_PROGRESS_BAR=none" ; Suppress progress output (bzr >=0.9)
"LC_ALL=C" ; Force English output
process-environment))
;; bzr may attempt some kind of user interaction if its stdin/stdout
;; is connected to a PTY; therefore, ask Emacs to use a pipe to
;; communicate with it.
;; This is redundant because vc-do-command does it already. --Stef
(process-connection-type nil))
(apply 'vc-do-command buffer okstatus vc-bzr-program
file command (append vc-bzr-program-args args)))
(defun vc-bzr-command* (command buffer okstatus &rest args)
"Wrapper round `vc-bzr-do-command*' using `vc-bzr-program' as COMMAND."
(apply 'vc-bzr-do-command* buffer okstatus vc-bzr-program
command file (append vc-bzr-program-args args)))
file bzr-command (append vc-bzr-program-args args))))
(unless (vc-bzr-at-least-version '(0 9))
;; For older versions, we fall back to washing the log buffer
;; when all output has been gathered.
(defun vc-bzr-post-command-function (command file flags)
"`vc-post-command-functions' function to remove progress messages."
;; Note that using this requires that the vc command is run
@ -169,73 +150,78 @@ First argument BZR-COMMAND is passed as the first optional argument to
(while (looking-at "read knit.*\n")
(replace-match "")))))
(add-hook 'vc-post-command-functions 'vc-bzr-post-command-function)))
(add-hook 'vc-post-command-functions 'vc-bzr-post-command-function))
;; Fixme: If we're only interested in status messages, we only need
;; to set LC_MESSAGES, and we might need finer control of this. This
;; is moot anyhow, since bzr doesn't appear to be localized at all
;; (yet?).
(eval-when-compile
(defmacro vc-bzr-with-c-locale (&rest body)
"Run BODY with LC_ALL=C in the process environment.
This ensures that messages to be matched come out as expected."
`(let ((process-environment (cons "LC_ALL=C" process-environment)))
,@body)))
(put 'vc-bzr-with-c-locale 'edebug-form-spec t)
(put 'vc-bzr-with-c-locale 'lisp-indent-function 0)
;;;###autoload
(defconst vc-bzr-admin-dirname ".bzr") ; FIXME: "_bzr" on w32?
(defun vc-bzr-bzr-dir (file)
"Return the .bzr directory in the hierarchy above FILE.
;;;###autoload (defun vc-bzr-registered (file)
;;;###autoload (if (vc-find-root file vc-bzr-admin-dirname)
;;;###autoload (progn
;;;###autoload (load "vc-bzr")
;;;###autoload (vc-bzr-registered file))))
(defun vc-bzr-root-dir (file)
"Return the root directory in the hierarchy above FILE.
Return nil if there isn't one."
(setq file (expand-file-name file))
(let ((dir (if (file-directory-p file)
file
(file-name-directory file)))
bzr)
(catch 'found
(while t
(setq bzr (expand-file-name ".bzr" dir)) ; fixme: "_bzr" on Doze??
(if (file-directory-p bzr)
(throw 'found (file-name-as-directory bzr)))
(if (equal "" (file-name-nondirectory (directory-file-name dir)))
(throw 'found nil)
(setq dir (file-name-directory (directory-file-name dir))))))))
(vc-find-root file vc-bzr-admin-dirname))
(defun vc-bzr-registered (file)
"Return non-nil if FILE is registered with bzr."
(if (vc-bzr-bzr-dir file) ; short cut
(vc-bzr-state file))) ; expensive
(if (vc-bzr-root-dir file) ; Short cut.
(vc-bzr-state file))) ; Expensive.
(defun vc-bzr-buffer-nonblank-p (&optional buffer)
"Return non-nil if BUFFER contains any non-blank characters."
(or (> (buffer-size buffer) 0)
(save-excursion
(set-buffer (or buffer (current-buffer)))
(goto-char (point-min))
(re-search-forward "[^ \t\n]" (point-max) t))))
(defconst vc-bzr-state-words
"added\\|ignored\\|modified\\|removed\\|renamed\\|unknown"
"Regexp matching file status words as reported in `bzr' output.")
;; FIXME: Also get this in a non-registered sub-directory.
(defun vc-bzr-state (file)
(let (ret state conflicts pending-merges)
(with-temp-buffer
(cd (file-name-directory file))
(setq ret (vc-bzr-with-c-locale (vc-bzr-command "status" t 255 file)))
(goto-char 1)
(save-excursion
(when (re-search-forward "^conflicts:" nil t)
(message "Warning -- conflicts in bzr branch")))
(save-excursion
(when (re-search-forward "^pending merges:" nil t)
(message "Warning -- pending merges in bzr branch")))
(setq state
(cond ((not (equal ret 0)) nil)
((looking-at "added\\|renamed\\|modified\\|removed") 'edited)
;; Fixme: Also get this in a non-registered sub-directory.
((looking-at "^$") 'up-to-date)
;; if we're seeing this as first line of text,
;; then the status is up-to-date,
;; but bzr output only gives the warning to users.
((looking-at "conflicts\\|pending") 'up-to-date)
((looking-at "unknown\\|ignored") nil)
(t (error "Unrecognized output from `bzr status'"))))
(when (or conflicts pending-merges)
(message
(concat "Warning -- "
(if conflicts "conflicts ")
(if (and conflicts pending-merges) "and ")
(if pending-merges "pending merges ")
"in bzr branch")))
(with-temp-buffer
(cd (file-name-directory file))
(let ((ret (vc-bzr-command "status" t 255 file))
(state 'up-to-date))
;; the only secure status indication in `bzr status' output
;; is a couple of lines following the pattern::
;; | <status>:
;; | <file name>
;; if the file is up-to-date, we get no status report from `bzr',
;; so if the regexp search for the above pattern fails, we consider
;; the file to be up-to-date.
(goto-char (point-min))
(when
(re-search-forward
(concat "^\\(" vc-bzr-state-words "\\):[ \t\n]+"
(file-name-nondirectory file) "[ \t\n]*$")
(point-max) t)
(let ((start (match-beginning 0))
(end (match-end 0)))
(goto-char start)
(setq state
(cond
((not (equal ret 0)) nil)
((looking-at "added\\|renamed\\|modified\\|removed") 'edited)
((looking-at "unknown\\|ignored") nil)))
;; erase the status text that matched
(delete-region start end)))
(when (vc-bzr-buffer-nonblank-p)
;; "bzr" will output some warnings and informational messages
;; to the user to stderr; due to Emacs' `vc-do-command' (and,
;; it seems, `start-process' itself), we cannot catch stderr
;; and stdout into different buffers. So, if there's anything
;; left in the buffer after removing the above status
;; keywords, let us just presume that any other message from
;; "bzr" is a user warning, and display it.
(message "Warnings in `bzr' output: %s"
(buffer-substring (point-min) (point-max))))
(when state
(vc-file-setprop file 'vc-workfile-version
(vc-bzr-workfile-version file))
@ -246,10 +232,12 @@ Return nil if there isn't one."
(eq 'up-to-date (vc-bzr-state file)))
(defun vc-bzr-workfile-version (file)
;; Looks like this could be obtained via counting lines in
;; .bzr/branch/revision-history.
(with-temp-buffer
(vc-bzr-command "revno" t 0 file)
(goto-char 1)
(buffer-substring 1 (line-end-position))))
(goto-char (point-min))
(buffer-substring (point) (line-end-position))))
(defun vc-bzr-checkout-model (file)
'implicit)
@ -263,11 +251,10 @@ COMMENT is ignored."
;; Could run `bzr status' in the directory and see if it succeeds, but
;; that's relatively expensive.
(defun vc-bzr-responsible-p (file)
(defalias 'vc-bzr-responsible-p 'vc-bzr-root-dir
"Return non-nil if FILE is (potentially) controlled by bzr.
The criterion is that there is a `.bzr' directory in the same
or a superior directory."
(vc-bzr-bzr-dir file))
or a superior directory.")
(defun vc-bzr-could-register (file)
"Return non-nil if FILE could be registered under bzr."
@ -277,7 +264,7 @@ or a superior directory."
(vc-bzr-command "add" t 0 file "--dry-run")
;; The command succeeds with no output if file is
;; registered (in bzr 0.8).
(goto-char 1)
(goto-char (point-min))
(looking-at "added "))
(error))))
@ -307,43 +294,39 @@ EDITABLE is ignored."
(unless contents-done
(with-temp-buffer (vc-bzr-command "revert" t 'async file))))
(eval-when-compile
(defvar log-view-message-re)
(defvar log-view-file-re)
(defvar log-view-font-lock-keywords)
(defvar log-view-current-tag-function))
(defvar log-view-message-re)
(defvar log-view-file-re)
(defvar log-view-font-lock-keywords)
(defvar log-view-current-tag-function)
;; Grim hack to account for lack of an extension mechanism for
;; log-view. Should be fixed in VC...
(defun vc-bzr-view-log-function ()
"To be added to `log-view-mode-hook' to set variables for bzr output.
Removes itself after running."
(remove-hook 'log-view-mode-hook 'vc-bzr-view-log-function)
(define-derived-mode vc-bzr-log-view-mode log-view-mode "Bzr-Log-View"
(remove-hook 'log-view-mode-hook 'vc-bzr-log-view-mode) ;Deactivate the hack.
(require 'add-log)
;; Don't have file markers, so use impossible regexp.
(set (make-local-variable 'log-view-file-re) "\\'\\`")
(set (make-local-variable 'log-view-message-re) "^ *-+\n *\\(revno: [0-9]+\\|merged: .+\\)")
(set (make-local-variable 'log-view-message-re)
"^ *-+\n *\\(?:revno: \\([0-9]+\\)\\|merged: .+\\)")
(set (make-local-variable 'log-view-font-lock-keywords)
`(("^ *committer: \
\\([^<(]+?\\)[ ]*[(<]\\([A-Za-z0-9_.-]+@[A-Za-z0-9_.-]+\\)[>)]"
nil nil
(1 'change-log-name-face nil t)
(2 'change-log-email-face nil t)
(3 'change-log-email-face nil t))
("^ *timestamp: \\(.*\\)" (1 'change-log-date-face))
(,log-view-message-re . 'log-view-message-face)
;; ("^ \\(.*\\)$" (1 'log-view-message-face))
)))
;; log-view-font-lock-keywords is careful to use the buffer-local
;; value of log-view-message-re only since Emacs-23.
(append `((,log-view-message-re . 'log-view-message-face))
;; log-view-font-lock-keywords
'(("^ *committer: \
\\([^<(]+?\\)[ ]*[(<]\\([[:alnum:]_.+-]+@[[:alnum:]_.-]+\\)[>)]"
(1 'change-log-name)
(2 'change-log-email))
("^ *timestamp: \\(.*\\)" (1 'change-log-date-face))))))
(defun vc-bzr-print-log (file &optional buffer) ; get buffer arg in Emacs 22
"Get bzr change log for FILE into specified BUFFER."
;; Fixme: VC needs a hook to sort out the mode for the buffer, or at
;; least set the regexps right.
;; Fixme: This might need the locale fixing up if things like `revno'
;; got localized, but certainly it shouldn't use LC_ALL=C.
;; NB. Can't be async -- see `vc-bzr-post-command-function'.
(vc-bzr-command "log" buffer 0 file)
(add-hook 'log-view-mode-hook 'vc-bzr-view-log-function))
;; FIXME: Until Emacs-23, VC was missing a hook to sort out the mode for
;; the buffer, or at least set the regexps right.
(unless (fboundp 'vc-default-log-view-mode)
(add-hook 'log-view-mode-hook 'vc-bzr-log-view-mode)))
(defun vc-bzr-show-log-entry (version)
"Find entry for patch name VERSION in bzr change log buffer."
@ -476,21 +459,22 @@ Return nil if current line isn't annotated."
(defun vc-bzr-dir-state (dir &optional localp)
"Find the VC state of all files in DIR.
Optional argument LOCALP is always ignored."
(let (at-start bzr-root-directory current-bzr-state current-vc-state)
;; check that DIR is a bzr repository
(set 'bzr-root-directory (vc-bzr-root dir))
(unless (string-match "^/" bzr-root-directory)
(let ((bzr-root-directory (vc-bzr-root dir))
(at-start t)
current-bzr-state current-vc-state)
;; Check that DIR is a bzr repository.
(unless (file-name-absolute-p bzr-root-directory)
(error "Cannot find bzr repository for directory `%s'" dir))
;; `bzr ls --versioned' lists all versioned files;
;; assume they are up-to-date, unless we are given
;; evidence of the contrary.
(set 'at-start t)
(setq at-start t)
(with-temp-buffer
(vc-bzr-command* "ls" t 0 "--versioned" "--non-recursive")
(vc-bzr-command "ls" t 0 nil "--versioned" "--non-recursive")
(goto-char (point-min))
(while (or at-start
(while (or at-start
(eq 0 (forward-line)))
(set 'at-start nil)
(setq at-start nil)
(let ((file (expand-file-name
(buffer-substring-no-properties
(line-beginning-position) (line-end-position))
@ -500,26 +484,26 @@ Optional argument LOCALP is always ignored."
;; mixes different SCMs in the same dir?
(vc-file-setprop file 'vc-backend 'BZR))))
;; `bzr status' reports on added/modified/renamed and unknown/ignored files
(set 'at-start t)
(setq at-start t)
(with-temp-buffer
(vc-bzr-with-c-locale (vc-bzr-command "status" t 0 nil))
(vc-bzr-command "status" t 0 nil)
(goto-char (point-min))
(while (or at-start
(while (or at-start
(eq 0 (forward-line)))
(set 'at-start nil)
(setq at-start nil)
(cond
((looking-at "^added")
(set 'current-vc-state 'edited)
(set 'current-bzr-state 'added))
(setq current-vc-state 'edited)
(setq current-bzr-state 'added))
((looking-at "^modified")
(set 'current-vc-state 'edited)
(set 'current-bzr-state 'modified))
(setq current-vc-state 'edited)
(setq current-bzr-state 'modified))
((looking-at "^renamed")
(set 'current-vc-state 'edited)
(set 'current-bzr-state 'renamed))
(setq current-vc-state 'edited)
(setq current-bzr-state 'renamed))
((looking-at "^\\(unknown\\|ignored\\)")
(set 'current-vc-state nil)
(set 'current-bzr-state 'not-versioned))
(setq current-vc-state nil)
(setq current-bzr-state 'not-versioned))
((looking-at " ")
;; file names are indented by two spaces
(when current-vc-state
@ -540,8 +524,8 @@ Optional argument LOCALP is always ignored."
(vc-file-setprop file 'vc-state nil))))
(t
;; skip this part of `bzr status' output
(set 'current-vc-state nil)
(set 'current-bzr-state nil)))))))
(setq current-vc-state nil)
(setq current-bzr-state nil)))))))
(defun vc-bzr-dired-state-info (file)
"Bzr-specific version of `vc-dired-state-info'."

393
lisp/vc-hg.el Normal file
View File

@ -0,0 +1,393 @@
;;; vc-hg.el --- VC backend for the mercurial version control system
;; Copyright (C) 2006, 2007 Free Software Foundation, Inc.
;; Author: Ivan Kanis
;; Keywords: tools
;; Version: 1889
;; 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:
;; This is a mercurial version control backend
;;; Thanks:
;;; Bugs:
;;; Installation:
;;; Todo:
;; Implement the rest of the vc interface. See the comment at the
;; beginning of vc.el. The current status is:
;; FUNCTION NAME STATUS
;; * registered (file) OK
;; * state (file) OK
;; - state-heuristic (file) ?? PROBABLY NOT NEEDED
;; - dir-state (dir) NEEDED
;; * workfile-version (file) OK
;; - latest-on-branch-p (file) ??
;; * checkout-model (file) OK
;; - workfile-unchanged-p (file) ??
;; - mode-line-string (file) NOT NEEDED
;; - dired-state-info (file) NEEDED
;; STATE-CHANGING FUNCTIONS
;; * register (file &optional rev comment) OK
;; - init-version () NOT NEEDED
;; - responsible-p (file) OK
;; - could-register (file) OK
;; - receive-file (file rev) ?? PROBABLY NOT NEEDED
;; - unregister (file) COMMENTED OUT, MAY BE INCORRECT
;; * checkin (file rev comment) OK
;; * find-version (file rev buffer) OK
;; * checkout (file &optional editable rev) NOT NEEDED, COMMENTED OUT
;; * revert (file &optional contents-done) OK
;; - cancel-version (file editable) ?? PROBABLY NOT NEEDED
;; - merge (file rev1 rev2) NEEDED
;; - merge-news (file) NEEDED
;; - steal-lock (file &optional version) NOT NEEDED
;; HISTORY FUNCTIONS
;; * print-log (file &optional buffer) OK
;; - log-view-mode () OK
;; - show-log-entry (version) NOT NEEDED, DEFAULT IS GOOD
;; - wash-log (file) ??
;; - logentry-check () NOT NEEDED
;; - comment-history (file) NOT NEEDED
;; - update-changelog (files) NOT NEEDED
;; * diff (file &optional rev1 rev2 buffer) OK
;; - revision-completion-table (file) ??
;; - diff-tree (dir &optional rev1 rev2) TEST IT
;; - annotate-command (file buf &optional rev) OK
;; - annotate-time () OK
;; - annotate-current-time () ?? NOT NEEDED
;; - annotate-extract-revision-at-line () OK
;; SNAPSHOT SYSTEM
;; - create-snapshot (dir name branchp) NEEDED (probably branch?)
;; - assign-name (file name) NOT NEEDED
;; - retrieve-snapshot (dir name update) ?? NEEDED??
;; MISCELLANEOUS
;; - make-version-backups-p (file) ??
;; - repository-hostname (dirname) ??
;; - previous-version (file rev) OK
;; - next-version (file rev) OK
;; - check-headers () ??
;; - clear-headers () ??
;; - delete-file (file) TEST IT
;; - rename-file (old new) OK
;; - find-file-hook () PROBABLY NOT NEEDED
;; - find-file-not-found-hook () PROBABLY NOT NEEDED
;; Implement Stefan Monnier's advice:
;; vc-hg-registered and vc-hg-state
;; Both of those functions should be super extra careful to fail gracefully in
;; unexpected circumstances. The reason this is important is that any error
;; there will prevent the user from even looking at the file :-(
;; Ideally, just like in vc-arch and vc-cvs, checking that the file is under
;; mercurial's control and extracting the current revision should be done
;; without even using `hg' (this way even if you don't have `hg' installed,
;; Emacs is able to tell you this file is under mercurial's control).
;;; History:
;;
;;; Code:
(eval-when-compile
(require 'vc))
;;; Customization options
(defcustom vc-hg-global-switches nil
"*Global switches to pass to any Hg command."
:type '(choice (const :tag "None" nil)
(string :tag "Argument String")
(repeat :tag "Argument List"
:value ("")
string))
:version "22.2"
:group 'vc)
;;; State querying functions
;;;###autoload (defun vc-hg-registered (file)
;;;###autoload "Return non-nil if FILE is registered with hg."
;;;###autoload (if (vc-find-root file ".hg") ; short cut
;;;###autoload (progn
;;;###autoload (load "vc-hg")
;;;###autoload (vc-hg-registered file))))
;; Modelled after the similar function in vc-bzr.el
(defun vc-hg-registered (file)
"Return non-nil if FILE is registered with hg."
(if (vc-hg-root file) ; short cut
(vc-hg-state file))) ; expensive
(defun vc-hg-state (file)
"Hg-specific version of `vc-state'."
(let*
((status nil)
(out
(with-output-to-string
(with-current-buffer
standard-output
(setq status
(condition-case nil
;; Ignore all errors.
(call-process
"hg" nil t nil "--cwd" (file-name-directory file)
"status" (file-name-nondirectory file))
;; Some problem happened. E.g. We can't find an `hg'
;; executable.
(error nil)))))))
(when (eq 0 status)
(if (eq 0 (length out)) 'up-to-date
(let ((state (aref out 0)))
(cond
((eq state ?M) 'edited)
((eq state ?A) 'edited)
((eq state ?P) 'needs-patch)
((eq state ??) nil)
(t 'up-to-date)))))))
(defun vc-hg-workfile-version (file)
"Hg-specific version of `vc-workfile-version'."
(let*
((status nil)
(out
(with-output-to-string
(with-current-buffer
standard-output
(setq status
(condition-case nil
;; Ignore all errors.
(call-process
"hg" nil t nil "--cwd" (file-name-directory file)
"log" "-l1" (file-name-nondirectory file))
;; Some problem happened. E.g. We can't find an `hg'
;; executable.
(error nil)))))))
(when (eq 0 status)
(if (string-match "changeset: *\\([0-9]*\\)" out)
(match-string 1 out)
"0"))))
;;; History functions
(defun vc-hg-print-log(file &optional buffer)
"Get change log associated with FILE."
;; `log-view-mode' needs to have the file name in order to function
;; correctly. "hg log" does not print it, so we insert it here by
;; hand.
;; `vc-do-command' creates the buffer, but we need it before running
;; the command.
(vc-setup-buffer buffer)
;; If the buffer exists from a previous invocation it might be
;; read-only.
(let ((inhibit-read-only t))
(with-current-buffer
buffer
(insert "File: " (file-name-nondirectory file) "\n")))
(vc-hg-command
buffer
(if (and (vc-stay-local-p file) (fboundp 'start-process)) 'async 0)
file "log"))
(defvar log-view-message-re)
(defvar log-view-file-re)
(defvar log-view-font-lock-keywords)
(define-derived-mode vc-hg-log-view-mode log-view-mode "HG-Log-View"
(require 'add-log) ;; we need the faces add-log
;; Don't have file markers, so use impossible regexp.
(set (make-local-variable 'log-view-file-re) "^File:[ \t]+\\(.+\\)")
(set (make-local-variable 'log-view-message-re)
"^changeset:[ \t]*\\([0-9]+\\):\\(.+\\)")
(set (make-local-variable 'log-view-font-lock-keywords)
(append
log-view-font-lock-keywords
;; Handle the case:
;; user: foo@bar
'(("^user:[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
(1 'change-log-email))
;; Handle the case:
;; user: FirstName LastName <foo@bar>
("^user:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
(1 'change-log-name)
(2 'change-log-email))
("^date: \\(.+\\)" (1 'change-log-date))
("^summary:[ \t]+\\(.+\\)" (1 'log-view-message))))))
(defun vc-hg-diff (file &optional oldvers newvers buffer)
"Get a difference report using hg between two versions of FILE."
(let ((working (vc-workfile-version file)))
(if (and (equal oldvers working) (not newvers))
(setq oldvers nil))
(if (and (not oldvers) newvers)
(setq oldvers working))
(apply 'call-process "hg" nil (or buffer "*vc-diff*") nil
"--cwd" (file-name-directory file) "diff"
(append
(if oldvers
(if newvers
(list "-r" oldvers "-r" newvers)
(list "-r" oldvers))
(list ""))
(list (file-name-nondirectory file))))))
(defalias 'vc-hg-diff-tree 'vc-hg-diff)
(defun vc-hg-annotate-command (file buffer &optional version)
"Execute \"hg annotate\" on FILE, inserting the contents in BUFFER.
Optional arg VERSION is a version to annotate from."
(vc-hg-command buffer 0 file "annotate" "-d" "-n" (if version (concat "-r" version)))
(with-current-buffer buffer
(goto-char (point-min))
(re-search-forward "^[0-9]")
(delete-region (point-min) (1- (point)))))
;; The format for one line output by "hg annotate -d -n" looks like this:
;;215 Wed Jun 20 21:22:58 2007 -0700: CONTENTS
;; i.e: VERSION_NUMBER DATE: CONTENTS
(defconst vc-hg-annotate-re "^[ \t]*\\([0-9]+\\) \\(.\\{30\\}\\): ")
(defun vc-hg-annotate-time ()
(when (looking-at vc-hg-annotate-re)
(goto-char (match-end 0))
(vc-annotate-convert-time
(date-to-time (match-string-no-properties 2)))))
(defun vc-hg-annotate-extract-revision-at-line ()
(save-excursion
(beginning-of-line)
(if (looking-at vc-hg-annotate-re) (match-string-no-properties 1))))
(defun vc-hg-previous-version (file rev)
(let ((newrev (1- (string-to-number rev))))
(when (>= newrev 0)
(number-to-string newrev))))
(defun vc-hg-next-version (file rev)
(let ((newrev (1+ (string-to-number rev)))
(tip-version
(with-temp-buffer
(vc-hg-command t nil nil "tip")
(goto-char (point-min))
(re-search-forward "^changeset:[ \t]*\\([0-9]+\\):")
(string-to-number (match-string-no-properties 1)))))
;; We don't want to exceed the maximum possible version number, ie
;; the tip version.
(when (<= newrev tip-version)
(number-to-string newrev))))
;; Modelled after the similar function in vc-bzr.el
(defun vc-hg-delete-file (file)
"Delete FILE and delete it in the hg repository."
(condition-case ()
(delete-file file)
(file-error nil))
(vc-hg-command nil nil file "remove" "--after" "--force"))
;; Modelled after the similar function in vc-bzr.el
(defun vc-hg-rename-file (old new)
"Rename file from OLD to NEW using `hg mv'."
(vc-hg-command nil nil new old "mv"))
(defun vc-hg-register (file &optional rev comment)
"Register FILE under hg.
REV is ignored.
COMMENT is ignored."
(vc-hg-command nil nil file "add"))
(defalias 'vc-hg-responsible-p 'vc-hg-root)
;; Modelled after the similar function in vc-bzr.el
(defun vc-hg-could-register (file)
"Return non-nil if FILE could be registered under hg."
(and (vc-hg-responsible-p file) ; shortcut
(condition-case ()
(with-temp-buffer
(vc-hg-command t nil file "add" "--dry-run"))
;; The command succeeds with no output if file is
;; registered.
(error))))
;; XXX This would remove the file. Is that correct?
;; (defun vc-hg-unregister (file)
;; "Unregister FILE from hg."
;; (vc-hg-command nil nil file "remove"))
(defun vc-hg-checkin (file rev comment)
"HG-specific version of `vc-backend-checkin'.
REV is ignored."
(vc-hg-command nil nil file "commit" "-m" comment))
(defun vc-hg-find-version (file rev buffer)
(let ((coding-system-for-read 'binary)
(coding-system-for-write 'binary))
(if rev
(vc-hg-command buffer nil file "cat" "-r" rev)
(vc-hg-command buffer nil file "cat"))))
;; Modelled after the similar function in vc-bzr.el
;; This should not be needed, `vc-hg-find-version' provides the same
;; functionality.
;; (defun vc-hg-checkout (file &optional editable rev workfile)
;; "Retrieve a revision of FILE into a WORKFILE.
;; EDITABLE is ignored.
;; REV is the revision to check out into WORKFILE."
;; (unless workfile
;; (setq workfile (vc-version-backup-file-name file rev)))
;; (let ((coding-system-for-read 'binary)
;; (coding-system-for-write 'binary))
;; (with-temp-file workfile
;; (if rev
;; (vc-hg-command t nil file "cat" "-r" rev)
;; (vc-hg-command t nil file "cat")))))
(defun vc-hg-checkout-model (file)
'implicit)
;; Modelled after the similar function in vc-bzr.el
(defun vc-hg-revert (file &optional contents-done)
(unless contents-done
(with-temp-buffer (vc-hg-command t nil file "revert"))))
;;; Internal functions
(defun vc-hg-command (buffer okstatus file &rest flags)
"A wrapper around `vc-do-command' for use in vc-hg.el.
The difference to vc-do-command is that this function always invokes `hg',
and that it passes `vc-hg-global-switches' to it before FLAGS."
(apply 'vc-do-command buffer okstatus "hg" file
(if (stringp vc-hg-global-switches)
(cons vc-hg-global-switches flags)
(append vc-hg-global-switches
flags))))
(defun vc-hg-root (file)
(vc-find-root file ".hg"))
(provide 'vc-hg)
;; arch-tag: bd094dc5-715a-434f-a331-37b9fb7cd954
;;; vc-hg.el ends here

2
lisp/vc-hooks.el
View File

@ -62,7 +62,7 @@ interpreted as hostnames."
:type 'regexp
:group 'vc)
(defcustom vc-handled-backends '(RCS CVS SVN SCCS Arch MCVS)
(defcustom vc-handled-backends '(RCS CVS SVN SCCS HG Arch MCVS)
;; Arch and MCVS come last because they are per-tree rather than per-dir.
"*List of version control backends for which VC will be used.
Entries in this list will be tried in order to determine whether a

4
lisp/vc-svn.el
View File

@ -492,7 +492,9 @@ and that it passes `vc-svn-global-switches' to it before FLAGS."
;; Old `svn' used name="svn:this_dir", newer use just name="".
(concat "name=\"\\(?:svn:this_dir\\)?\"[\n\t ]*"
"\\(?:[-a-z]+=\"[^\"]*\"[\n\t ]*\\)*?"
"url=\"\\([^\"]+\\)\"") nil t)
"url=\"\\(?1:[^\"]+\\)\""
;; Yet newer ones don't use XML any more.
"\\|^\ndir\n[0-9]+\n\\(?1:.*\\)") nil t)
;; This is not a hostname but a URL. This may actually be considered
;; as a feature since it allows vc-svn-stay-local to specify different
;; behavior for different modules on the same server.

165
lisp/vc.el
View File

@ -105,7 +105,9 @@
;;
;; * registered (file)
;;
;; Return non-nil if FILE is registered in this backend.
;; Return non-nil if FILE is registered in this backend. Both this
;; function as well as `state' should be careful to fail gracefully in the
;; event that the backend executable is absent.
;;
;; * state (file)
;;
@ -222,7 +224,7 @@
;; The implementation should pass the value of vc-checkout-switches
;; to the backend command.
;;
;; * checkout (file &optional editable rev)
;; - checkout (file &optional editable rev)
;;
;; Check out revision REV of FILE into the working area. If EDITABLE
;; is non-nil, FILE should be writable by the user and if locking is
@ -270,6 +272,12 @@
;; Insert the revision log of FILE into BUFFER, or the *vc* buffer
;; if BUFFER is nil.
;;
;; - log-view-mode ()
;;
;; Mode to use for the output of print-log. This defaults to
;; `log-view-mode' and is expected to be changed (if at all) to a derived
;; mode of `log-view-mode'.
;;
;; - show-log-entry (version)
;;
;; If provided, search the log entry for VERSION in the current buffer,
@ -315,6 +323,11 @@
;; of either 0 (no differences found), or 1 (either non-empty diff
;; or the diff is run asynchronously).
;;
;; - revision-completion-table (file)
;;
;; Return a completion table for existing revisions of FILE.
;; The default is to not use any completion table.
;;
;; - diff-tree (dir &optional rev1 rev2)
;;
;; Insert the diff for all files at and below DIR into the *vc-diff*
@ -939,6 +952,8 @@ Else, add CODE to the process' sentinel."
;; lost. Terminated processes get deleted automatically
;; anyway. -- cyd
((or (null proc) (eq (process-status proc) 'exit))
;; Make sure we've read the process's output before going further.
(if proc (accept-process-output proc))
(eval code))
;; If a process is running, add CODE to the sentinel
((eq (process-status proc) 'run)
@ -946,12 +961,13 @@ Else, add CODE to the process' sentinel."
(set-process-sentinel proc
`(lambda (p s)
(with-current-buffer ',(current-buffer)
(goto-char (process-mark p))
,@(append (cdr (cdr (cdr ;strip off `with-current-buffer buf
; (goto-char...)'
(car (cdr (cdr ;strip off `lambda (p s)'
sentinel))))))
(list `(vc-exec-after ',code))))))))
(save-excursion
(goto-char (process-mark p))
,@(append (cdr (cdr (car ;Strip off (save-exc (goto-char...)
(cdr (cdr ;Strip off (with-current-buffer buf
(car (cdr (cdr ;Strip off (lambda (p s)
sentinel))))))))
(list `(vc-exec-after ',code)))))))))
(t (error "Unexpected process state"))))
nil)
@ -1740,6 +1756,8 @@ saving the buffer."
(message "No changes to %s since latest version" file)
(vc-version-diff file nil nil)))))
(defun vc-default-revision-completion-table (backend file) nil)
(defun vc-version-diff (file rev1 rev2)
"List the differences between FILE's versions REV1 and REV2.
If REV1 is empty or nil it means to use the current workfile version;
@ -1747,12 +1765,13 @@ REV2 empty or nil means the current file contents. FILE may also be
a directory, in that case, generate diffs between the correponding
versions of all registered files in or below it."
(interactive
(let ((file (expand-file-name
(read-file-name (if buffer-file-name
"File or dir to diff (default visited file): "
"File or dir to diff: ")
default-directory buffer-file-name t)))
(rev1-default nil) (rev2-default nil))
(let* ((file (expand-file-name
(read-file-name (if buffer-file-name
"File or dir to diff (default visited file): "
"File or dir to diff: ")
default-directory buffer-file-name t)))
(rev1-default nil) (rev2-default nil)
(completion-table (vc-call revision-completion-table file)))
;; compute default versions based on the file state
(cond
;; if it's a directory, don't supply any version default
@ -1764,21 +1783,25 @@ versions of all registered files in or below it."
;; if the file is not locked, use last and previous version as default
(t
(setq rev1-default (vc-call previous-version file
(vc-workfile-version file)))
(vc-workfile-version file)))
(if (string= rev1-default "") (setq rev1-default nil))
(setq rev2-default (vc-workfile-version file))))
;; construct argument list
(list file
(read-string (if rev1-default
(concat "Older version (default "
rev1-default "): ")
"Older version: ")
nil nil rev1-default)
(read-string (if rev2-default
(concat "Newer version (default "
rev2-default "): ")
"Newer version (default current source): ")
nil nil rev2-default))))
(let* ((rev1-prompt (if rev1-default
(concat "Older version (default "
rev1-default "): ")
"Older version: "))
(rev2-prompt (concat "Newer version (default "
(or rev2-default "current source") "): "))
(rev1 (if completion-table
(completing-read rev1-prompt completion-table
nil nil nil nil rev1-default)
(read-string rev1-prompt nil nil rev1-default)))
(rev2 (if completion-table
(completing-read rev2-prompt completion-table
nil nil nil nil rev2-default)
(read-string rev2-prompt nil nil rev2-default))))
(list file rev1 rev2))))
(if (file-directory-p file)
;; recursive directory diff
(progn
@ -1933,7 +1956,16 @@ The meaning of REV1 and REV2 is the same as for `vc-version-diff'."
"Visit version REV of the current file in another window.
If the current file is named `F', the version is named `F.~REV~'.
If `F.~REV~' already exists, use it instead of checking it out again."
(interactive "sVersion to visit (default is workfile version): ")
(interactive
(save-current-buffer
(vc-ensure-vc-buffer)
(let ((completion-table
(vc-call revision-completion-table buffer-file-name))
(prompt "Version to visit (default is workfile version): "))
(list
(if completion-table
(completing-read prompt completion-table)
(read-string prompt))))))
(vc-ensure-vc-buffer)
(let* ((file buffer-file-name)
(version (if (string-equal rev "")
@ -2453,7 +2485,7 @@ If FOCUS-REV is non-nil, leave the point at that revision."
(pop-to-buffer (current-buffer))
(vc-exec-after
`(let ((inhibit-read-only t))
(log-view-mode)
(vc-call-backend ',(vc-backend file) 'log-view-mode)
(goto-char (point-max)) (forward-line -1)
(while (looking-at "=*\n")
(delete-char (- (match-end 0) (match-beginning 0)))
@ -2468,6 +2500,7 @@ If FOCUS-REV is non-nil, leave the point at that revision."
',focus-rev)
(set-buffer-modified-p nil)))))
(defun vc-default-log-view-mode (backend) (log-view-mode))
(defun vc-default-show-log-entry (backend rev)
(with-no-warnings
(log-view-goto-rev rev)))
@ -3026,13 +3059,13 @@ cover the range from the oldest annotation to the newest."
;; Run through this file and find the oldest and newest dates annotated.
(save-excursion
(goto-char (point-min))
(while (setq date (prog1 (vc-call-backend vc-annotate-backend
'annotate-time)
(forward-line 1)))
(if (> date newest)
(setq newest date))
(if (< date oldest)
(setq oldest date))))
(while (not (eobp))
(when (setq date (vc-call-backend vc-annotate-backend 'annotate-time))
(if (> date newest)
(setq newest date))
(if (< date oldest)
(setq oldest date)))
(forward-line 1)))
(vc-annotate-display
(/ (- (if full newest current) oldest)
(vc-annotate-oldest-in-map vc-annotate-color-map))
@ -3097,9 +3130,9 @@ use; you may override this using the second optional arg MODE."
(vc-annotate-display-default (or vc-annotate-ratio 1.0)))
;; One of the auto-scaling modes
((eq vc-annotate-display-mode 'scale)
(vc-annotate-display-autoscale))
(vc-exec-after `(vc-annotate-display-autoscale)))
((eq vc-annotate-display-mode 'fullscale)
(vc-annotate-display-autoscale t))
(vc-exec-after `(vc-annotate-display-autoscale t)))
((numberp vc-annotate-display-mode) ; A fixed number of days lookback
(vc-annotate-display-default
(/ vc-annotate-display-mode
@ -3176,9 +3209,13 @@ colors. `vc-annotate-background' specifies the background color."
(set (make-local-variable 'vc-annotate-parent-rev) rev)
(set (make-local-variable 'vc-annotate-parent-display-mode)
display-mode)))
(when current-line
(goto-line current-line temp-buffer-name))
(message "Annotating... done")))
(vc-exec-after
`(progn
(when ,current-line
(goto-line ,current-line ,temp-buffer-name))
(unless (active-minibuffer-window)
(message "Annotating... done"))))))
(defun vc-annotate-prev-version (prefix)
"Visit the annotation of the version previous to this one.
@ -3353,30 +3390,30 @@ The annotations are relative to the current time, unless overridden by OFFSET."
(font-lock-mode 1))
(defun vc-annotate-lines (limit)
(let (difference)
(while (and (< (point) limit)
(setq difference (vc-annotate-difference vc-annotate-offset)))
(let* ((color (or (vc-annotate-compcar difference vc-annotate-color-map)
(cons nil vc-annotate-very-old-color)))
;; substring from index 1 to remove any leading `#' in the name
(face-name (concat "vc-annotate-face-"
(if (string-equal
(substring (cdr color) 0 1) "#")
(substring (cdr color) 1)
(cdr color))))
;; Make the face if not done.
(face (or (intern-soft face-name)
(let ((tmp-face (make-face (intern face-name))))
(set-face-foreground tmp-face (cdr color))
(if vc-annotate-background
(set-face-background tmp-face
vc-annotate-background))
tmp-face))) ; Return the face
(point (point)))
(forward-line 1)
(put-text-property point (point) 'face face)))
;; Pretend to font-lock there were no matches.
nil))
(while (< (point) limit)
(let ((difference (vc-annotate-difference vc-annotate-offset))
(start (point))
(end (progn (forward-line 1) (point))))
(when difference
(let* ((color (or (vc-annotate-compcar difference vc-annotate-color-map)
(cons nil vc-annotate-very-old-color)))
;; substring from index 1 to remove any leading `#' in the name
(face-name (concat "vc-annotate-face-"
(if (string-equal
(substring (cdr color) 0 1) "#")
(substring (cdr color) 1)
(cdr color))))
;; Make the face if not done.
(face (or (intern-soft face-name)
(let ((tmp-face (make-face (intern face-name))))
(set-face-foreground tmp-face (cdr color))
(if vc-annotate-background
(set-face-background tmp-face
vc-annotate-background))
tmp-face)))) ; Return the face
(put-text-property start end 'face face)))))
;; Pretend to font-lock there were no matches.
nil)
;; Collect back-end-dependent stuff here

7
lisp/wdired.el
View File

@ -106,7 +106,6 @@
(eval-when-compile (require 'cl))
(require 'dired)
(autoload 'dired-do-create-files-regexp "dired-aux")
(autoload 'dired-call-process "dired-aux")
(defgroup wdired nil
"Mode to rename files by editing their names in dired buffers."
@ -684,7 +683,7 @@ Like original function but it skips read-only words."
(new-bit "-")
(pos-prop (- (point) (- (current-column) wdired-col-perm))))
(if (eq (char-after (point)) ?-)
(setq new-bit
(setq new-bit
(if (= (% (- (current-column) wdired-col-perm) 3) 0) "r"
(if (= (% (- (current-column) wdired-col-perm) 3) 1) "w"
"x"))))
@ -744,8 +743,8 @@ Like original function but it skips read-only words."
(progn
(setq perm-tmp
(int-to-string (wdired-perms-to-number perms-new)))
(unless (equal 0 (dired-call-process dired-chmod-program
t perm-tmp filename))
(unless (equal 0 (process-file dired-chmod-program
nil nil nil perm-tmp filename))
(setq errors (1+ errors))
(dired-log (concat dired-chmod-program " " perm-tmp
" `" filename "' failed\n\n"))))

34
lispref/ChangeLog
View File

@ -1,3 +1,37 @@
2007-07-07 Michael Albinus <michael.albinus@gmx.de>
* process.texi (Asynchronous Processes):
* files.texi (Magic File Names): Add `start-file-process'.
2007-06-27 Richard Stallman <rms@gnu.org>
* files.texi (Format Conversion Piecemeal): Clarify
`after-insert-file-functions' calling convention.
2007-06-27 Michael Albinus <michael.albinus@gmx.de>
* files.texi (Magic File Names): Remove `dired-call-process'. Add
`process-file'.
2007-06-27 Kenichi Handa <handa@m17n.org>
* text.texi (Special Properties): Fix description about
`compostion' property.
2007-06-26 Kenichi Handa <handa@m17n.org>
* nonascii.texi (Default Coding Systems): Document about the
return value `undecided'.
2007-06-25 David Kastrup <dak@gnu.org>
* keymaps.texi (Active Keymaps): Document new POSITION argument of
`current-active-maps'.
2007-06-24 Karl Berry <karl@gnu.org>
* elisp.texi, vol1.texi, vol2.texi: new Back-Cover Text.
2007-06-15 Juanma Barranquero <lekktu@gmail.com>
* display.texi (Overlay Arrow): Doc fix.

12
lispref/elisp.texi
View File

@ -15,7 +15,7 @@
@end direntry
@c in general, keep the following line commented out, unless doing a
@c copy of this manual that will be published. the manual should go
@c copy of this manual that will be published. The manual should go
@c onto the distribution in the full, 8.5 x 11" size.
@c set smallbook
@ -29,13 +29,11 @@
@tex
@ifset smallbook
@fonttextsize 10
@set EMACSVER 22
@set EMACSVER 22.1
\global\let\urlcolor=\Black % don't print links in grayscale
\global\let\linkcolor=\Black
@end ifset
\global\hbadness=6666 % don't worry about not-too-underfull boxes
\global\let\urlcolor=\Black % don't print links in grayscale
\global\let\linkcolor=\Black
@end tex
@c Combine indices.
@ -63,9 +61,9 @@ Front-Cover texts being ``A GNU Manual,'' and with the Back-Cover
Texts as in (a) below. A copy of the license is included in the
section entitled ``GNU Free Documentation License.''
(a) The FSF's Back-Cover Text is: ``You have freedom to copy and modify
this GNU Manual, like GNU software. Copies published by the Free
Software Foundation raise funds for GNU development.''
(a) The FSF's Back-Cover Text is: ``You are free to copy and modify
this GNU Manual. Buying copies from GNU Press supports the FSF in
developing GNU and promoting software freedom.''
@end quotation
@end copying

12
lispref/files.texi
View File

@ -2587,7 +2587,6 @@ first, before handlers for jobs such as remote file access.
@code{directory-file-name},
@code{directory-files},
@code{directory-files-and-attributes},
@code{dired-call-process},
@code{dired-compress-file}, @code{dired-uncache},@*
@code{expand-file-name},
@code{file-accessible-directory-p},
@ -2614,8 +2613,10 @@ first, before handlers for jobs such as remote file access.
@code{make-directory},
@code{make-directory-internal},
@code{make-symbolic-link},@*
@code{process-file},
@code{rename-file}, @code{set-file-modes}, @code{set-file-times},
@code{set-visited-file-modtime}, @code{shell-command},
@code{start-file-process},
@code{substitute-in-file-name},@*
@code{unhandled-file-name-directory},
@code{vc-registered},
@ -2633,7 +2634,6 @@ first, before handlers for jobs such as remote file access.
@code{directory-file-name},
@code{directory-files},
@code{directory-files-and-at@discretionary{}{}{}tributes},
@code{dired-call-process},
@code{dired-compress-file}, @code{dired-uncache},
@code{expand-file-name},
@code{file-accessible-direc@discretionary{}{}{}tory-p},
@ -2658,8 +2658,10 @@ first, before handlers for jobs such as remote file access.
@code{load}, @code{make-direc@discretionary{}{}{}tory},
@code{make-direc@discretionary{}{}{}tory-internal},
@code{make-symbolic-link},
@code{process-file},
@code{rename-file}, @code{set-file-modes},
@code{set-visited-file-modtime}, @code{shell-command},
@code{start-file-process},
@code{substitute-in-file-name},
@code{unhandled-file-name-directory},
@code{vc-regis@discretionary{}{}{}tered},
@ -3071,8 +3073,10 @@ have been dealt with by this function.
@defvar after-insert-file-functions
Each function in this list is called by @code{insert-file-contents}
with one argument, the number of characters inserted, and should
return the new character count, leaving point the same.
with one argument, the number of characters inserted, and with point
at the beginning of the inserted text. Each function should leave
point unchanged, and return the new character count describing the
inserted text as modified by the function.
@c ??? The docstring mentions a handler from `file-name-handler-alist'
@c "intercepting" `insert-file-contents'. Hmmm. --ttn
@end defvar

9
lispref/keymaps.texi
View File

@ -655,12 +655,15 @@ events within @code{read-key-sequence}. @xref{Translation Keymaps}.
@xref{Standard Keymaps}, for a list of standard keymaps.
@defun current-active-maps &optional olp
@defun current-active-maps &optional olp position
This returns the list of active keymaps that would be used by the
command loop in the current circumstances to look up a key sequence.
Normally it ignores @code{overriding-local-map} and
@code{overriding-terminal-local-map}, but if @var{olp} is
non-@code{nil} then it pays attention to them.
@code{overriding-terminal-local-map}, but if @var{olp} is non-@code{nil}
then it pays attention to them. @var{position} can optionally be either
an event position as returned by @code{event-start} or a buffer
position, and may change the keymaps as described for
@code{key-binding}.
@end defun
@defun key-binding key &optional accept-defaults no-remap position

3
lispref/nonascii.texi
View File

@ -1031,6 +1031,9 @@ argument, a list of all arguments passed to
@code{find-operation-coding-system}. It must return a coding system
or a cons cell containing two coding systems. This value has the same
meaning as described above.
If @var{coding} (or what returned by the above function) is
@code{undecided}, the normal code-detection is performed.
@end defvar
@defvar process-coding-system-alist

19
lispref/processes.texi
View File

@ -495,6 +495,23 @@ Process my-process finished
@end smallexample
@end defun
@defun start-file-process name buffer-or-name program &rest args
Like @code{start-process}, this function starts a new asynchronous
subprocess running @var{program} in it. The corresponding process
object is returned.
If @code{default-directory} corresponds to a file handler, that
handler is invoked. @var{program} runs then on a remote host which is
identified by @code{default-directory}. The local part of
@code{default-directory} is the working directory of the subprocess.
@var{program} and @var{program-args} might be file names. They are not
objects of file handler invocation.
Some file handlers may not support @code{start-file-process} (for
example @code{ange-ftp-hook-function}). It returns then @code{nil}.
@end defun
@defun start-process-shell-command name buffer-or-name command &rest command-args
This function is like @code{start-process} except that it uses a shell
to execute the specified command. The argument @var{command} is a shell
@ -1309,7 +1326,7 @@ latter specifies one measured in milliseconds. The two time periods
thus specified are added together, and @code{accept-process-output}
returns after that much time, whether or not there has been any
subprocess output.
The argument @var{millisec} is semi-obsolete nowadays because
@var{seconds} can be a floating point number to specify waiting a
fractional number of seconds. If @var{seconds} is 0, the function

21
lispref/text.texi
View File

@ -3256,25 +3256,10 @@ Manual}) provides an example.
@item composition
@kindex composition @r{(text property)}
This text property is used to display a sequence of characters as a
single glyph composed from components. For instance, in Thai a base
consonant is composed with the following combining vowel as a single
glyph. The value should be a character or a sequence (vector, list,
or string) of integers.
single glyph composed from components. But the value of the property
itself is completely internal to Emacs and should not be manipulated
directly by, for instance, @code{put-text-property}.
@itemize @bullet
@item
If it is a character, it means to display that character instead of
the text in the region.
@item
If it is a string, it means to display that string's contents instead
of the text in the region.
@item
If it is a vector or list, the elements are characters interleaved
with internal codes specifying how to compose the following character
with the previous one.
@end itemize
@end table
@node Format Properties

6
lispref/vol1.texi
View File

@ -80,9 +80,9 @@ Front-Cover texts being ``A GNU Manual,'' and with the Back-Cover
Texts as in (a) below. A copy of the license is included in the
section entitled ``GNU Free Documentation License.''
(a) The FSF's Back-Cover Text is: ``You have freedom to copy and modify
this GNU Manual, like GNU software. Copies published by the Free
Software Foundation raise funds for GNU development.''
(a) The FSF's Back-Cover Text is: ``You are free to copy and modify
this GNU Manual. Buying copies from GNU Press supports the FSF in
developing GNU and promoting software freedom.''
@end quotation
@end copying

6
lispref/vol2.texi
View File

@ -80,9 +80,9 @@ Front-Cover texts being ``A GNU Manual,'' and with the Back-Cover
Texts as in (a) below. A copy of the license is included in the
section entitled ``GNU Free Documentation License.''
(a) The FSF's Back-Cover Text is: ``You have freedom to copy and modify
this GNU Manual, like GNU software. Copies published by the Free
Software Foundation raise funds for GNU development.''
(a) The FSF's Back-Cover Text is: ``You are free to copy and modify
this GNU Manual. Buying copies from GNU Press supports the FSF in
developing GNU and promoting software freedom.''
@end quotation
@end copying

26
man/ChangeLog
View File

@ -1,3 +1,29 @@
2007-07-02 Carsten Dominik <dominik@science.uva.nl>
* org.texi (Properties): New chapter.
2007-06-24 Karl Berry <karl@gnu.org>
* emacs.texi: new Back-Cover Text.
2007-06-20 Jay Belanger <jay.p.belanger@gmail.com>
* calc.texi:Change ifinfo to ifnottex (as appropriate) throughout.
(About This Manual): Remove redundant information.
(Getting Started): Mention author.
(Basic Arithmetic, Customizing Calc): Make description of the
variable `calc-multiplication-has-precedence' match its new effect.
2007-06-19 Jay Belanger <jay.p.belanger@gmail.com>
* calc.texi (Basic Arithmetic, Customizing Calc): Mention
the variable `calc-multiplication-has-precedence'.
2007-06-19 Carsten Dominik <dominik@science.uva.nl>
* org.texi (Tag): Section swapped with node Timestamps.
(Formula syntax for Lisp): Document new `L' flag.
2007-06-06 Andreas Seltenreich <andreas@gate450.dyndns.org>
* gnus.texi (Misc Group Stuff, Summary Buffer)

254
man/calc.texi
View File

@ -124,28 +124,32 @@ Copyright @copyright{} 1990, 1991, 2001, 2002, 2003, 2004,
@end titlepage
@c [begin]
@ifinfo
@ifnottex
@node Top, Getting Started, (dir), (dir)
@chapter The GNU Emacs Calculator
@noindent
@dfn{Calc} is an advanced desk calculator and mathematical tool
that runs as part of the GNU Emacs environment.
written by Dave Gillespie that runs as part of the GNU Emacs environment.
This manual is divided into three major parts: ``Getting Started,''
the ``Calc Tutorial,'' and the ``Calc Reference.'' The Tutorial
introduces all the major aspects of Calculator use in an easy,
hands-on way. The remainder of the manual is a complete reference to
the features of the Calculator.
This manual, also written (mostly) by Dave Gillespie, is divided into
three major parts: ``Getting Started,'' the ``Calc Tutorial,'' and the
``Calc Reference.'' The Tutorial introduces all the major aspects of
Calculator use in an easy, hands-on way. The remainder of the manual is
a complete reference to the features of the Calculator.
@end ifnottex
@ifinfo
For help in the Emacs Info system (which you are using to read this
file), type @kbd{?}. (You can also type @kbd{h} to run through a
longer Info tutorial.)
@end ifinfo
@menu
* Getting Started:: General description and overview.
@ifinfo
* Interactive Tutorial::
@end ifinfo
* Tutorial:: A step-by-step introduction for beginners.
* Introduction:: Introduction to the Calc reference manual.
@ -179,7 +183,12 @@ longer Info tutorial.)
* Lisp Function Index:: Internal Lisp math functions.
@end menu
@ifinfo
@node Getting Started, Interactive Tutorial, Top, Top
@end ifinfo
@ifnotinfo
@node Getting Started, Tutorial, Top, Top
@end ifnotinfo
@chapter Getting Started
@noindent
This chapter provides a general overview of Calc, the GNU Emacs
@ -267,12 +276,6 @@ experience with GNU Emacs in order to get the most out of Calc,
this manual ought to be readable even if you don't know or use Emacs
regularly.
@ifinfo
The manual is divided into three major parts:@: the ``Getting
Started'' chapter you are reading now, the Calc tutorial (chapter 2),
and the Calc reference manual (the remaining chapters and appendices).
@end ifinfo
@iftex
The manual is divided into three major parts:@: the ``Getting
Started'' chapter you are reading now, the Calc tutorial (chapter 2),
and the Calc reference manual (the remaining chapters and appendices).
@ -280,7 +283,6 @@ and the Calc reference manual (the remaining chapters and appendices).
@c This manual has been printed in two volumes, the @dfn{Tutorial} and the
@c @dfn{Reference}. Both volumes include a copy of the ``Getting Started''
@c chapter.
@end iftex
If you are in a hurry to use Calc, there is a brief ``demonstration''
below which illustrates the major features of Calc in just a couple of
@ -321,6 +323,7 @@ you can also go to the part of the manual describing any Calc key,
function, or variable using @w{@kbd{h k}}, @kbd{h f}, or @kbd{h v},
respectively. @xref{Help Commands}.
@ifnottex
The Calc manual can be printed, but because the manual is so large, you
should only make a printed copy if you really need it. To print the
manual, you will need the @TeX{} typesetting program (this is a free
@ -347,7 +350,7 @@ or
@example
dvips calc.dvi
@end example
@end ifnottex
@c Printed copies of this manual are also available from the Free Software
@c Foundation.
@ -543,13 +546,13 @@ system. Type @kbd{d N} to return to normal notation.
Type @kbd{7.5}, then @kbd{s l a @key{RET}} to let @expr{a = 7.5} in these formulas.
(That's a letter @kbd{l}, not a numeral @kbd{1}.)
@iftex
@ifnotinfo
@strong{Help functions.} You can read about any command in the on-line
manual. Type @kbd{C-x * c} to return to Calc after each of these
commands: @kbd{h k t N} to read about the @kbd{t N} command,
@kbd{h f sqrt @key{RET}} to read about the @code{sqrt} function, and
@kbd{h s} to read the Calc summary.
@end iftex
@end ifnotinfo
@ifinfo
@strong{Help functions.} You can read about any command in the on-line
manual. Remember to type the letter @kbd{l}, then @kbd{C-x * c}, to
@ -1251,9 +1254,12 @@ Press @kbd{1} now to enter the first section of the Tutorial.
@menu
* Tutorial::
@end menu
@end ifinfo
@node Tutorial, Introduction, Interactive Tutorial, Top
@end ifinfo
@ifnotinfo
@node Tutorial, Introduction, Getting Started, Top
@end ifnotinfo
@chapter Tutorial
@noindent
@ -1272,32 +1278,22 @@ The Quick mode and Keypad mode interfaces are fairly
self-explanatory. @xref{Embedded Mode}, for a description of
the Embedded mode interface.
@ifinfo
The easiest way to read this tutorial on-line is to have two windows on
your Emacs screen, one with Calc and one with the Info system. (If you
have a printed copy of the manual you can use that instead.) Press
@kbd{C-x * c} to turn Calc on or to switch into the Calc window, and
press @kbd{C-x * i} to start the Info system or to switch into its window.
Or, you may prefer to use the tutorial in printed form.
@end ifinfo
@iftex
The easiest way to read this tutorial on-line is to have two windows on
your Emacs screen, one with Calc and one with the Info system. (If you
have a printed copy of the manual you can use that instead.) Press
@kbd{C-x * c} to turn Calc on or to switch into the Calc window, and
press @kbd{C-x * i} to start the Info system or to switch into its window.
@end iftex
This tutorial is designed to be done in sequence. But the rest of this
manual does not assume you have gone through the tutorial. The tutorial
does not cover everything in the Calculator, but it touches on most
general areas.
@ifinfo
@ifnottex
You may wish to print out a copy of the Calc Summary and keep notes on
it as you learn Calc. @xref{About This Manual}, to see how to make a
printed summary. @xref{Summary}.
@end ifinfo
@end ifnottex
@iftex
The Calc Summary at the end of the reference manual includes some blank
space for your own use. You may wish to keep notes there as you learn
@ -1334,13 +1330,13 @@ to control various modes of the Calculator.
@subsection RPN Calculations and the Stack
@cindex RPN notation
@ifinfo
@ifnottex
@noindent
Calc normally uses RPN notation. You may be familiar with the RPN
system from Hewlett-Packard calculators, FORTH, or PostScript.
(Reverse Polish Notation, RPN, is named after the Polish mathematician
Jan Lukasiewicz.)
@end ifinfo
@end ifnottex
@tex
\noindent
Calc normally uses RPN notation. You may be familiar with the RPN
@ -1769,7 +1765,7 @@ is equivalent to
@noindent
or, in large mathematical notation,
@ifinfo
@ifnottex
@example
@group
3 * 4 * 5
@ -1778,7 +1774,7 @@ or, in large mathematical notation,
6 * 7
@end group
@end example
@end ifinfo
@end ifnottex
@tex
\turnoffactive
\beforedisplay
@ -3325,7 +3321,7 @@ We can multiply these two matrices in either order to get an identity.
Matrix inverses are related to systems of linear equations in algebra.
Suppose we had the following set of equations:
@ifinfo
@ifnottex
@group
@example
a + 2b + 3c = 6
@ -3333,7 +3329,7 @@ Suppose we had the following set of equations:
7a + 6b = 3
@end example
@end group
@end ifinfo
@end ifnottex
@tex
\turnoffactive
\beforedisplayh
@ -3352,7 +3348,7 @@ $$
@noindent
This can be cast into the matrix equation,
@ifinfo
@ifnottex
@group
@example
[ [ 1, 2, 3 ] [ [ a ] [ [ 6 ]
@ -3360,7 +3356,7 @@ This can be cast into the matrix equation,
[ 7, 6, 0 ] ] [ c ] ] [ 3 ] ]
@end example
@end group
@end ifinfo
@end ifnottex
@tex
\turnoffactive
\beforedisplay
@ -3425,14 +3421,14 @@ vectors and matrices that include variables. Solve the following
system of equations to get expressions for @expr{x} and @expr{y}
in terms of @expr{a} and @expr{b}.
@ifinfo
@ifnottex
@group
@example
x + a y = 6
x + b y = 10
@end example
@end group
@end ifinfo
@end ifnottex
@tex
\turnoffactive
\beforedisplay
@ -3456,9 +3452,9 @@ you can't solve @expr{A X = B} directly because the matrix @expr{A}
is not square for an over-determined system. Matrix inversion works
only for square matrices. One common trick is to multiply both sides
on the left by the transpose of @expr{A}:
@ifinfo
@ifnottex
@samp{trn(A)*A*X = trn(A)*B}.
@end ifinfo
@end ifnottex
@tex
\turnoffactive
$A^T A \, X = A^T B$, where $A^T$ is the transpose \samp{trn(A)}.
@ -3472,7 +3468,7 @@ solution, which can be regarded as the ``closest'' solution to the set
of equations. Use Calc to solve the following over-determined
system:
@ifinfo
@ifnottex
@group
@example
a + 2b + 3c = 6
@ -3481,7 +3477,7 @@ system:
2a + 4b + 6c = 11
@end example
@end group
@end ifinfo
@end ifnottex
@tex
\turnoffactive
\beforedisplayh
@ -3749,11 +3745,11 @@ stored value from the stack.)
In a least squares fit, the slope @expr{m} is given by the formula
@ifinfo
@ifnottex
@example
m = (N sum(x y) - sum(x) sum(y)) / (N sum(x^2) - sum(x)^2)
@end example
@end ifinfo
@end ifnottex
@tex
\turnoffactive
\beforedisplay
@ -3790,12 +3786,12 @@ this formula uses.
@end group
@end smallexample
@ifinfo
@ifnottex
@noindent
These are @samp{sum(x)}, @samp{sum(x^2)}, @samp{sum(y)}, and @samp{sum(x y)},
respectively. (We could have used @kbd{*} to compute @samp{sum(x^2)} and
@samp{sum(x y)}.)
@end ifinfo
@end ifnottex
@tex
\turnoffactive
These are $\sum x$, $\sum x^2$, $\sum y$, and $\sum x y$,
@ -3845,11 +3841,11 @@ Now we grind through the formula:
That gives us the slope @expr{m}. The y-intercept @expr{b} can now
be found with the simple formula,
@ifinfo
@ifnottex
@example
b = (sum(y) - m sum(x)) / N
@end example
@end ifinfo
@end ifnottex
@tex
\turnoffactive
\beforedisplay
@ -3987,14 +3983,14 @@ The @kbd{C-x * g} command accepts numbers separated by spaces or commas,
with or without surrounding vector brackets.
@xref{List Answer 3, 3}. (@bullet{})
@ifinfo
@ifnottex
As another example, a theorem about binomial coefficients tells
us that the alternating sum of binomial coefficients
@var{n}-choose-0 minus @var{n}-choose-1 plus @var{n}-choose-2, and so
on up to @var{n}-choose-@var{n},
always comes out to zero. Let's verify this
for @expr{n=6}.
@end ifinfo
@end ifnottex
@tex
As another example, a theorem about binomial coefficients tells
us that the alternating sum of binomial coefficients
@ -5193,12 +5189,12 @@ to be a better approximation than stairsteps. A third method is
that the steps are not required to be flat. Simpson's rule boils
down to the formula,
@ifinfo
@ifnottex
@example
(h/3) * (f(a) + 4 f(a+h) + 2 f(a+2h) + 4 f(a+3h) + ...
+ 2 f(a+(n-2)*h) + 4 f(a+(n-1)*h) + f(a+n*h))
@end example
@end ifinfo
@end ifnottex
@tex
\turnoffactive
\beforedisplay
@ -5215,12 +5211,12 @@ is the width of each slice. These are 10 and 0.1 in our example.
For reference, here is the corresponding formula for the stairstep
method:
@ifinfo
@ifnottex
@example
h * (f(a) + f(a+h) + f(a+2h) + f(a+3h) + ...
+ f(a+(n-2)*h) + f(a+(n-1)*h))
@end example
@end ifinfo
@end ifnottex
@tex
\turnoffactive
\beforedisplay
@ -5657,11 +5653,11 @@ so that @expr{2 - 3 (x + y) + x y} is a sum of three terms.)
infinite series that exactly equals the value of that function at
values of @expr{x} near zero.
@ifinfo
@ifnottex
@example
cos(x) = 1 - x^2 / 2! + x^4 / 4! - x^6 / 6! + ...
@end example
@end ifinfo
@end ifnottex
@tex
\turnoffactive
\beforedisplay
@ -5675,11 +5671,11 @@ Calc represents the truncated Taylor series as a polynomial in @expr{x}.
Mathematicians often write a truncated series using a ``big-O'' notation
that records what was the lowest term that was truncated.
@ifinfo
@ifnottex
@example
cos(x) = 1 - x^2 / 2! + O(x^3)
@end example
@end ifinfo
@end ifnottex
@tex
\turnoffactive
\beforedisplay
@ -6204,11 +6200,11 @@ equations numerically is @dfn{Newton's Method}. Given the equation
@expr{x_0} which is reasonably close to the desired solution, apply
this formula over and over:
@ifinfo
@ifnottex
@example
new_x = x - f(x)/f'(x)
@end example
@end ifinfo
@end ifnottex
@tex
\beforedisplay
$$ x_{\rm new} = x - {f(x) \over f'(x)} $$
@ -6242,11 +6238,11 @@ is defined as the derivative of
@infoline @expr{ln(gamma(z))}.
For large values of @expr{z}, it can be approximated by the infinite sum
@ifinfo
@ifnottex
@example
psi(z) ~= ln(z) - 1/2z - sum(bern(2 n) / 2 n z^(2 n), n, 1, inf)
@end example
@end ifinfo
@end ifnottex
@tex
\beforedisplay
$$ \psi(z) \approx \ln z - {1\over2z} -
@ -6305,13 +6301,13 @@ a way to convert from this form back to the standard algebraic form.
(@bullet{}) @strong{Exercise 11.} The @dfn{Stirling numbers of the
first kind} are defined by the recurrences,
@ifinfo
@ifnottex
@example
s(n,n) = 1 for n >= 0,
s(n,0) = 0 for n > 0,
s(n+1,m) = s(n,m-1) - n s(n,m) for n >= m >= 1.
@end example
@end ifinfo
@end ifnottex
@tex
\turnoffactive
\beforedisplay
@ -6843,14 +6839,14 @@ get the row sum. Similarly, use @kbd{[1 1] r 4 *} to get the column sum.
@node Matrix Answer 2, Matrix Answer 3, Matrix Answer 1, Answers to Exercises
@subsection Matrix Tutorial Exercise 2
@ifinfo
@ifnottex
@example
@group
x + a y = 6
x + b y = 10
@end group
@end example
@end ifinfo
@end ifnottex
@tex
\turnoffactive
\beforedisplay
@ -6905,7 +6901,7 @@ now, we have a system
@infoline @expr{A2 * X = B2}
which we can solve using Calc's @samp{/} command.
@ifinfo
@ifnottex
@example
@group
a + 2b + 3c = 6
@ -6914,7 +6910,7 @@ which we can solve using Calc's @samp{/} command.
2a + 4b + 6c = 11
@end group
@end example
@end ifinfo
@end ifnottex
@tex
\turnoffactive
\beforedisplayh
@ -7045,11 +7041,11 @@ vector.
Given @expr{x} and @expr{y} vectors in quick variables 1 and 2 as before,
the first job is to form the matrix that describes the problem.
@ifinfo
@ifnottex
@example
m*x + b*1 = y
@end example
@end ifinfo
@end ifnottex
@tex
\turnoffactive
\beforedisplay
@ -7836,11 +7832,11 @@ Why does this work? Think about a two-step computation:
subtracting off enough 511's to put the result in the desired range.
So the result when we take the modulo after every step is,
@ifinfo
@ifnottex
@example
3 (3 a + b - 511 m) + c - 511 n
@end example
@end ifinfo
@end ifnottex
@tex
\turnoffactive
\beforedisplay
@ -7852,11 +7848,11 @@ $$ 3 (3 a + b - 511 m) + c - 511 n $$
for some suitable integers @expr{m} and @expr{n}. Expanding out by
the distributive law yields
@ifinfo
@ifnottex
@example
9 a + 3 b + c - 511*3 m - 511 n
@end example
@end ifinfo
@end ifnottex
@tex
\turnoffactive
\beforedisplay
@ -7870,11 +7866,11 @@ contribution it makes could just as easily be made by the @expr{n}
term. So we can take it out to get an equivalent formula with
@expr{n' = 3m + n},
@ifinfo
@ifnottex
@example
9 a + 3 b + c - 511 n'
@end example
@end ifinfo
@end ifnottex
@tex
\turnoffactive
\beforedisplay
@ -11285,7 +11281,7 @@ from 1 to 8. Interval arithmetic is used to get a worst-case estimate
of the possible range of values a computation will produce, given the
set of possible values of the input.
@ifinfo
@ifnottex
Calc supports several varieties of intervals, including @dfn{closed}
intervals of the type shown above, @dfn{open} intervals such as
@samp{(2 ..@: 4)}, which represents the range of numbers from 2 to 4
@ -11296,7 +11292,7 @@ terms,
@samp{[2 ..@: 4)} represents @expr{2 <= x < 4},
@samp{(2 ..@: 4]} represents @expr{2 < x <= 4}, and
@samp{(2 ..@: 4)} represents @expr{2 < x < 4}.
@end ifinfo
@end ifnottex
@tex
Calc supports several varieties of intervals, including \dfn{closed}
intervals of the type shown above, \dfn{open} intervals such as
@ -11929,14 +11925,14 @@ commands, @kbd{t h} works only when Calc Trail is the selected window.
@pindex calc-trail-isearch-forward
@kindex t r
@pindex calc-trail-isearch-backward
@ifinfo
@ifnottex
The @kbd{t s} (@code{calc-trail-isearch-forward}) and @kbd{t r}
(@code{calc-trail-isearch-backward}) commands perform an incremental
search forward or backward through the trail. You can press @key{RET}
to terminate the search; the trail pointer moves to the current line.
If you cancel the search with @kbd{C-g}, the trail pointer stays where
it was when the search began.
@end ifinfo
@end ifnottex
@tex
The @kbd{t s} (@code{calc-trail-isearch-forward}) and @kbd{t r}
(@code{calc-trail-isearch-backward}) com\-mands perform an incremental
@ -14237,10 +14233,10 @@ font information.
Also, the ``discretionary multiplication sign'' @samp{\*} is read
the same as @samp{*}.
@ifinfo
@ifnottex
The @TeX{} version of this manual includes some printed examples at the
end of this section.
@end ifinfo
@end ifnottex
@iftex
Here are some examples of how various Calc formulas are formatted in @TeX{}:
@ -15975,9 +15971,28 @@ whereas @w{@samp{[-2 ..@: 3] ^ 2}} is @samp{[0 ..@: 9]}.
@mindex @null
@end ignore
@tindex /
The @kbd{/} (@code{calc-divide}) command divides two numbers. Note that
when using algebraic entry, @samp{/} has lower precedence than @samp{*},
so that @samp{a/b*c} is interpreted as @samp{a/(b*c)}.
The @kbd{/} (@code{calc-divide}) command divides two numbers.
When combining multiplication and division in an algebraic formula, it
is good style to use parentheses to distinguish between possible
interpretations; the expression @samp{a/b*c} should be written
@samp{(a/b)*c} or @samp{a/(b*c)}, as appropriate. Without the
parentheses, Calc will interpret @samp{a/b*c} as @samp{a/(b*c)}, since
in algebraic entry Calc gives division a lower precedence than
multiplication. (This is not standard across all computer languages, and
Calc may change the precedence depending on the language mode being used.
@xref{Language Modes}.) This default ordering can be changed by setting
the customizable variable @code{calc-multiplication-has-precedence} to
@code{nil} (@pxref{Customizing Calc}); this will give multiplication and
division equal precedences. Note that Calc's default choice of
precedence allows @samp{a b / c d} to be used as a shortcut for
@smallexample
@group
a b
---.
c d
@end group
@end smallexample
When dividing a scalar @expr{B} by a square matrix @expr{A}, the
computation performed is @expr{B} times the inverse of @expr{A}. This
@ -17637,7 +17652,7 @@ formulas below for symbolic arguments only when you use the @kbd{a "}
(@code{calc-expand-formula}) command, or when taking derivatives or
integrals or solving equations involving the functions.
@ifinfo
@ifnottex
These formulas are shown using the conventions of Big display
mode (@kbd{d B}); for example, the formula for @code{fv} written
linearly is @samp{pmt * ((1 + rate)^n) - 1) / rate}.
@ -17717,7 +17732,7 @@ syd(cost, salv, life, per) = --------------------------------
ddb(cost, salv, life, per) = --------, book = cost - depreciation so far
life
@end example
@end ifinfo
@end ifnottex
@tex
\turnoffactive
$$ \code{fv}(r, n, p) = p { (1 + r)^n - 1 \over r } $$
@ -18366,14 +18381,14 @@ some authors, is computed by the @kbd{I f G} [@code{gammaQ}] command.
You can think of this as taking the other half of the integral, from
@expr{x} to infinity.
@ifinfo
@ifnottex
The functions corresponding to the integrals that define @expr{P(a,x)}
and @expr{Q(a,x)} but without the normalizing @expr{1/gamma(a)}
factor are called @expr{g(a,x)} and @expr{G(a,x)}, respectively
(where @expr{g} and @expr{G} represent the lower- and upper-case Greek
letter gamma). You can obtain these using the @kbd{H f G} [@code{gammag}]
and @kbd{H I f G} [@code{gammaG}] commands.
@end ifinfo
@end ifnottex
@tex
\turnoffactive
The functions corresponding to the integrals that define $P(a,x)$
@ -18889,10 +18904,10 @@ real numbers by
@kindex H k c
@pindex calc-perm
@tindex perm
@ifinfo
@ifnottex
The @kbd{H k c} (@code{calc-perm}) [@code{perm}] command computes the
number-of-permutations function @expr{N! / (N-M)!}.
@end ifinfo
@end ifnottex
@tex
The \kbd{H k c} (\code{calc-perm}) [\code{perm}] command computes the
number-of-perm\-utations function $N! \over (N-M)!\,$.
@ -23132,13 +23147,13 @@ integral of the expression on top of the stack. In this case, the
command will again prompt for an integration variable, then prompt for a
lower limit and an upper limit.
@ifinfo
@ifnottex
If you use the @code{integ} function directly in an algebraic formula,
you can also write @samp{integ(f,x,v)} which expresses the resulting
indefinite integral in terms of variable @code{v} instead of @code{x}.
With four arguments, @samp{integ(f(x),x,a,b)} represents a definite
integral from @code{a} to @code{b}.
@end ifinfo
@end ifnottex
@tex
If you use the @code{integ} function directly in an algebraic formula,
you can also write @samp{integ(f,x,v)} which expresses the resulting
@ -24019,14 +24034,14 @@ name only those and let the parameters use default names.
For example, suppose the data matrix
@ifinfo
@ifnottex
@example
@group
[ [ 1, 2, 3, 4, 5 ]
[ 5, 7, 9, 11, 13 ] ]
@end group
@end example
@end ifinfo
@end ifnottex
@tex
\turnoffactive
\turnoffactive
@ -24083,11 +24098,11 @@ Calc has chosen a line that best approximates the data points using
the method of least squares. The idea is to define the @dfn{chi-square}
error measure
@ifinfo
@ifnottex
@example
chi^2 = sum((y_i - (a + b x_i))^2, i, 1, N)
@end example
@end ifinfo
@end ifnottex
@tex
\turnoffactive
\beforedisplay
@ -24272,11 +24287,11 @@ then the
@infoline @expr{chi^2}
statistic is now,
@ifinfo
@ifnottex
@example
chi^2 = sum(((y_i - (a + b x_i)) / sigma_i)^2, i, 1, N)
@end example
@end ifinfo
@end ifnottex
@tex
\turnoffactive
\beforedisplay
@ -27594,9 +27609,9 @@ The unit @code{A} stands for Amperes; the name @code{Ang} is used
@tex
for \AA ngstroms.
@end tex
@ifinfo
@ifnottex
for Angstroms.
@end ifinfo
@end ifnottex
The unit @code{pt} stands for pints; the name @code{point} stands for
a typographical point, defined by @samp{72 point = 1 in}. This is
@ -34516,9 +34531,9 @@ modification follow.
@iftex
@unnumberedsec TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
@end iftex
@ifinfo
@ifnottex
@center TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
@end ifinfo
@end ifnottex
@enumerate 0
@item
@ -34741,9 +34756,9 @@ of promoting the sharing and reuse of software generally.
@iftex
@heading NO WARRANTY
@end iftex
@ifinfo
@ifnottex
@center NO WARRANTY
@end ifinfo
@end ifnottex
@item
BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
@ -34771,9 +34786,9 @@ POSSIBILITY OF SUCH DAMAGES.
@iftex
@heading END OF TERMS AND CONDITIONS
@end iftex
@ifinfo
@ifnottex
@center END OF TERMS AND CONDITIONS
@end ifinfo
@end ifnottex
@page
@unnumberedsec Appendix: How to Apply These Terms to Your New Programs
@ -34899,10 +34914,9 @@ See @ref{Graphics}.@*
The variable @code{calc-gnuplot-name} should be the name of the
GNUPLOT program (a string). If you have GNUPLOT installed on your
system but Calc is unable to find it, you may need to set this
variable. (@pxref{Customizing Calc})
You may also need to set some Lisp variables to show Calc how to run
GNUPLOT on your system, see @ref{Devices, ,Graphical Devices} . The default value
of @code{calc-gnuplot-name} is @code{"gnuplot"}.
variable. You may also need to set some Lisp variables to show Calc how
to run GNUPLOT on your system, see @ref{Devices, ,Graphical Devices} .
The default value of @code{calc-gnuplot-name} is @code{"gnuplot"}.
@end defvar
@defvar calc-gnuplot-plot-command
@ -35158,6 +35172,18 @@ should also be added to @code{calc-embedded-announce-formula-alist}
and @code{calc-embedded-open-close-plain-alist}.
@end defvar
@defvar calc-multiplication-has-precedence
The variable @code{calc-multiplication-has-precedence} determines
whether multiplication has precedence over division in algebraic formulas
in normal language modes. If @code{calc-multiplication-has-precedence}
is non-@code{nil}, then multiplication has precedence, and so for
example @samp{a/b*c} will be interpreted as @samp{a/(b*c)}. If
@code{calc-multiplication-has-precedence} is @code{nil}, then
multiplication has the same precedence as division, and so for example
@samp{a/b*c} will be interpreted as @samp{(a/b)*c}. The default value
of @code{calc-multiplication-has-precedence} is @code{t}.
@end defvar
@node Reporting Bugs, Summary, Customizing Calc, Top
@appendix Reporting Bugs

8
man/emacs.texi
View File

@ -25,9 +25,9 @@ Manual,'' and with the Back-Cover Texts as in (a) below. A copy of the
license is included in the section entitled ``GNU Free Documentation
License.''
(a) The FSF's Back-Cover Text is: ``You have freedom to copy and modify
this GNU Manual, like GNU software. Copies published by the Free
Software Foundation raise funds for GNU development.''
(a) The FSF's Back-Cover Text is: ``You are free to copy and modify
this GNU Manual. Buying copies from GNU Press supports the FSF in
developing GNU and promoting software freedom.''
@end quotation
@end copying
@ -37,7 +37,7 @@ Software Foundation raise funds for GNU development.''
@end direntry
@c in general, keep the following line commented out, unless doing a
@c copy of this manual that will be published. the manual should go
@c copy of this manual that will be published. The manual should go
@c onto the distribution in the full, 8.5 x 11" size.
@c set smallbook

1033
man/org.texi
View File

File diff suppressed because it is too large Load Diff

22
man/texinfo.tex
View File

@ -3,7 +3,7 @@
% Load plain if necessary, i.e., if running under initex.
\expandafter\ifx\csname fmtname\endcsname\relax\input plain\fi
%
\def\texinfoversion{2007-05-04.09}
\def\texinfoversion{2007-06-16.10}
%
% Copyright (C) 1985, 1986, 1988, 1990, 1991, 1992, 1993, 1994, 1995,
% 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
@ -5765,11 +5765,11 @@
% regular 0x27.
%
\def\codequoteright{%
\expandafter\ifx\csname SETcodequoteundirected\endcsname\relax
'%
\else
\char'15
\fi
\expandafter\ifx\csname SETtxicodequoteundirected\endcsname\relax
\expandafter\ifx\csname SETcodequoteundirected\endcsname\relax
'%
\else \char'15 \fi
\else \char'15 \fi
}
%
% and a similar option for the left quote char vs. a grave accent.
@ -5777,11 +5777,11 @@
% the code environments to do likewise.
%
\def\codequoteleft{%
\expandafter\ifx\csname SETcodequotebacktick\endcsname\relax
`%
\else
\char'22
\fi
\expandafter\ifx\csname SETtxicodequotebacktick\endcsname\relax
\expandafter\ifx\csname SETcodequotebacktick\endcsname\relax
`%
\else \char'22 \fi
\else \char'22 \fi
}
%
\begingroup

8
nt/ChangeLog
View File

@ -1,3 +1,11 @@
2007-06-25 Jason Rumney <jasonr@gnu.org>
* cmdproxy.c (main): Set console codepages to "ANSI".
2007-06-20 Jason Rumney <jasonr@gnu.org>
* configure.bat: Complain if image libraries are missing.
2007-06-15 Jason Rumney <jasonr@gnu.org>
* emacs.manifest: New file.

6
nt/cmdproxy.c
View File

@ -466,6 +466,12 @@ main (int argc, char ** argv)
SetCurrentDirectory (modname);
*progname = '\\';
/* Due to problems with interaction between API functions that use "OEM"
codepage vs API functions that use the "ANSI" codepage, we need to
make things consistent by choosing one and sticking with it. */
SetConsoleCP (GetACP());
SetConsoleOutputCP (GetACP());
/* Although Emacs always sets argv[0] to an absolute pathname, we
might get run in other ways as well, so convert argv[0] to an
absolute name before comparing to the module name. Don't get

55
nt/configure.bat
View File

@ -119,11 +119,11 @@ echo. --no-opt disable optimization
echo. --no-cygwin use -mno-cygwin option with GCC
echo. --cflags FLAG pass FLAG to compiler
echo. --ldflags FLAG pass FLAG to compiler when linking
echo. --without-png do not use libpng even if it is installed
echo. --without-jpeg do not use jpeg-6b even if it is installed
echo. --without-gif do not use libungif even if it is installed
echo. --without-tiff do not use libtiff even if it is installed
echo. --without-xpm do not use libXpm even if it is installed
echo. --without-png do not use libpng
echo. --without-jpeg do not use jpeg-6b
echo. --without-gif do not use giflib or libungif
echo. --without-tiff do not use libtiff
echo. --without-xpm do not use libXpm
echo. --enable-font-backend build with font backend support
goto end
rem ----------------------------------------------------------------------
@ -542,6 +542,51 @@ copy subdirs.el ..\site-lisp\subdirs.el
:dontUpdateSubdirs
echo.
rem check that we have all the libraries we need.
set libsOK=1
if not "(%HAVE_XPM%)" == "()" goto checkpng
if (%xpmsupport%) == (N) goto checkpng
set libsOK=0
echo XPM support is missing. It is required for color icons in the toolbar.
echo Install libXpm development files or use --without-xpm
:checkpng
if not "(%HAVE_PNG%)" == "()" goto checkjpeg
if (%pngsupport%) == (N) goto checkjpeg
set libsOK=0
echo PNG support is missing.
echo Install libpng development files or use --without-png
:checkjpeg
if not "(%HAVE_JPEG%)" == "()" goto checktiff
if (%jpegsupport%) == (N) goto checktiff
set libsOK=0
echo JPEG support is missing.
echo Install jpeg development files or use --without-jpeg
:checktiff
if not "(%HAVE_TIFF%)" == "()" goto checkgif
if (%tiffsupport%) == (N) goto checkgif
set libsOK=0
echo TIFF support is missing.
echo Install libtiff development files or use --without-tiff
:checkgif
if not "(%HAVE_GIF%)" == "()" goto donelibchecks
if (%gifsupport%) == (N) goto donelibchecks
set libsOK=0
echo GIF support is missing.
echo Install giflib or libungif development files or use --without-gif
:donelibchecks
if (%libsOK%) == (1) goto success
echo.
echo Important libraries are missing. Fix these issues before running make.
goto end
:success
echo Emacs successfully configured.
echo Emacs successfully configured. >>config.log
echo Run `%MAKECMD%' to build, then run `%MAKECMD% install' to install.

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