# HG changeset patch # User cvs # Date 1186992514 -7200 # Node ID d44af0c5477531dffeca7b5751da1399a0836981 # Parent 43306a74e31cfda2f3595851ba4370a3bcedfd5d Import from CVS: tag r20-4b7 diff -r 43306a74e31c -r d44af0c54775 CHANGES-beta --- a/CHANGES-beta Mon Aug 13 10:07:42 2007 +0200 +++ b/CHANGES-beta Mon Aug 13 10:08:34 2007 +0200 @@ -1,4 +1,199 @@ -*- indented-text -*- +to 20.4 beta7 "Appenzell" +-- Miscellaneous MS Windows patches from David Hobley and Jeff Sparkes +-- ImageMagick is not autodetected by configure courtesy of IENAGA Kazuyuki +-- (broken) energize support has been removed courtesy of Jeff Miller +-- lisp/eos has been packaged +-- lisp/sunpro has been packaged +-- lisp/tooltak has been packaged +-- abbrevlist.el has been packaged +-- advice.el has been packaged +-- annotations.el has been packaged +-- assoc.el has been packaged +-- atomic-extents.el has been packaged +-- bench.el has been packaged +-- browse-url.el has been packaged +-- edit-toolbar.el has been packaged +-- edmacro.el has been packaged +-- eldoc.el has been packaged +-- facemenu.el has been packaged +-- floating-toolbar.el has been packaged +-- foldout.el has been packaged +-- frame-icon.el has been packaged +-- hippie-exp.el has been packaged +-- live-icon.el has been packaged +-- loadhist.el has been packaged +-- passwd.el has been packaged +-- ph.el has been packaged +-- pp.el has been packaged +-- pretty-print.el has been packaged +-- redo.el has been packaged +-- regexp-opt.el has been packaged +-- regi.el has been packaged +-- reporter.el has been packaged +-- ring.el has been packaged +-- savehist.el has been packaged +-- shadowfile.el has been packaged +-- skeleton.el has been packaged +-- symbol-syntax.el has been packaged +-- sysdep.el has been packaged +-- thing.el has been packaged +-- timezone.el has been packaged +-- toolbar-utils.el has been packaged +-- tree-menu.el has been packaged +-- xbm-button.el has been packaged +-- xpm-button.el has been packaged +-- advocacy.el has been packaged +-- case-table.el has been packaged +-- debug.el has been packaged +-- disp-table.el has been packaged +-- env.el has been packaged +-- find-func.el has been packaged +-- lisp-file-db.el has been packaged +-- macros.el has been packaged +-- novice.el has been packaged +-- options.el has been removed +-- overlay.el has been packaged +-- profile.el has been packaged +-- rect.el has been packaged +-- reposition.el has been packaged +-- sort.el has been packaged +-- tabify.el has been packaged +-- userlock.el has been packaged +-- elp.el has been packaged +-- highlight-headers.el has been packaged +-- id-select.el has been packaged +-- rfc822.el has been packaged +-- smtp.el has been packaged +-- soundex.el has been packaged +-- tq.el has been packaged +-- trace.el has been packaged +-- uniquify.el has been packaged +-- cmdloop1.el has been removed +-- inc-vers.el has been removed +-- icomplete.el has been packaged +-- igrep.el has been packaged +-- informat.el has been packaged +-- iswitchb.el has been packaged +-- jka-compr.el has been packaged +-- makeinfo.el has been packaged +-- makesum.el has been packaged +-- man.el has been packaged +-- metamail.el has been packaged +-- mic-paren.el has been packaged +-- mode-motion+.el has been packaged +-- rcompile.el has been packaged +-- recent-files.el has been packaged +-- refbib.el has been packaged +-- reportmail.el has been packaged +-- resume.el has been packaged +-- generic-sc.el has been packaged +-- gopher.el has been packaged +-- hexl.el has been packaged +-- fast-lock.el has been packaged +-- feedmail.el has been packaged +-- file-part.el has been packaged +-- filladapt.el has been packaged +-- func-menu.el has been packaged +-- saveconf.el has been packaged +-- saveplace.el has been packaged +-- scroll-in-place.el has been packaged +-- shell-font.el has been packaged +-- spell.el has been packaged +-- supercite.el has been packaged +-- page-ext.el has been packaged +-- paren.el has been packaged +-- pending-del.el has been packaged +-- ps-print.el has been packaged +-- edit-faces.el has been packaged +-- emacsbug.el has been packaged +-- emerge.el has been packaged +-- lazy-lock.el has been packaged +-- ledit.el has been packaged +-- lispm-fonts.el has been packaged +-- lpr.el has been packaged +-- tar-mode.el has been packaged +-- terminal.el has been packaged +-- tex-latin1.el has been packaged +-- texinfmt.el has been packaged +-- texnfo-tex.el has been packaged +-- texnfo-upd.el has been packaged +-- time-stamp.el has been packaged +-- time.el has been packaged +-- uncompress.el has been packaged +-- underline.el has been packaged +-- upd-copyr.el has been packaged +-- webjump.el has been packaged +-- webster-www.el has been packaged +-- xscheme.el has been packaged +-- dabbrev.el has been packaged +-- desktop.el has been packaged +-- detexinfo.el has been packaged +-- diff.el has been packaged +-- doctex.el has been packaged +-- chistory.el has been packaged +-- cmuscheme.el has been packaged +-- compare-w.el has been packaged +-- compile.el has been packaged +-- completion.el has been packaged +-- crypt.el has been packaged +-- bookmark.el has been packaged +-- blink-paren.el has been packaged +-- blink-cursor.el has been packaged +-- big-menubar.el has been packaged +-- balloon-help.el has been packaged +-- backup-dir.el has been packaged +-- avoid.el has been packaged +-- autoinsert.el has been packaged +-- array.el has been packaged +-- add-log.el has been packaged +-- oobr has been packaged +-- mail-extr.el, mail-utils.el have been packaged +-- view-process has been packaged +-- vhdl-mode has been packaged +-- texinfo.el has been packaged +-- tex-mode.el has been packaged +-- sendmail.el has been packaged +-- sgml-mode.el has been packaged +-- scribe.el has been packaged +-- scheme.el has been packaged +-- rsz-minibuf.el has been packaged +-- rexx-mode.el has been packaged +-- reftex.el has been packaged +-- python-mode.el has been packaged +-- prolog.el has been packaged +-- postscript.el has been packaged +-- picture.el has been packaged +-- perl-mode.el has been packaged +-- pascal.el has been packaged +-- outline.el has been packaged +-- outl-mouse.el has been packaged +-- nroff-mode.el has been packaged +-- modula2.el has been packaged +-- make-mode.el has been packaged +-- mail-abbrevs.el has been packaged +-- lisp-mnt.el has been packaged +-- linuxdoc-sgml.el has been packaged +-- lazy-shot.el has been packaged +-- image-mode.el has been packaged +-- icon.el has been packaged +-- hideshow.el has been packaged +-- hideif.el has been packaged +-- executable.el has been packaged +-- enriched.el has been packaged +-- eiffel3.el has been packaged +-- cperl-mode.el has been packaged +-- cmacexp.el has been packaged +-- cl-indent.el has been packaged +-- c-style.el has been packged +-- c-fill.el has been packaged +-- c-comment.el has been packaged +-- bibtex.el has been packaged +-- bib-mode.el has been packaged +-- awk-mode.el has been packaged +-- autoconf-mode.el has been packaged +-- Miscellaneous bug fixes + to 20.4 beta6 "Angora" -- New package-path syntax. A null package indicates where the default lisp should go. This allows specifying packages that must be appended to the @@ -11,7 +206,7 @@ -- Egg update courtesy of Jareth Hein -- Update to Norwegian TUTORIAL courtesy of Stig Bjørlykke -- Polish translation of the TUTORIAL courtesy of Remek Trzaska, update and - corrections courtesy of Rysiek Kubiak. + corrections courtesy of Rysiek Kubiak -- Toolbar improvements courtesy of Kyle Jones -- Miscellaneous bug fixes diff -r 43306a74e31c -r d44af0c54775 ChangeLog --- a/ChangeLog Mon Aug 13 10:07:42 2007 +0200 +++ b/ChangeLog Mon Aug 13 10:08:34 2007 +0200 @@ -1,3 +1,37 @@ +1997-11-27 SL Baur + + * XEmacs 20.4-beta7 is released. + + * configure.in: When testing for -ltiff, fall back on the extra + libraries -ljpeg, and -lz since some -ltiff's need them. + +1997-11-26 SL Baur + + * lwlib/xlwmenu.c (display_menu): Defer incremental menus properly. + From Glynn Clements + +1997-11-25 Kazuyuki IENAGA + + * configure.in: Improve auto detect of libraries ImageMagick rely + on. + +1997-11-23 Jeff Miller + + * Energize is dead. Removed ENERGIZE ifdef's from code in lwlib + and src. Configure.in modified. --with-energize is no longer a + valid configure option. + + * lwlib/Makefile.in.in removed energize support + * lwlib/lwlib-Xm.c removed energize support + * lwlib/lwlib-config.c removed energize support + + * lwlib/energize/* removed + +1997-11-23 SL Baur + + * Makefile.in: Change references of lisp/utils/finder-inf.el to + lisp/finder-inf.el. + 1997-11-20 SL Baur * XEmacs 20.4-beta6 is released. @@ -12,7 +46,7 @@ 1997-11-20 SL Baur - * XEmacs 20.3 is released. + * XEmacs 20.3 is released for binary kit building. 1997-11-19 Tor Arntsen diff -r 43306a74e31c -r d44af0c54775 INSTALL --- a/INSTALL Mon Aug 13 10:07:42 2007 +0200 +++ b/INSTALL Mon Aug 13 10:08:34 2007 +0200 @@ -263,11 +263,6 @@ drop support. `configure' will attempt to detect this option and define `--with-offix' for you. -The `--with-energize' option specifies that XEmacs should be built -with support for the Lucid Energize system. (If you have not -purchased Energize, specifying this option won't gain you anything.) -Currently this doesn't work. - The `--external-widget' option specifies that XEmacs should be built with support for being used as a widget by other X11 applications. This functionality should be considered beta. diff -r 43306a74e31c -r d44af0c54775 Makefile.in --- a/Makefile.in Mon Aug 13 10:07:42 2007 +0200 +++ b/Makefile.in Mon Aug 13 10:08:34 2007 +0200 @@ -229,7 +229,7 @@ COPYDIR = ${srcdir}/etc ${srcdir}/lisp COPYDESTS = ${etcdir} ${lispdir} GENERATED_HEADERS = src/paths.h src/Emacs.ad.h src/puresize-adjust.h src/config.h lwlib/config.h -GENERATED_LISP = lisp/utils/finder-inf.el +GENERATED_LISP = lisp/finder-inf.el all: ${GENERATED_HEADERS} ${MAKE_SUBDIR} ${GENERATED_LISP} @@ -270,14 +270,14 @@ finder: src @echo "Building finder database" - @(cd lisp/utils; \ + @(cd lisp; \ ${blddir}/src/xemacs -batch -q -no-site-file \ -eval '(setq finder-compile-keywords-quiet t)' \ -l finder -f finder-compile-keywords ) -lisp/utils/finder-inf.el: +lisp/finder-inf.el: @echo "Building finder database" - @(cd lisp/utils; \ + @(cd lisp; \ ${blddir}/src/xemacs -batch -q -no-site-file \ -eval '(setq finder-compile-keywords-quiet t)' \ -l finder -f finder-compile-keywords ) @@ -344,7 +344,7 @@ lwlib: FRC.lwlib dynodump: FRC.dynodump FRC.src FRC.lib-src FRC.lwlib FRC.dynodump pkg-src/FRC.tree-x: -FRC.lisp.utils.finder-inf.el: +FRC.lisp.finder-inf.el: .RECURSIVE: ${SUBDIR} @@ -560,7 +560,7 @@ $(RM) $$d/Makefile $$d/Makefile.in ; \ done ; \ $(RM) core .sbinit Makefile lock/*; \ - $(RM) lisp/utils/finder-inf.el* + $(RM) lisp/finder-inf.el* distclean: FRC.distclean for d in $(SUBDIR); do (cd $$d && $(RECURSIVE_MAKE) $@); done diff -r 43306a74e31c -r d44af0c54775 configure --- a/configure Mon Aug 13 10:07:42 2007 +0200 +++ b/configure Mon Aug 13 10:08:34 2007 +0200 @@ -241,7 +241,6 @@ with_x11='' rel_alloc='default' with_system_malloc='default' -energize_version='' native_sound_lib='' use_assertions="yes" with_toolbars="" @@ -318,7 +317,6 @@ with_canna | \ with_wnn | \ with_wnn6 | \ - with_energize | \ with_workshop | \ with_sparcworks | \ with_tooltalk | \ @@ -577,11 +575,6 @@ eval set x "$quoted_arguments"; shift -if test "$with_energize" = "yes" ; then - with_menubars=lucid with_scrollbars=motif with_dialogs=motif with_tooltalk=yes - MAKE_SUBDIR="$MAKE_SUBDIR lwlib/energize" && if test "$extra_verbose" = "yes"; then echo " Appending \"lwlib/energize\" to \$MAKE_SUBDIR"; fi -fi - test "$extra_verbose" = "yes" && verbose=yes case "$site_includes" in *:* ) site_includes="`echo '' $site_includes | sed -e 's/^ //' -e 's/:/ /g'`";; esac @@ -645,7 +638,7 @@ esac echo $ac_n "checking whether ln -s works""... $ac_c" 1>&6 -echo "configure:649: checking whether ln -s works" >&5 +echo "configure:642: checking whether ln -s works" >&5 rm -f conftestdata if ln -s X conftestdata 2>/dev/null @@ -822,8 +815,8 @@ echo "checking "the configuration name"" 1>&6 -echo "configure:826: checking "the configuration name"" >&5 -internal_configuration=`echo $configuration | sed 's/-\(energize\|workshop\)//'` +echo "configure:819: checking "the configuration name"" >&5 +internal_configuration=`echo $configuration | sed 's/-\(workshop\)//'` if canonical=`$srcdir/config.sub "$internal_configuration"` ; then : ; else exit $? fi @@ -1278,7 +1271,7 @@ # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1282: checking for $ac_word" >&5 +echo "configure:1275: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1304,7 +1297,7 @@ # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1308: checking for $ac_word" >&5 +echo "configure:1301: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1349,7 +1342,7 @@ fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 -echo "configure:1353: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 +echo "configure:1346: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 ac_ext=c xe_cppflags='$CPPFLAGS $c_switch_site $c_switch_machine $c_switch_system $c_switch_x_site $X_CFLAGS' @@ -1361,11 +1354,11 @@ cross_compiling=no cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:1362: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then ac_cv_prog_cc_works=yes # If we can't run a trivial program, we are probably using a cross compiler. if (./conftest; exit) 2>/dev/null; then @@ -1385,19 +1378,19 @@ { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; } fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6 -echo "configure:1389: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 +echo "configure:1382: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6 cross_compiling=$ac_cv_prog_cc_cross echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6 -echo "configure:1394: checking whether we are using GNU C" >&5 +echo "configure:1387: checking whether we are using GNU C" >&5 cat > conftest.c <&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then +if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1394: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then ac_cv_prog_gcc=yes else ac_cv_prog_gcc=no @@ -1411,7 +1404,7 @@ ac_save_CFLAGS="$CFLAGS" CFLAGS= echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 -echo "configure:1415: checking whether ${CC-cc} accepts -g" >&5 +echo "configure:1408: checking whether ${CC-cc} accepts -g" >&5 echo 'void f(){}' > conftest.c if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then @@ -1440,7 +1433,7 @@ # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1444: checking for $ac_word" >&5 +echo "configure:1437: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1466,7 +1459,7 @@ # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1470: checking for $ac_word" >&5 +echo "configure:1463: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1511,7 +1504,7 @@ fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 -echo "configure:1515: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 +echo "configure:1508: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 ac_ext=c xe_cppflags='$CPPFLAGS $c_switch_site $c_switch_machine $c_switch_system $c_switch_x_site $X_CFLAGS' @@ -1523,11 +1516,11 @@ cross_compiling=no cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:1524: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then ac_cv_prog_cc_works=yes # If we can't run a trivial program, we are probably using a cross compiler. if (./conftest; exit) 2>/dev/null; then @@ -1547,19 +1540,19 @@ { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; } fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6 -echo "configure:1551: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 +echo "configure:1544: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6 cross_compiling=$ac_cv_prog_cc_cross echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6 -echo "configure:1556: checking whether we are using GNU C" >&5 +echo "configure:1549: checking whether we are using GNU C" >&5 cat > conftest.c <&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then +if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1556: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then ac_cv_prog_gcc=yes else ac_cv_prog_gcc=no @@ -1573,7 +1566,7 @@ ac_save_CFLAGS="$CFLAGS" CFLAGS= echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 -echo "configure:1577: checking whether ${CC-cc} accepts -g" >&5 +echo "configure:1570: checking whether ${CC-cc} accepts -g" >&5 echo 'void f(){}' > conftest.c if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then @@ -1602,7 +1595,7 @@ # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1606: checking for $ac_word" >&5 +echo "configure:1599: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1628,7 +1621,7 @@ # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1632: checking for $ac_word" >&5 +echo "configure:1625: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1673,7 +1666,7 @@ fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 -echo "configure:1677: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 +echo "configure:1670: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 ac_ext=c xe_cppflags='$CPPFLAGS $c_switch_site $c_switch_machine $c_switch_system $c_switch_x_site $X_CFLAGS' @@ -1685,11 +1678,11 @@ cross_compiling=no cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:1686: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then ac_cv_prog_cc_works=yes # If we can't run a trivial program, we are probably using a cross compiler. if (./conftest; exit) 2>/dev/null; then @@ -1709,19 +1702,19 @@ { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; } fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6 -echo "configure:1713: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 +echo "configure:1706: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6 cross_compiling=$ac_cv_prog_cc_cross echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6 -echo "configure:1718: checking whether we are using GNU C" >&5 +echo "configure:1711: checking whether we are using GNU C" >&5 cat > conftest.c <&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then +if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1718: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then ac_cv_prog_gcc=yes else ac_cv_prog_gcc=no @@ -1735,7 +1728,7 @@ ac_save_CFLAGS="$CFLAGS" CFLAGS= echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 -echo "configure:1739: checking whether ${CC-cc} accepts -g" >&5 +echo "configure:1732: checking whether ${CC-cc} accepts -g" >&5 echo 'void f(){}' > conftest.c if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then @@ -1768,7 +1761,7 @@ test -n "$NON_GNU_CPP" -a "$GCC" != "yes" -a -z "$CPP" && CPP="$NON_GNU_CPP" echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6 -echo "configure:1772: checking how to run the C preprocessor" >&5 +echo "configure:1765: checking how to run the C preprocessor" >&5 # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= @@ -1781,13 +1774,13 @@ # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. cat > conftest.$ac_ext < Syntax Error EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:1791: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:1784: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then : @@ -1798,13 +1791,13 @@ rm -rf conftest* CPP="${CC-cc} -E -traditional-cpp" cat > conftest.$ac_ext < Syntax Error EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:1808: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:1801: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then : @@ -1827,9 +1820,9 @@ echo $ac_n "checking for AIX""... $ac_c" 1>&6 -echo "configure:1831: checking for AIX" >&5 -cat > conftest.$ac_ext <&5 +cat > conftest.$ac_ext <&6 -echo "configure:1860: checking whether we are using SunPro C" >&5 -cat > conftest.$ac_ext <&5 +cat > conftest.$ac_ext <&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:1866: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* __sunpro_c=yes else @@ -2147,7 +2140,7 @@ fi echo $ac_n "checking for dynodump""... $ac_c" 1>&6 -echo "configure:2151: checking for dynodump" >&5 +echo "configure:2144: checking for dynodump" >&5 if test "$unexec" != "unexsol2.o"; then echo "$ac_t""no" 1>&6 else @@ -2243,19 +2236,19 @@ if test "$add_runtime_path" = "yes"; then echo $ac_n "checking "for runtime libraries flag"""... $ac_c" 1>&6 -echo "configure:2247: checking "for runtime libraries flag"" >&5 +echo "configure:2240: checking "for runtime libraries flag"" >&5 dash_r="" for try_dash_r in "-R" "-R " "-rpath "; do xe_check_libs="${try_dash_r}/no/such/file-or-directory" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +#line 2245 "configure" +#include "confdefs.h" + +int main() { + +; return 0; } +EOF +if { (eval echo configure:2252: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* dash_r="$try_dash_r" else @@ -2353,7 +2346,7 @@ # Extract the first word of "ranlib", so it can be a program name with args. set dummy ranlib; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:2357: checking for $ac_word" >&5 +echo "configure:2350: checking for $ac_word" >&5 if test -n "$RANLIB"; then ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. @@ -2406,7 +2399,7 @@ # SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" # ./install, which can be erroneously created by make from ./install.sh. echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6 -echo "configure:2410: checking for a BSD compatible install" >&5 +echo "configure:2403: checking for a BSD compatible install" >&5 if test -z "$INSTALL"; then IFS="${IFS= }"; ac_save_IFS="$IFS"; IFS="${IFS}:" @@ -2457,7 +2450,7 @@ # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:2461: checking for $ac_word" >&5 +echo "configure:2454: checking for $ac_word" >&5 if test -n "$YACC"; then ac_cv_prog_YACC="$YACC" # Let the user override the test. @@ -2488,15 +2481,15 @@ do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:2492: checking for $ac_hdr" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2500: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2493: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -2529,15 +2522,15 @@ do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:2533: checking for $ac_hdr" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2541: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2534: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -2570,15 +2563,15 @@ do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:2574: checking for $ac_hdr" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2582: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2575: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -2608,10 +2601,10 @@ done echo $ac_n "checking for sys/wait.h that is POSIX.1 compatible""... $ac_c" 1>&6 -echo "configure:2612: checking for sys/wait.h that is POSIX.1 compatible" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #include @@ -2627,7 +2620,7 @@ s = WIFEXITED (s) ? WEXITSTATUS (s) : 1; ; return 0; } EOF -if { (eval echo configure:2631: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:2624: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_header_sys_wait_h=yes else @@ -2651,10 +2644,10 @@ fi echo $ac_n "checking for ANSI C header files""... $ac_c" 1>&6 -echo "configure:2655: checking for ANSI C header files" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #include @@ -2662,7 +2655,7 @@ #include EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2666: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2659: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -2679,7 +2672,7 @@ if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat > conftest.$ac_ext < EOF @@ -2697,7 +2690,7 @@ if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. cat > conftest.$ac_ext < EOF @@ -2715,7 +2708,7 @@ if test $ac_cv_header_stdc = yes; then # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. cat > conftest.$ac_ext < #define ISLOWER(c) ('a' <= (c) && (c) <= 'z') @@ -2726,7 +2719,7 @@ exit (0); } EOF -if { (eval echo configure:2730: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:2723: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then : else @@ -2751,10 +2744,10 @@ fi echo $ac_n "checking whether time.h and sys/time.h may both be included""... $ac_c" 1>&6 -echo "configure:2755: checking whether time.h and sys/time.h may both be included" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #include @@ -2763,7 +2756,7 @@ struct tm *tp; ; return 0; } EOF -if { (eval echo configure:2767: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:2760: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_header_time=yes else @@ -2787,10 +2780,10 @@ fi echo $ac_n "checking for sys_siglist declaration in signal.h or unistd.h""... $ac_c" 1>&6 -echo "configure:2791: checking for sys_siglist declaration in signal.h or unistd.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #include @@ -2802,7 +2795,7 @@ char *msg = *(sys_siglist + 1); ; return 0; } EOF -if { (eval echo configure:2806: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:2799: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_decl_sys_siglist=yes else @@ -2827,9 +2820,9 @@ echo $ac_n "checking for struct utimbuf""... $ac_c" 1>&6 -echo "configure:2831: checking for struct utimbuf" >&5 -cat > conftest.$ac_ext <&5 +cat > conftest.$ac_ext < @@ -2848,7 +2841,7 @@ static struct utimbuf x; x.actime = x.modtime; ; return 0; } EOF -if { (eval echo configure:2852: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:2845: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* echo "$ac_t""yes" 1>&6 { test "$extra_verbose" = "yes" && cat << \EOF @@ -2868,10 +2861,10 @@ rm -f conftest* echo $ac_n "checking return type of signal handlers""... $ac_c" 1>&6 -echo "configure:2872: checking return type of signal handlers" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #include @@ -2888,7 +2881,7 @@ int i; ; return 0; } EOF -if { (eval echo configure:2892: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:2885: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_type_signal=void else @@ -2910,10 +2903,10 @@ echo $ac_n "checking for size_t""... $ac_c" 1>&6 -echo "configure:2914: checking for size_t" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #if STDC_HEADERS @@ -2944,10 +2937,10 @@ fi echo $ac_n "checking for pid_t""... $ac_c" 1>&6 -echo "configure:2948: checking for pid_t" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #if STDC_HEADERS @@ -2978,10 +2971,10 @@ fi echo $ac_n "checking for uid_t in sys/types.h""... $ac_c" 1>&6 -echo "configure:2982: checking for uid_t in sys/types.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF @@ -3017,10 +3010,10 @@ fi echo $ac_n "checking for mode_t""... $ac_c" 1>&6 -echo "configure:3021: checking for mode_t" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #if STDC_HEADERS @@ -3051,10 +3044,10 @@ fi echo $ac_n "checking for off_t""... $ac_c" 1>&6 -echo "configure:3055: checking for off_t" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #if STDC_HEADERS @@ -3086,9 +3079,9 @@ echo $ac_n "checking for struct timeval""... $ac_c" 1>&6 -echo "configure:3090: checking for struct timeval" >&5 -cat > conftest.$ac_ext <&5 +cat > conftest.$ac_ext < @@ -3104,7 +3097,7 @@ static struct timeval x; x.tv_sec = x.tv_usec; ; return 0; } EOF -if { (eval echo configure:3108: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3101: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* echo "$ac_t""yes" 1>&6 HAVE_TIMEVAL=yes @@ -3126,10 +3119,10 @@ rm -f conftest* echo $ac_n "checking whether struct tm is in sys/time.h or time.h""... $ac_c" 1>&6 -echo "configure:3130: checking whether struct tm is in sys/time.h or time.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #include @@ -3137,7 +3130,7 @@ struct tm *tp; tp->tm_sec; ; return 0; } EOF -if { (eval echo configure:3141: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3134: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_struct_tm=time.h else @@ -3161,10 +3154,10 @@ fi echo $ac_n "checking for tm_zone in struct tm""... $ac_c" 1>&6 -echo "configure:3165: checking for tm_zone in struct tm" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #include <$ac_cv_struct_tm> @@ -3172,7 +3165,7 @@ struct tm tm; tm.tm_zone; ; return 0; } EOF -if { (eval echo configure:3176: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3169: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_struct_tm_zone=yes else @@ -3195,10 +3188,10 @@ else echo $ac_n "checking for tzname""... $ac_c" 1>&6 -echo "configure:3199: checking for tzname" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #ifndef tzname /* For SGI. */ @@ -3208,7 +3201,7 @@ atoi(*tzname); ; return 0; } EOF -if { (eval echo configure:3212: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:3205: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_cv_var_tzname=yes else @@ -3234,10 +3227,10 @@ echo $ac_n "checking for working const""... $ac_c" 1>&6 -echo "configure:3238: checking for working const" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3283: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_c_const=yes else @@ -3311,7 +3304,7 @@ echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6 -echo "configure:3315: checking whether ${MAKE-make} sets \${MAKE}" >&5 +echo "configure:3308: checking whether ${MAKE-make} sets \${MAKE}" >&5 set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'` cat > conftestmake <<\EOF @@ -3336,12 +3329,12 @@ echo $ac_n "checking whether byte ordering is bigendian""... $ac_c" 1>&6 -echo "configure:3340: checking whether byte ordering is bigendian" >&5 +echo "configure:3333: checking whether byte ordering is bigendian" >&5 ac_cv_c_bigendian=unknown # See if sys/param.h defines the BYTE_ORDER macro. cat > conftest.$ac_ext < #include @@ -3352,11 +3345,11 @@ #endif ; return 0; } EOF -if { (eval echo configure:3356: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3349: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* # It does; now see whether it defined to BIG_ENDIAN or not. cat > conftest.$ac_ext < #include @@ -3367,7 +3360,7 @@ #endif ; return 0; } EOF -if { (eval echo configure:3371: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3364: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_c_bigendian=yes else @@ -3384,7 +3377,7 @@ rm -f conftest* if test $ac_cv_c_bigendian = unknown; then cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:3394: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_c_bigendian=no else @@ -3423,10 +3416,10 @@ echo $ac_n "checking size of short""... $ac_c" 1>&6 -echo "configure:3427: checking size of short" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < main() @@ -3437,7 +3430,7 @@ exit(0); } EOF -if { (eval echo configure:3441: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:3434: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_sizeof_short=`cat conftestval` else @@ -3464,10 +3457,10 @@ exit 1 fi echo $ac_n "checking size of int""... $ac_c" 1>&6 -echo "configure:3468: checking size of int" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < main() @@ -3478,7 +3471,7 @@ exit(0); } EOF -if { (eval echo configure:3482: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:3475: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_sizeof_int=`cat conftestval` else @@ -3499,10 +3492,10 @@ echo $ac_n "checking size of long""... $ac_c" 1>&6 -echo "configure:3503: checking size of long" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < main() @@ -3513,7 +3506,7 @@ exit(0); } EOF -if { (eval echo configure:3517: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:3510: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_sizeof_long=`cat conftestval` else @@ -3534,10 +3527,10 @@ echo $ac_n "checking size of long long""... $ac_c" 1>&6 -echo "configure:3538: checking size of long long" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < main() @@ -3548,7 +3541,7 @@ exit(0); } EOF -if { (eval echo configure:3552: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:3545: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_sizeof_long_long=`cat conftestval` else @@ -3569,10 +3562,10 @@ echo $ac_n "checking size of void *""... $ac_c" 1>&6 -echo "configure:3573: checking size of void *" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < main() @@ -3583,7 +3576,7 @@ exit(0); } EOF -if { (eval echo configure:3587: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:3580: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_sizeof_void_p=`cat conftestval` else @@ -3605,7 +3598,7 @@ echo $ac_n "checking for long file names""... $ac_c" 1>&6 -echo "configure:3609: checking for long file names" >&5 +echo "configure:3602: checking for long file names" >&5 ac_cv_sys_long_file_names=yes # Test for long file names in all the places we know might matter: @@ -3652,12 +3645,12 @@ echo $ac_n "checking for sin in -lm""... $ac_c" 1>&6 -echo "configure:3656: checking for sin in -lm" >&5 +echo "configure:3649: checking for sin in -lm" >&5 ac_lib_var=`echo m'_'sin | sed 'y%./+-%__p_%'` xe_check_libs=" -lm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:3665: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -3710,7 +3703,7 @@ echo "checking type of mail spool file locking" 1>&6 -echo "configure:3714: checking type of mail spool file locking" >&5 +echo "configure:3707: checking type of mail spool file locking" >&5 test -z "$mail_locking" -a "$mail_use_flock" = "yes" && mail_locking=flock test -z "$mail_locking" -a "$mail_use_lockf" = "yes" && mail_locking=lockf if test "$mail_locking" = "lockf"; then { test "$extra_verbose" = "yes" && cat << \EOF @@ -3734,12 +3727,12 @@ echo $ac_n "checking for kstat_open in -lkstat""... $ac_c" 1>&6 -echo "configure:3738: checking for kstat_open in -lkstat" >&5 +echo "configure:3731: checking for kstat_open in -lkstat" >&5 ac_lib_var=`echo kstat'_'kstat_open | sed 'y%./+-%__p_%'` xe_check_libs=" -lkstat " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:3747: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -3784,12 +3777,12 @@ echo $ac_n "checking for kvm_read in -lkvm""... $ac_c" 1>&6 -echo "configure:3788: checking for kvm_read in -lkvm" >&5 +echo "configure:3781: checking for kvm_read in -lkvm" >&5 ac_lib_var=`echo kvm'_'kvm_read | sed 'y%./+-%__p_%'` xe_check_libs=" -lkvm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:3797: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -3834,12 +3827,12 @@ echo $ac_n "checking for cma_open in -lpthreads""... $ac_c" 1>&6 -echo "configure:3838: checking for cma_open in -lpthreads" >&5 +echo "configure:3831: checking for cma_open in -lpthreads" >&5 ac_lib_var=`echo pthreads'_'cma_open | sed 'y%./+-%__p_%'` xe_check_libs=" -lpthreads " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:3847: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -3886,7 +3879,7 @@ fi echo $ac_n "checking whether the -xildoff compiler flag is required""... $ac_c" 1>&6 -echo "configure:3890: checking whether the -xildoff compiler flag is required" >&5 +echo "configure:3883: checking whether the -xildoff compiler flag is required" >&5 if ${CC-cc} '-###' -xildon no_such_file.c 2>&1 | grep '^[^ ]*/ild ' > /dev/null ; then if ${CC-cc} '-###' -xildoff no_such_file.c 2>&1 | grep '^[^ ]*/ild ' > /dev/null ; then echo "$ac_t""no" 1>&6; @@ -3897,7 +3890,7 @@ if test "$opsys" = "sol2" && test "$OS_RELEASE" -ge 56; then echo $ac_n "checking for \"-z ignore\" linker flag""... $ac_c" 1>&6 -echo "configure:3901: checking for \"-z ignore\" linker flag" >&5 +echo "configure:3894: checking for \"-z ignore\" linker flag" >&5 case "`ld -h 2>&1`" in *-z\ ignore\|record* ) echo "$ac_t""yes" 1>&6 ld_switch_site="-z ignore $ld_switch_site" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-z ignore\" to \$ld_switch_site"; fi ;; @@ -3907,7 +3900,7 @@ echo "checking "for specified window system"" 1>&6 -echo "configure:3911: checking "for specified window system"" >&5 +echo "configure:3904: checking "for specified window system"" >&5 if test "$with_x11" != "no"; then test "$x_includes $x_libraries" != "NONE NONE" && \ @@ -3937,7 +3930,7 @@ # Uses ac_ vars as temps to allow command line to override cache and checks. # --without-x overrides everything else, but does not touch the cache. echo $ac_n "checking for X""... $ac_c" 1>&6 -echo "configure:3941: checking for X" >&5 +echo "configure:3934: checking for X" >&5 # Check whether --with-x or --without-x was given. if test "${with_x+set}" = set; then @@ -3997,12 +3990,12 @@ # First, try using that file with no special directory specified. cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:4006: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:3999: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -4071,14 +4064,14 @@ ac_save_LIBS="$LIBS" LIBS="-l$x_direct_test_library $LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4075: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* LIBS="$ac_save_LIBS" # We can link X programs with no special library path. @@ -4187,17 +4180,17 @@ case "`(uname -sr) 2>/dev/null`" in "SunOS 5"*) echo $ac_n "checking whether -R must be followed by a space""... $ac_c" 1>&6 -echo "configure:4191: checking whether -R must be followed by a space" >&5 +echo "configure:4184: checking whether -R must be followed by a space" >&5 ac_xsave_LIBS="$LIBS"; LIBS="$LIBS -R$x_libraries" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +#line 4187 "configure" +#include "confdefs.h" + +int main() { + +; return 0; } +EOF +if { (eval echo configure:4194: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_R_nospace=yes else @@ -4213,14 +4206,14 @@ else LIBS="$ac_xsave_LIBS -R $x_libraries" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +#line 4210 "configure" +#include "confdefs.h" + +int main() { + +; return 0; } +EOF +if { (eval echo configure:4217: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_R_space=yes else @@ -4256,12 +4249,12 @@ else echo $ac_n "checking for dnet_ntoa in -ldnet""... $ac_c" 1>&6 -echo "configure:4260: checking for dnet_ntoa in -ldnet" >&5 +echo "configure:4253: checking for dnet_ntoa in -ldnet" >&5 ac_lib_var=`echo dnet'_'dnet_ntoa | sed 'y%./+-%__p_%'` xe_check_libs=" -ldnet " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4269: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4296,12 +4289,12 @@ if test $ac_cv_lib_dnet_dnet_ntoa = no; then echo $ac_n "checking for dnet_ntoa in -ldnet_stub""... $ac_c" 1>&6 -echo "configure:4300: checking for dnet_ntoa in -ldnet_stub" >&5 +echo "configure:4293: checking for dnet_ntoa in -ldnet_stub" >&5 ac_lib_var=`echo dnet_stub'_'dnet_ntoa | sed 'y%./+-%__p_%'` xe_check_libs=" -ldnet_stub " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4309: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4341,10 +4334,10 @@ # The nsl library prevents programs from opening the X display # on Irix 5.2, according to dickey@clark.net. echo $ac_n "checking for gethostbyname""... $ac_c" 1>&6 -echo "configure:4345: checking for gethostbyname" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4364: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_gethostbyname=yes" else @@ -4388,12 +4381,12 @@ if test $ac_cv_func_gethostbyname = no; then echo $ac_n "checking for gethostbyname in -lnsl""... $ac_c" 1>&6 -echo "configure:4392: checking for gethostbyname in -lnsl" >&5 +echo "configure:4385: checking for gethostbyname in -lnsl" >&5 ac_lib_var=`echo nsl'_'gethostbyname | sed 'y%./+-%__p_%'` xe_check_libs=" -lnsl " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4401: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4434,10 +4427,10 @@ # -lsocket must be given before -lnsl if both are needed. # We assume that if connect needs -lnsl, so does gethostbyname. echo $ac_n "checking for connect""... $ac_c" 1>&6 -echo "configure:4438: checking for connect" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4457: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_connect=yes" else @@ -4483,12 +4476,12 @@ xe_msg_checking="for connect in -lsocket" test -n "$X_EXTRA_LIBS" && xe_msg_checking="$xe_msg_checking using extra libs $X_EXTRA_LIBS" echo $ac_n "checking "$xe_msg_checking"""... $ac_c" 1>&6 -echo "configure:4487: checking "$xe_msg_checking"" >&5 +echo "configure:4480: checking "$xe_msg_checking"" >&5 ac_lib_var=`echo socket'_'connect | sed 'y%./+-%__p_%'` xe_check_libs=" -lsocket $X_EXTRA_LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4496: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4523,10 +4516,10 @@ # gomez@mi.uni-erlangen.de says -lposix is necessary on A/UX. echo $ac_n "checking for remove""... $ac_c" 1>&6 -echo "configure:4527: checking for remove" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4546: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_remove=yes" else @@ -4570,12 +4563,12 @@ if test $ac_cv_func_remove = no; then echo $ac_n "checking for remove in -lposix""... $ac_c" 1>&6 -echo "configure:4574: checking for remove in -lposix" >&5 +echo "configure:4567: checking for remove in -lposix" >&5 ac_lib_var=`echo posix'_'remove | sed 'y%./+-%__p_%'` xe_check_libs=" -lposix " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4583: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4610,10 +4603,10 @@ # BSDI BSD/OS 2.1 needs -lipc for XOpenDisplay. echo $ac_n "checking for shmat""... $ac_c" 1>&6 -echo "configure:4614: checking for shmat" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4633: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_shmat=yes" else @@ -4657,12 +4650,12 @@ if test $ac_cv_func_shmat = no; then echo $ac_n "checking for shmat in -lipc""... $ac_c" 1>&6 -echo "configure:4661: checking for shmat in -lipc" >&5 +echo "configure:4654: checking for shmat in -lipc" >&5 ac_lib_var=`echo ipc'_'shmat | sed 'y%./+-%__p_%'` xe_check_libs=" -lipc " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4670: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4707,12 +4700,12 @@ # --interran@uluru.Stanford.EDU, kb@cs.umb.edu. echo $ac_n "checking for IceConnectionNumber in -lICE""... $ac_c" 1>&6 -echo "configure:4711: checking for IceConnectionNumber in -lICE" >&5 +echo "configure:4704: checking for IceConnectionNumber in -lICE" >&5 ac_lib_var=`echo ICE'_'IceConnectionNumber | sed 'y%./+-%__p_%'` xe_check_libs=" -lICE " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4720: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4856,7 +4849,7 @@ fi echo "checking for X defines extracted by xmkmf" 1>&6 -echo "configure:4860: checking for X defines extracted by xmkmf" >&5 +echo "configure:4853: checking for X defines extracted by xmkmf" >&5 rm -fr conftestdir if mkdir conftestdir; then cd conftestdir @@ -4888,15 +4881,15 @@ ac_safe=`echo "X11/Intrinsic.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for X11/Intrinsic.h""... $ac_c" 1>&6 -echo "configure:4892: checking for X11/Intrinsic.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:4900: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:4893: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -4920,12 +4913,12 @@ echo $ac_n "checking for XOpenDisplay in -lX11""... $ac_c" 1>&6 -echo "configure:4924: checking for XOpenDisplay in -lX11" >&5 +echo "configure:4917: checking for XOpenDisplay in -lX11" >&5 ac_lib_var=`echo X11'_'XOpenDisplay | sed 'y%./+-%__p_%'` xe_check_libs=" -lX11 " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4933: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4961,12 +4954,12 @@ xe_msg_checking="for XGetFontProperty in -lX11" test -n "-b i486-linuxaout" && xe_msg_checking="$xe_msg_checking using extra libs -b i486-linuxaout" echo $ac_n "checking "$xe_msg_checking"""... $ac_c" 1>&6 -echo "configure:4965: checking "$xe_msg_checking"" >&5 +echo "configure:4958: checking "$xe_msg_checking"" >&5 ac_lib_var=`echo X11'_'XGetFontProperty | sed 'y%./+-%__p_%'` xe_check_libs=" -lX11 -b i486-linuxaout" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4974: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5004,12 +4997,12 @@ echo $ac_n "checking for XShapeSelectInput in -lXext""... $ac_c" 1>&6 -echo "configure:5008: checking for XShapeSelectInput in -lXext" >&5 +echo "configure:5001: checking for XShapeSelectInput in -lXext" >&5 ac_lib_var=`echo Xext'_'XShapeSelectInput | sed 'y%./+-%__p_%'` xe_check_libs=" -lXext " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5017: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5043,12 +5036,12 @@ echo $ac_n "checking for XtOpenDisplay in -lXt""... $ac_c" 1>&6 -echo "configure:5047: checking for XtOpenDisplay in -lXt" >&5 +echo "configure:5040: checking for XtOpenDisplay in -lXt" >&5 ac_lib_var=`echo Xt'_'XtOpenDisplay | sed 'y%./+-%__p_%'` xe_check_libs=" -lXt " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5056: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5082,14 +5075,14 @@ echo $ac_n "checking the version of X11 being used""... $ac_c" 1>&6 -echo "configure:5086: checking the version of X11 being used" >&5 +echo "configure:5079: checking the version of X11 being used" >&5 cat > conftest.$ac_ext < main(int c, char* v[]) { return c>1 ? XlibSpecificationRelease : 0; } EOF -if { (eval echo configure:5093: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:5086: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ./conftest foobar; x11_release=$? else @@ -5113,15 +5106,15 @@ do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:5117: checking for $ac_hdr" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5125: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5118: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -5152,7 +5145,7 @@ echo $ac_n "checking for XFree86""... $ac_c" 1>&6 -echo "configure:5156: checking for XFree86" >&5 +echo "configure:5149: checking for XFree86" >&5 if test -d "/usr/X386/include" -o \ -f "/etc/XF86Config" -o \ -f "/etc/X11/XF86Config" -o \ @@ -5172,12 +5165,12 @@ test -z "$with_xmu" && { echo $ac_n "checking for XmuReadBitmapDataFromFile in -lXmu""... $ac_c" 1>&6 -echo "configure:5176: checking for XmuReadBitmapDataFromFile in -lXmu" >&5 +echo "configure:5169: checking for XmuReadBitmapDataFromFile in -lXmu" >&5 ac_lib_var=`echo Xmu'_'XmuReadBitmapDataFromFile | sed 'y%./+-%__p_%'` xe_check_libs=" -lXmu " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5185: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5227,19 +5220,19 @@ echo $ac_n "checking for main in -lXbsd""... $ac_c" 1>&6 -echo "configure:5231: checking for main in -lXbsd" >&5 +echo "configure:5224: checking for main in -lXbsd" >&5 ac_lib_var=`echo Xbsd'_'main | sed 'y%./+-%__p_%'` xe_check_libs=" -lXbsd " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5236: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5293,7 +5286,7 @@ esac echo "checking for session-management option" 1>&6 -echo "configure:5297: checking for session-management option" >&5; +echo "configure:5290: checking for session-management option" >&5; if test "$with_session" = "yes"; then { test "$extra_verbose" = "yes" && cat << \EOF Defining HAVE_SESSION @@ -5308,15 +5301,15 @@ test -z "$with_xauth" && test "$window_system" = "none" && with_xauth=no test -z "$with_xauth" && { ac_safe=`echo "X11/Xauth.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for X11/Xauth.h""... $ac_c" 1>&6 -echo "configure:5312: checking for X11/Xauth.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5320: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5313: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -5339,12 +5332,12 @@ } test -z "$with_xauth" && { echo $ac_n "checking for XauGetAuthByAddr in -lXau""... $ac_c" 1>&6 -echo "configure:5343: checking for XauGetAuthByAddr in -lXau" >&5 +echo "configure:5336: checking for XauGetAuthByAddr in -lXau" >&5 ac_lib_var=`echo Xau'_'XauGetAuthByAddr | sed 'y%./+-%__p_%'` xe_check_libs=" -lXau " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5352: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5415,15 +5408,15 @@ for dir in "" "Tt/" "desktop/" ; do ac_safe=`echo "${dir}tt_c.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for ${dir}tt_c.h""... $ac_c" 1>&6 -echo "configure:5419: checking for ${dir}tt_c.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5427: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5420: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -5452,12 +5445,12 @@ xe_msg_checking="for tt_message_create in -ltt" test -n "$extra_libs" && xe_msg_checking="$xe_msg_checking using extra libs $extra_libs" echo $ac_n "checking "$xe_msg_checking"""... $ac_c" 1>&6 -echo "configure:5456: checking "$xe_msg_checking"" >&5 +echo "configure:5449: checking "$xe_msg_checking"" >&5 ac_lib_var=`echo tt'_'tt_message_create | sed 'y%./+-%__p_%'` xe_check_libs=" -ltt $extra_libs" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5465: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5517,15 +5510,15 @@ test -z "$with_cde" && { ac_safe=`echo "Dt/Dt.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for Dt/Dt.h""... $ac_c" 1>&6 -echo "configure:5521: checking for Dt/Dt.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5529: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5522: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -5548,12 +5541,12 @@ } test -z "$with_cde" && { echo $ac_n "checking for DtDndDragStart in -lDtSvc""... $ac_c" 1>&6 -echo "configure:5552: checking for DtDndDragStart in -lDtSvc" >&5 +echo "configure:5545: checking for DtDndDragStart in -lDtSvc" >&5 ac_lib_var=`echo DtSvc'_'DtDndDragStart | sed 'y%./+-%__p_%'` xe_check_libs=" -lDtSvc " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5561: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5600,164 +5593,16 @@ need_motif=yes # CDE requires Motif fi -if test "$with_energize" = "yes" ; then - { test "$extra_verbose" = "yes" && cat << \EOF - Defining ENERGIZE -EOF -cat >> confdefs.h <<\EOF -#define ENERGIZE 1 -EOF -} - - -echo $ac_n "checking for main in -lenergize""... $ac_c" 1>&6 -echo "configure:5615: checking for main in -lenergize" >&5 -ac_lib_var=`echo energize'_'main | sed 'y%./+-%__p_%'` - -xe_check_libs=" -lenergize " -cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=no" -fi -rm -f conftest* -xe_check_libs="" - -if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes" ; then - echo "$ac_t""yes" 1>&6 - LIBS="-lenergize $LIBS" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-lenergize\" to \$LIBS"; fi - energize_version="3.X" - { test "$extra_verbose" = "yes" && cat << \EOF - Defining ENERGIZE_3 -EOF -cat >> confdefs.h <<\EOF -#define ENERGIZE_3 1 -EOF -} - -else - echo "$ac_t""no" 1>&6 -fi - - - if test -z "$energize_version"; then - -echo $ac_n "checking for main in -lconn""... $ac_c" 1>&6 -echo "configure:5659: checking for main in -lconn" >&5 -ac_lib_var=`echo conn'_'main | sed 'y%./+-%__p_%'` - -xe_check_libs=" -lconn " -cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=no" -fi -rm -f conftest* -xe_check_libs="" - -if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes" ; then - echo "$ac_t""yes" 1>&6 - LIBS="-lconn $LIBS" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-lconn\" to \$LIBS"; fi - energize_version="2.X" - { test "$extra_verbose" = "yes" && cat << \EOF - Defining ENERGIZE_2 -EOF -cat >> confdefs.h <<\EOF -#define ENERGIZE_2 1 -EOF -} - -else - echo "$ac_t""no" 1>&6 -{ echo "configure: error: Unable to find Energize library." 1>&2; exit 1; } -fi - - - fi - ac_safe=`echo "editorconn.h" | sed 'y%./+-%__p_%'` -echo $ac_n "checking for editorconn.h""... $ac_c" 1>&6 -echo "configure:5704: checking for editorconn.h" >&5 - -cat > conftest.$ac_ext < -EOF -ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5712: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } -ac_err=`grep -v '^ *+' conftest.out` -if test -z "$ac_err"; then - rm -rf conftest* - eval "ac_cv_header_$ac_safe=yes" -else - echo "$ac_err" >&5 - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_header_$ac_safe=no" -fi -rm -f conftest* -if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then - echo "$ac_t""yes" 1>&6 - : -else - echo "$ac_t""no" 1>&6 -{ echo "configure: error: Unable to find Energize editorconn.h header file." 1>&2; exit 1; } -fi - - - test "$energize_version" = "2.X" && { test "$extra_verbose" = "yes" && cat << \EOF - Defining ENERGIZE_2 -EOF -cat >> confdefs.h <<\EOF -#define ENERGIZE_2 1 -EOF -} - - test "$energize_version" = "3.X" && { test "$extra_verbose" = "yes" && cat << \EOF - Defining ENERGIZE_3 -EOF -cat >> confdefs.h <<\EOF -#define ENERGIZE_3 1 -EOF -} - -fi - if test "$with_x11" = "yes"; then echo "checking for X11 graphics libraries" 1>&6 -echo "configure:5756: checking for X11 graphics libraries" >&5 +echo "configure:5601: checking for X11 graphics libraries" >&5 echo $ac_n "checking for Xpm - no older than 3.4f""... $ac_c" 1>&6 -echo "configure:5758: checking for Xpm - no older than 3.4f" >&5 +echo "configure:5603: checking for Xpm - no older than 3.4f" >&5 xe_check_libs=-lXpm test -z "$with_xpm" && { cat > conftest.$ac_ext < int main(int c, char **v) { @@ -5767,7 +5612,7 @@ 0 ; } EOF -if { (eval echo configure:5771: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:5616: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ./conftest foobar; xpm_status=$?; if test "$xpm_status" = "0"; then with_xpm=yes; else with_xpm=no; fi; @@ -5805,15 +5650,15 @@ test -z "$with_xface" && { ac_safe=`echo "compface.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for compface.h""... $ac_c" 1>&6 -echo "configure:5809: checking for compface.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5817: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5662: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -5836,12 +5681,12 @@ } test -z "$with_xface" && { echo $ac_n "checking for UnGenFace in -lcompface""... $ac_c" 1>&6 -echo "configure:5840: checking for UnGenFace in -lcompface" >&5 +echo "configure:5685: checking for UnGenFace in -lcompface" >&5 ac_lib_var=`echo compface'_'UnGenFace | sed 'y%./+-%__p_%'` xe_check_libs=" -lcompface " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5701: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5888,15 +5733,15 @@ test -z "$with_imagick" && { ac_safe=`echo "magick/magick.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for magick/magick.h""... $ac_c" 1>&6 -echo "configure:5892: checking for magick/magick.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5900: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5745: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -5917,14 +5762,400 @@ with_imagick=no fi } + test -z "$with_imagick" && { + imagick_libs="" + +echo $ac_n "checking for XDPSPixelsPerPoint in -ldps""... $ac_c" 1>&6 +echo "configure:5770: checking for XDPSPixelsPerPoint in -ldps" >&5 +ac_lib_var=`echo dps'_'XDPSPixelsPerPoint | sed 'y%./+-%__p_%'` + +xe_check_libs="-ldpstk -ldps " +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=no" +fi +rm -f conftest* +xe_check_libs="" + +if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes" ; then + echo "$ac_t""yes" 1>&6 + imagick_libs="$imagick_libs -ldpstk -ldps" && if test "$extra_verbose" = "yes"; then echo " Appending \"-ldpstk -ldps\" to \$imagick_libs"; fi +else + echo "$ac_t""no" 1>&6 +fi + + + +echo $ac_n "checking for FPX_SetToolkitMemoryLimit in -lfpx""... $ac_c" 1>&6 +echo "configure:5808: checking for FPX_SetToolkitMemoryLimit in -lfpx" >&5 +ac_lib_var=`echo fpx'_'FPX_SetToolkitMemoryLimit | sed 'y%./+-%__p_%'` + +xe_check_libs=" -lfpx " +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=no" +fi +rm -f conftest* +xe_check_libs="" + +if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes" ; then + echo "$ac_t""yes" 1>&6 + imagick_libs="$imagick_libs -lfpx" && if test "$extra_verbose" = "yes"; then echo " Appending \"-lfpx\" to \$imagick_libs"; fi +else + echo "$ac_t""no" 1>&6 +fi + + + +echo $ac_n "checking for DF24getdims in -ldf""... $ac_c" 1>&6 +echo "configure:5846: checking for DF24getdims in -ldf" >&5 +ac_lib_var=`echo df'_'DF24getdims | sed 'y%./+-%__p_%'` + +xe_check_libs=" -ldf " +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=no" +fi +rm -f conftest* +xe_check_libs="" + +if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes" ; then + echo "$ac_t""yes" 1>&6 + imagick_libs="$imagick_libs -ldf" && if test "$extra_verbose" = "yes"; then echo " Appending \"-ldf\" to \$imagick_libs"; fi +else + echo "$ac_t""no" 1>&6 +fi + + + +echo $ac_n "checking for jbg_dec_init in -ljbig""... $ac_c" 1>&6 +echo "configure:5884: checking for jbg_dec_init in -ljbig" >&5 +ac_lib_var=`echo jbig'_'jbg_dec_init | sed 'y%./+-%__p_%'` + +xe_check_libs=" -ljbig " +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=no" +fi +rm -f conftest* +xe_check_libs="" + +if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes" ; then + echo "$ac_t""yes" 1>&6 + imagick_libs="$imagick_libs -ljbig" && if test "$extra_verbose" = "yes"; then echo " Appending \"-ljbig\" to \$imagick_libs"; fi +else + echo "$ac_t""no" 1>&6 +fi + + + +echo $ac_n "checking for jpeg_read_header in -ljpeg""... $ac_c" 1>&6 +echo "configure:5922: checking for jpeg_read_header in -ljpeg" >&5 +ac_lib_var=`echo jpeg'_'jpeg_read_header | sed 'y%./+-%__p_%'` + +xe_check_libs=" -ljpeg " +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=no" +fi +rm -f conftest* +xe_check_libs="" + +if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes" ; then + echo "$ac_t""yes" 1>&6 + imagick_libs="$imagick_libs -ljpeg" && if test "$extra_verbose" = "yes"; then echo " Appending \"-ljpeg\" to \$imagick_libs"; fi +else + echo "$ac_t""no" 1>&6 +fi + + + +echo $ac_n "checking for OpenMPEG in -lmpeg""... $ac_c" 1>&6 +echo "configure:5960: checking for OpenMPEG in -lmpeg" >&5 +ac_lib_var=`echo mpeg'_'OpenMPEG | sed 'y%./+-%__p_%'` + +xe_check_libs=" -lmpeg " +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=no" +fi +rm -f conftest* +xe_check_libs="" + +if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes" ; then + echo "$ac_t""yes" 1>&6 + imagick_libs="$imagick_libs -lmpeg" && if test "$extra_verbose" = "yes"; then echo " Appending \"-lmpeg\" to \$imagick_libs"; fi +else + echo "$ac_t""no" 1>&6 +fi + + + +echo $ac_n "checking for png_create_read_struct in -lpng""... $ac_c" 1>&6 +echo "configure:5998: checking for png_create_read_struct in -lpng" >&5 +ac_lib_var=`echo png'_'png_create_read_struct | sed 'y%./+-%__p_%'` + +xe_check_libs=" -lpng " +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=no" +fi +rm -f conftest* +xe_check_libs="" + +if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes" ; then + echo "$ac_t""yes" 1>&6 + imagick_libs="$imagick_libs -lpng" && if test "$extra_verbose" = "yes"; then echo " Appending \"-lpng\" to \$imagick_libs"; fi +else + echo "$ac_t""no" 1>&6 +xe_msg_checking="for png_create_read_struct in -lpng" +test -n "-lz" && xe_msg_checking="$xe_msg_checking using extra libs -lz" +echo $ac_n "checking "$xe_msg_checking"""... $ac_c" 1>&6 +echo "configure:6034: checking "$xe_msg_checking"" >&5 +ac_lib_var=`echo png'_'png_create_read_struct | sed 'y%./+-%__p_%'` + +xe_check_libs=" -lpng -lz" +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=no" +fi +rm -f conftest* +xe_check_libs="" + +if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes" ; then + echo "$ac_t""yes" 1>&6 + imagick_libs="$imagick_libs -lpng -lz" && if test "$extra_verbose" = "yes"; then echo " Appending \"-lpng -lz\" to \$imagick_libs"; fi +else + echo "$ac_t""no" 1>&6 +fi + + +fi + + + +echo $ac_n "checking for TIFFOpen in -ltiff""... $ac_c" 1>&6 +echo "configure:6075: checking for TIFFOpen in -ltiff" >&5 +ac_lib_var=`echo tiff'_'TIFFOpen | sed 'y%./+-%__p_%'` + +xe_check_libs=" -ltiff " +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=no" +fi +rm -f conftest* +xe_check_libs="" + +if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes" ; then + echo "$ac_t""yes" 1>&6 + imagick_libs="$imagick_libs -ltiff" && if test "$extra_verbose" = "yes"; then echo " Appending \"-ltiff\" to \$imagick_libs"; fi +else + echo "$ac_t""no" 1>&6 +xe_msg_checking="for TIFFOpen in -ltiff" +test -n "-ljpeg -lz" && xe_msg_checking="$xe_msg_checking using extra libs -ljpeg -lz" +echo $ac_n "checking "$xe_msg_checking"""... $ac_c" 1>&6 +echo "configure:6111: checking "$xe_msg_checking"" >&5 +ac_lib_var=`echo tiff'_'TIFFOpen | sed 'y%./+-%__p_%'` + +xe_check_libs=" -ltiff -ljpeg -lz" +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=no" +fi +rm -f conftest* +xe_check_libs="" + +if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes" ; then + echo "$ac_t""yes" 1>&6 + imagick_libs="$imagick_libs -ltiff -ljpeg -lz" && if test "$extra_verbose" = "yes"; then echo " Appending \"-ltiff -ljpeg -lz\" to \$imagick_libs"; fi +else + echo "$ac_t""no" 1>&6 +fi + + +fi + + + libs_x="$libs_x $imagick_libs" && if test "$extra_verbose" = "yes"; then echo " Appending \"$imagick_libs\" to \$libs_x"; fi + } test -z "$with_imagick" && { echo $ac_n "checking for MogrifyImage in -lMagick""... $ac_c" 1>&6 -echo "configure:5923: checking for MogrifyImage in -lMagick" >&5 +echo "configure:6154: checking for MogrifyImage in -lMagick" >&5 ac_lib_var=`echo Magick'_'MogrifyImage | sed 'y%./+-%__p_%'` xe_check_libs=" -lMagick " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6170: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5971,12 +6202,12 @@ echo $ac_n "checking for XawScrollbarSetThumb in -lXaw""... $ac_c" 1>&6 -echo "configure:5975: checking for XawScrollbarSetThumb in -lXaw" >&5 +echo "configure:6206: checking for XawScrollbarSetThumb in -lXaw" >&5 ac_lib_var=`echo Xaw'_'XawScrollbarSetThumb | sed 'y%./+-%__p_%'` xe_check_libs=" -lXaw " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6222: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6011,15 +6242,15 @@ if test "$have_xaw" = "yes"; then ac_safe=`echo "X11/Xaw/Reports.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for X11/Xaw/Reports.h""... $ac_c" 1>&6 -echo "configure:6015: checking for X11/Xaw/Reports.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6023: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6254: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6045,15 +6276,15 @@ ac_safe=`echo "Xm/Xm.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for Xm/Xm.h""... $ac_c" 1>&6 -echo "configure:6049: checking for Xm/Xm.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6057: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6288: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6070,12 +6301,12 @@ echo "$ac_t""yes" 1>&6 echo $ac_n "checking for XmStringFree in -lXm""... $ac_c" 1>&6 -echo "configure:6074: checking for XmStringFree in -lXm" >&5 +echo "configure:6305: checking for XmStringFree in -lXm" >&5 ac_lib_var=`echo Xm'_'XmStringFree | sed 'y%./+-%__p_%'` xe_check_libs=" -lXm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6321: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6348,7 +6579,7 @@ if test "$with_mule" = "yes" ; then echo "checking for Mule-related features" 1>&6 -echo "configure:6352: checking for Mule-related features" >&5 +echo "configure:6583: checking for Mule-related features" >&5 { test "$extra_verbose" = "yes" && cat << \EOF Defining MULE EOF @@ -6365,15 +6596,15 @@ do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:6369: checking for $ac_hdr" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6377: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6608: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6404,12 +6635,12 @@ echo $ac_n "checking for strerror in -lintl""... $ac_c" 1>&6 -echo "configure:6408: checking for strerror in -lintl" >&5 +echo "configure:6639: checking for strerror in -lintl" >&5 ac_lib_var=`echo intl'_'strerror | sed 'y%./+-%__p_%'` xe_check_libs=" -lintl " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6655: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6453,19 +6684,19 @@ echo "checking for Mule input methods" 1>&6 -echo "configure:6457: checking for Mule input methods" >&5 +echo "configure:6688: checking for Mule input methods" >&5 test -z "$with_xim" -a "$opsys" != "sol2" && with_xim=no case "$with_xim" in "" | "yes" ) echo "checking for XIM" 1>&6 -echo "configure:6461: checking for XIM" >&5 +echo "configure:6692: checking for XIM" >&5 echo $ac_n "checking for XmImMbLookupString in -lXm""... $ac_c" 1>&6 -echo "configure:6464: checking for XmImMbLookupString in -lXm" >&5 +echo "configure:6695: checking for XmImMbLookupString in -lXm" >&5 ac_lib_var=`echo Xm'_'XmImMbLookupString | sed 'y%./+-%__p_%'` xe_check_libs=" -lXm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6711: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6541,15 +6772,15 @@ if test "$with_xfs" = "yes" ; then echo "checking for XFontSet" 1>&6 -echo "configure:6545: checking for XFontSet" >&5 +echo "configure:6776: checking for XFontSet" >&5 echo $ac_n "checking for XmbDrawString in -lX11""... $ac_c" 1>&6 -echo "configure:6548: checking for XmbDrawString in -lX11" >&5 +echo "configure:6779: checking for XmbDrawString in -lX11" >&5 ac_lib_var=`echo X11'_'XmbDrawString | sed 'y%./+-%__p_%'` xe_check_libs=" -lX11 " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6795: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6600,15 +6831,15 @@ test "$with_wnn6" = "yes" && with_wnn=yes # wnn6 implies wnn support test -z "$with_wnn" && { ac_safe=`echo "wnn/jllib.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for wnn/jllib.h""... $ac_c" 1>&6 -echo "configure:6604: checking for wnn/jllib.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6612: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6843: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6633,10 +6864,10 @@ for ac_func in crypt do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:6637: checking for $ac_func" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6894: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -6688,12 +6919,12 @@ test "$ac_cv_func_crypt" != "yes" && { echo $ac_n "checking for crypt in -lcrypt""... $ac_c" 1>&6 -echo "configure:6692: checking for crypt in -lcrypt" >&5 +echo "configure:6923: checking for crypt in -lcrypt" >&5 ac_lib_var=`echo crypt'_'crypt | sed 'y%./+-%__p_%'` xe_check_libs=" -lcrypt " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6939: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6738,12 +6969,12 @@ fi test -z "$with_wnn" && { echo $ac_n "checking for jl_dic_list_e in -lwnn""... $ac_c" 1>&6 -echo "configure:6742: checking for jl_dic_list_e in -lwnn" >&5 +echo "configure:6973: checking for jl_dic_list_e in -lwnn" >&5 ac_lib_var=`echo wnn'_'jl_dic_list_e | sed 'y%./+-%__p_%'` xe_check_libs=" -lwnn " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6989: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6791,12 +7022,12 @@ fi echo $ac_n "checking for jl_fi_dic_list in -lwnn""... $ac_c" 1>&6 -echo "configure:6795: checking for jl_fi_dic_list in -lwnn" >&5 +echo "configure:7026: checking for jl_fi_dic_list in -lwnn" >&5 ac_lib_var=`echo wnn'_'jl_fi_dic_list | sed 'y%./+-%__p_%'` xe_check_libs=" -lwnn " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7042: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6839,15 +7070,15 @@ test -z "$with_canna" && { ac_safe=`echo "canna/RK.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for canna/RK.h""... $ac_c" 1>&6 -echo "configure:6843: checking for canna/RK.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6851: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:7082: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6870,12 +7101,12 @@ } test -z "$with_canna" && { echo $ac_n "checking for RkBgnBun in -lRKC""... $ac_c" 1>&6 -echo "configure:6874: checking for RkBgnBun in -lRKC" >&5 +echo "configure:7105: checking for RkBgnBun in -lRKC" >&5 ac_lib_var=`echo RKC'_'RkBgnBun | sed 'y%./+-%__p_%'` xe_check_libs=" -lRKC " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7121: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6909,12 +7140,12 @@ } test -z "$with_canna" && { echo $ac_n "checking for jrKanjiControl in -lcanna""... $ac_c" 1>&6 -echo "configure:6913: checking for jrKanjiControl in -lcanna" >&5 +echo "configure:7144: checking for jrKanjiControl in -lcanna" >&5 ac_lib_var=`echo canna'_'jrKanjiControl | sed 'y%./+-%__p_%'` xe_check_libs=" -lcanna " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7160: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6974,12 +7205,12 @@ libs_x="-lXm $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-lXm\" to \$libs_x"; fi echo $ac_n "checking for layout_object_getvalue in -li18n""... $ac_c" 1>&6 -echo "configure:6978: checking for layout_object_getvalue in -li18n" >&5 +echo "configure:7209: checking for layout_object_getvalue in -li18n" >&5 ac_lib_var=`echo i18n'_'layout_object_getvalue | sed 'y%./+-%__p_%'` xe_check_libs=" -li18n " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7225: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7063,10 +7294,10 @@ for ac_func in acosh asinh atanh cbrt closedir dup2 eaccess fmod fpathconf frexp ftime gethostname getpagesize gettimeofday getcwd getwd logb lrand48 matherr mkdir mktime perror poll random rename res_init rint rmdir select setitimer setpgid setlocale setsid sigblock sighold sigprocmask strcasecmp strerror tzset ulimit usleep utimes waitpid do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:7067: checking for $ac_func" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7324: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -7126,10 +7357,10 @@ for ac_func in realpath do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:7130: checking for $ac_func" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7387: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -7185,16 +7416,16 @@ esac echo $ac_n "checking whether netdb declares h_errno""... $ac_c" 1>&6 -echo "configure:7189: checking whether netdb declares h_errno" >&5 -cat > conftest.$ac_ext <&5 +cat > conftest.$ac_ext < int main() { return h_errno; ; return 0; } EOF -if { (eval echo configure:7198: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7429: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* echo "$ac_t""yes" 1>&6 { test "$extra_verbose" = "yes" && cat << \EOF @@ -7214,16 +7445,16 @@ rm -f conftest* echo $ac_n "checking for sigsetjmp""... $ac_c" 1>&6 -echo "configure:7218: checking for sigsetjmp" >&5 -cat > conftest.$ac_ext <&5 +cat > conftest.$ac_ext < int main() { sigjmp_buf bar; sigsetjmp (bar, 0); ; return 0; } EOF -if { (eval echo configure:7227: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:7458: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* echo "$ac_t""yes" 1>&6 { test "$extra_verbose" = "yes" && cat << \EOF @@ -7243,11 +7474,11 @@ rm -f conftest* echo $ac_n "checking whether localtime caches TZ""... $ac_c" 1>&6 -echo "configure:7247: checking whether localtime caches TZ" >&5 +echo "configure:7478: checking whether localtime caches TZ" >&5 if test "$ac_cv_func_tzset" = "yes"; then cat > conftest.$ac_ext < #if STDC_HEADERS @@ -7282,7 +7513,7 @@ exit (0); } EOF -if { (eval echo configure:7286: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:7517: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then emacs_cv_localtime_cache=no else @@ -7311,9 +7542,9 @@ if test "$HAVE_TIMEVAL" = "yes"; then echo $ac_n "checking whether gettimeofday cannot accept two arguments""... $ac_c" 1>&6 -echo "configure:7315: checking whether gettimeofday cannot accept two arguments" >&5 -cat > conftest.$ac_ext <&5 +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7570: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* echo "$ac_t""no" 1>&6 else @@ -7357,19 +7588,19 @@ echo $ac_n "checking for inline""... $ac_c" 1>&6 -echo "configure:7361: checking for inline" >&5 +echo "configure:7592: checking for inline" >&5 ac_cv_c_inline=no for ac_kw in inline __inline__ __inline; do cat > conftest.$ac_ext <&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:7604: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_c_inline=$ac_kw; break else @@ -7419,17 +7650,17 @@ # The Ultrix 4.2 mips builtin alloca declared by alloca.h only works # for constant arguments. Useless! echo $ac_n "checking for working alloca.h""... $ac_c" 1>&6 -echo "configure:7423: checking for working alloca.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < int main() { char *p = alloca(2 * sizeof(int)); ; return 0; } EOF -if { (eval echo configure:7433: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7664: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_cv_header_alloca_h=yes else @@ -7453,10 +7684,10 @@ fi echo $ac_n "checking for alloca""... $ac_c" 1>&6 -echo "configure:7457: checking for alloca" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7714: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_cv_func_alloca_works=yes else @@ -7518,10 +7749,10 @@ echo $ac_n "checking whether alloca needs Cray hooks""... $ac_c" 1>&6 -echo "configure:7522: checking whether alloca needs Cray hooks" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&6 -echo "configure:7549: checking for $ac_func" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7806: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -7601,10 +7832,10 @@ fi echo $ac_n "checking stack direction for C alloca""... $ac_c" 1>&6 -echo "configure:7605: checking stack direction for C alloca" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:7858: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_c_stack_direction=1 else @@ -7651,15 +7882,15 @@ ac_safe=`echo "vfork.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for vfork.h""... $ac_c" 1>&6 -echo "configure:7655: checking for vfork.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:7663: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:7894: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -7687,10 +7918,10 @@ fi echo $ac_n "checking for working vfork""... $ac_c" 1>&6 -echo "configure:7691: checking for working vfork" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < @@ -7785,7 +8016,7 @@ } } EOF -if { (eval echo configure:7789: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:8020: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_func_vfork_works=yes else @@ -7810,10 +8041,10 @@ echo $ac_n "checking for working strcoll""... $ac_c" 1>&6 -echo "configure:7814: checking for working strcoll" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < main () @@ -7823,7 +8054,7 @@ strcoll ("123", "456") >= 0); } EOF -if { (eval echo configure:7827: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:8058: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_func_strcoll_works=yes else @@ -7850,10 +8081,10 @@ for ac_func in getpgrp do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:7854: checking for $ac_func" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8111: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -7904,10 +8135,10 @@ done echo $ac_n "checking whether getpgrp takes no argument""... $ac_c" 1>&6 -echo "configure:7908: checking whether getpgrp takes no argument" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:8197: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then ac_cv_func_getpgrp_void=yes else @@ -7988,10 +8219,10 @@ echo $ac_n "checking for working mmap""... $ac_c" 1>&6 -echo "configure:7992: checking for working mmap" >&5 +echo "configure:8223: checking for working mmap" >&5 case "$opsys" in ultrix* ) have_mmap=no ;; *) cat > conftest.$ac_ext < #include @@ -8024,7 +8255,7 @@ return 1; } EOF -if { (eval echo configure:8028: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 +if { (eval echo configure:8259: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>&5 then have_mmap=yes else @@ -8058,15 +8289,15 @@ ac_safe=`echo "termios.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for termios.h""... $ac_c" 1>&6 -echo "configure:8062: checking for termios.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8070: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8301: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8109,15 +8340,15 @@ echo "$ac_t""no" 1>&6 ac_safe=`echo "termio.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for termio.h""... $ac_c" 1>&6 -echo "configure:8113: checking for termio.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8121: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8352: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8149,10 +8380,10 @@ echo $ac_n "checking for socket""... $ac_c" 1>&6 -echo "configure:8153: checking for socket" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8410: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_socket=yes" else @@ -8190,15 +8421,15 @@ echo "$ac_t""yes" 1>&6 ac_safe=`echo "netinet/in.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for netinet/in.h""... $ac_c" 1>&6 -echo "configure:8194: checking for netinet/in.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8202: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8433: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8215,15 +8446,15 @@ echo "$ac_t""yes" 1>&6 ac_safe=`echo "arpa/inet.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for arpa/inet.h""... $ac_c" 1>&6 -echo "configure:8219: checking for arpa/inet.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8227: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8458: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8248,9 +8479,9 @@ } echo $ac_n "checking "for sun_len member in struct sockaddr_un"""... $ac_c" 1>&6 -echo "configure:8252: checking "for sun_len member in struct sockaddr_un"" >&5 +echo "configure:8483: checking "for sun_len member in struct sockaddr_un"" >&5 cat > conftest.$ac_ext < @@ -8261,7 +8492,7 @@ static struct sockaddr_un x; x.sun_len = 1; ; return 0; } EOF -if { (eval echo configure:8265: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8496: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* echo "$ac_t""yes" 1>&6; { test "$extra_verbose" = "yes" && cat << \EOF Defining HAVE_SOCKADDR_SUN_LEN @@ -8292,10 +8523,10 @@ echo $ac_n "checking for msgget""... $ac_c" 1>&6 -echo "configure:8296: checking for msgget" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8553: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_msgget=yes" else @@ -8333,15 +8564,15 @@ echo "$ac_t""yes" 1>&6 ac_safe=`echo "sys/ipc.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for sys/ipc.h""... $ac_c" 1>&6 -echo "configure:8337: checking for sys/ipc.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8345: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8576: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8358,15 +8589,15 @@ echo "$ac_t""yes" 1>&6 ac_safe=`echo "sys/msg.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for sys/msg.h""... $ac_c" 1>&6 -echo "configure:8362: checking for sys/msg.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8370: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8601: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8404,15 +8635,15 @@ ac_safe=`echo "dirent.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for dirent.h""... $ac_c" 1>&6 -echo "configure:8408: checking for dirent.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8416: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8647: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8439,15 +8670,15 @@ echo "$ac_t""no" 1>&6 ac_safe=`echo "sys/dir.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for sys/dir.h""... $ac_c" 1>&6 -echo "configure:8443: checking for sys/dir.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8451: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8682: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8480,15 +8711,15 @@ ac_safe=`echo "nlist.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for nlist.h""... $ac_c" 1>&6 -echo "configure:8484: checking for nlist.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8492: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8723: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8518,7 +8749,7 @@ echo "checking "for sound support"" 1>&6 -echo "configure:8522: checking "for sound support"" >&5 +echo "configure:8753: checking "for sound support"" >&5 case "$with_sound" in native | both ) with_native_sound=yes;; nas | no ) with_native_sound=no;; @@ -8529,15 +8760,15 @@ if test -n "$native_sound_lib"; then ac_safe=`echo "multimedia/audio_device.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for multimedia/audio_device.h""... $ac_c" 1>&6 -echo "configure:8533: checking for multimedia/audio_device.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8541: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8772: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8585,12 +8816,12 @@ if test -z "$native_sound_lib"; then echo $ac_n "checking for ALopenport in -laudio""... $ac_c" 1>&6 -echo "configure:8589: checking for ALopenport in -laudio" >&5 +echo "configure:8820: checking for ALopenport in -laudio" >&5 ac_lib_var=`echo audio'_'ALopenport | sed 'y%./+-%__p_%'` xe_check_libs=" -laudio " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8836: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -8632,12 +8863,12 @@ if test -z "$native_sound_lib"; then echo $ac_n "checking for AOpenAudio in -lAlib""... $ac_c" 1>&6 -echo "configure:8636: checking for AOpenAudio in -lAlib" >&5 +echo "configure:8867: checking for AOpenAudio in -lAlib" >&5 ac_lib_var=`echo Alib'_'AOpenAudio | sed 'y%./+-%__p_%'` xe_check_libs=" -lAlib " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8883: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -8686,15 +8917,15 @@ for dir in "machine" "sys" "linux"; do ac_safe=`echo "${dir}/soundcard.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for ${dir}/soundcard.h""... $ac_c" 1>&6 -echo "configure:8690: checking for ${dir}/soundcard.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8698: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8929: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8764,7 +8995,7 @@ fi libs_x="-laudio $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-laudio\" to \$libs_x"; fi cat > conftest.$ac_ext < EOF @@ -8791,7 +9022,7 @@ if test "$with_tty" = "yes" ; then echo "checking for TTY-related features" 1>&6 -echo "configure:8795: checking for TTY-related features" >&5 +echo "configure:9026: checking for TTY-related features" >&5 { test "$extra_verbose" = "yes" && cat << \EOF Defining HAVE_TTY EOF @@ -8807,12 +9038,12 @@ if test -z "$with_ncurses"; then echo $ac_n "checking for tgetent in -lncurses""... $ac_c" 1>&6 -echo "configure:8811: checking for tgetent in -lncurses" >&5 +echo "configure:9042: checking for tgetent in -lncurses" >&5 ac_lib_var=`echo ncurses'_'tgetent | sed 'y%./+-%__p_%'` xe_check_libs=" -lncurses " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9058: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -8856,15 +9087,15 @@ ac_safe=`echo "ncurses/curses.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for ncurses/curses.h""... $ac_c" 1>&6 -echo "configure:8860: checking for ncurses/curses.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8868: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9099: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8886,15 +9117,15 @@ ac_safe=`echo "ncurses/term.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for ncurses/term.h""... $ac_c" 1>&6 -echo "configure:8890: checking for ncurses/term.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8898: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9129: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8924,15 +9155,15 @@ c_switch_site="$c_switch_site -I/usr/include/ncurses" ac_safe=`echo "ncurses/curses.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for ncurses/curses.h""... $ac_c" 1>&6 -echo "configure:8928: checking for ncurses/curses.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8936: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9167: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8967,12 +9198,12 @@ for lib in curses termlib termcap; do echo $ac_n "checking for tgetent in -l$lib""... $ac_c" 1>&6 -echo "configure:8971: checking for tgetent in -l$lib" >&5 +echo "configure:9202: checking for tgetent in -l$lib" >&5 ac_lib_var=`echo $lib'_'tgetent | sed 'y%./+-%__p_%'` xe_check_libs=" -l$lib " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9218: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -9014,12 +9245,12 @@ else echo $ac_n "checking for tgetent in -lcurses""... $ac_c" 1>&6 -echo "configure:9018: checking for tgetent in -lcurses" >&5 +echo "configure:9249: checking for tgetent in -lcurses" >&5 ac_lib_var=`echo curses'_'tgetent | sed 'y%./+-%__p_%'` xe_check_libs=" -lcurses " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9265: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -9048,12 +9279,12 @@ else echo "$ac_t""no" 1>&6 echo $ac_n "checking for tgetent in -ltermcap""... $ac_c" 1>&6 -echo "configure:9052: checking for tgetent in -ltermcap" >&5 +echo "configure:9283: checking for tgetent in -ltermcap" >&5 ac_lib_var=`echo termcap'_'tgetent | sed 'y%./+-%__p_%'` xe_check_libs=" -ltermcap " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9299: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -9112,15 +9343,15 @@ test -z "$with_gpm" && { ac_safe=`echo "gpm.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for gpm.h""... $ac_c" 1>&6 -echo "configure:9116: checking for gpm.h" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9124: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9355: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9143,12 +9374,12 @@ } test -z "$with_gpm" && { echo $ac_n "checking for Gpm_Open in -lgpm""... $ac_c" 1>&6 -echo "configure:9147: checking for Gpm_Open in -lgpm" >&5 +echo "configure:9378: checking for Gpm_Open in -lgpm" >&5 ac_lib_var=`echo gpm'_'Gpm_Open | sed 'y%./+-%__p_%'` xe_check_libs=" -lgpm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9394: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -9208,17 +9439,17 @@ echo "checking for database support" 1>&6 -echo "configure:9212: checking for database support" >&5 +echo "configure:9443: checking for database support" >&5 if test "$with_database_gnudbm" != "no"; then echo $ac_n "checking for dbm_open in -lgdbm""... $ac_c" 1>&6 -echo "configure:9217: checking for dbm_open in -lgdbm" >&5 +echo "configure:9448: checking for dbm_open in -lgdbm" >&5 ac_lib_var=`echo gdbm'_'dbm_open | sed 'y%./+-%__p_%'` xe_check_libs=" -lgdbm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9464: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -9251,10 +9482,10 @@ if test "$with_database_gnudbm" != "yes"; then echo $ac_n "checking for dbm_open""... $ac_c" 1>&6 -echo "configure:9255: checking for dbm_open" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9512: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_dbm_open=yes" else @@ -9313,10 +9544,10 @@ if test "$with_database_dbm" != "no"; then echo $ac_n "checking for dbm_open""... $ac_c" 1>&6 -echo "configure:9317: checking for dbm_open" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9574: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_dbm_open=yes" else @@ -9360,12 +9591,12 @@ if test "$need_libdbm" != "no"; then echo $ac_n "checking for dbm_open in -ldbm""... $ac_c" 1>&6 -echo "configure:9364: checking for dbm_open in -ldbm" >&5 +echo "configure:9595: checking for dbm_open in -ldbm" >&5 ac_lib_var=`echo dbm'_'dbm_open | sed 'y%./+-%__p_%'` xe_check_libs=" -ldbm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9611: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -9413,10 +9644,10 @@ if test "$with_database_berkdb" != "no"; then echo $ac_n "checking for dbopen""... $ac_c" 1>&6 -echo "configure:9417: checking for dbopen" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9674: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_dbopen=yes" else @@ -9460,12 +9691,12 @@ if test "$need_libdb" != "no"; then echo $ac_n "checking for dbopen in -ldb""... $ac_c" 1>&6 -echo "configure:9464: checking for dbopen in -ldb" >&5 +echo "configure:9695: checking for dbopen in -ldb" >&5 ac_lib_var=`echo db'_'dbopen | sed 'y%./+-%__p_%'` xe_check_libs=" -ldb " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9711: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -9500,7 +9731,7 @@ if test "$with_database_berkdb" = "yes"; then for path in "db/db.h" "db.h"; do cat > conftest.$ac_ext <&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:9753: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* db_h_path="$path"; break else @@ -9570,12 +9801,12 @@ if test "$with_socks" = "yes"; then echo $ac_n "checking for SOCKSinit in -lsocks""... $ac_c" 1>&6 -echo "configure:9574: checking for SOCKSinit in -lsocks" >&5 +echo "configure:9805: checking for SOCKSinit in -lsocks" >&5 ac_lib_var=`echo socks'_'SOCKSinit | sed 'y%./+-%__p_%'` xe_check_libs=" -lsocks " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9821: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -10128,7 +10359,6 @@ test "$with_tooltalk" = yes && echo " Compiling in support for ToolTalk." test "$with_offix" = yes && echo " Compiling in support for OffiX." test "$with_workshop" = yes && echo " Compiling in support for Sun WorkShop." -test "$with_energize" = yes && echo " Compiling in support for Lucid Energize (doesn't currently work)." test "$with_session" != no && echo " Compiling in support for proper session-management." case "$with_menubars" in lucid ) echo " Using Lucid menubars." ;; diff -r 43306a74e31c -r d44af0c54775 configure.in --- a/configure.in Mon Aug 13 10:07:42 2007 +0200 +++ b/configure.in Mon Aug 13 10:08:34 2007 +0200 @@ -351,7 +351,6 @@ with_x11='' rel_alloc='default' with_system_malloc='default' -energize_version='' native_sound_lib='' dnl use-assertions should be 'yes' by default. Too many people in this dnl world have core dumps turned off by default or \"cannot find where the @@ -464,7 +463,6 @@ with_canna | \ with_wnn | \ with_wnn6 | \ - with_energize | \ with_workshop | \ with_sparcworks | \ with_tooltalk | \ @@ -736,12 +734,6 @@ dnl Get the arguments back. See the diatribe on Shell Magic above. eval set x "$quoted_arguments"; shift -dnl Argument interdependencies -if test "$with_energize" = "yes" ; then - with_menubars=lucid with_scrollbars=motif with_dialogs=motif with_tooltalk=yes - XE_APPEND(lwlib/energize, MAKE_SUBDIR) -fi - dnl --extra-verbose implies --verbose test "$extra_verbose" = "yes" && verbose=yes @@ -907,8 +899,8 @@ dnl Canonicalize the configuration name. AC_CHECKING("the configuration name") -dnl allow -energize or -workshop suffix on configuration name -internal_configuration=`echo $configuration | sed 's/-\(energize\|workshop\)//'` +dnl allow -workshop suffix on configuration name +internal_configuration=`echo $configuration | sed 's/-\(workshop\)//'` if canonical=`$srcdir/config.sub "$internal_configuration"` ; then : ; else exit $? fi @@ -2316,27 +2308,6 @@ need_motif=yes # CDE requires Motif fi -dnl if Energize specified, make sure we can find its libraries/headers -if test "$with_energize" = "yes" ; then - AC_DEFINE(ENERGIZE) - AC_CHECK_LIB(energize, main, [ - XE_PREPEND(-lenergize, LIBS) - energize_version="3.X" - AC_DEFINE(ENERGIZE_3)]) - if test -z "$energize_version"; then - AC_CHECK_LIB(conn, main, [ - XE_PREPEND(-lconn, LIBS) - energize_version="2.X" - AC_DEFINE(ENERGIZE_2)], - [AC_MSG_ERROR(Unable to find Energize library.)]) - fi - AC_CHECK_HEADER(editorconn.h, , - [AC_MSG_ERROR(Unable to find Energize editorconn.h header file.)]) - - test "$energize_version" = "2.X" && AC_DEFINE(ENERGIZE_2) - test "$energize_version" = "3.X" && AC_DEFINE(ENERGIZE_3) -fi - dnl ---------------------- dnl X11 Graphics libraries dnl ---------------------- @@ -2385,6 +2356,21 @@ dnl autodetect ImageMagick test -z "$with_imagick" && { AC_CHECK_HEADER(magick/magick.h, ,with_imagick=no) } + test -z "$with_imagick" && { + dnl check the appropriate libraries for ImageMagick + imagick_libs="" + AC_CHECK_LIB(dps, XDPSPixelsPerPoint, XE_APPEND(-ldpstk -ldps, imagick_libs),,,-ldpstk) + AC_CHECK_LIB(fpx, FPX_SetToolkitMemoryLimit, XE_APPEND(-lfpx, imagick_libs)) + AC_CHECK_LIB(df, DF24getdims, XE_APPEND(-ldf, imagick_libs)) + AC_CHECK_LIB(jbig, jbg_dec_init, XE_APPEND(-ljbig, imagick_libs)) + AC_CHECK_LIB(jpeg, jpeg_read_header, XE_APPEND(-ljpeg, imagick_libs)) + AC_CHECK_LIB(mpeg, OpenMPEG, XE_APPEND(-lmpeg, imagick_libs)) + AC_CHECK_LIB(png, png_create_read_struct, XE_APPEND(-lpng, imagick_libs), + AC_CHECK_LIB(png, png_create_read_struct, XE_APPEND(-lpng -lz, imagick_libs),,-lz)) + AC_CHECK_LIB(tiff, TIFFOpen, XE_APPEND(-ltiff, imagick_libs), + AC_CHECK_LIB(tiff, TIFFOpen, XE_APPEND(-ltiff -ljpeg -lz, imagick_libs),,-ljpeg -lz)) + XE_APPEND($imagick_libs, libs_x) + } test -z "$with_imagick" && { AC_CHECK_LIB(Magick, MogrifyImage,[:],with_imagick=no) } test -z "$with_imagick" && with_imagick=yes if test "$with_imagick" = "yes"; then @@ -3351,7 +3337,6 @@ test "$with_tooltalk" = yes && echo " Compiling in support for ToolTalk." test "$with_offix" = yes && echo " Compiling in support for OffiX." test "$with_workshop" = yes && echo " Compiling in support for Sun WorkShop." -test "$with_energize" = yes && echo " Compiling in support for Lucid Energize (doesn't currently work)." test "$with_session" != no && echo " Compiling in support for proper session-management." case "$with_menubars" in lucid ) echo " Using Lucid menubars." ;; diff -r 43306a74e31c -r d44af0c54775 configure.usage --- a/configure.usage Mon Aug 13 10:07:42 2007 +0200 +++ b/configure.usage Mon Aug 13 10:08:34 2007 +0200 @@ -101,8 +101,6 @@ --with-tooltalk (*) Support the ToolTalk IPC protocol. --with-workshop Support the Sun WorkShop (formerly Sparcworks) development environment. ---with-energize Support the Lucid Energize development environment. - This doesn't currently work. --with-socks Compile with support for SOCKS (an Internet proxy). --with-term Compile with support for TERM (a way to multiplex serial lines and provide vaguely Internet-like diff -r 43306a74e31c -r d44af0c54775 info/dir --- a/info/dir Mon Aug 13 10:07:42 2007 +0200 +++ b/info/dir Mon Aug 13 10:08:34 2007 +0200 @@ -55,8 +55,6 @@ * External-Widget:: Use XEmacs as a text widget inside of another program. * Forms:: A package for editing databases by filling in forms. -* Ispell:: Interactive spelling corrector. -* OO-Browser:: The Multi-Language Object-Oriented Browser. * PH:: Client interface to the CCSO white pages directory system * Standards:: The GNU coding standards. * Supercite:: Lets you cite parts of messages you're replying to. @@ -65,6 +63,5 @@ to handle all types of character-display terminals. * Texinfo:: With one source file, make either a printed manual (through TeX) or an Info file (through texinfo). -* Vhdl-mode:: A major mode for editing VHDL files. * Widget:: An Emacs Lisp widget library * Locals: diff -r 43306a74e31c -r d44af0c54775 lib-src/ChangeLog --- a/lib-src/ChangeLog Mon Aug 13 10:07:42 2007 +0200 +++ b/lib-src/ChangeLog Mon Aug 13 10:08:34 2007 +0200 @@ -1,3 +1,12 @@ +1997-11-27 SL Baur + + * update-elc.sh: Obliterate usage of make_special, since nothing + requires it any more. + +1997-11-23 SL Baur + + * update-elc.sh (BYTECOMP): cleantree.el has been moved. + 1997-11-18 Colin Rafferty * update-elc.sh (prune_vc): Made it ignore any directory that diff -r 43306a74e31c -r d44af0c54775 lib-src/update-autoloads.sh --- a/lib-src/update-autoloads.sh Mon Aug 13 10:07:42 2007 +0200 +++ b/lib-src/update-autoloads.sh Mon Aug 13 10:08:34 2007 +0200 @@ -116,6 +116,9 @@ fi done +$EMACS -batch -vanilla -eval '(setq autoload-package-name "Standard")' \ + -l autoload -f batch-update-directory lisp + # set -x for dir in $dirs; do $EMACS -batch -vanilla -l autoload -f batch-update-directory $dir diff -r 43306a74e31c -r d44af0c54775 lib-src/update-elc.sh --- a/lib-src/update-elc.sh Mon Aug 13 10:07:42 2007 +0200 +++ b/lib-src/update-elc.sh Mon Aug 13 10:08:34 2007 +0200 @@ -65,7 +65,7 @@ echo "Recompiling in `pwd|sed 's|^/tmp_mnt||'`" echo " with $REAL..." -$EMACS -batch -vanilla -l `pwd`/lisp/prim/cleantree -f batch-remove-old-elc lisp +$EMACS -batch -vanilla -l `pwd`/lisp/cleantree -f batch-remove-old-elc lisp prune_vc="( -name '.*' -o -name SCCS -o -name RCS -o -name CVS ) -prune -o" @@ -110,15 +110,17 @@ #$BYTECOMP -f batch-byte-recompile-directory lisp/bytecomp # Prepare for byte-compiling directories with directory-specific instructions -make_special_commands='' -make_special () { - dir="$1"; shift; - ignore_dirs="$ignore_dirs $dir" - make_special_commands="$make_special_commands \ -echo \"Compiling in lisp/$dir\"; \ -(cd \"lisp/$dir\" && ${MAKE:-make} EMACS=$REAL ${1+$*}); \ -echo \"lisp/$dir done.\";" -} +# Not necessary any more, but I want to keep the text current to cut & paste +# into the package lisp maintenance tree. +#make_special_commands='' +#make_special () { +# dir="$1"; shift; +# ignore_dirs="$ignore_dirs $dir" +# make_special_commands="$make_special_commands \ +#echo \"Compiling in lisp/$dir\"; \ +#(cd \"lisp/$dir\" && ${MAKE:-make} EMACS=$REAL ${1+$*}); \ +#echo \"lisp/$dir done.\";" +#} ## AUCTeX is a package now # if test "$mule_p" = nil ; then @@ -129,7 +131,7 @@ #make_special cc-mode all # EFS is now packaged # make_special efs x20 -make_special eos -k # not strictly necessary... +#make_special eos -k # not strictly necessary... ## make_special gnus some # Now this is a package. # hyperbole is now packaged # make_special hyperbole elc @@ -190,4 +192,4 @@ xargs -t -n$NUMTOCOMPILE $BYTECOMP -f batch-byte-compile echo "Compiling files without .elc... Done" -eval "$make_special_commands" +#eval "$make_special_commands" diff -r 43306a74e31c -r d44af0c54775 lisp/ChangeLog --- a/lisp/ChangeLog Mon Aug 13 10:07:42 2007 +0200 +++ b/lisp/ChangeLog Mon Aug 13 10:08:34 2007 +0200 @@ -1,3 +1,83 @@ +1997-11-28 Hrvoje Niksic + + * x-toolbar.el (toolbar-news-frame-properties): Made customizable. + +1997-11-27 Christoph Wedler + + * lazy-shot.el (lazy-shot-stealth-timer): `defvar'. Would + bug out when setting `lazy-shot-stealth-time' to nil and visiting + a buffer smaller than `lazy-shot-minimum-size'. + (font-lock-mode-hook): Option is turn-on-lazy-shot. + +1997-11-27 Kyle Jones + + * etags.el: Support new `include' + directive. Search for exact tag matches and then + inexact matches. + +1997-11-26 SL Baur + + * packages.el (packages-useful-lisp): advice.el is a package. + + * x-menubar.el (default-menubar): Make `Options ... Color Printing' + a toggle. + +1997-11-26 Kyle Jones + + * toolbar.el (init-toolbar-from-resrouces): Fix + parens to make valid if-expression. + +1997-11-21 Hrvoje Niksic + + * x-toolbar.el (toolbar-gnus): Respect + `toolbar-news-use-separate-frame'. + +1997-11-22 Hrvoje Niksic + + * x-menubar.el (default-menubar): Use `bookmark-menu-filter' + for the Bookmarks menu. + (bookmark-menu-filter): Handle inactive submenus. + +1997-11-25 Hrvoje Niksic + + * custom.el (custom-declare-variable): Attach the symbol to + load history. + +1997-11-23 SL Baur + + * startup.el (find-emacs-root-internal-1): Erase references to + prim. + + * blessmail.el: dumped-lisp.el has been moved. + * font.el: ditto. + * make-docfile.el: ditto. + * package-admin.el: ditto. + * update-elc.el: ditto. + + * about.el: Moved. + * cleantree.el: ditto. + * dumped-lisp.el: ditto. + * sound.el: ditto. + * winnt.el: ditto. + +1997-11-22 Kyle Jones + + * faces.el: Don't set global background pixmap + property of the modeline face to [nothing], as that + the attributeBackgroundPixmap X resource. + +1997-11-21 SL Baur + + * autoload.el: Moved. + * config.el: ditto. + * etags.el: ditto. + * font-lock.el: ditto. + * fontl-hooks.el: ditto. + * gnuserv.el: ditto. + * info.el: ditto. + * shadow.el: ditto. + * view-less.el: ditto. + 1997-11-18 Colin Rafferty * packages.el (packages-find-packages): Modified to allow `nil' diff -r 43306a74e31c -r d44af0c54775 lisp/about.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/about.el Mon Aug 13 10:08:34 2007 +0200 @@ -0,0 +1,1428 @@ +;;; about.el --- the About The Authors page (shameless self promotion). + +;; Copyright (c) 1997 Free Software Foundation, Inc. + +;; Keywords: extensions +;; Version: 2.4 +;; Maintainer: Hrvoje Niksic + +;; This file is part of XEmacs. + +;; XEmacs 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. + +;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF. + +;; Original code: Jamie Zawinski +;; Text: Ben Wing , Jamie Zawinski +;; Hard: Amiga 1000, Progressive Peripherals Frame Grabber. +;; Soft: FG 2.0, DigiPaint 3.0, pbmplus (dec 91), xv 3.0. +;; Modified for 19.11 by Eduardo Pelegri-Llopart +;; and Chuck Thompson +;; More hacking for 19.12 by Chuck Thompson and Ben Wing. +;; 19.13 and 19.14 updating done by Chuck Thompson. +;; 19.15 and 20.0 updating done by Steve Baur and Martin Buchholz. + +;; Completely rewritten for 20.3 by Hrvoje Niksic . +;; The original had no version numbers; I numbered the rewrite as 2.0. + +;; Many things in this file are to gag. Ideally, we should just use +;; HTML (or some other extension, e.g. info) for this sort of thing. +;; However, W3 loads too long and is too large to be dumped with +;; XEmacs. + +;; If you think this is ugly now -- o boy, you should have seen it +;; before. + +(require 'wid-edit) + +;; People in this list have their individual links from the main page, +;; or from the `Legion' page. If they have an image, it should be +;; named after the CAR of the list element (baw -> baw.xpm). +;; +;; If you add to this list, you'll want to update +;; `about-maintainer-info' (and maybe `about-hackers'. +(defvar xemacs-hackers + '((ajc "Andrew Cosgriff" "ajc@bing.wattle.id.au") + (baw "Barry Warsaw" "bwarsaw@python.org") + (bw "Bob Weiner" "weiner@altrasoft.com") + (cthomp "Chuck Thompson" "cthomp@xemacs.org") + (dmoore "David Moore" "dmoore@ucsd.edu") + (dkindred "Darrell Kindred" "dkindred@cmu.edu") + (dv "Didier Verna" "verna@inf.enst.fr") + (hniksic "Hrvoje Niksic" "hniksic@srce.hr") + (jareth "Jareth Hein" "jhod@camelot-soft.com") + (jens "Jens Lautenbacher" "jens@lemcbed.lem.uni-karlsruhe.de") + (juhp "Jens-Ulrik Holger Petersen" "petersen@kurims.kyoto-u.ac.jp") + (jwz "Jamie Zawinski" "jwz@netscape.com") + (kazz "IENAGA Kazuyuki" "ienaga@jsys.co.jp") + (kyle "Kyle Jones" "kyle_jones@wonderworks.com") + (larsi "Lars Magne Ingebrigtsen" "larsi@gnus.org") + (marcpa "Marc Paquette" "marcpa@CAM.ORG") + (mly "Richard Mlynarik" "mly@adoc.xerox.com") + (morioka "MORIOKA Tomohiko" "morioka@jaist.ac.jp") + (mrb "Martin Buchholz" "mrb@sun.eng.com") + (ograf "Oliver Graf" "ograf@fga.de") + (pez "Peter Pezaris" "pez@dwwc.com") + (piper "Andy Piper" "andy@parallax.co.uk") + (rickc "Rick Campbell" "rickc@lehman.com") + (rossini "Anthony Rossini" "rossini@stat.sc.edu") + (vin "Vin Shelton" "acs@acm.org") + (sperber "Michael Sperber" "sperber@informatik.uni-tuebingen.de") + (slb "SL Baur" "steve@xemacs.org") + (stig "Jonathan Stigelman" "stig@hackvan.com") + (stigb "Stig Bjorlykke" "stigb@tihlde.hist.no") + (thiessel "Marcus Thiessel" "thiessel@rhrk.uni-kl.de") + (vladimir "Vladimir Ivanovic" "vladimir@mri.com") + (wing "Ben Wing" "wing@xemacs.org") + (wmperry "William Perry" "wmperry@aventail.com")) + "Alist of XEmacs hackers.") + +;; The CAR of alist elements is a valid argument to `about-url-link'. +;; It is preferred to a simple string, because it makes maintenance +;; easier. Please add new URLs to this list. +(defvar about-url-alist + '((ajc . "http://www-personal.monash.edu.au/~ajc/") + (altrasoft . "http://www.altrasoft.com/") + (baw . "http://www.python.org/~bwarsaw/") + (cc-mode . "http://www.python.org/ftp/emacs/") + (dkindred . "http://www.cs.cmu.edu/People/dkindred/me.html") + (dmoore . "http://oj.egbt.org/dmoore/") + (juhp . "http://www.kurims.kyoto-u.ac.jp/~petersen/") + (jwz . "http://people.netscape.com/jwz/") + (kazz . "http://www.imasy.or.jp/~kazz/") + (kyle . "http://www.wonderworks.com/kyle/") + (larsi . "http://www.ifi.uio.no/~larsi/") + (marcpa . "http://www.positron911.com/products/power.htm") + (ograf . "http://www.fga.de/~ograf/") + (pez . "http://www.dwwc.com/") + (vin . "http://www.upa.org/") + (stigb . "http://www.tihlde.hist.no/~stigb/") + (wget . "ftp://gnjilux.cc.fer.hr/pub/unix/util/wget/") + (xemacs . "http://www.xemacs.org/")) + "Some of the more important URLs.") + +(defvar about-left-margin 3) + +;; Insert a URL link to the buffer. +(defun about-url-link (what &optional echo) + (or (stringp what) + (setq what (cdr (assq what about-url-alist)))) + (assert what) + (widget-create 'url-link + :button-prefix "" + :button-suffix "" + :help-echo echo + what)) + +;; Attach a face to a string, in order to be inserted into the buffer. +;; Make sure that the extent is duplicable, but unique. Returns the +;; string. +(defun about-with-face (string face) + (let ((ext (make-extent 0 (length string) string))) + (set-extent-property ext 'duplicable t) + (set-extent-property ext 'unique t) + (set-extent-property ext 'start-open t) + (set-extent-property ext 'end-open t) + (set-extent-face ext face)) + string) + +;; Switch to buffer NAME. If it doesn't exist, make it and switch to it. +(defun about-get-buffer (name) + (cond ((get-buffer name) + (switch-to-buffer name) + (delete-other-windows) + (goto-char (point-min)) + name) + (t + (switch-to-buffer name) + (delete-other-windows) + (buffer-disable-undo) + (set-specifier left-margin-width about-left-margin (current-buffer)) + nil))) + +;; Set up the stuff needed by widget. Allowed types are `bury' and +;; `kill'. +(defun about-finish-buffer (&optional type) + (or type (setq type 'bury)) + (widget-insert "\n") + (if (eq type 'bury) + (widget-create 'link :help-echo "Bury buffer" + :action (lambda (&rest ignore) + (bury-buffer)) + "Remove") + (widget-create 'link :help-echo "Kill buffer" + :action (lambda (&rest ignore) + (kill-buffer (current-buffer))) + "Kill")) + (widget-insert " this buffer.\n") + (use-local-map (make-sparse-keymap)) + (set-keymap-parent (current-local-map) widget-keymap) + (if (eq type 'bury) + (progn + (local-set-key "q" 'bury-buffer) + (local-set-key "l" 'bury-buffer)) + (let ((dispose (lambda () (interactive) (kill-buffer (current-buffer))))) + (local-set-key "q" dispose) + (local-set-key "l" dispose))) + (local-set-key " " 'scroll-up) + (local-set-key "\177" 'scroll-down) + (widget-setup) + (goto-char (point-min)) + (toggle-read-only 1) + (set-buffer-modified-p nil)) + +;; Make the appropriate number of spaces. +(defun about-center (string-or-glyph) + (let ((n (- (startup-center-spaces string-or-glyph) about-left-margin))) + (make-string (if (natnump n) n 0) ?\ ))) + +;; Main entry page. + +;;;###autoload +(defun about-xemacs () + "Describe the True Editor and its minions." + (interactive) + (unless (about-get-buffer "*About XEmacs*") + (widget-insert (about-center xemacs-logo)) + (widget-create 'default + :format "%t" + :tag-glyph xemacs-logo) + (widget-insert "\n") + (let* ((emacs-short-version (concat emacs-major-version + "." emacs-minor-version)) + (emacs-about-version (format "version %s; Jan 1998" + emacs-short-version))) + (widget-insert (about-center emacs-about-version)) + (widget-create 'link :help-echo "The latest NEWS of XEmacs" + :action 'about-news + emacs-about-version)) + + (widget-insert + "\n\n" + (about-with-face "XEmacs" 'italic) + " (formerly known as " + (about-with-face "Lucid Emacs" 'italic) + ") is a powerful, extensible text +editor with full GUI support, initially based on an early version of\n" + (about-with-face "GNU Emacs 19" 'italic) + " from the Free Software Foundation and since kept up to +date with recent versions of that product. XEmacs stems from a\n") + (widget-create 'link :help-echo "An XEmacs history lesson" + :action 'about-collaboration + :button-prefix "" + :button-suffix "" + "collaboration") + (widget-insert + " of Lucid, Inc. with Sun Microsystems, Inc. and the +University of Illinois with additional support having been provided by +Amdahl Corporation, INS Engineering Corporation, and a huge amount of +volunteer effort. + +XEmacs provides a great number of ") + (widget-create 'link :help-echo "See a list of the new features" + :action 'about-features + :button-prefix "" + :button-suffix "" + "new features") + (widget-insert ". More details on +XEmacs's functionality, including bundled packages, can be obtained +through the ") + (widget-create 'info-link + :help-echo "Browse the info system" + :button-prefix "" + :button-suffix "" + :tag "info" + "(dir)") + + (widget-insert + " on-line information system.\n +The XEmacs web page can be browsed, using any WWW browser at\n +\t\t ") + (about-url-link 'xemacs "Visit XEmacs WWW page") + (widget-insert "\n +Note that W3 (XEmacs's own browser), might need customization (due to +firewalls) in order to work correctly. + +XEmacs is the result of the time and effort of many people. The +developers responsible for the 20.4 release are:\n\n") + + (flet ((setup-person (who) + (widget-insert "\t* ") + (let* ((entry (assq who xemacs-hackers)) + (name (cadr entry)) + (address (caddr entry))) + (widget-create 'link + :help-echo (concat "Find out more about " name) + :button-prefix "" + :button-suffix "" + :action 'about-maintainer + :tag name + :value who) + (widget-insert (format " <%s>\n" address))))) + ;; Setup persons responsible for this release. + (mapc 'setup-person '(slb hniksic kyle mrb)) + (widget-insert "\n\t* ") + (widget-create 'link :help-echo "A legion of XEmacs hackers" + :action 'about-hackers + :button-prefix "" + :button-suffix "" + "And many other contributors...") + (widget-insert "\n +Chuck Thompson was Mr. XEmacs from 19.11 through 19.14. Ben Wing was +crucial to each of these releases.\n\n") + (setup-person 'cthomp) + (setup-person 'wing) + (widget-insert " +Jamie Zawinski was Mr. Lucid Emacs from 19.0 through 19.10, the last +release actually named Lucid Emacs. A lot of work has been done by +Richard Mlynarik.\n\n") + (setup-person 'jwz) + (setup-person 'mly)) + (about-finish-buffer))) + +;; View news +(defun about-news (&rest ignore) + (view-emacs-news) + (message "%s" (substitute-command-keys + "Press \\[kill-buffer] to exit this buffer"))) + +(defun about-collaboration (&rest ignore) + (unless (about-get-buffer "*About Collaboration*") + (let ((title "Why Another Version of Emacs")) + (widget-insert + "\n" + (about-center title) + (about-with-face title 'bold))) + (widget-insert + "\n\n" + (about-with-face "The Lucid, Inc. Point of View" + 'italic) + " (quite outdated)\n +At the time of the inception of Lucid Emacs (the former name of +XEmacs), Lucid's latest product was Energize, a C/C++ development +environment. Rather than invent (and force our users to learn) a new +user interface, we chose to build part of our environment on top of +the world's best editor, GNU Emacs. (Though our product is +commercial, the work we did on GNU Emacs is free software, and is +useful in its own right.) + +We needed a version of Emacs with mouse-sensitive regions, multiple +fonts, the ability to mark sections of a buffer as read-only, the +ability to detect which parts of a buffer have been modified, and many +other features. + +For our purposes, the existing version of Epoch was not sufficient; it +did not allow us to put arbitrary pixmaps/icons in buffers, `undo' did +not restore changes to regions, regions did not overlap and merge +their attributes in the way we needed, and several other things. + +We could have devoted our time to making Epoch do what we needed (and, +in fact, we spent some time doing that in 1990) but, since the FSF +planned to include Epoch-like features in their version 19, we decided +that our efforts would be better spent improving Emacs 19 instead of +Epoch. + +Our original hope was that our changes to Emacs would be incorporated +into the \"official\" v19. However, scheduling conflicts arose, and +we found that, given the amount of work still remaining to be done, we +didn't have the time or manpower to do the level of coordination that +would be necessary to get our changes accepted by the FSF. +Consequently, we released our work as a forked branch of Emacs, +instead of delaying any longer. + +Roughly a year after Lucid Emacs 19.0 was released, a beta version of +the FSF branch of Emacs 19 was released. The FSF version is better in +some areas, and worse in others, as reflects the differing focus of +our development efforts. + +We plan to continue developing and supporting Lucid Emacs, and merging +in bug fixes and new features from the FSF branch as appropriate; we +do not plan to discard any of the functionality that we implemented +which RMS has chosen not to include in his version. + +Certain elements of Lucid Emacs, or derivatives of them, have been +ported to the FSF version. We have not been doing work in this +direction, because we feel that Lucid Emacs has a cleaner and more +extensible substrate, and that any kind of merger between the two +branches would be far easier by merging the FSF changes into our +version than the other way around. + +We have been working closely with the Epoch developers to merge in the +remaining Epoch functionality which Lucid Emacs does not yet have. +Epoch and Lucid Emacs will soon be one and the same thing. Work is +being done on a compatibility package which will allow Epoch 4 code to +run in XEmacs with little or no change.\n\n" + (about-with-face "The Sun Microsystems, Inc. Point of View" + 'italic) + "\n +Emacs 18 has been around for a long, long time. Version 19 was +supposed to be the successor to v18 with X support. It was going to +be available \"real soon\" for a long time (some people remember +hearing about v19 as early as 1984!), but it never came out. v19 +development was going very, very slowly, and from the outside it +seemed that it was not moving at all. In the meantime other people +gave up waiting for v19 and decided to build their own X-aware +Emacsen. The most important of these was probably Epoch, which came +from the University of Illinois (\"UofI\") and was based on v18. + +Around 1990, the Developer Products group within Sun Microsystems +Inc., decided that it wanted an integrated editor. (This group is now +known as DevPro. It used to be known as SunPro - the name was changed +in mid-1994.) They contracted with the University of Illinois to +provide a number of basic enhancements to the functionality in Epoch. +UofI initially was planning to deliver this on top of Epoch code. + +In the meantime, (actually some time before they talked with UofI) +Lucid had decided that it also wanted to provide an integrated +environment with an integrated editor. Lucid decided that the Version +19 base was a better one than Version 18 and thus decided not to use +Epoch but instead to work with Richard Stallman, the head of the Free +Software Foundation and principal author of Emacs, on getting v19 out. +At some point Stallman and Lucid parted ways. Lucid kept working and +got a v19 out that they called Lucid Emacs 19. + +After Lucid's v19 came out it became clear to us (the UofI and Sun) +that the right thing to do was to push for an integration of both +Lucid Emacs and Epoch, and to get the deliverables that Sun was asking +from the University of Illinois on top of this integrated platform. +Until 1994, Sun and Lucid both actively supported XEmacs as part of +their product suite and invested a comparable amount of effort into +it. Substantial portions of the current code have originated under +the support of Sun, either directly within Sun, or at UofI but paid +for by Sun. This code was kept away from Lucid for a while, but later +was made available to them. Initially Lucid didn't know that Sun was +supporting UofI, but later Sun was open about it. + +Around 1992 DevPro-originated code started showing up in Lucid Emacs, +starting with the infusion of the Epoch redisplay code. The separate +code bases at Lucid, Sun, and the University of Illinois were merged, +allowing a single XEmacs to evolve from that point on. + +Sun originally called the integrated product ERA, for \"Emacs +Rewritten Again\". SunPro and Lucid eventually came to an agreement +to find a name for the product that was not specific to either +company. An additional constraint that Lucid placed on the name was +that it must contain the word \"Emacs\" in it -- thus \"ERA\" was not +acceptable. The tentatively agreed-upon name was \"XEmacs\", and this +has been the name of the program since version 19.11.) + +As of 1997, Sun is shipping XEmacs as part of its Developer Products +integrated programming environment \"Sun WorkShop\". Sun is +continuing to support XEmacs development, with focus on +internationalization and quality improvement.\n\n" + (about-with-face "Lucid goes under" 'italic) + "\n +Around mid-'94, Lucid went out of business. Lucid founder Richard +Gabriel's book \"Patterns of Software\", which is highly recommended +reading in any case, documents the demise of Lucid and suggests +lessons to be learned for the whole software development community. + +Development on XEmacs, however, has continued unabated under the +auspices of Sun Microsystems and the University of Illinois, with help +from Amdahl Corporation and INS Engineering Corporation. Sun plans to +continue to support XEmacs into the future.\n\n" + (about-with-face "The Amdahl Corporation point of view" + 'italic) + "\n +Amdahl Corporation's Storage Products Group (SPG) uses XEmacs as the +focal point of a environment for development of the microcode used in +Amdahl's large-scale disk arrays, or DASD's. SPG has joint ventures +with Japanese companies, and decided in late 1994 to contract out for +work on XEmacs in order to hasten the development of Mule support +\(i.e. support for Japanese, Chinese, etc.) in XEmacs and as a gesture +of goodwill towards the XEmacs community for all the work they have +done on making a powerful, modern, freely available text editor. +Through this contract, Amdahl provided a large amount of work in +XEmacs in the form of rewriting the basic text-processing mechanisms +to allow for Mule support and writing a large amount of the support +for multiple devices. + +Although Amdahl is no longer hiring a full-time contractor, they are +still funding part-time work on XEmacs and providing resources for +further XEmacs development.\n\n" + (about-with-face "The INS Engineering point of view" + 'italic) + "\n +INS Engineering Corporation, based in Tokyo, bought rights to sell +Energize when Lucid went out of business. Unhappy with the +performance of the Japanese support in XEmacs 19.11, INS also +contributed to the XEmacs development from late 1994 to early +1995.\n") + (about-finish-buffer))) + +(defun about-features (&rest ignore) + (unless (about-get-buffer "*About Features*") + (let ((title "New features in XEmacs")) + (widget-insert + "\n" + (about-center title) + (about-with-face title 'bold))) + (widget-insert + "\n +* MULE (Multi-Lingual Emacs) support. Simultaneous display of + multiple character sets is now possible. + +* Support for arbitrary pixmaps in a buffer. + +* A real toolbar. + +* Horizontal and vertical scrollbars in all windows. + +* Support for variable-width and variable height fonts. + +* Support for display on multiple simultaneous X and/or TTY devices. + +* Face support on TTY's, including color. + +* Support for overlapping regions (or extents) and efficient handling + of a large number of such extents in a single buffer. + +* Powerful, flexible control over the display characteristics of most + of the visual aspects of XEmacs through the use of specifiers, which + allow separate values to be specified for individual buffers, + windows, frames, devices, device classes, and device types. + +* A clean interface to the menubar, window-system events, and key + combinations. + +* Proper integration with Xt and Motif (including Motif menubars and + scrollbars). Motif look-alike menubars and scrollbars are provided + for those systems without real Motif support. + +* Text for complex languages can be entered using the XIM mechanism. + +* Localization of menubar text for the Japanese locale. + +* Access to the ToolTalk API. + +* Support for using XEmacs frames as Xt widgets.\n\n") + (about-finish-buffer))) + +(defvar about-glyphs nil + "Cached glyphs") + +;; Return a maintainer's glyph +(defun about-maintainer-glyph (who) + (let ((glyph (cdr (assq who about-glyphs)))) + (unless glyph + (let ((file (expand-file-name + (concat (symbol-name who) + (if (memq (device-class) + '(color grayscale)) + "" "m") + ".xpm") + (locate-data-directory "photos"))) + (data nil)) + (unless (file-exists-p file) + ;; Maybe the file is compressed? + (setq file (concat file ".Z")) + (if (file-exists-p file) + ;; Decompress it. + (condition-case nil + (let ((buffer (get-buffer-create " *image*"))) + (unwind-protect + (save-excursion + (message "Uncompressing image...") + (set-buffer buffer) + (erase-buffer) + (let ((coding-system-for-read 'binary) + (coding-system-for-write 'binary)) + (insert-file-contents-literally file) + (call-process-region (point-min) (point-max) + "zcat" t t nil) + (setq data + (buffer-substring (point-min) (point-max)))) + (message "Uncompressing image... done")) + (kill-buffer buffer))) + (error (setq data 'error))) + (setq file nil))) + (setq glyph + (cond ((stringp data) + (make-glyph + (if (featurep 'xpm) + `([xpm :data ,data] + [string :data "[Image]"]) + `([string :data "[Image]"])))) + ((eq data 'error) + (make-glyph [string :data "[Error]"])) + (file + (make-glyph + (if (featurep 'xbm) + `([xbm :data ,data] + [string :data "[Image]"]) + `([string :data "[Image]"])))) + (t + (make-glyph [nothing])))) + (set-glyph-property glyph 'baseline 100) + ;; Cache the glyph + (push (cons who glyph) about-glyphs))) + glyph)) + +;; Insert info about a maintainer. Add the maintainer-specific info +;; here. +(defun about-maintainer-info (entry) + (ecase (car entry) + (slb + (widget-insert "\ +I took over the maintenance of XEmacs in November of 1996 (it +seemed like a good idea at the time ...). In real life I am a +network administrator and Unix systems programmer for Calag.com, +Inc. a small, but growing ISP in California. + +My main hobby while not maintaining XEmacs or working is ... +you have got to be kidding ...") + (widget-insert ".\n")) + (mrb + (widget-insert "\ +Martin is the XEmacs guy at DevPro, a part of Sun Microsystems. +Martin used to do XEmacs as a `hobby' while at IBM, and was crazy +enough to try to make a living doing it at Sun. + +Martin starting using Emacs originally not to edit files, but to get +the benefit of shell mode. He actually used to run nothing but a shell +buffer, and use `xterm -e vi' to edit files. But then he saw the +light. He dreams of rewriting shell mode from scratch. Stderr should +show up in red!! + +Martin is currently working mostly on Internationalization. He spends +most of his waking hours inside a Japanized XEmacs.\n")) + (hniksic + (widget-insert "\ +Hrvoje is currently a student at the Faculty of Electrical +Engineering and Computing in Zagreb, Croatia. He works part-time +at SRCE, where he helps run the network machines. In his free time he +is helping develop free software (especially XEmacs, as well as GNU +software) and is writing his own -- he has written a small network +mirroring utility Wget, see ") + (about-url-link 'wget "Download Wget") + (widget-insert ".\n")) + (wing + (widget-insert + "\ +I'm not a thug -- I just play one on video. +My roommate says I'm a San Francisco \"Mission Critter\".\n\n" + (about-with-face "Gory stuff follows:" 'italic) + "\n +In 1992 I left a stuffy East-Coast university, set out into the real +world, and ended up a co-founder of Pearl Software. As part of this +company, I became the principal architect of Win-Emacs, a port of +Lucid Emacs to Microsoft Windows and Windows NT (for more info, e-mail +to info@pearlsoft.com). + +Since April 1993, I've worked on XEmacs as a contractor for various +companies, changing hats faster than Ronald Reagan's hair color (oops, +did I just show my age?). My main contributions to XEmacs include +rewriting large parts of the internals and the gory Xt/Xlib +interfacing, adding the Mule support, implementing the external client +widget, improving the documentation (especially the Emacs Lisp +manual), and being a general nuisance ... er, brainstormer for many of +the new features of XEmacs. + +Recently I took a job at Dimension X, where I'm working on a +Java-based toolkit for developing VRML applications.\n")) + (cthomp + (widget-insert "\ +Chuck, through being in the wrong place at the right time, has gotten +stuck with being Jamie's replacement as the primary maintainer of +XEmacs. This has caused his hair to begin falling out and quadrupled +his daily coffee dosage. Though he works at and for the University of +Illinois his funding for XEmacs work actually came from Sun +Microsystems. + +He has worked on XEmacs since November 1992, which fact occasionally +gives him nightmares. As of October 1995, he no longer works +full-time on XEmacs, though he does continue as an active maintainer. +His main contributions have been the greatly enhanced redisplay +engine, scrollbar support, the toolbars, configure support and +numerous other features and fixes. + +Rumors that Chuck is aka Black Francis aka Frank Black are completely +unfounded.\n")) + (jwz + (widget-insert + "\t" + (about-with-face "\"So much to do, so little time.\"" 'italic) + "\n +Jamie Zawinski was primarily to blame for Lucid Emacs from its +inception in 1991, to 1994 when Lucid Inc. finally died. He is now to +be found at Netscape Communications, hacking on Netscape Navigator (he +did the first Unix version and the mail and news reader). Thankfully +his extensive sleep deprivation experiments conducted during 1994 and +1995 are now a thing of the past, but his predilection for dark, +Gothic music remains unabated. + +Come visit his glorified .plan file at\n\n") + (about-url-link 'jwz "Visit Jamie's home page") + (widget-insert "\n")) + (mly + (widget-insert "Cars are evil. Ride a bike.\n")) + (vladimir + (widget-insert "\ +Former technical lead for XEmacs at Sun. He is now with Microtec +Research Inc., working on embedded systems development tools.\n")) + (stig + (widget-insert "\ +Stig is sort of a tool fetishist. He has a hate/love relationship +with computers and he hacks on XEmacs because it's a good tool that +makes computers somewhat less of a nuisance. Besides XEmacs, Stig +especially likes his Leatherman, his Makita, and his lockpicks. Stig +wants a MIG welder and air tools. + +Stig likes to perch, hang from the ceiling, and climb on the walls. +Stig has a cool van. Stig would like to be able to telecommute from, +say, the north rim of the Grand Canyon or the midst of Baja.\n")) + (stigb + (widget-insert "\ +Currently studying computer science in Trondheim, Norway. Full time +Linux user and proud of it. XEmacs hacker light. Maintainer of the +RPM package. + +See:\t") + (about-url-link 'stigb "Visit Stig's home page")) + (baw + (widget-insert + "\ +Author of CC Mode, for C, C++, Objective-C and Java editing, and +Supercite for mail and news citing. Also various and sundry other +Emacs utilities, fixes, enhancements and kludgery as whimsy, boredom, +and ToT dictate (but not necessarily in that order). See also:\n\n\t") + (about-url-link 'baw "Visit Barry's home page") + (widget-insert "\n\nand:\n\n\t") + (about-url-link 'cc-mode "Visit the CC Mode distribution") + (widget-insert "\n +Daddy +\(C) 1994 Warsaw +=============== +Drive me Daddy, drive me quick +Push my pedal, shift my stick +Fill me up with golden gas +My rubber squeals, I go real fast + +Milk me Daddy, milk me now +Milk me like a big ol' cow +I've got milk inside my udder +Churn it up and make some butter\n")) + (piper + (widget-insert "\ +Author of the original \"fake\" XEmacs toolbar, and outl-mouse for +mouse gesture based outlining. Accomplished kludge contributor.\n")) + (bw + (widget-insert "\ +Author of the Hyperbole everyday information management hypertext +system and the OO-Browser multi-language code browser. He also +designed the Altrasoft integrated tool framework for software +engineers. It runs atop XEmacs and is available from his firm, +Altrasoft, which offers distributions, custom development, support, +and training packages for corporate users of XEmacs, GNU Emacs and +InfoDock. See ") + (about-url-link 'altrasoft "Visit Altrasoft WWW page") + (widget-insert ". + +His interests include user interfaces, information management, +CASE tools, communications and enterprise integration.\n")) + (wmperry + (widget-insert "\ +Author of Emacs-w3, the builtin web browser that comes with XEmacs, +and various additions to the C code (e.g. the database support, the +PNG support, some of the GIF/JPEG support, the strikethru face +attribute support). + +He is currently working at Aventail, Corp. on SOCKS v5 servers.\n")) + (kyle + (widget-insert "\ +Author of VM, a mail-reading package that is included in the standard +XEmacs distribution, and contributor of many improvements and bug +fixes. Unlike RMAIL and MH-E, VM uses the standard UNIX mailbox +format for its folders; thus, you can use VM concurrently with other +UNIX mail readers such as Berkeley Mail and ELM. See\n") + (about-url-link 'kyle "Visit Kyle's Home page") + (widget-insert ".\n")) + (larsi + (widget-insert "\ +Author of Gnus the Usenet news and Mail reading package in the +standard XEmacs distribution, and contributor of various enhancements +and portability fixes. Lars is a student at the Institute of +Informatics at the University of Oslo. He is currently plumbing away +at his majors work at the Institute of Physics, working on an SCI +project connected with CASCADE and CERN and stuff. + +See ") + (about-url-link 'larsi "Visit the Larsissistic pages") + (widget-insert ".\n")) + (marcpa + (widget-insert "\ +I work for Positron Industries Inc., Public Safety Division. +I'm part of the team producing POWER 911, a 911 emergency response +system written in Modula3:\n") + (about-url-link 'marcpa "Visit POWER 911") + (widget-insert "\ +Previously, I worked at Softimage Inc., now a Microsoft company +(eeekkk!), as a UNIX system administrator. This is where I've been +converted to NT. + +In a previous life, I was a programmer/sysadmin at CRIM (Centre de +Recherche Informatique de Montreal) for the speech recognition group.\n")) + (jens + (widget-insert "\ +Jens did the artwork for graphics added to XEmacs 20.2 and 19.15. + +I'm currently working at the University of Karlsruhe, Germany on +getting my diploma thesis on Supersymmetry (uuh, that's physics) done. +After that (and all the remaining exams) I'm looking forward to make a +living out of my hobbies -- computers (and graphics). But because I +have no deadline for the exams and XEmacs betas are released at a high +rate this may take some time...\n")) + (jareth + (widget-insert "\ +Jareth Hein is a mountain boy who abandoned his home state of Colorado +for the perpetual state of chaos known as Tokyo in a failed attempt to +become a cel-animator, and a more successful one to become a +computer-game programmer. As he happens to be bilingual (guess which +two?) he's been doing quite a bit of MULE hacking. He's also getting +his hands dirty in the graphics areas as well.\n")) + (morioka + (widget-insert "\ +I am the author of tm-view (general MIME Viewer for GNU Emacs) and +major author and maintainer of tm (Tools for MIME; general MIME +package for GNU Emacs). In addition, I am working to unify MULE API +for Emacs and XEmacs. In XEmacs, I have ported many mule features. + +I am a doctoral student at School of Information Science of JAIST +\(Japan Advanced Institute of Science and Technology, Hokuriku). I'm +interested in Natural Language, Affordance and writing systems.\n")) + (dmoore + (widget-insert "\ +David has contributed greatly to the quest to speed up XEmacs. He is +a student in the Computer Systems Laboratory at UCSD. When he manages +to have free time, he usually spends it on 200 mile bicycle rides, +learning german or showing people the best mail & news environment +he's found in 10 years. (That'd be XEmacs, Gnus and bbdb, of course.) +He can be found at `druidmuck.egbt.org 4201' at various hours of the +day. + +He has a page at ") + (about-url-link 'dmoore "Visit David's home page") + (widget-insert ".\n")) + (thiessel + (widget-insert "\ +On May 1, 1996 he started working at University of Kaiserslautern in +the field of computer aided analog circuit design. His +responsibilities include the development and design of a CAD-Tool for +analog integrated circuits with special emphasis on distributed +software concepts. + +When all the daily hacking is done he tries to take care of XEmacs +website at ") + (about-url-link 'xemacs "Visit XEmacs web site") + (widget-insert ".\n")) + (sperber + (widget-insert "\ +Mike ported EFS to XEmacs 20 and integrated EFS into XEmacs. He's +also responsible for the ports of facemenu.el and enriched.el. When +Mike isn't busy putting together patches for free software he has just +installed or changing his hairstyle, he does research in modern +programming languages and their implementation, and hopes that one day +XEmacs will speak Scheme.\n")) + (vin + (widget-insert "\ +Vin maintains the XEmacs patch pages in order to bring a more +stable XEmacs. (Actually, he does it 'cause it's fun and he's been +using emacs for a long, long time.) Vin also contributed the detached +minibuffer code as well as a few minor enhancements to the menubar +options. + +I own and operate my own consulting firm, EtherSoft. Shhh, don't +tell anyone, but it's named after an Ultimate team I used to play +with in Austin, Texas - the Ether Bunnies. I'm getting too old +to play competitive Ultimate any more, so now I've gotten roped +into serving on the board of directors of the Ultimate Players +Association. See ") + (about-url-link 'vin "Visit the UPA homepage") + (widget-insert ".\n")) + (ajc + (widget-insert "\ +When not helping maintain the XEmacs website, Andrew is a Network +Software Engineer(tm) for Monash University in Australia, maintaining +webservers and doing random other things. As well as spending spare +time being an Eager Young Space Cadet and fiddling with XEmacs/Gnus +et. al., he spends his time pursuing, among other things, a Life. +Some of this currently involves doing an A-Z (by country) of +restaurants with friends, and has, in the past, involved dyeing his +hair various colours (see ") + (about-url-link 'ajc "Visit Andrew's home page") + (widget-insert ".\n")) + (rickc + (widget-insert "\ +The hacker formerly known as Rick Busdiecker develops and maintains +libraries for financial applications at Lehman Brothers during +daylight hours. In the evenings he maintains three children, and +when he ought to be sleeping he co-maintains ILISP, builds XEmacs +betas, and tinkers with various personal hacking projects..\n")) + (kazz + (widget-insert "\ +Kazz is the XEmacs lead on BSD (especially FreeBSD). +His main workspace is, probably, the latest stable version of +FreeBSD and it makes him comfortable and not. +His *mission* is to make XEmacs runs on FreeBSD without +any problem. + +In real life, he is working on a PDM product based on CORBA, +and doing consultation, design and implemention. +He loves to play soccer, yes football! +See also:") + (about-url-link 'kazz "Visit Kazz's home page") + (widget-insert ".\n")) + (dkindred + (widget-insert "\ +Darrell tends to come out of the woodwork a couple of weeks +before a new release with a flurry of fixes for bugs that +annoy him. He hopes he's spared you from a core dump or two. + +Darrell is currently a doctoral student in computer science at +Carnegie Mellon University, but he's trying hard to kick that +habit. + +See ") + (about-url-link 'dkindred "Visit Darrell's WWW page") + (widget-insert ".\n")) + (pez + (widget-insert "\ +Author of SQL Mode, edit-toolbar, mailtool-mode, and various other +small packages with varying degrees of usefulness. Peter has +recently left Wall Street to start Daedalus World Wide Corporation, +a software development firm. See ") + (about-url-link 'pez "Daedalus on the web") + (widget-insert ".\n")) + (dv + (widget-insert "\ +I'm currently working (Ph.D.) on the cognitive aspects of +Human-Machine Interaction in Virtual Environments, and especialy on +the possibility of adding (artificial) intelligence between the system +and the operator, in order to detect the intentions of the latter. + +Otherwise, I'm, say, 35.82% professional Jazz guitar player, +which means that's not the way I earn my crust, but things may very +well reverse in the future ...\n")) + (rossini + (widget-insert "\ +Author of the first XEmacs FAQ, as well as minor priest in the +movement to get every statistician in the world to use XEmacs for +statistical programming and data analysis. Current development lead +for ESS (Emacs Speaks Statistics), a mode and inferior mode for +statistical programming and data analysis for SAS, S, S-PLUS, R, +XLispStat; configurable for nearly any other statistical +language/package one might want. In spare time, acts as a +Ph.D. (bio)statistician for money and amusement. Current position: +Assistant Professor of Statistics at the University of South Carolina.\n")) + (ograf + (widget-insert "\ +I'm a student of computer sciences at the University of Koblenz. My +major is computational linguistics (human language generation and +analysis). + +I make my living as a managing director of a small but fine company +which I started two years ago with one of my friends. We provide +business network solutions based on linux servers and various other +networking products. + +Most of my spare time I spent on the development of the XEmacs DnD +events, a enhanced version of Tk called TkStep (better looks, DnD, +and more), and various other minor hacks: ISDN-tools, cd players, +python, etc... + +To see some of these have a look at ") + (about-url-link 'ograf "one of my homepages") + (widget-insert ".\n")) + (juhp + (widget-insert "\ +I started using XEmacs-20 as my work-environment in June 1997. I +became a beta developer shortly after that (\"it seems like a good +idea at the time...\" :-), so far contributing mainly bug fixes, +\"find-func.el\" and improvements to \"help.el\". + +My current dreams for XEmacs: move to using guile as the Lisp engine +and gtk as the default X toolkit. + +I have been a postdoctoral researcher at the Research Institute for +Mathematical Sciences, Kyoto University, since August 1994, doing +research in mathematical physics (representation theory of quantum +groups). Though now I seem to be heading for other things. + +My homepage is ") + (about-url-link 'juhp "Visit Jens' homepage") + (widget-insert ".\n")) + +)) + +;; Setup the buffer for a maintainer. +(defun about-maintainer (widget &optional event) + (let* ((entry (assq (widget-value widget) xemacs-hackers)) + (who (car entry)) + (name (cadr entry)) + (address (caddr entry)) + (bufname (format "*About %s*" name))) + (unless (about-get-buffer bufname) + ;; Display the glyph and name + (widget-insert "\n") + (widget-create 'default :format "%t" + :tag-glyph (about-maintainer-glyph who)) + (widget-insert + " " (about-with-face (format "%s" name) 'bold) + " <" address ">\n\n") + ;; Display the actual info + (about-maintainer-info entry) + ;; I don't use `about-finish-buffer' because I want "Remove" to + ;; kill the buffer. + (widget-insert "\n") + (about-finish-buffer 'kill) + (forward-line 2)))) + +(defsubst about-tabs (str) + (let ((x (length str))) + (cond ((>= x 24) " ") + ((>= x 16) "\t") + ((>= x 8) "\t\t") + (t "\t\t\t")))) + +(defun about-show-linked-info (who shortinfo) + (let* ((entry (assq who xemacs-hackers)) + (name (cadr entry)) + (address (caddr entry))) + (widget-create 'link :help-echo (concat "Find out more about " name) + :action 'about-maintainer + :button-prefix "" + :button-suffix "" + :tag name + :value who) + (widget-insert (about-tabs name) + (format "<%s>\n%s\n" address shortinfo)))) + +(defun about-hackers (&rest ignore) + (unless (about-get-buffer "*About Hackers*") + (let ((title "Other Contributors to XEmacs")) + (widget-insert + (about-center title) + (about-with-face title 'bold))) + (widget-insert + "\n +Like most free software, XEmacs is a collaborative effort. These are +some of the contributors. We have no doubt forgotten someone; we +apologize! You can see some of our faces under the links.\n\n") + (about-show-linked-info 'vladimir "\ +Former technical lead for XEmacs at Sun Microsystems. He is now with +Microtec Research Inc., working on embedded systems development tools.\n") + (about-show-linked-info 'stig "\ +Peripatetic uninominal Emacs hacker. Stig sometimes operates out of a +big white van set up for nomadic living and hacking. Implemented the +faster stay-up Lucid menus and hyper-apropos. Contributor of many +dispersed improvements in the core Lisp code, and back-seat +contributor for several of it's major packages.\n") + (about-show-linked-info 'baw "\ +Author of CC Mode for C, C++, Objective-C and Java editing, and +Supercite for mail and news citing. Also various and sundry other +Emacs utilities, fixes, enhancements and kludgery as whimsy, boredom, +and ToT dictate (but not necessarily in that order).\n") + (about-show-linked-info 'piper "\ +Created the prototype for the toolbars. Has been the first to make +use of many of the new XEmacs graphics features.\n") + (about-show-linked-info 'bw "\ +Author of the Hyperbole everyday information management hypertext +system and the OO-Browser multi-language code browser. He also +designed the Altrasoft integrated tool framework for software +engineers. It runs atop XEmacs and is available from his firm, +Altrasoft, which offers custom development and support packages for +corporate users of XEmacs, GNU Emacs and InfoDock. His interests +include user interfaces, information management, CASE tools, +communications and enterprise integration.\n") + (about-show-linked-info 'wmperry "\ +Author of Emacs-w3, the builtin web browser that comes with XEmacs, +and various additions to the C code (e.g. the database support, the +PNG support, some of the GIF/JPEG support, the strikethru face +attribute support).\n") + (about-show-linked-info 'kyle "\ +Author of VM, a mail-reading package that is included in the standard +XEmacs distribution, and contributor of many improvements and bug +fixes. Unlike RMAIL and MH-E, VM uses the standard UNIX mailbox +format for its folders; thus, you can use VM concurrently with other +UNIX mail readers such as Berkeley Mail and ELM.\n") + (about-show-linked-info 'larsi "\ +Author of Gnus the Usenet news and Mail reading package in the +standard XEmacs distribution, and contributor of various enhancements +and portability fixes. Lars is a student at the Institute of +Informatics at the University of Oslo. He is currently plumbing away +at his majors work at the Institute of Physics, working on an SCI +project connected with CASCADE and CERN and stuff.\n") + (about-show-linked-info 'jens "\ +I'm currently working at the University of Karlsruhe, Germany on +getting my diploma thesis on Supersymmetry (uuh, that's physics) done. +After that (and all the remaining exams) I'm looking forward to make a +living out of my hobbies -- computers (and graphics). But because I +have no deadline for the exams and XEmacs betas are released at a high +rate this may take some time...\n") + (about-show-linked-info 'jareth "\ +Jareth Hein is a mountain boy who abandoned his home state of Colorado +for the perpetual state of chaos known as Tokyo in a failed attempt to +become a cel-animator, and a more successful one to become a +computer-game programmer. As he happens to be bilingual (guess which +two?) he's been doing quite a bit of MULE hacking. He's also getting +his hands dirty in the graphics areas as well.\n") + (about-show-linked-info 'morioka "\ +I am the author of tm-view (general MIME Viewer for GNU Emacs) and +major author and maintainer of tm (Tools for MIME; general MIME +package for GNU Emacs). In addition, I am working to unify MULE API +for Emacs and XEmacs. In XEmacs, I have ported many mule features. + +I am a doctoral student at School of Information Science of JAIST +\(Japan Advanced Institute of Science and Technology, Hokuriku). I'm +interested in Natural Language, Affordance and writing systems.\n") + (about-show-linked-info 'dmoore "\ +David has contributed greatly to the quest to speed up XEmacs. He is +a student in the Computer Systems Laboratory at UCSD. When he manages +to have free time, he usually spends it on 200 mile bicycle rides, +learning german or showing people the best mail & news environment +he's found in 10 years. (That'd be XEmacs, Gnus and bbdb, of course.) +He can be found at `druidmuck.egbt.org 4201' at various hours of the +day.\n") + (about-show-linked-info 'thiessel "\ +On May 1, 1996 he started working at University of Kaiserslautern in +the field of computer aided analog circuit design. His +responsibilities include the development and design of a CAD-Tool for +analog integrated circuits with special emphasis on distributed +software concepts. + +When all the daily hacking is done he tries to take care of XEmacs +website at .\n") + (about-show-linked-info 'ajc "\ +When not helping maintain the XEmacs website, Andrew is a Network +Software Engineer(tm) for Monash University in Australia, maintaining +webservers and doing random other things. As well as spending spare +time being an Eager Young Space Cadet and fiddling with XEmacs/Gnus +et. al., he spends his time pursuing, among other things, a Life. +Some of this currently involves doing an A-Z (by country) of +restaurants with friends, and has, in the past, involved dyeing his +hair various colours.\n") + (about-show-linked-info 'kazz "\ +IENAGA Kazuyuki is the XEmacs technical lead on BSD, particularly +FreeBSD.\n") + (about-show-linked-info 'dkindred "\ +Darrell tends to come out of the woodwork a couple of weeks +before a new release with a flurry of fixes for bugs that +annoy him. He hopes he's spared you from a core dump or two. + +Darrell is currently a doctoral student in computer science at +Carnegie Mellon University, but he's trying hard to kick that +habit.\n") + (about-show-linked-info 'dv "\ +I'm currently working (Ph.D.) on the cognitive aspects of +Human-Machine Interaction in Virtual Environments, and especialy on +the possibility of adding (artificial) intelligence between the system +and the operator, in order to detect the intentions of the latter. + +Otherwise, I'm, say, 35.82% professional Jazz guitar player, +which means that's not the way I earn my crust, but things may very +well reverse in the future ...\n") + (about-show-linked-info 'marcpa "\ +I work for Positron Industries Inc., Public Safety Division.\n") + (about-show-linked-info 'pez "\ +Author of SQL Mode, edit-toolbar, mailtool-mode, and various other +small packages with varying degrees of usefulness.\n") + (about-show-linked-info 'rickc "\ +The hacker formerly known as Rick Busdiecker, maintainer of ILISP.\n") + (about-show-linked-info 'rossini "\ +Author of the first XEmacs FAQ, as well as minor priest in the +movement to get every statistician in the world to use XEmacs for +statistical programming and data analysis. Current development lead +for ESS (Emacs Speaks Statistics), a mode and inferior mode for +statistical programming and data analysis for SAS, S, S-PLUS, R, +XLispStat; configurable for nearly any other statistical +language/package one might want. In spare time, acts as a +Ph.D. (bio)statistician for money and amusement. Current position: +Assistant Professor of Statistics at the University of South Carolina.\n") + (about-show-linked-info 'stigb "\ +Currently studying computer science in Trondheim, Norway. Full time +Linux user and proud of it. XEmacs hacker light. Maintainer of the +RPM package.\n") + (about-show-linked-info 'ograf "\ +Is currently working on the integration of OffiX and CDE drag-and-drop +into the event system of XEmacs.\n") + (about-show-linked-info 'juhp "\ +Author of \"find-func.el\".\n") + (flet ((print-short (name addr &optional shortinfo) + (concat (about-with-face name 'italic) + (about-tabs name) + "<" addr ">\n" + (if shortinfo (concat shortinfo "\n") "")))) + (widget-insert + (print-short "Eduardo Pelegri-Llopart" "pelegri@eng.sun.com" "\ +Author of EOS, a package included in the standard XEmacs distribution +that integrates XEmacs with the SPARCworks development environment +from Sun. Past lead for XEmacs at Sun; advocated the validity of +using Epoch, and later Lemacs, at Sun through several early +prototypes.\n") + (print-short "Matthieu Devin" "devin@rs.com" "\ +Part of the original (pre-19.0) Lucid Emacs development team. +Matthieu wrote the initial Energize interface, designed the +toolkit-independent Lucid Widget library, and fixed enough redisplay +bugs to last a lifetime. The features in Lucid Emacs were largely +inspired by Matthieu's initial prototype of an Energize interface +using Epoch.\n") + (print-short "Harlan Sexton" "hbs@odi.com" "\ +Part of the original (pre-19.0) Lucid Emacs development team. Harlan +designed and implemented many of the low level data structures which +are original to the Lucid version of Emacs, including extents and hash +tables.\n") + (print-short "Eric Benson" "eb@kaleida.com" "\ +Also part of the original Lucid Emacs development team. Eric played a +big part in the design of many aspects of the system, including the +new command loop and keymaps, fixed numerous bugs, and has been a +reliable beta tester ever since.\n") + (print-short "John Rose" "john.rose@sun.com" "\ +Author of many extensions to the `extents' code, including the initial +implementation of `duplicable' properties.\n") + (print-short "Hans Muller" "hmuller@eng.sun.com" "\ +Author of the code used to connect XEmacs with ToolTalk, and of an +early client of the external Emacs widget.\n") + (print-short "David hobley" "david.hobley@usa.net" "\ +I used to do real work, but now I am a Project Manager for one of the +Telco's in Australia. In my spare time I like to get back to basics and +muck around with things. As a result I started the NT port. Hopefully I +will get to finish it sometime sooner rather than later. I do vaguely +remember University where it seems like I had more spare time that I can +believe now. Oh well, such is life.\n") + "\n\ +In addition to those just mentioned, the following people have spent a +great deal of effort providing feedback, testing beta versions of +XEmacs, providing patches to the source code, or doing all of the +above. We couldn't have done it without them.\n\n" + (print-short "Nagi M. Aboulenein" "aboulene@ponder.csci.unt.edu") + (print-short "Per Abrahamsen" "abraham@dina.kvl.dk") + (print-short "Gary Adams" "gra@zeppo.East.Sun.COM") + (print-short "Gennady Agranov" "agranov@csa.CS.Technion.Ac.IL") + (print-short "Adrian Aichner" "aichner@ecf.teradyne.com") + (print-short "Mark Allender" "allender@vnet.IBM.COM") + (print-short "Butch Anton" "butch@zaphod.uchicago.edu") + (print-short "Fred Appelman" "Fred.Appelman@cv.ruu.nl") + (print-short "Erik \"The Pope\" Arneson" "lazarus@mind.net") + (print-short "Tor Arntsen" "tor@spacetec.no") + (print-short "Marc Aurel" "4-tea-2@bong.saar.de") + (print-short "Larry Auton" "lda@control.att.com") + (print-short "Oswald P. Backus IV" "backus@altagroup.com") + (print-short "Mike Battaglia" "mbattagl@dsccc.com") + (print-short "Neal Becker" "neal@ctd.comsat.com") + (print-short "Paul Bibilo" "peb@delcam.com") + (print-short "Leonard Blanks" "ltb@haruspex.demon.co.uk") + (print-short "Jan Borchers" "job@tk.uni-linz.ac.at") + (print-short "Mark Borges" "mdb@cdc.noaa.gov") + (print-short "David P. Boswell" "daveb@tau.space.thiokol.com") + (print-short "Tim Bradshaw" "tfb@edinburgh.ac.uk") + (print-short "Rick Braumoeller" "rickb@mti.sgi.com") + (print-short "Matthew J. Brown" "mjb@doc.ic.ac.uk") + (print-short "Alastair Burt" "burt@dfki.uni-kl.de") + (print-short "Richard Caley" "rjc@cstr.edinburgh.ac.uk") + (print-short "Stephen Carney" "carney@gvc.dec.com") + (print-short "Lorenzo M. Catucci" "lorenzo@argon.roma2.infn.it") + (print-short "Philippe Charton" "charton@lmd.ens.fr") + (print-short "Peter Cheng" "peter.cheng@sun.com") + (print-short "Jin S. Choi" "jin@atype.com") + (print-short "Tomasz J. Cholewo" "tjchol01@mecca.spd.louisville.edu") + (print-short "Serenella Ciongoli" "czs00@ladybug.oes.amdahl.com") + (print-short "Glynn Clements" "glynn@sensei.co.uk") + (print-short "Richard Cognot" "cognot@ensg.u-nancy.fr") + (print-short "Andy Cohen" "cohen@andy.bu.edu") + (print-short "Andrew J Cosgriff" "ajc@bing.wattle.id.au") + (print-short "Nick J. Crabtree" "nickc@scopic.com") + (print-short "Christopher Davis" "ckd@kei.com") + (print-short "Soren Dayton" "csdayton@cs.uchicago.edu") + (print-short "Chris Dean" "ctdean@cogit.com") + (print-short "Michael Diers" "mdiers@logware.de") + (print-short "William G. Dubuque" "wgd@martigny.ai.mit.edu") + (print-short "Steve Dunham" "dunham@dunham.tcimet.net") + (print-short "Samuel J. Eaton" "samuele@cogs.susx.ac.uk") + (print-short "Carl Edman" "cedman@Princeton.EDU") + (print-short "Dave Edmondson" "davided@sco.com") + (print-short "Jonathan Edwards" "edwards@intranet.com") + (print-short "Eric Eide" "eeide@asylum.cs.utah.edu") + (print-short "EKR" "ekr@terisa.com") + (print-short "Oscar Figueiredo" "Oscar.Figueiredo@di.epfl.ch") + (print-short "David Fletcher" "frodo@tsunami.com") + (print-short "Paul Flinders" "ptf@delcam.co.uk") + (print-short "Jered J Floyd" "jered@mit.edu") + (print-short "Gary D. Foster" "Gary.Foster@Corp.Sun.COM") + (print-short "Jerry Frain" "jerry@sneffels.tivoli.com") + (print-short "Holger Franz" "hfranz@physik.rwth-aachen.de") + (print-short "Benjamin Fried" "bf@morgan.com") + (print-short "Barry Friedman" "friedman@nortel.ca") + (print-short "Noah Friedman" "friedman@splode.com") + (print-short "Kazuyoshi Furutaka" "furutaka@Flux.tokai.jaeri.go.jp") + (print-short "Lew Gaiter III" "lew@StarFire.com") + (print-short "Olivier Galibert" "Olivier.Galibert@mines.u-nancy.fr") + (print-short "Itay Gat" "itay@cs.huji.ac.il") + (print-short "Tim Geisler" "Tim.Geisler@informatik.uni-muenchen.de") + (print-short "Dave Gillespie" "daveg@synaptics.com") + (print-short "Christian F. Goetze" "cg@bigbook.com") + (print-short "Yusuf Goolamabbas" "yusufg@iss.nus.sg") + (print-short "Wolfgang Grieskamp" "wg@cs.tu-berlin.de") + (print-short "John Griffith" "griffith@sfs.nphil.uni-tuebingen.de") + (print-short "James Grinter" "jrg@demon.net") + (print-short "Ben Gross" "bgross@uiuc.edu") + (print-short "Dirk Grunwald" "grunwald@foobar.cs.Colorado.EDU") + (print-short "Michael Guenther" "michaelg@igor.stuttgart.netsurf.de") + (print-short "Dipankar Gupta" "dg@hplb.hpl.hp.com") + (print-short "Markus Gutschke" "gutschk@GOEDEL.UNI-MUENSTER.DE") + (print-short "Adam Hammer" "hammer@cs.purdue.edu") + (print-short "Magnus Hammerin" "magnush@epact.se") + (print-short "ChangGil Han" "cghan@phys401.phys.pusan.ac.kr") + (print-short "Derek Harding" "dharding@lssec.bt.co.uk") + (print-short "Michael Harnois" "mharnois@sbt.net") + (print-short "John Haxby" "J.Haxby@isode.com") + (print-short "Karl M. Hegbloom" "karlheg@inetarena.com") + (print-short "Benedikt Heinen" "beh@icemark.thenet.ch") + (print-short "Stephan Herrmann" "sh@first.gmd.de") + (print-short "Charles Hines" "chuck_hines@VNET.IBM.COM") + (print-short "Shane Holder" "holder@rsn.hp.com") + (print-short "David Hughes" "djh@harston.cv.com") + (print-short "Tatsuya Ichikawa" "ichikawa@hv.epson.co.jp") + (print-short "Andrew Innes" "andrewi@harlequin.co.uk") + (print-short "Andreas Jaeger" "aj@arthur.rhein-neckar.de") + (print-short "Markku Jarvinen" "Markku.Jarvinen@simpukka.funet.fi") + (print-short "Robin Jeffries" "robin.jeffries@sun.com") + (print-short "Philip Johnson" "johnson@uhics.ics.Hawaii.Edu") + (print-short "J. Kean Johnston" "jkj@paradigm-sa.com") + (print-short "Andreas Kaempf" "andreas@sccon.com") + (print-short "Yoshiaki Kasahara" "kasahara@nc.kyushu-u.ac.jp") + (print-short "Amir Katz" "amir@ndsoft.com") + (print-short "Doug Keller" "dkeller@vnet.ibm.com") + (print-short "Hunter Kelly" "retnuh@corona") + (print-short "Gregor Kennedy" "gregork@dadd.ti.com") + (print-short "Michael Kifer" "kifer@cs.sunysb.edu") + (print-short "Yasuhiko Kiuchi" "kiuchi@dsp.ksp.fujixerox.co.jp") + (print-short "Greg Klanderman" "greg@alphatech.com") + (print-short "Valdis Kletnieks" "Valdis.Kletnieks@vt.edu") + (print-short "Rob Kooper" "kooper@cc.gatech.edu") + (print-short "Peter Skov Knudsen" "knu@dde.dk") + (print-short "Jens Krinke" "krinke@ips.cs.tu-bs.de") + (print-short "Mats Larsson" "Mats.Larsson@uab.ericsson.se") + (print-short "Simon Leinen" "simon@instrumatic.ch") + (print-short "Carsten Leonhardt" "leo@arioch.tng.oche.de") + (print-short "James LewisMoss" "moss@cs.sc.edu") + (print-short "Mats Lidell" "mats.lidell@contactor.se") + (print-short "Matt Liggett" "mliggett@seven.ucs.indiana.edu") + (print-short "Christian Limpach" "Christian.Limpach@nice.ch") + (print-short "Markus Linnala" "maage@b14b.tupsu.ton.tut.fi") + (print-short "Robert Lipe" "robertl@arnet.com") + (print-short "Derrell Lipman" "derrell@vis-av.com") + (print-short "Damon Lipparelli" "lipp@aa.net") + (print-short "Hamish Macdonald" "hamish@bnr.ca") + (print-short "Ian MacKinnon" "imackinnon@telia.co.uk") + (print-short "Patrick MacRoberts" "macro@hpcobr30.cup.hp.com") + (print-short "Tonny Madsen" "Tonny.Madsen@netman.dk") + (print-short "Ketil Z Malde" "ketil@ii.uib.no") + (print-short "Steve March" "smarch@quaver.urbana.mcd.mot.com") + (print-short "Ricardo Marek" "ricky@ornet.co.il") + (print-short "Pekka Marjola" "pema@iki.fi") + (print-short "Simon Marshall" "simon@gnu.ai.mit.edu") + (print-short "Dave Mason" "dmason@plg.uwaterloo.ca") + (print-short "Jason R Mastaler" "jason@4b.org") + (print-short "Jaye Mathisen" "mrcpu@cdsnet.net") + (print-short "Jason McLaren" "mclaren@math.mcgill.ca") + (print-short "Michael McNamara" "mac@silicon-sorcery.com") + (print-short "Michael Meissner" "meissner@osf.org") + (print-short "David M. Meyer" "meyer@ns.uoregon.edu") + (print-short "Brad Miller" "bmiller@cs.umn.edu") + (print-short "Jeff Miller" "jmiller@smart.net") + (print-short "John Morey" "jmorey@crl.com") + (print-short "Rob Mori" "rob.mori@sun.com") + (print-short "Heiko Muenkel" "muenkel@tnt.uni-hannover.de") + (print-short "Arup Mukherjee" "arup+@cs.cmu.edu") + (print-short "Colas Nahaboo" "Colas.Nahaboo@sophia.inria.fr") + (print-short "Lynn D. Newton" "lynn@ives.phx.mcd.mot.com") + (print-short "Casey Nielson" "knielson@joule.elee.calpoly.edu") + (print-short "Georg Nikodym" "Georg.Nikodym@canada.sun.com") + (print-short "Andy Norman" "ange@hplb.hpl.hp.com") + (print-short "Joe Nuspl" "nuspl@sequent.com") + (print-short "Kim Nyberg" "kny@tekla.fi") + (print-short "David Ofelt" "ofelt@getalife.Stanford.EDU") + (print-short "Alexandre Oliva" "oliva@dcc.unicamp.br") + (print-short "Tore Olsen" "toreo@colargol.idb.hist.no") + (print-short "Greg Onufer" "Greg.Onufer@eng.sun.com") + (print-short "Achim Oppelt" "aoppelt@theorie3.physik.uni-erlangen.de") + (print-short "Rebecca Ore" "rebecca.ore@op.net") + (print-short "Sudeep Kumar Palat" "palat@idt.unit.no") + (print-short "Joel Peterson" "tarzan@aosi.com") + (print-short "Thomas A. Peterson" "tap@src.honeywell.com") + (print-short "Tibor Polgar" "tlp00@eng.amdahl.com") + (print-short "Frederic Poncin" "fp@info.ucl.ac.be") + (print-short "E. Rehmi Post" "rehmi@asylum.sf.ca.us") + (print-short "Martin Pottendorfer" "Martin.Pottendorfer@aut.alcatel.at") + (print-short "Colin Rafferty" "craffert@ml.com") + (print-short "Paul M Reilly" "pmr@pajato.com") + (print-short "Jack Repenning" "jackr@sgi.com") + (print-short "Daniel Rich" "drich@cisco.com") + (print-short "Roland Rieke" "rol@darmstadt.gmd.de") + (print-short "Art Rijos" "art.rijos@SNET.com") + (print-short "Russell Ritchie" "ritchier@britannia-life.co.uk") + (print-short "Roland" "rol@darmstadt.gmd.de") + (print-short "Mike Russell" "mjruss@rchland.vnet.ibm.com") + (print-short "Jan Sandquist" "etxquist@iqa.ericsson.se") + (print-short "Marty Sasaki" "sasaki@spdcc.com") + (print-short "SATO Daisuke" "densuke@ga2.so-net.or.jp") + (print-short "Mike Scheidler" "c23mts@eng.delcoelect.com") + (print-short "Daniel Schepler" "daniel@shep13.wustl.edu") + (print-short "Darrel Schneider" "darrel@slc.com") + (print-short "Hayden Schultz" "haydens@ll.mit.edu") + (print-short "Cotton Seed" "cottons@cybercom.net") + (print-short "Axel Seibert" "seiberta@informatik.tu-muenchen.de") + (print-short "Odd-Magne Sekkingstad" "oddms@ii.uib.no") + (print-short "Justin Sheehy" "justin@linus.mitre.org") + (print-short "John Shen" "zfs60@cas.org") + (print-short "Murata Shuuichirou" "mrt@mickey.ai.kyutech.ac.jp") + (print-short "Matt Simmons" "simmonmt@acm.org") + (print-short "Dinesh Somasekhar" "somasekh@ecn.purdue.edu") + (print-short "Jeffrey Sparkes" "jsparkes@bnr.ca") + (print-short "Manoj Srivastava" "srivasta@pilgrim.umass.edu") + (print-short "Francois Staes" "frans@kiwi.uia.ac.be") + (print-short "Anders Stenman" "stenman@isy.liu.se") + (print-short "Jason Stewart" "jasons@cs.unm.edu") + (print-short "Rick Tait" "rickt@gnu.ai.mit.edu") + (print-short "Samuel Tardieu" "sam@inf.enst.fr") + (print-short "James Thompson" "thompson@wg2.waii.com") + (print-short "Raymond L. Toy" "toy@rtp.ericsson.se") + (print-short "Remek Trzaska" "remek@npac.syr.edu") + (print-short "TSUTOMU Nakamura" "tsutomu@rs.kyoto.omronsoft.co.jp") + (print-short "Stephen Turnbull" "turnbull@sk.tsukuba.ac.jp") + (print-short "John Turner" "turner@xdiv.lanl.gov") + (print-short "UENO Fumihiro" "7m2vej@ritp.ye.IHI.CO.JP") + (print-short "Aki Vehtari" "Aki.Vehtari@hut.fi") + (print-short "Juan E. Villacis" "jvillaci@cs.indiana.edu") + (print-short "Jan Vroonhof" "vroonhof@math.ethz.ch") + (print-short "Vladimir Vukicevic" "vladimir@intrepid.com") + (print-short "David Walte" "djw18@cornell.edu") + (print-short "Peter Ware" "ware@cis.ohio-state.edu") + (print-short "Yoav Weiss" "yoav@zeus.datasrv.co.il") + (print-short "Rod Whitby" "rwhitby@asc.corp.mot.com") + (print-short "Rich Williams" "rdw@hplb.hpl.hp.com") + (print-short "David C Worenklein" "dcw@gcm.com") + (print-short "Takeshi Yamada" "yamada@sylvie.kecl.ntt.jp") + (print-short "Katsumi Yamaoka" "yamaoka@ga.sony.co.jp") + (print-short "Jason Yanowitz" "yanowitz@eternity.cs.umass.edu") + (print-short "La Monte Yarroll" "piggy@hilbert.maths.utas.edu.au") + (print-short "Blair Zajac" "blair@olympia.gps.caltech.edu") + (print-short "Daniel Zivkovic" "daniel@canada.sun.com") + (print-short "Karel Zuiderveld" "Karel.Zuiderveld@cv.ruu.nl") + "\n")) + (about-finish-buffer))) + +;;; about.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/apropos.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/apropos.el Mon Aug 13 10:08:34 2007 +0200 @@ -0,0 +1,676 @@ +;;; apropos.el --- apropos commands for users and programmers. + +;; Copyright (C) 1989, 1994, 1995 Free Software Foundation, Inc. + +;; Author: Joe Wells +;; Rewritten: Daniel.Pfeiffer@Informatik.START.dbp.de, fax (+49 69) 7588-2389 +;; Keywords: help + +;; This file is part of XEmacs. + +;; XEmacs 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. + +;; XEmacs 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., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: FSF 19.34. + +;;; Commentary: + +;; The ideas for this package were derived from the C code in +;; src/keymap.c and elsewhere. The functions in this file should +;; always be byte-compiled for speed. Someone should rewrite this in +;; C (as part of src/keymap.c) for speed. + +;; The idea for super-apropos is based on the original implementation +;; by Lynn Slater . + +;; History: +;; Fixed bug, current-local-map can return nil. +;; Change, doesn't calculate key-bindings unless needed. +;; Added super-apropos capability, changed print functions. +;;; Made fast-apropos and super-apropos share code. +;;; Sped up fast-apropos again. +;; Added apropos-do-all option. +;;; Added fast-command-apropos. +;; Changed doc strings to comments for helping functions. +;;; Made doc file buffer read-only, buried it. +;; Only call substitute-command-keys if do-all set. + +;; Optionally use configurable faces to make the output more legible. +;; Differentiate between command, function and macro. +;; Apropos-command (ex command-apropos) does cmd and optionally user var. +;; Apropos shows all 3 aspects of symbols (fn, var and plist) +;; Apropos-documentation (ex super-apropos) now finds all it should. +;; New apropos-value snoops through all values and optionally plists. +;; Reading DOC file doesn't load nroff. +;; Added hypertext following of documentation, mouse-2 on variable gives value +;; from buffer in active window. + +;;; Code: + +;; I see a degradation of maybe 10-20% only. +;; [sb -- FSF protects the face declarations with `if window-system' +;; I see no reason why we should do so] +(defvar apropos-do-all nil + "*Whether the apropos commands should do more. +Slows them down more or less. Set this non-nil if you have a fast machine.") + +;; XEmacs addition +(defvar apropos-symbol-face (if (boundp 'font-lock-keyword-face) + font-lock-keyword-face + 'bold) + "*Face for symbol name in apropos output or `nil'. +This looks good, but slows down the commands several times.") + +;; XEmacs addition +(defvar apropos-keybinding-face (if (boundp 'font-lock-string-face) + font-lock-string-face + 'underline) + "*Face for keybinding display in apropos output or `nil'. +This looks good, but slows down the commands several times.") + +;; XEmacs addition +(defvar apropos-label-face (if (boundp 'font-lock-comment-face) + font-lock-comment-face + 'italic) + "*Face for label (Command, Variable ...) in apropos output or `nil'. +If this is `nil' no mouse highlighting occurs. +This looks good, but slows down the commands several times. +When this is a face name, as it is initially, it gets transformed to a +text-property list for efficiency.") + +;; XEmacs addition +(defvar apropos-property-face (if (boundp 'font-lock-variable-name-face) + font-lock-variable-name-face + 'bold-italic) + "*Face for property name in apropos output or `nil'. +This looks good, but slows down the commands several times.") + +(defvar apropos-match-face 'secondary-selection + "*Face for matching part in apropos-documentation/value output or `nil'. +This looks good, but slows down the commands several times.") + + +(defvar apropos-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [(control m)] 'apropos-follow) + (define-key map [(button2up)] 'apropos-mouse-follow) + (define-key map [(button2)] 'undefined) + map) + "Keymap used in Apropos mode.") + + +(defvar apropos-regexp nil + "Regexp used in current apropos run.") + +(defvar apropos-files-scanned () + "List of elc files already scanned in current run of `apropos-documentation'.") + +(defvar apropos-accumulator () + "Alist of symbols already found in current apropos run.") + +(defvar apropos-item () + "Current item in or for apropos-accumulator.") + +(defvar apropos-mode-hook nil) ; XEmacs + +(defun apropos-mode () + "Major mode for following hyperlinks in output of apropos commands. + +\\{apropos-mode-map}" + (interactive) + (kill-all-local-variables) + (use-local-map apropos-mode-map) + (setq major-mode 'apropos-mode + mode-name "Apropos") + (run-hooks 'apropos-mode-hook)) ; XEmacs + + +;; For auld lang syne: +;;;###autoload +(fset 'command-apropos 'apropos-command) +;;;###autoload +(defun apropos-command (apropos-regexp &optional do-all) + "Shows commands (interactively callable functions) that match REGEXP. +With optional prefix ARG or if `apropos-do-all' is non-nil, also show +variables." + (interactive (list (read-string (concat "Apropos command " + (if (or current-prefix-arg + apropos-do-all) + "or variable ") + "(regexp): ")) + current-prefix-arg)) + (let ((message + (let ((standard-output (get-buffer-create "*Apropos*"))) + (print-help-return-message 'identity)))) + (or do-all (setq do-all apropos-do-all)) + (setq apropos-accumulator + (apropos-internal apropos-regexp + (if do-all + (lambda (symbol) (or (commandp symbol) + (user-variable-p symbol))) + 'commandp))) + (if (apropos-print + t + (lambda (p) + (let (doc symbol) + (while p + (setcar p (list + (setq symbol (car p)) + (if (commandp symbol) + (if (setq doc + ;; XEmacs change: if obsolete, + ;; only mention that. + (or (function-obsoleteness-doc symbol) + (documentation symbol t))) + (substring doc 0 (string-match "\n" doc)) + "(not documented)")) + (and do-all + (user-variable-p symbol) + (if (setq doc + (or + ;; XEmacs change: if obsolete, + ;; only mention that. + (variable-obsoleteness-doc symbol) + (documentation-property + symbol 'variable-documentation t))) + (substring doc 0 + (string-match "\n" doc)))))) + (setq p (cdr p))))) + nil) + (and message (message message))))) + + +;;;###autoload +(defun apropos (apropos-regexp &optional do-all) + "Show all bound symbols whose names match REGEXP. +With optional prefix ARG or if `apropos-do-all' is non-nil, also show unbound +symbols and key bindings, which is a little more time-consuming. +Returns list of symbols and documentation found." + (interactive "sApropos symbol (regexp): \nP") + ;; XEmacs change: hitting ENTER by mistake is a common mess-up and + ;; shouldn't make Emacs hang for a long time trying to list all symbols. + (or (> (length apropos-regexp) 0) + (error "Must pass non-empty regexp to `apropos'")) + (setq apropos-accumulator + (apropos-internal apropos-regexp + (and (not do-all) + (not apropos-do-all) + (lambda (symbol) + (or (fboundp symbol) + (boundp symbol) + (find-face symbol) + (symbol-plist symbol)))))) + (apropos-print + (or do-all apropos-do-all) + (lambda (p) + (let (symbol doc) + (while p + (setcar p (list + (setq symbol (car p)) + (if (fboundp symbol) + (if (setq doc + ;; XEmacs change: if obsolete, + ;; only mention that. + (or (function-obsoleteness-doc symbol) + (documentation symbol t))) + (substring doc 0 (string-match "\n" doc)) + "(not documented)")) + (if (boundp symbol) + (if (setq doc + (or + ;; XEmacs change: if obsolete, + ;; only mention that. + (variable-obsoleteness-doc symbol) + (documentation-property + symbol 'variable-documentation t))) + (substring doc 0 + (string-match "\n" doc)) + "(not documented)")) + (if (setq doc (symbol-plist symbol)) + (if (eq (/ (length doc) 2) 1) + (format "1 property (%s)" (car doc)) + (concat (/ (length doc) 2) " properties"))) + (if (get symbol 'widget-type) + (if (setq doc (documentation-property + symbol 'widget-documentation t)) + (substring doc 0 + (string-match "\n" doc)) + "(not documented)")) + (if (find-face symbol) + (if (setq doc (face-doc-string symbol)) + (substring doc 0 + (string-match "\n" doc)) + "(not documented)")) + (when (get symbol 'custom-group) + (if (setq doc (documentation-property + symbol 'group-documentation t)) + (substring doc 0 + (string-match "\n" doc)) + "(not documented)")))) + (setq p (cdr p))))) + nil)) + + +;;;###autoload +(defun apropos-value (apropos-regexp &optional do-all) + "Show all symbols whose value's printed image matches REGEXP. +With optional prefix ARG or if `apropos-do-all' is non-nil, also looks +at the function and at the names and values of properties. +Returns list of symbols and values found." + (interactive "sApropos value (regexp): \nP") + (or do-all (setq do-all apropos-do-all)) + (setq apropos-accumulator ()) + (let (f v p) + (mapatoms + (lambda (symbol) + (setq f nil v nil p nil) + (or (memq symbol '(apropos-regexp do-all apropos-accumulator + symbol f v p)) + (setq v (apropos-value-internal 'boundp symbol 'symbol-value))) + (if do-all + (setq f (apropos-value-internal 'fboundp symbol 'symbol-function) + p (apropos-format-plist symbol "\n " t))) + (if (or f v p) + (setq apropos-accumulator (cons (list symbol f v p) + apropos-accumulator)))))) + (apropos-print nil nil t)) + + +;;;###autoload +(defun apropos-documentation (apropos-regexp &optional do-all) + "Show symbols whose documentation contain matches for REGEXP. +With optional prefix ARG or if `apropos-do-all' is non-nil, also use +documentation that is not stored in the documentation file and show key +bindings. +Returns list of symbols and documentation found." + (interactive "sApropos documentation (regexp): \nP") + (or do-all (setq do-all apropos-do-all)) + (setq apropos-accumulator () apropos-files-scanned ()) + (let ((standard-input (get-buffer-create " apropos-temp")) + f v) + (unwind-protect + (save-excursion + (set-buffer standard-input) + (apropos-documentation-check-doc-file) + (if do-all + (mapatoms + (lambda (symbol) + (setq f (apropos-safe-documentation symbol) + v (get symbol 'variable-documentation)) + (if (integerp v) (setq v)) + (setq f (apropos-documentation-internal f) + v (apropos-documentation-internal v)) + (if (or f v) + (if (setq apropos-item + (cdr (assq symbol apropos-accumulator))) + (progn + (if f + (setcar apropos-item f)) + (if v + (setcar (cdr apropos-item) v))) + (setq apropos-accumulator + (cons (list symbol f v) + apropos-accumulator))))))) + (apropos-print nil nil t)) + (kill-buffer standard-input)))) + + +(defun apropos-value-internal (predicate symbol function) + (if (funcall predicate symbol) + (progn + (setq symbol (prin1-to-string (funcall function symbol))) + (if (string-match apropos-regexp symbol) + (progn + (if apropos-match-face + (put-text-property (match-beginning 0) (match-end 0) + 'face apropos-match-face + symbol)) + symbol))))) + +(defun apropos-documentation-internal (doc) + (if (consp doc) + (apropos-documentation-check-elc-file (car doc)) + (and doc + (string-match apropos-regexp doc) + (progn + (if apropos-match-face + (put-text-property (match-beginning 0) + (match-end 0) + 'face apropos-match-face + (setq doc (copy-sequence doc)))) + doc)))) + +(defun apropos-format-plist (pl sep &optional compare) + (setq pl (symbol-plist pl)) + (let (p p-out) + (while pl + (setq p (format "%s %S" (car pl) (nth 1 pl))) + (if (or (not compare) (string-match apropos-regexp p)) + (if apropos-property-face + (put-text-property 0 (length (symbol-name (car pl))) + 'face apropos-property-face p)) + (setq p nil)) + (if p + (progn + (and compare apropos-match-face + (put-text-property (match-beginning 0) (match-end 0) + 'face apropos-match-face + p)) + (setq p-out (concat p-out (if p-out sep) p)))) + (setq pl (nthcdr 2 pl))) + p-out)) + + +;; Finds all documentation related to APROPOS-REGEXP in internal-doc-file-name. + +(defun apropos-documentation-check-doc-file () + (let (type symbol (sepa 2) sepb beg end) + (insert ?\^_) + (backward-char) + (insert-file-contents (concat doc-directory internal-doc-file-name)) + (forward-char) + (while (save-excursion + (setq sepb (search-forward "\^_")) + (not (eobp))) + (beginning-of-line 2) + (if (save-restriction + (narrow-to-region (point) (1- sepb)) + (re-search-forward apropos-regexp nil t)) + (progn + (setq beg (match-beginning 0) + end (point)) + (goto-char (1+ sepa)) + (or (setq type (if (eq ?F (preceding-char)) + 1 ; function documentation + 2) ; variable documentation + symbol (read) + beg (- beg (point) 1) + end (- end (point) 1) + doc (buffer-substring (1+ (point)) (1- sepb)) + apropos-item (assq symbol apropos-accumulator)) + (setq apropos-item (list symbol nil nil) + apropos-accumulator (cons apropos-item + apropos-accumulator))) + (if apropos-match-face + (put-text-property beg end 'face apropos-match-face doc)) + (setcar (nthcdr type apropos-item) doc))) + (setq sepa (goto-char sepb))))) + +(defun apropos-documentation-check-elc-file (file) + (if (member file apropos-files-scanned) + nil + (let (symbol doc beg end this-is-a-variable) + (setq apropos-files-scanned (cons file apropos-files-scanned)) + (erase-buffer) + (insert-file-contents file) + (while (search-forward "\n#@" nil t) + ;; Read the comment length, and advance over it. + (setq end (read) + beg (1+ (point)) + end (+ (point) end -1)) + (forward-char) + (if (save-restriction + ;; match ^ and $ relative to doc string + (narrow-to-region beg end) + (re-search-forward apropos-regexp nil t)) + (progn + (goto-char (+ end 2)) + (setq doc (buffer-substring beg end) + end (- (match-end 0) beg) + beg (- (match-beginning 0) beg) + this-is-a-variable (looking-at "(def\\(var\\|const\\) ") + symbol (progn + (skip-chars-forward "(a-z") + (forward-char) + (read)) + symbol (if (consp symbol) + (nth 1 symbol) + symbol)) + (if (if this-is-a-variable + (get symbol 'variable-documentation) + (and (fboundp symbol) (apropos-safe-documentation symbol))) + (progn + (or (setq apropos-item (assq symbol apropos-accumulator)) + (setq apropos-item (list symbol nil nil) + apropos-accumulator (cons apropos-item + apropos-accumulator))) + (if apropos-match-face + (put-text-property beg end 'face apropos-match-face + doc)) + (setcar (nthcdr (if this-is-a-variable 2 1) + apropos-item) + doc))))))))) + + + +(defun apropos-safe-documentation (function) + "Like documentation, except it avoids calling `get_doc_string'. +Will return nil instead." + (while (and function (symbolp function)) + (setq function (if (fboundp function) + (symbol-function function)))) + (if (eq (car-safe function) 'macro) + (setq function (cdr function))) + ;; XEmacs change from: (setq function (if (byte-code-function-p function) + (setq function (if (compiled-function-p function) + (if (fboundp 'compiled-function-doc-string) + (compiled-function-doc-string function) + (if (> (length function) 4) + (aref function 4))) + (if (eq (car-safe function) 'autoload) + (nth 2 function) + (if (eq (car-safe function) 'lambda) + (if (stringp (nth 2 function)) + (nth 2 function) + (if (stringp (nth 3 function)) + (nth 3 function))))))) + (if (integerp function) + nil + function)) + + + +(defun apropos-print (do-keys doc-fn spacing) + "Output result of various apropos commands with `apropos-regexp'. +APROPOS-ACCUMULATOR is a list. Optional DOC-FN is called for each element +of apropos-accumulator and may modify it resulting in (symbol fn-doc +var-doc [plist-doc]). Returns sorted list of symbols and documentation +found." + (if (null apropos-accumulator) + (message "No apropos matches for `%s'" apropos-regexp) + (if doc-fn + (funcall doc-fn apropos-accumulator)) + (setq apropos-accumulator + (sort apropos-accumulator (lambda (a b) + (string-lessp (car a) (car b))))) + (and apropos-label-face + (or (symbolp apropos-label-face) + (facep apropos-label-face)) ; XEmacs + (setq apropos-label-face `(face ,apropos-label-face + mouse-face highlight))) + (with-output-to-temp-buffer "*Apropos*" + (let ((p apropos-accumulator) + (old-buffer (current-buffer)) + symbol item point1 point2) + (set-buffer standard-output) + (apropos-mode) + ;; XEmacs change from (if window-system + (if (device-on-window-system-p) + (insert "If you move the mouse over text that changes color,\n" + (substitute-command-keys + "you can click \\[apropos-mouse-follow] to get more information.\n"))) + (insert (substitute-command-keys + "Type \\[apropos-follow] in this buffer to get full documentation.\n\n")) + (while (consp p) + (or (not spacing) (bobp) (terpri)) + (setq apropos-item (car p) + symbol (car apropos-item) + p (cdr p) + point1 (point)) + (princ symbol) ; print symbol name + (setq point2 (point)) + ;; Calculate key-bindings if we want them. + (and do-keys + (commandp symbol) + (indent-to 30 1) + (if (let ((keys + (save-excursion + (set-buffer old-buffer) + (where-is-internal symbol))) + filtered) + ;; Copy over the list of key sequences, + ;; omitting any that contain a buffer or a frame. + (while keys + (let ((key (car keys)) + (i 0) + loser) + (while (< i (length key)) + (if (or (framep (aref key i)) + (bufferp (aref key i))) + (setq loser t)) + (setq i (1+ i))) + (or loser + (setq filtered (cons key filtered)))) + (setq keys (cdr keys))) + (setq item filtered)) + ;; Convert the remaining keys to a string and insert. + (insert + (mapconcat + (lambda (key) + (setq key (key-description key)) + (if apropos-keybinding-face + (put-text-property 0 (length key) + 'face apropos-keybinding-face + key)) + key) + item ", ")) + (insert "Type ") + (insert "M-x") + (put-text-property (- (point) 3) (point) + 'face apropos-keybinding-face) + (insert " " (symbol-name symbol) " ") + (insert "RET") + (put-text-property (- (point) 3) (point) + 'face apropos-keybinding-face))) + (terpri) + ;; only now so we don't propagate text attributes all over + (put-text-property point1 point2 'item + (if (eval `(or ,@(cdr apropos-item))) + (car apropos-item) + apropos-item)) + (if apropos-symbol-face + (put-text-property point1 point2 'face apropos-symbol-face)) + (apropos-print-doc 'describe-function 1 + (if (commandp symbol) + "Command" + (if (apropos-macrop symbol) + "Macro" + "Function")) + do-keys) + (if (get symbol 'custom-type) + (apropos-print-doc 'customize-variable-other-window 2 + "User Option" do-keys) + (apropos-print-doc 'describe-variable 2 + "Variable" do-keys)) + (apropos-print-doc 'customize-other-window 6 "Group" do-keys) + (apropos-print-doc 'customize-face-other-window 5 "Face" do-keys) + (apropos-print-doc 'widget-browse-other-window 4 "Widget" do-keys) + (apropos-print-doc 'apropos-describe-plist 3 + "Plist" nil))))) + (prog1 apropos-accumulator + (setq apropos-accumulator ()))) ; permit gc + + +(defun apropos-macrop (symbol) + "T if SYMBOL is a Lisp macro." + (and (fboundp symbol) + (consp (setq symbol + (symbol-function symbol))) + (or (eq (car symbol) 'macro) + (if (eq (car symbol) 'autoload) + (memq (nth 4 symbol) + '(macro t)))))) + + +(defun apropos-print-doc (action i str do-keys) + (if (stringp (setq i (nth i apropos-item))) + (progn + (insert " ") + (put-text-property (- (point) 2) (1- (point)) + 'action action) + (insert str ": ") + (if apropos-label-face + (add-text-properties (- (point) (length str) 2) + (1- (point)) + apropos-label-face)) + (insert (if do-keys (substitute-command-keys i) i)) + (or (bolp) (terpri))))) + +(defun apropos-mouse-follow (event) + (interactive "e") + (let ((other (if (eq (current-buffer) (get-buffer "*Apropos*")) + () + (current-buffer)))) + (save-excursion + ;; XEmacs change from: + ;; (set-buffer (window-buffer (posn-window (event-start event)))) + ;; (goto-char (posn-point (event-start event))) + (set-buffer (event-buffer event)) + (goto-char (event-closest-point event)) + ;; XEmacs change: following code seems useless + ;;(or (and (not (eobp)) (get-text-property (point) 'mouse-face)) + ;; (and (not (bobp)) (get-text-property (1- (point)) 'mouse-face)) + ;; (error "There is nothing to follow here")) + (apropos-follow other)))) + + +(defun apropos-follow (&optional other) + (interactive) + (let* (;; Properties are always found at the beginning of the line. + (bol (save-excursion (beginning-of-line) (point))) + ;; If there is no `item' property here, look behind us. + (item (get-text-property bol 'item)) + (item-at (if item nil (previous-single-property-change bol 'item))) + ;; Likewise, if there is no `action' property here, look in front. + (action (get-text-property bol 'action)) + (action-at (if action nil (next-single-property-change bol 'action)))) + (and (null item) item-at + (setq item (get-text-property (1- item-at) 'item))) + (and (null action) action-at + (setq action (get-text-property action-at 'action))) + (if (not (and item action)) + (error "There is nothing to follow here")) + (if (consp item) (error "There is nothing to follow in `%s'" (car item))) + (if other (set-buffer other)) + (funcall action item))) + + + +(defun apropos-describe-plist (symbol) + "Display a pretty listing of SYMBOL's plist." + (with-output-to-temp-buffer "*Help*" + (set-buffer standard-output) + (princ "Symbol ") + (prin1 symbol) + (princ "'s plist is\n (") + (if apropos-symbol-face + (put-text-property 8 (- (point) 14) 'face apropos-symbol-face)) + (insert (apropos-format-plist symbol "\n ")) + (princ ")") + (print-help-return-message))) + +(provide 'apropos) ; XEmacs + +;;; apropos.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/auto-autoloads.el --- a/lisp/auto-autoloads.el Mon Aug 13 10:07:42 2007 +0200 +++ b/lisp/auto-autoloads.el Mon Aug 13 10:08:34 2007 +0200 @@ -1,5 +1,92 @@ ;;; DO NOT MODIFY THIS FILE -(if (featurep 'TopLevel-autoloads) (error "Already loaded")) +(if (featurep 'Standard-autoloads) (error "Already loaded")) + +;;;### (autoloads nil "abbrev" "lisp/abbrev.el") + +;;;*** + +;;;### (autoloads (about-xemacs) "about" "lisp/about.el") + +(autoload 'about-xemacs "about" "\ +Describe the True Editor and its minions." t nil) + +;;;*** + +;;;### (autoloads (apropos-documentation apropos-value apropos apropos-command) "apropos" "lisp/apropos.el") + +(fset 'command-apropos 'apropos-command) + +(autoload 'apropos-command "apropos" "\ +Shows commands (interactively callable functions) that match REGEXP. +With optional prefix ARG or if `apropos-do-all' is non-nil, also show +variables." t nil) + +(autoload 'apropos "apropos" "\ +Show all bound symbols whose names match REGEXP. +With optional prefix ARG or if `apropos-do-all' is non-nil, also show unbound +symbols and key bindings, which is a little more time-consuming. +Returns list of symbols and documentation found." t nil) + +(autoload 'apropos-value "apropos" "\ +Show all symbols whose value's printed image matches REGEXP. +With optional prefix ARG or if `apropos-do-all' is non-nil, also looks +at the function and at the names and values of properties. +Returns list of symbols and values found." t nil) + +(autoload 'apropos-documentation "apropos" "\ +Show symbols whose documentation contain matches for REGEXP. +With optional prefix ARG or if `apropos-do-all' is non-nil, also use +documentation that is not stored in the documentation file and show key +bindings. +Returns list of symbols and documentation found." t nil) + +;;;*** + +;;;### (autoloads (batch-update-directory batch-update-autoloads update-autoloads-from-directory update-autoloads-here update-file-autoloads generate-file-autoloads) "autoload" "lisp/autoload.el") + +(autoload 'generate-file-autoloads "autoload" "\ +Insert at point a loaddefs autoload section for FILE. +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." t nil) + +(autoload 'update-file-autoloads "autoload" "\ +Update the autoloads for FILE in `generated-autoload-file' +\(which FILE might bind in its local variables). +This functions refuses to update autoloads files." t nil) + +(autoload 'update-autoloads-here "autoload" "\ +Update sections of the current buffer generated by `update-file-autoloads'." t nil) + +(autoload 'update-autoloads-from-directory "autoload" "\ +Update `generated-autoload-file' with all the current autoloads from DIR. +This runs `update-file-autoloads' on each .el file in DIR. +Obsolete autoload entries for files that no longer exist are deleted." t nil) + +(autoload 'batch-update-autoloads "autoload" "\ +Update the autoloads for the files or directories on the command line. +Runs `update-file-autoloads' on files and `update-directory-autoloads' +on directories. 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 `xemacs -batch -f batch-update-autoloads *.el'. +The directory to which the auto-autoloads.el file must be the first parameter +on the command line." nil nil) + +(autoload 'batch-update-directory "autoload" "\ +Update the autoloads for the directory on the command line. +Runs `update-file-autoloads' on each file in the given directory, must +be used only with -batch and kills XEmacs on completion." nil nil) + +;;;*** + +;;;### (autoloads nil "buff-menu" "lisp/buff-menu.el") + +(defvar list-buffers-directory nil) + +(make-variable-buffer-local 'list-buffers-directory) + +;;;*** ;;;### (autoloads (batch-byte-recompile-directory batch-byte-recompile-directory-norecurse batch-byte-compile display-call-tree byte-compile-sexp byte-compile compile-defun byte-compile-file byte-recompile-file byte-recompile-directory byte-force-recompile) "bytecomp" "lisp/bytecomp.el") @@ -407,6 +494,22 @@ ;;;*** +;;;### (autoloads (batch-remove-old-elc) "cleantree" "lisp/cleantree.el") + +(autoload 'batch-remove-old-elc "cleantree" nil nil nil) + +;;;*** + +;;;### (autoloads (config-value config-value-hash-table) "config" "lisp/config.el") + +(autoload 'config-value-hash-table "config" "\ +Returns hashtable of configuration parameters and their values." nil nil) + +(autoload 'config-value "config" "\ +Return the value of the configuration parameter CONFIG_SYMBOL." nil nil) + +;;;*** + ;;;### (autoloads (Custom-make-dependencies) "cus-dep" "lisp/cus-dep.el") (autoload 'Custom-make-dependencies "cus-dep" "\ @@ -530,7 +633,7 @@ (autoload 'customize-browse "cus-edit" "\ Create a tree browser for the customize hierarchy." t nil) -(defcustom custom-file (if (boundp 'emacs-user-extension-dir) (concat "~" init-file-user emacs-user-extension-dir "options.el") "~/.emacs") "File used for storing customization information.\nIf you change this from the default \"~/.emacs\" you need to\nexplicitly load that file for the settings to take effect." :type 'file :group 'customize) +(defcustom custom-file (if (boundp 'user-init-directory) (concat "~" init-file-user user-init-directory "options.el") "~/.emacs") "File used for storing customization information.\nIf you change this from the default \"~/.emacs\" you need to\nexplicitly load that file for the settings to take effect." :type 'file :group 'customize) (autoload 'customize-save-customized "cus-edit" "\ Save all user options which have been set in this session." t nil) @@ -579,6 +682,647 @@ ;;;*** +;;;### (autoloads nil "easymenu" "lisp/easymenu.el") + +;;;*** + +;;;### (autoloads (tags-apropos list-tags tags-query-replace tags-search tags-loop-continue next-file find-tag-other-window find-tag visit-tags-table) "etags" "lisp/etags.el") + +(defcustom tags-build-completion-table 'ask "*If this variable is nil, then tags completion is disabled.\nIf this variable is t, then things which prompt for tags will do so with \n completion across all known tags.\nIf this variable is the symbol `ask', then you will be asked whether each\n tags table should be added to the completion list as it is read in.\n (With the exception that for very small tags tables, you will not be asked,\n since they can be parsed quickly.)" :type '(radio (const :tag "Disabled" nil) (const :tag "Complete All" t) (const :tag "Ask" ask)) :group 'etags) + +(defcustom tags-always-exact nil "*If this variable is non-nil, then tags always looks for exact matches." :type 'boolean :group 'etags) + +(defcustom tag-table-alist nil "*A list which determines which tags files are active for a buffer.\nThis is not really an association list, in that all elements are\nchecked. The CAR of each element of this list is a pattern against\nwhich the buffer's file name is compared; if it matches, then the CDR\nof the list should be the name of the tags table to use. If more than\none element of this list matches the buffer's file name, then all of\nthe associated tags tables will be used. Earlier ones will be\nsearched first.\n\nIf the CAR of elements of this list are strings, then they are treated\nas regular-expressions against which the file is compared (like the\nauto-mode-alist). If they are not strings, then they are evaluated.\nIf they evaluate to non-nil, then the current buffer is considered to\nmatch.\n\nIf the CDR of the elements of this list are strings, then they are\nassumed to name a TAGS file. If they name a directory, then the string\n\"TAGS\" is appended to them to get the file name. If they are not \nstrings, then they are evaluated, and must return an appropriate string.\n\nFor example:\n (setq tag-table-alist\n '((\"/usr/src/public/perl/\" . \"/usr/src/public/perl/perl-3.0/\")\n (\"\\\\.el$\" . \"/usr/local/emacs/src/\")\n (\"/jbw/gnu/\" . \"/usr15/degree/stud/jbw/gnu/\")\n (\"\" . \"/usr/local/emacs/src/\")\n ))\n\nThis means that anything in the /usr/src/public/perl/ directory should use\nthe TAGS file /usr/src/public/perl/perl-3.0/TAGS; and file ending in .el should\nuse the TAGS file /usr/local/emacs/src/TAGS; and anything in or below the\ndirectory /jbw/gnu/ should use the TAGS file /usr15/degree/stud/jbw/gnu/TAGS.\nA file called something like \"/usr/jbw/foo.el\" would use both the TAGS files\n/usr/local/emacs/src/TAGS and /usr15/degree/stud/jbw/gnu/TAGS (in that order)\nbecause it matches both patterns.\n\nIf the buffer-local variable `buffer-tag-table' is set, then it names a tags\ntable that is searched before all others when find-tag is executed from this\nbuffer.\n\nIf there is a file called \"TAGS\" in the same directory as the file in \nquestion, then that tags file will always be used as well (after the\n`buffer-tag-table' but before the tables specified by this list.)\n\nIf the variable tags-file-name is set, then the tags file it names will apply\nto all buffers (for backwards compatibility.) It is searched first.\n" :type '(repeat (cons (choice :value "" (regexp :tag "Buffer regexp") (function :tag "Expression")) (string :tag "Tag file or directory"))) :group 'etags) + +(autoload 'visit-tags-table "etags" "\ +Tell tags commands to use tags table file FILE first. +FILE should be the name of a file created with the `etags' program. +A directory name is ok too; it means file TAGS in that directory." t nil) + +(autoload 'find-tag "etags" "\ +*Find tag whose name contains TAGNAME. + Selects the buffer that the tag is contained in +and puts point at its definition. + If TAGNAME is a null string, the expression in the buffer +around or before point is used as the tag name. + If called interactively with a numeric argument, searches for the next tag +in the tag table that matches the tagname used in the previous find-tag. + If second arg OTHER-WINDOW is non-nil, uses another window to display +the tag. + +This version of this function supports multiple active tags tables, +and completion. + +Variables of note: + + tag-table-alist controls which tables apply to which buffers + tags-file-name a default tags table + tags-build-completion-table controls completion behavior + buffer-tag-table another way of specifying a buffer-local table + make-tags-files-invisible whether tags tables should be very hidden + tag-mark-stack-max how many tags-based hops to remember" t nil) + +(autoload 'find-tag-other-window "etags" "\ +*Find tag whose name contains TAGNAME. + Selects the buffer that the tag is contained in in another window +and puts point at its definition. + If TAGNAME is a null string, the expression in the buffer +around or before point is used as the tag name. + If second arg NEXT is non-nil (interactively, with prefix arg), +searches for the next tag in the tag table +that matches the tagname used in the previous find-tag. + +This version of this function supports multiple active tags tables, +and completion. + +Variables of note: + + tag-table-alist controls which tables apply to which buffers + tags-file-name a default tags table + tags-build-completion-table controls completion behavior + buffer-tag-table another way of specifying a buffer-local table + make-tags-files-invisible whether tags tables should be very hidden + tag-mark-stack-max how many tags-based hops to remember" t nil) + +(autoload 'next-file "etags" "\ +Select next file among files in current tag table(s). + +A first argument of t (prefix arg, if interactive) initializes to the +beginning of the list of files in the (first) tags table. If the argument +is neither nil nor t, it is evalled to initialize the list of files. + +Non-nil second argument NOVISIT means use a temporary buffer +to save time and avoid uninteresting warnings. + +Value is nil if the file was already visited; +if the file was newly read in, the value is the filename." t nil) + +(autoload 'tags-loop-continue "etags" "\ +Continue last \\[tags-search] or \\[tags-query-replace] command. +Used noninteractively with non-nil argument to begin such a command (the +argument is passed to `next-file', which see). +Two variables control the processing we do on each file: +the value of `tags-loop-scan' is a form to be executed on each file +to see if it is interesting (it returns non-nil if so) +and `tags-loop-operate' is a form to execute to operate on an interesting file +If the latter returns non-nil, we exit; otherwise we scan the next file." t nil) + +(autoload 'tags-search "etags" "\ +Search through all files listed in tags table for match for REGEXP. +Stops when a match is found. +To continue searching for next match, use command \\[tags-loop-continue]. + +See documentation of variable `tag-table-alist'." t nil) + +(autoload 'tags-query-replace "etags" "\ +Query-replace-regexp FROM with TO through all files listed in tags table. +Third arg DELIMITED (prefix arg) means replace only word-delimited matches. +If you exit (\\[keyboard-quit] or ESC), you can resume the query-replace +with the command \\[tags-loop-continue]. + +See documentation of variable `tag-table-alist'." t nil) + +(autoload 'list-tags "etags" "\ +Display list of tags in file FILE. +FILE should not contain a directory spec +unless it has one in the tag table." t nil) + +(autoload 'tags-apropos "etags" "\ +Display list of all tags in tag table REGEXP matches." t nil) + +;;;*** + +;;;### (autoloads (font-lock-set-defaults-1 font-lock-fontify-buffer turn-off-font-lock turn-on-font-lock font-lock-mode) "font-lock" "lisp/font-lock.el") + +(defvar font-lock-auto-fontify t "\ +*Whether font-lock should automatically fontify files as they're loaded. +This will only happen if font-lock has fontifying keywords for the major +mode of the file. You can get finer-grained control over auto-fontification +by using this variable in combination with `font-lock-mode-enable-list' or +`font-lock-mode-disable-list'.") + +(defvar font-lock-mode-enable-list nil "\ +*List of modes to auto-fontify, if `font-lock-auto-fontify' is nil.") + +(defvar font-lock-mode-disable-list nil "\ +*List of modes not to auto-fontify, if `font-lock-auto-fontify' is t.") + +(defvar font-lock-use-colors '(color) "\ +*Specification for when Font Lock will set up color defaults. +Normally this should be '(color), meaning that Font Lock will set up +color defaults that are only used on color displays. Set this to nil +if you don't want Font Lock to set up color defaults at all. This +should be one of + +-- a list of valid tags, meaning that the color defaults will be used + when all of the tags apply. (e.g. '(color x)) +-- a list whose first element is 'or and whose remaining elements are + lists of valid tags, meaning that the defaults will be used when + any of the tag lists apply. +-- nil, meaning that the defaults should not be set up at all. + +\(If you specify face values in your init file, they will override any +that Font Lock specifies, regardless of whether you specify the face +values before or after loading Font Lock.) + +See also `font-lock-use-fonts'. If you want more control over the faces +used for fontification, see the documentation of `font-lock-mode' for +how to do it.") + +(defvar font-lock-use-fonts '(or (mono) (grayscale)) "\ +*Specification for when Font Lock will set up non-color defaults. + +Normally this should be '(or (mono) (grayscale)), meaning that Font +Lock will set up non-color defaults that are only used on either mono +or grayscale displays. Set this to nil if you don't want Font Lock to +set up non-color defaults at all. This should be one of + +-- a list of valid tags, meaning that the non-color defaults will be used + when all of the tags apply. (e.g. '(grayscale x)) +-- a list whose first element is 'or and whose remaining elements are + lists of valid tags, meaning that the defaults will be used when + any of the tag lists apply. +-- nil, meaning that the defaults should not be set up at all. + +\(If you specify face values in your init file, they will override any +that Font Lock specifies, regardless of whether you specify the face +values before or after loading Font Lock.) + +See also `font-lock-use-colors'. If you want more control over the faces +used for fontification, see the documentation of `font-lock-mode' for +how to do it.") + +(defvar font-lock-maximum-decoration nil "\ +*If non-nil, the maximum decoration level for fontifying. +If nil, use the minimum decoration (equivalent to level 0). +If t, use the maximum decoration available. +If a number, use that level of decoration (or if not available the maximum). +If a list, each element should be a cons pair of the form (MAJOR-MODE . LEVEL), +where MAJOR-MODE is a symbol or t (meaning the default). For example: + ((c++-mode . 2) (c-mode . t) (t . 1)) +means use level 2 decoration for buffers in `c++-mode', the maximum decoration +available for buffers in `c-mode', and level 1 decoration otherwise.") + +(define-obsolete-variable-alias 'font-lock-use-maximal-decoration 'font-lock-maximum-decoration) + +(defvar font-lock-maximum-size (* 250 1024) "\ +*If non-nil, the maximum size for buffers for fontifying. +Only buffers less than this can be fontified when Font Lock mode is turned on. +If nil, means size is irrelevant. +If a list, each element should be a cons pair of the form (MAJOR-MODE . SIZE), +where MAJOR-MODE is a symbol or t (meaning the default). For example: + ((c++-mode . 256000) (c-mode . 256000) (rmail-mode . 1048576)) +means that the maximum size is 250K for buffers in `c++-mode' or `c-mode', one +megabyte for buffers in `rmail-mode', and size is irrelevant otherwise.") + +(defvar font-lock-keywords nil "\ +*A list of the keywords to highlight. +Each element should be of the form: + + MATCHER + (MATCHER . MATCH) + (MATCHER . FACENAME) + (MATCHER . HIGHLIGHT) + (MATCHER HIGHLIGHT ...) + (eval . FORM) + +where HIGHLIGHT should be either MATCH-HIGHLIGHT or MATCH-ANCHORED. + +FORM is an expression, whose value should be a keyword element, +evaluated when the keyword is (first) used in a buffer. This feature +can be used to provide a keyword that can only be generated when Font +Lock mode is actually turned on. + +For highlighting single items, typically only MATCH-HIGHLIGHT is required. +However, if an item or (typically) items is to be highlighted following the +instance of another item (the anchor) then MATCH-ANCHORED may be required. + +MATCH-HIGHLIGHT should be of the form: + + (MATCH FACENAME OVERRIDE LAXMATCH) + +Where MATCHER can be either the regexp to search for, a variable +containing the regexp to search for, or the function to call to make +the search (called with one argument, the limit of the search). MATCH +is the subexpression of MATCHER to be highlighted. FACENAME is either +a symbol naming a face, or an expression whose value is the face name +to use. If you want FACENAME to be a symbol that evaluates to a face, +use a form like \"(progn sym)\". + +OVERRIDE and LAXMATCH are flags. If OVERRIDE is t, existing fontification may +be overwritten. If `keep', only parts not already fontified are highlighted. +If `prepend' or `append', existing fontification is merged with the new, in +which the new or existing fontification, respectively, takes precedence. +If LAXMATCH is non-nil, no error is signalled if there is no MATCH in MATCHER. + +For example, an element of the form highlights (if not already highlighted): + + \"\\\\\\=\" Discrete occurrences of \"foo\" in the value of the + variable `font-lock-keyword-face'. + (\"fu\\\\(bar\\\\)\" . 1) Substring \"bar\" within all occurrences of \"fubar\" in + the value of `font-lock-keyword-face'. + (\"fubar\" . fubar-face) Occurrences of \"fubar\" in the value of `fubar-face'. + (\"foo\\\\|bar\" 0 foo-bar-face t) + Occurrences of either \"foo\" or \"bar\" in the value + of `foo-bar-face', even if already highlighted. + +MATCH-ANCHORED should be of the form: + + (MATCHER PRE-MATCH-FORM POST-MATCH-FORM MATCH-HIGHLIGHT ...) + +Where MATCHER is as for MATCH-HIGHLIGHT with one exception; see below. +PRE-MATCH-FORM and POST-MATCH-FORM are evaluated before the first, and after +the last, instance MATCH-ANCHORED's MATCHER is used. Therefore they can be +used to initialise before, and cleanup after, MATCHER is used. Typically, +PRE-MATCH-FORM is used to move to some position relative to the original +MATCHER, before starting with MATCH-ANCHORED's MATCHER. POST-MATCH-FORM might +be used to move, before resuming with MATCH-ANCHORED's parent's MATCHER. + +For example, an element of the form highlights (if not already highlighted): + + (\"\\\\\\=\" (0 anchor-face) (\"\\\\\\=\" nil nil (0 item-face))) + + Discrete occurrences of \"anchor\" in the value of `anchor-face', and subsequent + discrete occurrences of \"item\" (on the same line) in the value of `item-face'. + (Here PRE-MATCH-FORM and POST-MATCH-FORM are nil. Therefore \"item\" is + initially searched for starting from the end of the match of \"anchor\", and + searching for subsequent instance of \"anchor\" resumes from where searching + for \"item\" concluded.) + +The above-mentioned exception is as follows. The limit of the MATCHER search +defaults to the end of the line after PRE-MATCH-FORM is evaluated. +However, if PRE-MATCH-FORM returns a position greater than the position after +PRE-MATCH-FORM is evaluated, that position is used as the limit of the search. +It is generally a bad idea to return a position greater than the end of the +line, i.e., cause the MATCHER search to span lines. + +Note that the MATCH-ANCHORED feature is experimental; in the future, we may +replace it with other ways of providing this functionality. + +These regular expressions should not match text which spans lines. While +\\[font-lock-fontify-buffer] handles multi-line patterns correctly, updating +when you edit the buffer does not, since it considers text one line at a time. + +Be very careful composing regexps for this list; +the wrong pattern can dramatically slow things down!") + +(make-variable-buffer-local 'font-lock-keywords) + +(defvar font-lock-mode nil) + +(defvar font-lock-mode-hook nil "\ +Function or functions to run on entry to font-lock-mode.") + +(autoload 'font-lock-mode "font-lock" "\ +Toggle Font Lock Mode. +With arg, turn font-lock mode on if and only if arg is positive. + +When Font Lock mode is enabled, text is fontified as you type it: + + - Comments are displayed in `font-lock-comment-face'; + - Strings are displayed in `font-lock-string-face'; + - Documentation strings (in Lisp-like languages) are displayed in + `font-lock-doc-string-face'; + - Language keywords (\"reserved words\") are displayed in + `font-lock-keyword-face'; + - Function names in their defining form are displayed in + `font-lock-function-name-face'; + - Variable names in their defining form are displayed in + `font-lock-variable-name-face'; + - Type names are displayed in `font-lock-type-face'; + - References appearing in help files and the like are displayed + in `font-lock-reference-face'; + - Preprocessor declarations are displayed in + `font-lock-preprocessor-face'; + + and + + - Certain other expressions are displayed in other faces according + to the value of the variable `font-lock-keywords'. + +Where modes support different levels of fontification, you can use the variable +`font-lock-maximum-decoration' to specify which level you generally prefer. +When you turn Font Lock mode on/off the buffer is fontified/defontified, though +fontification occurs only if the buffer is less than `font-lock-maximum-size'. +To fontify a buffer without turning on Font Lock mode, and regardless of buffer +size, you can use \\[font-lock-fontify-buffer]. + +See the variable `font-lock-keywords' for customization." t nil) + +(autoload 'turn-on-font-lock "font-lock" "\ +Unconditionally turn on Font Lock mode." nil nil) + +(autoload 'turn-off-font-lock "font-lock" "\ +Unconditionally turn off Font Lock mode." nil nil) + +(autoload 'font-lock-fontify-buffer "font-lock" "\ +Fontify the current buffer the way `font-lock-mode' would. +See `font-lock-mode' for details. + +This can take a while for large buffers." t nil) + +(autoload 'font-lock-set-defaults-1 "font-lock" nil nil nil) + +(add-minor-mode 'font-lock-mode " Font") + +;;;*** + +;;;### (autoloads (x-font-build-cache font-default-size-for-device font-default-encoding-for-device font-default-registry-for-device font-default-family-for-device font-default-object-for-device font-default-font-for-device font-create-object) "font" "lisp/font.el") + +(autoload 'font-create-object "font" nil nil nil) + +(autoload 'font-default-font-for-device "font" nil nil nil) + +(autoload 'font-default-object-for-device "font" nil nil nil) + +(autoload 'font-default-family-for-device "font" nil nil nil) + +(autoload 'font-default-registry-for-device "font" nil nil nil) + +(autoload 'font-default-encoding-for-device "font" nil nil nil) + +(autoload 'font-default-size-for-device "font" nil nil nil) + +(autoload 'x-font-build-cache "font" nil nil nil) + +;;;*** + +;;;### (autoloads (gnuserv-start gnuserv-running-p) "gnuserv" "lisp/gnuserv.el") + +(defcustom gnuserv-frame nil "*The frame to be used to display all edited files.\nIf nil, then a new frame is created for each file edited.\nIf t, then the currently selected frame will be used.\nIf a function, then this will be called with a symbol `x' or `tty' as the\nonly argument, and its return value will be interpreted as above." :tag "Gnuserv Frame" :type '(radio (const :tag "Create new frame each time" nil) (const :tag "Use selected frame" t) (function-item :tag "Use main Emacs frame" gnuserv-main-frame-function) (function-item :tag "Use visible frame, otherwise create new" gnuserv-visible-frame-function) (function-item :tag "Create special Gnuserv frame and use it" gnuserv-special-frame-function) (function :tag "Other")) :group 'gnuserv :group 'frames) + +(autoload 'gnuserv-running-p "gnuserv" "\ +Return non-nil if a gnuserv process is running from this XEmacs session." nil nil) + +(autoload 'gnuserv-start "gnuserv" "\ +Allow this Emacs process to be a server for client processes. +This starts a gnuserv communications subprocess through which +client \"editors\" (gnuclient and gnudoit) can send editing commands to +this Emacs job. See the gnuserv(1) manual page for more details. + +Prefix arg means just kill any existing server communications subprocess." t nil) + +;;;*** + +;;;### (autoloads nil "help-macro" "lisp/help-macro.el") + +(defcustom three-step-help t "*Non-nil means give more info about Help command in three steps.\nThe three steps are simple prompt, prompt with all options,\nand window listing and describing the options.\nA value of nil means skip the middle step, so that\n\\[help-command] \\[help-command] gives the window that lists the options." :type 'boolean :group 'help-appearance) + +;;;*** + +;;;### (autoloads (hyper-apropos-popup-menu hyper-apropos-set-variable hyper-set-variable hyper-apropos-read-variable-symbol hyper-describe-function hyper-describe-variable hyper-describe-face hyper-describe-key-briefly hyper-describe-key hyper-apropos) "hyper-apropos" "lisp/hyper-apropos.el") + +(autoload 'hyper-apropos "hyper-apropos" "\ +Display lists of functions and variables matching REGEXP +in buffer \"*Hyper Apropos*\". If optional prefix arg is given, then the +value of `hyper-apropos-programming-apropos' is toggled for this search. +See also `hyper-apropos-mode'." t nil) + +(autoload 'hyper-describe-key "hyper-apropos" nil t nil) + +(autoload 'hyper-describe-key-briefly "hyper-apropos" nil t nil) + +(autoload 'hyper-describe-face "hyper-apropos" "\ +Describe face.. +See also `hyper-apropos' and `hyper-describe-function'." t nil) + +(autoload 'hyper-describe-variable "hyper-apropos" "\ +Hypertext drop-in replacement for `describe-variable'. +See also `hyper-apropos' and `hyper-describe-function'." t nil) + +(autoload 'hyper-describe-function "hyper-apropos" "\ +Hypertext replacement for `describe-function'. Unlike `describe-function' +in that the symbol under the cursor is the default if it is a function. +See also `hyper-apropos' and `hyper-describe-variable'." t nil) + +(autoload 'hyper-apropos-read-variable-symbol "hyper-apropos" "\ +Hypertext drop-in replacement for `describe-variable'. +See also `hyper-apropos' and `hyper-describe-function'." nil nil) + +(define-obsolete-function-alias 'hypropos-read-variable-symbol 'hyper-apropos-read-variable-symbol) + +(define-obsolete-function-alias 'hypropos-get-doc 'hyper-apropos-get-doc) + +(autoload 'hyper-set-variable "hyper-apropos" nil t nil) + +(autoload 'hyper-apropos-set-variable "hyper-apropos" "\ +Interactively set the variable on the current line." t nil) + +(define-obsolete-function-alias 'hypropos-set-variable 'hyper-apropos-set-variable) + +(autoload 'hyper-apropos-popup-menu "hyper-apropos" nil t nil) + +(define-obsolete-function-alias 'hypropos-popup-menu 'hyper-apropos-popup-menu) + +;;;*** + +;;;### (autoloads (Info-elisp-ref Info-emacs-key Info-goto-emacs-key-command-node Info-goto-emacs-command-node Info-emacs-command Info-search Info-visit-file Info-goto-node Info-query info) "info" "lisp/info.el") + +(autoload 'info "info" "\ +Enter Info, the documentation browser. +Optional argument FILE specifies the file to examine; +the default is the top-level directory of Info. + +In interactive use, a prefix argument directs this command +to read a file name from the minibuffer." t nil) + +(autoload 'Info-query "info" "\ +Enter Info, the documentation browser. Prompt for name of Info file." t nil) + +(autoload 'Info-goto-node "info" "\ +Go to info node named NAME. Give just NODENAME or (FILENAME)NODENAME. +Actually, the following interpretations of NAME are tried in order: + (FILENAME)NODENAME + (FILENAME) (using Top node) + NODENAME (in current file) + TAGNAME (see below) + FILENAME (using Top node) +where TAGNAME is a string that appears in quotes: \"TAGNAME\", in an +annotation for any node of any file. (See `a' and `x' commands.)" t nil) + +(autoload 'Info-visit-file "info" "\ +Directly visit an info file." t nil) + +(autoload 'Info-search "info" "\ +Search for REGEXP, starting from point, and select node it's found in." t nil) + +(autoload 'Info-emacs-command "info" "\ +Look up an Emacs command in the Emacs manual in the Info system. +This command is designed to be used whether you are already in Info or not." t nil) + +(autoload 'Info-goto-emacs-command-node "info" "\ +Look up an Emacs command in the Emacs manual in the Info system. +This command is designed to be used whether you are already in Info or not." t nil) + +(autoload 'Info-goto-emacs-key-command-node "info" "\ +Look up an Emacs key sequence in the Emacs manual in the Info system. +This command is designed to be used whether you are already in Info or not." t nil) + +(autoload 'Info-emacs-key "info" "\ +Look up an Emacs key sequence in the Emacs manual in the Info system. +This command is designed to be used whether you are already in Info or not." t nil) + +(autoload 'Info-elisp-ref "info" "\ +Look up an Emacs Lisp function in the Elisp manual in the Info system. +This command is designed to be used whether you are already in Info or not." t nil) + +;;;*** + +;;;### (autoloads nil "itimer-autosave" "lisp/itimer-autosave.el") + +;;;*** + +;;;### (autoloads nil "loaddefs" "lisp/loaddefs.el") + +;;;*** + +;;;### (autoloads (package-admin-add-binary-package package-admin-add-single-file-package) "package-admin" "lisp/package-admin.el") + +(autoload 'package-admin-add-single-file-package "package-admin" "\ +Install a single file Lisp package into XEmacs package hierarchy. +`file' should be the full path to the lisp file to install. +`destdir' should be a simple directory name. +The optional `pkg-dir' can be used to override the default package hiearchy +\(last package-path)." t nil) + +(autoload 'package-admin-add-binary-package "package-admin" "\ +Install a pre-bytecompiled XEmacs package into package hierarchy." t nil) + +;;;*** + +;;;### (autoloads (list-load-path-shadows) "shadow" "lisp/shadow.el") + +(autoload 'list-load-path-shadows "shadow" "\ +Display a list of Emacs Lisp files that shadow other files. + +This function lists potential load-path problems. Directories in the +`load-path' variable are searched, in order, for Emacs Lisp +files. When a previously encountered file name is found again, a +message is displayed indicating that the later file is \"hidden\" by +the earlier. + +For example, suppose `load-path' is set to + +\(\"/usr/gnu/emacs/site-lisp\" \"/usr/gnu/emacs/share/emacs/19.30/lisp\") + +and that each of these directories contains a file called XXX.el. Then +XXX.el in the site-lisp directory is referred to by all of: +\(require 'XXX), (autoload .... \"XXX\"), (load-library \"XXX\") etc. + +The first XXX.el file prevents emacs from seeing the second (unless +the second is loaded explicitly via load-file). + +When not intended, such shadowings can be the source of subtle +problems. For example, the above situation may have arisen because the +XXX package was not distributed with versions of emacs prior to +19.30. An emacs maintainer downloaded XXX from elsewhere and installed +it. Later, XXX was updated and included in the emacs distribution. +Unless the emacs maintainer checks for this, the new version of XXX +will be hidden behind the old (which may no longer work with the new +emacs version). + +This function performs these checks and flags all possible +shadowings. Because a .el file may exist without a corresponding .elc +\(or vice-versa), these suffixes are essentially ignored. A file +XXX.elc in an early directory (that does not contain XXX.el) is +considered to shadow a later file XXX.el, and vice-versa. + +When run interactively, the shadowings (if any) are displayed in a +buffer called `*Shadows*'. Shadowings are located by calling the +\(non-interactive) companion function, `find-emacs-lisp-shadows'." t nil) + +;;;*** + +;;;### (autoloads (load-default-sounds load-sound-file) "sound" "lisp/sound.el") + +(or sound-alist (setq sound-alist '((ready nil) (warp nil)))) + +(autoload 'load-sound-file "sound" "\ +Read in an audio-file and add it to the sound-alist. + +You can only play sound files if you are running on display 0 of the +console of a machine with native sound support or running a NetAudio +server and XEmacs has the necessary sound support compiled in. + +The sound file must be in the Sun/NeXT U-LAW format, except on Linux, +where .wav files are also supported by the sound card drivers." t nil) + +(autoload 'load-default-sounds "sound" "\ +Load and install some sound files as beep-types, using +`load-sound-file'. This only works if you're on display 0 of the +console of a machine with native sound support or running a NetAudio +server and XEmacs has the necessary sound support compiled in." t nil) + +;;;*** + +;;;### (autoloads (auto-view-mode view-major-mode view-mode view-minor-mode view-buffer-other-window view-file-other-window view-buffer view-file) "view-less" "lisp/view-less.el") + +(defvar view-minor-mode-map (let ((map (make-keymap))) (set-keymap-name map 'view-minor-mode-map) (suppress-keymap map) (define-key map "-" 'negative-argument) (define-key map " " 'scroll-up) (define-key map "f" 'scroll-up) (define-key map "b" 'scroll-down) (define-key map 'backspace 'scroll-down) (define-key map 'delete 'scroll-down) (define-key map " " 'view-scroll-lines-up) (define-key map "\n" 'view-scroll-lines-up) (define-key map "e" 'view-scroll-lines-up) (define-key map "j" 'view-scroll-lines-up) (define-key map "y" 'view-scroll-lines-down) (define-key map "k" 'view-scroll-lines-down) (define-key map "d" 'view-scroll-some-lines-up) (define-key map "u" 'view-scroll-some-lines-down) (define-key map "r" 'recenter) (define-key map "t" 'toggle-truncate-lines) (define-key map "N" 'view-buffer) (define-key map "E" 'view-file) (define-key map "P" 'view-buffer) (define-key map "!" 'shell-command) (define-key map "|" 'shell-command-on-region) (define-key map "=" 'what-line) (define-key map "?" 'view-search-backward) (define-key map "h" 'view-mode-describe) (define-key map "s" 'view-repeat-search) (define-key map "n" 'view-repeat-search) (define-key map "/" 'view-search-forward) (define-key map "\\" 'view-search-backward) (define-key map "g" 'view-goto-line) (define-key map "G" 'view-last-windowful) (define-key map "%" 'view-goto-percent) (define-key map "p" 'view-goto-percent) (define-key map "m" 'point-to-register) (define-key map "'" 'register-to-point) (define-key map "C" 'view-cleanup-backspaces) (define-key map "" 'view-quit) (define-key map "" 'view-quit-toggle-ro) (define-key map "q" 'view-quit) map)) + +(defvar view-mode-map (let ((map (copy-keymap view-minor-mode-map))) (set-keymap-name map 'view-mode-map) map)) + +(autoload 'view-file "view-less" "\ +Find FILE, enter view mode. With prefix arg OTHER-P, use other window." t nil) + +(autoload 'view-buffer "view-less" "\ +Switch to BUF, enter view mode. With prefix arg use other window." t nil) + +(autoload 'view-file-other-window "view-less" "\ +Find FILE in other window, and enter view mode." t nil) + +(autoload 'view-buffer-other-window "view-less" "\ +Switch to BUFFER in another window, and enter view mode." t nil) + +(autoload 'view-minor-mode "view-less" "\ +Minor mode for viewing text, with bindings like `less'. +Commands are: +\\ +0..9 prefix args +- prefix minus +\\[scroll-up] page forward +\\[scroll-down] page back +\\[view-scroll-lines-up] scroll prefix-arg lines forward, default 1. +\\[view-scroll-lines-down] scroll prefix-arg lines backward, default 1. +\\[view-scroll-some-lines-down] scroll prefix-arg lines backward, default 10. +\\[view-scroll-some-lines-up] scroll prefix-arg lines forward, default 10. +\\[what-line] print line number +\\[view-mode-describe] print this help message +\\[view-search-forward] regexp search, uses previous string if you just hit RET +\\[view-search-backward] as above but searches backward +\\[view-repeat-search] repeat last search +\\[view-goto-line] goto line prefix-arg, default 1 +\\[view-last-windowful] goto line prefix-arg, default last line +\\[view-goto-percent] goto a position by percentage +\\[toggle-truncate-lines] toggle truncate-lines +\\[view-file] view another file +\\[view-buffer] view another buffer +\\[view-cleanup-backspaces] cleanup backspace constructions +\\[shell-command] execute a shell command +\\[shell-command-on-region] execute a shell command with the region as input +\\[view-quit] exit view-mode, and bury the current buffer. + +If invoked with the optional (prefix) arg non-nil, view-mode cleans up +backspace constructions. + +More precisely: +\\{view-minor-mode-map}" t nil) + +(autoload 'view-mode "view-less" "\ +View the current buffer using view-minor-mode. This exists to be 99.9% +compatible with the implementations of `view-mode' in view.el and older +versions of view-less.el." t nil) + +(autoload 'view-major-mode "view-less" "\ +View the current buffer using view-mode, as a major mode. +This function has a nonstandard name because `view-mode' is wrongly +named but is like this for compatibility reasons." t nil) + +(autoload 'auto-view-mode "view-less" "\ +If the file of the current buffer is not writable, call view-mode. +This is meant to be added to `find-file-hooks'." nil nil) + +;;;*** + ;;;### (autoloads (widget-minor-mode widget-browse-other-window widget-browse widget-browse-at) "wid-browse" "lisp/wid-browse.el") (autoload 'widget-browse-at "wid-browse" "\ @@ -635,4 +1379,4 @@ ;;;*** -(provide 'TopLevel-autoloads) +(provide 'Standard-autoloads) diff -r 43306a74e31c -r d44af0c54775 lisp/autoload.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/autoload.el Mon Aug 13 10:08:34 2007 +0200 @@ -0,0 +1,564 @@ +;;; autoload.el --- maintain autoloads in loaddefs.el. + +;; Copyright (C) 1991, 1992, 1993, 1994, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. +;; Copyright (C) 1996 Ben Wing. + +;; Author: Roland McGrath +;; Keywords: maint + +;; This file is part of XEmacs. + +;; XEmacs 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. + +;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not synched with FSF. + +;;; Commentary: + +;; This code helps GNU Emacs maintainers keep the loaddefs.el file up to +;; date. It interprets magic cookies of the form ";;;###autoload" in +;; lisp source files in various useful ways. To learn more, read the +;; source; if you're going to use this, you'd better be able to. + +;; ChangeLog: + +;; Sep-26-1997: slb removed code dealing with customization. + +;;; Code: + +(defun make-autoload (form file) + "Turn FORM, a defun or defmacro, into an autoload for source file FILE. +Returns nil if FORM is not a defun, define-skeleton or defmacro." + (let ((car (car-safe form))) + (if (memq car '(defun define-skeleton defmacro)) + (let ((macrop (eq car 'defmacro)) + name doc) + (setq form (cdr form) + name (car form) + ;; Ignore the arguments. + form (cdr (if (eq car 'define-skeleton) + form + (cdr form))) + doc (car form)) + (if (stringp doc) + (setq form (cdr form)) + (setq doc nil)) + (list 'autoload (list 'quote name) file doc + (or (eq car 'define-skeleton) + (eq (car-safe (car form)) 'interactive)) + (if macrop (list 'quote 'macro) nil))) + nil))) + +(put 'define-skeleton 'doc-string-elt 3) + +(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 +\(defun function-to-be-autoloaded () ...) + +If this string appears alone on a line, the following form will be +read and an autoload made for it. If it is followed by the string +\"immediate\", then the form on the following line will be copied +verbatim. If there is further text on the line, that text will be +copied verbatim to `generated-autoload-file'.") + +(defvar generate-autoload-section-header "\f\n;;;### " + "String inserted before the form identifying +the section of autoloads for a file.") + +(defvar generate-autoload-section-trailer "\n;;;***\n" + "String which indicates the end of the section of autoloads for a file.") + +;;; Forms which have doc-strings which should be printed specially. +;;; A doc-string-elt property of ELT says that (nth ELT FORM) is +;;; the doc-string in FORM. +;;; +;;; There used to be the following note here: +;;; ;;; Note: defconst and defvar should NOT be marked in this way. +;;; ;;; We don't want to produce defconsts and defvars that +;;; ;;; make-docfile can grok, because then it would grok them twice, +;;; ;;; once in foo.el (where they are given with ;;;###autoload) and +;;; ;;; once in loaddefs.el. +;;; +;;; Counter-note: Yes, they should be marked in this way. +;;; make-docfile only processes those files that are loaded into the +;;; dumped Emacs, and those files should never have anything +;;; autoloaded here. The above-feared problem only occurs with files +;;; which have autoloaded entries *and* are processed by make-docfile; +;;; there should be no such files. + +(put 'autoload 'doc-string-elt 3) +(put 'defun 'doc-string-elt 3) +(put 'defvar 'doc-string-elt 3) +(put 'defconst 'doc-string-elt 3) +(put 'defmacro 'doc-string-elt 3) + +(defun autoload-trim-file-name (file) + "Returns a relative pathname of FILE including the last directory." + (setq file (expand-file-name file)) + (file-relative-name file (file-name-directory + (directory-file-name + (file-name-directory file))))) + +;;;###autoload +(defun generate-file-autoloads (file &optional funlist) + "Insert at point a loaddefs autoload section for FILE. +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." + (interactive "fGenerate autoloads for file: ") + (generate-file-autoloads-1 file funlist)) + +(defun* generate-file-autoloads-1 (file funlist) + "Insert at point a loaddefs autoload section for FILE. +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." + (let ((outbuf (current-buffer)) + (autoloads-done '()) + (load-name (replace-in-string (file-name-nondirectory file) + "\\.elc?$" + "")) + (trim-name (autoload-trim-file-name file)) + (dofiles (not (null funlist))) + (print-length nil) + (print-readably t) ; XEmacs + (float-output-format nil) + ;; (done-any nil) + (visited (get-file-buffer file)) + output-end) + + ;; If the autoload section we create here uses an absolute + ;; pathname 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)) + + (save-excursion + (unwind-protect + (progn + (let ((find-file-hooks nil) + (enable-local-variables nil)) + (set-buffer (or visited (find-file-noselect file))) + (set-syntax-table lisp-mode-syntax-table)) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (unless (search-forward generate-autoload-cookie nil t) + (message "No autoloads found in %s" trim-name) + (return-from generate-file-autoloads-1)) + + (message "Generating autoloads for %s..." trim-name) + (goto-char (point-min)) + (while (if dofiles funlist (not (eobp))) + (if (not dofiles) + (skip-chars-forward " \t\n\f") + (goto-char (point-min)) + (re-search-forward + (concat "(def\\(un\\|var\\|const\\|macro\\) " + (regexp-quote (symbol-name (car funlist))) + "\\s ")) + (goto-char (match-beginning 0))) + (cond + ((or dofiles + (looking-at (regexp-quote generate-autoload-cookie))) + (if dofiles + nil + (search-forward generate-autoload-cookie) + (skip-chars-forward " \t")) + ;; (setq done-any t) + (if (or dofiles (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)) + (doc-string-elt (get (car-safe form) + 'doc-string-elt))) + (if autoload + (setq autoloads-done (cons (nth 1 form) + autoloads-done)) + (setq autoload form)) + (if (and doc-string-elt + (stringp (nth doc-string-elt autoload))) + ;; We need to hack the printing because the + ;; doc-string must be printed specially for + ;; make-docfile (sigh). + (let* ((p (nthcdr (1- doc-string-elt) + autoload)) + (elt (cdr p))) + (setcdr p nil) + (princ "\n(" outbuf) + ;; XEmacs change: don't let ^^L's get into + ;; the file or sorting is hard. + (let ((print-escape-newlines t) + (p (save-excursion + (set-buffer outbuf) + (point))) + p2) + (mapcar (function (lambda (elt) + (prin1 elt outbuf) + (princ " " outbuf))) + autoload) + (save-excursion + (set-buffer outbuf) + (setq p2 (point-marker)) + (goto-char p) + (save-match-data + (while (search-forward "\^L" p2 t) + (delete-char -1) + (insert "\\^L"))) + (goto-char p2) + )) + (princ "\"\\\n" outbuf) + (let ((begin (save-excursion + (set-buffer outbuf) + (point)))) + (princ (substring + (prin1-to-string (car elt)) 1) + outbuf) + ;; Insert a backslash before each ( that + ;; appears at the beginning of a line in + ;; the doc string. + (save-excursion + (set-buffer outbuf) + (save-excursion + (while (search-backward "\n(" begin t) + (forward-char 1) + (insert "\\")))) + (if (null (cdr elt)) + (princ ")" outbuf) + (princ " " outbuf) + (princ (substring + (prin1-to-string (cdr elt)) + 1) + outbuf)) + (terpri outbuf))) + ;; XEmacs change: another fucking ^L hack + (let ((p (save-excursion + (set-buffer outbuf) + (point))) + (print-escape-newlines t) + p2) + (print autoload outbuf) + (save-excursion + (set-buffer outbuf) + (setq p2 (point-marker)) + (goto-char p) + (save-match-data + (while (search-forward "\^L" p2 t) + (delete-char -1) + (insert "\\^L"))) + (goto-char p2) + )) + )) + ;; Copy the rest of the line to the output. + (let ((begin (point))) + (terpri outbuf) + (cond ((looking-at "immediate\\s *$") ; XEmacs + ;; This is here so that you can automatically + ;; have small hook functions copied to + ;; loaddefs.el so that it's not necessary to + ;; load a whole file just to get a two-line + ;; do-nothing find-file-hook... --Stig + (forward-line 1) + (setq begin (point)) + (forward-sexp) + (forward-line 1)) + (t + (forward-line 1))) + (princ (buffer-substring begin (point)) outbuf)))) + ((looking-at ";") + ;; Don't read the comment. + (forward-line 1)) + (t + (forward-sexp 1) + (forward-line 1))) + (if dofiles + (setq funlist (cdr funlist))))))) + (unless visited + ;; We created this buffer, so we should kill it. + (kill-buffer (current-buffer))) + (set-buffer outbuf) + (setq output-end (point-marker)))) + (if t ;; done-any + ;; XEmacs -- always do this so that we cache the information + ;; that we've processed the file already. + (progn + (insert generate-autoload-section-header) + (prin1 (list 'autoloads autoloads-done load-name trim-name) + outbuf) + (terpri outbuf) + ;;;; (insert ";;; Generated autoloads from " + ;;;; (autoload-trim-file-name file) "\n") + ;; Warn if we put a line in loaddefs.el + ;; that is long enough to cause trouble. + (when (< output-end (point)) + (setq output-end (point-marker))) + (while (< (point) output-end) + ;; (let ((beg (point))) + (end-of-line) + ;; Emacs -- I still haven't figured this one out. + ;; (if (> (- (point) beg) 900) + ;; (progn + ;; (message "A line is too long--over 900 characters") + ;; (sleep-for 2) + ;; (goto-char output-end))) + ;; ) + (forward-line 1)) + (goto-char output-end) + (insert generate-autoload-section-trailer))) + (or noninteractive ; XEmacs: only need one line in -batch mode. + (message "Generating autoloads for %s...done" file)))) + + +(defconst autoload-file-name "auto-autoloads.el" + "Generic filename to put autoloads into. +Unless you are an XEmacs maintainer, it is probably unwise to change this.") + +(defvar autoload-target-directory "../lisp/prim/" + "Directory to put autoload declaration file into. +Unless you know what you're doing, don't mess with this.") + +(defvar generated-autoload-file + (expand-file-name (concat autoload-target-directory + autoload-file-name) + data-directory) + "*File `update-file-autoloads' puts autoloads into. +A .el file can set this in its local variables section to make its +autoloads go somewhere else.") + +(defconst cusload-file-name "custom-load.el" + "Generic filename ot put custom loads into. +Unless you are an XEmacs maintainr, it is probably unwise to change this.") + +;;;###autoload +(defun update-file-autoloads (file) + "Update the autoloads for FILE in `generated-autoload-file' +\(which FILE might bind in its local variables). +This functions refuses to update autoloads files." + (interactive "fUpdate autoloads for file: ") + (setq file (expand-file-name file)) + (when (and (file-newer-than-file-p file generated-autoload-file) + (not (member (file-name-nondirectory file) + (list autoload-file-name)))) + + (let ((load-name (replace-in-string (file-name-nondirectory file) + "\\.elc?$" + "")) + (trim-name (autoload-trim-file-name file)) + section-begin form) + (save-excursion + (let ((find-file-hooks nil)) + (set-buffer (or (get-file-buffer generated-autoload-file) + (find-file-noselect generated-autoload-file)))) + ;; First delete all sections for this file. + (goto-char (point-min)) + (while (search-forward generate-autoload-section-header nil t) + (setq section-begin (match-beginning 0)) + (setq form (read (current-buffer))) + (when (string= (nth 2 form) load-name) + (search-forward generate-autoload-section-trailer) + (delete-region section-begin (point)))) + + ;; Now find insertion point for new section + (block find-insertion-point + (goto-char (point-min)) + (while (search-forward generate-autoload-section-header nil t) + (setq form (read (current-buffer))) + (when (string< trim-name (nth 3 form)) + ;; Found alphabetically correct insertion point + (goto-char (match-beginning 0)) + (return-from find-insertion-point)) + (search-forward generate-autoload-section-trailer)) + (when (eq (point) (point-min)) ; No existing entries? + (goto-char (point-max)))) ; Append. + + ;; Add in new sections for file + (generate-file-autoloads file)) + + (when (interactive-p) (save-buffer))))) + +;;;###autoload +(defun update-autoloads-here () + "Update sections of the current buffer generated by `update-file-autoloads'." + (interactive) + (let ((generated-autoload-file (buffer-file-name))) + (save-excursion + (goto-char (point-min)) + (while (search-forward generate-autoload-section-header nil t) + (let* ((form (condition-case () + (read (current-buffer)) + (end-of-file nil))) + (file (nth 3 form))) + ;; XEmacs change: if we can't find the file as specified, look + ;; around a bit more. + (cond ((and (stringp file) + (or (get-file-buffer file) + (file-exists-p file)))) + ((and (stringp file) + (save-match-data + (let ((loc (locate-file (file-name-nondirectory file) + load-path))) + (if (null loc) + nil + (setq loc (expand-file-name + (autoload-trim-file-name loc) + "..")) + (if (or (get-file-buffer loc) + (file-exists-p loc)) + (setq file loc) + nil)))))) + (t + (setq file + (if (y-or-n-p + (format + "Can't find library `%s'; remove its autoloads? " + (nth 2 form) file)) + t + (condition-case () + (read-file-name + (format "Find `%s' load file: " + (nth 2 form)) + nil nil t) + (quit nil)))))) + (if file + (let ((begin (match-beginning 0))) + (search-forward generate-autoload-section-trailer) + (delete-region begin (point)))) + (if (stringp file) + (generate-file-autoloads file))))))) + +;;;###autoload +(defun update-autoloads-from-directory (dir) + "Update `generated-autoload-file' with all the current autoloads from DIR. +This runs `update-file-autoloads' on each .el file in DIR. +Obsolete autoload entries for files that no longer exist are deleted." + (interactive "DUpdate autoloads for directory: ") + (setq dir (expand-file-name dir)) + (let ((simple-dir (file-name-as-directory + (file-name-nondirectory + (directory-file-name dir)))) + (enable-local-eval nil)) + (save-excursion + (let ((find-file-hooks nil)) + (set-buffer (find-file-noselect generated-autoload-file))) + (goto-char (point-min)) + (while (search-forward generate-autoload-section-header nil t) + (let* ((begin (match-beginning 0)) + (form (condition-case () + (read (current-buffer)) + (end-of-file nil))) + (file (nth 3 form))) + (when (and (stringp file) + (string= (file-name-directory file) simple-dir) + (not (file-exists-p + (expand-file-name + (file-name-nondirectory file) dir)))) + ;; Remove the obsolete section. + (search-forward generate-autoload-section-trailer) + (delete-region begin (point))))) + ;; Update or create autoload sections for existing files. + (mapcar 'update-file-autoloads (directory-files dir t "^[^=].*\\.el$")) + (unless noninteractive + (save-buffer))))) + +;;;###autoload +(defun batch-update-autoloads () + "Update the autoloads for the files or directories on the command line. +Runs `update-file-autoloads' on files and `update-directory-autoloads' +on directories. 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 `xemacs -batch -f batch-update-autoloads *.el'. +The directory to which the auto-autoloads.el file must be the first parameter +on the command line." + (unless noninteractive + (error "batch-update-autoloads is to be used only with -batch")) + (let ((defdir default-directory) + (enable-local-eval nil)) ; Don't query in batch mode. + ;; (message "Updating autoloads in %s..." generated-autoload-file) + (dolist (arg command-line-args-left) + (setq arg (expand-file-name arg defdir)) + (cond + ((file-directory-p arg) + (message "Updating autoloads for directory %s..." arg) + (update-autoloads-from-directory arg)) + ((file-exists-p arg) + (update-file-autoloads arg)) + (t (error "No such file or directory: %s" arg)))) + (fixup-autoload-buffer (concat (if autoload-package-name + autoload-package-name + (file-name-nondirectory defdir)) + "-autoloads")) + (save-some-buffers t) + ;; (message "Done") + (kill-emacs 0))) + +(defun fixup-autoload-buffer (sym) + (save-excursion + (set-buffer (find-file-noselect generated-autoload-file)) + (goto-char (point-min)) + (if (and (not (= (point-min) (point-max))) + (not (looking-at ";;; DO NOT MODIFY THIS FILE"))) + (progn + (insert ";;; DO NOT MODIFY THIS FILE\n") + (insert "(if (featurep '" sym ")") + (insert " (error \"Already loaded\"))\n") + (goto-char (point-max)) + (insert "\n(provide '" sym ")\n"))))) + +(defvar autoload-package-name nil) + +;;;###autoload +(defun batch-update-directory () + "Update the autoloads for the directory on the command line. +Runs `update-file-autoloads' on each file in the given directory, must +be used only with -batch and kills XEmacs on completion." + (unless noninteractive + (error "batch-update-directory is to be used only with -batch")) + (let ((defdir default-directory) + (enable-local-eval nil)) ; Don't query in batch mode. + (dolist (arg command-line-args-left) + (setq arg (expand-file-name arg defdir)) + (let ((generated-autoload-file (concat arg "/" autoload-file-name))) + (cond + ((file-directory-p arg) + (message "Updating autoloads in directory %s..." arg) + (update-autoloads-from-directory arg)) + (t (error "No such file or directory: %s" arg))) + (fixup-autoload-buffer (concat (if autoload-package-name + autoload-package-name + (file-name-nondirectory arg)) + "-autoloads")) + (save-some-buffers t)) + ;; (message "Done") + ;; (kill-emacs 0) + ) + (setq command-line-args-left nil))) + +(provide 'autoload) + +;;; autoload.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/blessmail.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/blessmail.el Mon Aug 13 10:08:34 2007 +0200 @@ -0,0 +1,71 @@ +;;; blessmail.el --- Decide whether movemail needs special privileges. + +;; Copyright (C) 1994 Free Software Foundation, Inc. + +;; Maintainer: FSF +;; Keywords: internal + +;; This file is part of XEmacs. + +;; XEmacs 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. + +;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: FSF 19.34. + +;;; Commentary: + +;; This is loaded into a bare Emacs to create the blessmail script, +;; which (on systems that need it) is used during installation +;; to give appropriate permissions to movemail. +;; +;; It has to be done from lisp in order to be sure of getting the +;; correct value of rmail-spool-directory. + +;;; Code: + +;; These are no longer needed because we run this in emacs instead of temacs. +;; (message "Using load-path %s" load-path) +;; (load "paths.el") +;; It is not safe to load site-init.el here, because it might have things in it +;; that won't load properly unless all the rest of Emacs is loaded. + +(let ((dirname (directory-file-name rmail-spool-directory)) + linkname attr modes) + ;; Check for symbolic link + (while (setq linkname (file-symlink-p dirname)) + (setq dirname (if (file-name-absolute-p linkname) + linkname + (concat (file-name-directory dirname) linkname)))) + (insert "#!/bin/sh\n") + (setq attr (file-attributes dirname)) + (if (not (eq t (car attr))) + (insert (format "echo %s is not a directory\n" rmail-spool-directory)) + (setq modes (nth 8 attr)) + (cond ((= ?w (aref modes 8)) + ;; Nothing needs to be done. + ) + ((= ?w (aref modes 5)) + (insert "chgrp " (number-to-string (nth 3 attr)) + " $* && chmod g+s $*\n")) + ((= ?w (aref modes 2)) + (insert "chown " (number-to-string (nth 2 attr)) + " $* && chmod u+s $*\n")) + (t + (insert "chown root $* && chmod u+s $*\n")))) + (insert "echo mail directory = " dirname "\n")) +(write-region (point-min) (point-max) "blessmail") +(kill-emacs) + +;;; blessmail.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/build-report.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/build-report.el Mon Aug 13 10:08:34 2007 +0200 @@ -0,0 +1,243 @@ +;;; xemacs-build-report.el --- Automatically formatted build reports for XEmacs + +;; Copyright (C) 1997 Adrian Aichner + +;; Author: Adrian Aichner, Teradyne GmbH Munich +;; Date: Sun., Apr. 20, 1997. +;; Version: 1.28 +;; Keywords: internal + +;; This file is part of XEmacs. + +;; XEmacs 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. + +;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not synched. + +;;; Commentary: + +;; The Idea: +;; Let XEmacs report interesting aspects of how it was built. + +;; The Concept: +;; User creates an XEmacs Build Report by just calling +;; M-x xemacs-create-build-report +;; which will initialize a mail buffer with relevant information +;; derived from the XEmacs build process. Point is left at the +;; beginning of the report for user to input some personal notes and +;; send the report. + +;; The Status: +;; This is the first `Proof of Concept'. + +;; The Author: +;; Adrian Aichner, Teradyne GmbH Munich, Sun., Apr. 20, 1997. + +;;; Code: + +(require 'config) +(provide 'xemacs-build-report) + +;; Due to recommandation by developers on xemacs-beta@xemacs.org, +;; release versions are to be checked out using `co -u -kv ...'. +(defconst xemacs-build-report-version + "1.28" + "Version number of xemacs-build-report.") + +(defgroup xemacs-build-report nil + "Package automating the process of sending Xemacs Build Reports.") + +(defcustom xemacs-build-report-destination + "xemacs-beta@xemacs.org" + "The mail address XEmacs Build Reports should go to." + :group 'xemacs-build-report) + +(defcustom xemacs-build-report-keep-regexp + "make\\[\\|error\\|warn\\|pure.*\\(space\\|size\\)\\|hides\\b\\|strange\\|shadowings" + "Regexp of make process output lines to keep in the report." + :group 'xemacs-build-report) + +(defcustom xemacs-build-report-delete-regexp + "confl.*with.*auto-inlining" + "Regexp of make process output lines to delete from the report." + :group 'xemacs-build-report) + +(defcustom xemacs-build-report-make-output-file + (concat (gethash 'blddir (config-value-hash-table)) "/beta.err") + "Filename where stdout and stderr of XEmacs make process have been stored. +mk.err will not be created automatically. You'll have to run make with +output redirection. I use an alias +alias mk 'make \!* >>&\! \!$.err &' +for that, so that I get beta.err went I run `mk beta'." + :group 'xemacs-build-report) + +(defcustom xemacs-build-report-installation-file + (concat (gethash 'blddir (config-value-hash-table)) "/Installation") + "Installation file produced by XEmacs configure process." + :group 'xemacs-build-report) + +(defcustom xemacs-build-report-subject + (concat "[%s] " emacs-version " on " system-configuration) + "XEmacs Build Report Subject Line. %s-sequences will be substituted +with user input through `xemacs-create-build-report' according to +`xemacs-build-report-prompts' using `format'." + :group 'xemacs-build-report) + +(defcustom xemacs-build-report-prompts + '(("Status?: " "Success" "Failure")) + "XEmacs Build Report Prompt(s). This is a list of prompt-string +lists used by `xemacs-create-build-report' in conjunction with +`xemacs-build-report-subject'. Each list consists of a prompt string +followed by any number of strings which can be chosen via the history +mechanism." + :group 'xemacs-build-report) + +(defcustom xemacs-build-report-file-encoding + "7bit" + "XEmacs Build Report File Encoding to be used when MIME support is +available." +:group 'xemacs-build-report) + +;; Symbol Name mappings from TM to SEMI serving as +;; Compatibility Bandaid +;; If 'mime-editor/version-name is bound, we must be using TM(-edit). +(if (featurep 'mime-setup) + (if (locate-library "tm-edit") + (progn + ;; No (defvaralias ...) so far. T + ;; Thanks to "Didier Verna" verna@inf.enst.fr for reporting my + ;; incorrect defvaraliasing of `mime-editor/insert-tag'. + (defalias + 'mime-edit-insert-tag + 'mime-editor/insert-tag + ) + (defalias + 'mime-edit-insert-binary-file + 'mime-editor/insert-binary-file + )))) + +(defun xemacs-create-build-report (&rest args) + "Initializes a fresh mail-mode buffer with the contents of XEmacs +Installation file and excerpts from XEmacs make output and errors and +leaves point at the beginning of the mail text. See also +`xemacs-build-report-destination', +`xemacs-build-report-keep-regexp', +`xemacs-build-report-delete-regexp', +`xemacs-build-report-make-output-file' and +`xemacs-build-report-installation-file'." + (interactive + (let (prompt + hist + arg + (prompts xemacs-build-report-prompts)) + (progn + (while prompts + (setq prompt (caar prompts)) + (setq hist (cdar prompts)) + (setq prompts (cdr prompts)) + (setq arg (cons (read-string prompt "" 'hist) arg))) + arg))) + (save-excursion + (compose-mail + xemacs-build-report-destination + (apply 'format xemacs-build-report-subject args) + nil + nil + nil + nil + nil) + (let ((report-begin (mail-text))) + (xemacs-build-report-insert-make-output report-begin) + (xemacs-build-report-insert-installation-file report-begin) + (xemacs-build-report-insert-header report-begin) + ))) + +(defun xemacs-build-report-insert-header (where) + "Inserts the xemacs-build-report-header at the point specified by `where'." + (goto-char where) + (insert "\n> XEmacs Build Report as generated\n> by " + "xemacs-build-report-version " + xemacs-build-report-version + " follows:\n\n")) + +(defun xemacs-build-report-insert-make-output (where) + "Inserts the output of the XEmacs Beta make run. +The make process output must have been saved in +`xemacs-build-report-make-output-file' during the XEmacs Beta building." + (goto-char where) + (if (file-exists-p xemacs-build-report-make-output-file) + (progn + (if (featurep 'mime-setup) + (progn + (setq xemacs-build-report-keep-regexp + (concat "^--\\[\\[\\|\\]\\]$\\|" + xemacs-build-report-keep-regexp)) + (mime-edit-insert-tag + "application" + "octet-stream" + (concat + "\nContent-Disposition: attachment;" + " filename=\"" + (file-name-nondirectory + xemacs-build-report-make-output-file) + "\"")) + (mime-edit-insert-binary-file + xemacs-build-report-make-output-file + xemacs-build-report-file-encoding)) + (insert-file-contents xemacs-build-report-make-output-file)) + (goto-char where) + (delete-non-matching-lines + xemacs-build-report-keep-regexp) + (goto-char where) + (delete-matching-lines xemacs-build-report-delete-regexp) + (goto-char where) + (insert "> Contents of " + xemacs-build-report-make-output-file + "\n> keeping lines matching\n> \"" + xemacs-build-report-keep-regexp + "\"\n> and then deleting lines matching\n> \"" + xemacs-build-report-delete-regexp + "\"\n\n")) + (insert "> " xemacs-build-report-make-output-file + " does not exist!\n\n"))) + +(defun xemacs-build-report-insert-installation-file (where) + "Inserts the contents of the `xemacs-build-report-installation-file' +created by the XEmacs Beta configure process." + (goto-char where) + (if (file-exists-p xemacs-build-report-installation-file) + (progn + (insert "> Contents of " + xemacs-build-report-installation-file + ":\n\n") + (if (featurep 'mime-setup) + (progn + (mime-edit-insert-tag + "application" + "octet-stream" + (concat + "\nContent-Disposition: attachment;" + " filename=\"" + (file-name-nondirectory + xemacs-build-report-installation-file) + "\"")) + (mime-edit-insert-binary-file + xemacs-build-report-installation-file + xemacs-build-report-file-encoding)) + (insert-file-contents xemacs-build-report-installation-file))) + (insert "> " xemacs-build-report-installation-file + " does not exist!\n\n"))) + +;;; xemacs-build-report.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/cleantree.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cleantree.el Mon Aug 13 10:08:34 2007 +0200 @@ -0,0 +1,68 @@ +;;; cleantree.el --- Remove out of date .elcs in lisp directories + +;; Copyright (C) 1997 by Free Software Foundation, Inc. + +;; Author: Steven L Baur +;; Keywords: internal + +;; This file is part of XEmacs. + +;; XEmacs 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. + +;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +;; This code is derived from Gnus based on a suggestion by +;; David Moore + +;;; Code: + +(defun remove-old-elc-1 (dir &optional seen) + (setq dir (file-name-as-directory dir)) + ;; Only scan this sub-tree if we haven't been here yet. + (unless (member (file-truename dir) seen) + (push (file-truename dir) seen) + ;; We descend recursively + (let ((dirs (directory-files dir t nil t)) + dir) + (while (setq dir (pop dirs)) + (when (and (not (member (file-name-nondirectory dir) '("." ".."))) + (file-directory-p dir)) + (remove-old-elc-1 dir seen)))) + ;; Do this directory. + (let ((files (directory-files dir t ".el$")) + file file-c) + (while (setq file (car files)) + (setq files (cdr files)) + (setq file-c (concat file "c")) + (when (and (file-exists-p file-c) + (file-newer-than-file-p file file-c)) + (message file-c) + (delete-file file-c)))))) + +;;;###autoload +(defun batch-remove-old-elc () + (defvar command-line-args-left) + (unless noninteractive + (error "`batch-remove-old-elc' is to be used only with -batch")) + (let ((dir (car command-line-args-left))) + (message "Cleaning out of date .elcs in directory `%s'..." dir) + (remove-old-elc-1 dir) + (message "Cleaning out of date .elcs in directory `%s'...done" dir)) + (setq command-line-args-left nil)) + +;;; cleantree.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/config.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/config.el Mon Aug 13 10:08:34 2007 +0200 @@ -0,0 +1,70 @@ +;;; config.el --- access configuration parameters + +;; Copyright (C) 1997 Sun Microsystems, Inc. + +;; Author: Martin Buchholz +;; Keywords: configure + +;; This file is part of XEmacs. + +;; XEmacs 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. + +;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: not in FSF. + +;;; Commentary: + +;;; Code: + + +(defvar config-value-file (expand-file-name "config.values" exec-directory) + "File containing configuration parameters and their values.") + +(defvar config-value-hash-table nil + "Hashtable to store configuration parameters and their values.") + +;;;###autoload +(defun config-value-hash-table () + "Returns hashtable of configuration parameters and their values." + (when (null config-value-hash-table) + (setq config-value-hash-table (make-hashtable 300)) + (save-excursion + (let ((buf (get-buffer-create " *Config*"))) + (set-buffer buf) + (erase-buffer) + (insert-file-contents config-value-file) + (goto-char (point-min)) + (condition-case nil + (while t + (let* ((key (read buf)) + (value (read buf)) + (prev (gethash key config-value-hash-table))) + (cond ((null prev) + (puthash key value config-value-hash-table)) + ((atom prev) + (puthash key (list prev value) config-value-hash-table)) + (t + (nconc prev (list value)))))) + (end-of-file nil))) + (kill-buffer " *Config*"))) + config-value-hash-table) + +;;;###autoload +(defun config-value (config-symbol) + "Return the value of the configuration parameter CONFIG_SYMBOL." + (gethash config-symbol (config-value-hash-table))) + +(provide 'config) +;;; config.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/custom-load.el --- a/lisp/custom-load.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,41 +0,0 @@ -;;; custom-load.el --- automatically extracted custom dependencies - - -;;; Code: - -(custom-add-loads 'extensions '("wid-edit")) -(custom-add-loads 'custom-buffer '("cus-edit")) -(custom-add-loads 'custom-faces '("cus-edit")) -(custom-add-loads 'widgets '("wid-browse" "wid-edit")) -(custom-add-loads 'menu '("x-menubar")) -(custom-add-loads 'environment '("cus-edit" "x-toolbar")) -(custom-add-loads 'custom-menu '("cus-edit")) -(custom-add-loads 'internal '("cus-edit")) -(custom-add-loads 'buffers-menu '("x-menubar")) -(custom-add-loads 'hypermedia '("wid-edit")) -(custom-add-loads 'applications '("cus-edit")) -(custom-add-loads 'help '("cus-edit")) -(custom-add-loads 'widget-browse '("wid-browse")) -(custom-add-loads 'widget-documentation '("wid-edit")) -(custom-add-loads 'customize '("cus-edit" "wid-edit")) -(custom-add-loads 'custom-browse '("cus-edit")) -(custom-add-loads 'abbrev '("cus-edit")) -(custom-add-loads 'programming '("cus-edit")) -(custom-add-loads 'toolbar '("x-toolbar")) -(custom-add-loads 'widget-button '("wid-edit")) -(custom-add-loads 'files '("cus-edit")) -(custom-add-loads 'external '("cus-edit")) -(custom-add-loads 'development '("cus-edit")) -(custom-add-loads 'widget-faces '("wid-edit")) -(custom-add-loads 'languages '("cus-edit")) -(custom-add-loads 'custom-magic-faces '("cus-edit")) -(custom-add-loads 'faces '("cus-edit" "wid-edit")) -(custom-add-loads 'emacs '("cus-edit")) -(custom-add-loads 'processes '("cus-edit")) -(custom-add-loads 'wp '("cus-edit")) -(custom-add-loads 'editing '("cus-edit")) -(custom-add-loads 'i18n '("cus-edit")) -(custom-add-loads 'info '("x-toolbar")) -(custom-add-loads 'x '("x-faces" "x-font-menu")) - -;;; custom-load.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/custom.el --- a/lisp/custom.el Mon Aug 13 10:07:42 2007 +0200 +++ b/lisp/custom.el Mon Aug 13 10:08:34 2007 +0200 @@ -145,6 +145,9 @@ (put symbol 'custom-requests requests) ;; Do the actual initialization. (funcall initialize symbol value)) + ;; #### This is a rough equivalent of LOADHIST_ATTACH. However, + ;; LOADHIST_ATTACH also checks for `initialized'. + (push symbol current-load-list) (run-hooks 'custom-define-hook) symbol) diff -r 43306a74e31c -r d44af0c54775 lisp/dumped-lisp.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/dumped-lisp.el Mon Aug 13 10:08:34 2007 +0200 @@ -0,0 +1,187 @@ +(setq preloaded-file-list + '("backquote" ; needed for defsubst etc. + "bytecomp-runtime" ; define defsubst + "packages" ; Bootstrap run-time lisp environment + "subr" ; load the most basic Lisp functions + "replace" ; match-string used in version.el. + "version.el" ; Ignore compiled-by-mistake version.elc + "cl" + "cl-extra" + "cl-seq" + "widget" + "custom" ; Before the world so everything can be + ; customized + "cus-start" ; for customization of builtin variables + "cmdloop" + "keymap" + "syntax" + "device" + "console" + "obsolete" + "specifier" + "faces" ; must be loaded before any make-face call +;;(load-gc "facemenu") #### not yet ported + "glyphs" + "objects" + "extents" + "events" + "text-props" + "process" + "frame" ; move up here cause some stuff needs it here + "map-ynp" + "simple" + "keydefs" ; Before loaddefs so that keymap vars exist. + "abbrev" + "derived" + "minibuf" + "list-mode" + "modeline" ; needs simple.el to be loaded first +;; If SparcWorks support is included some additional packages are +;; dumped which would normally have autoloads. To avoid +;; duplicate doc string warnings, SparcWorks uses a separate +;; autoloads file with the dumped packages removed. +;; After fixing, eos/loaddefs-eos and loaddefs appear identical?!! +;; So just make loaddefs-eos go away... +;;(load-gc (if (featurep 'sparcworks) "eos/loaddefs-eos" "loaddefs")) + "startup" ; For initialization of + ; `emacs-user-extension-dir' + "misc" + ;; (load-gc "profile") + #-mule "help-nomule" + "help" + ;; (load-gc "hyper-apropos") Soon... + #-mule "files-nomule" + "files" + #+xemacs "lib-complete" ; InfoDock uses an older version + "format" + "indent" + "isearch-mode" + "buffer" + "buff-menu" + "undo-stack" + "window" + "window-xemacs" + "paths.el" ; don't get confused if paths compiled. + "lisp" + "page" + "register" + "iso8859-1" ; This must be before any modes + ; (sets standard syntax table.) + "paragraphs" + "easymenu" ; Added for 20.3. + "lisp-mode" + "text-mode" + "fill" + "auto-save" ; Added for 20.4 + + #+windows-nt "winnt" + #+lisp-float-type "float-sup" + "itimer" ; for vars auto-save-timeout and + ; auto-gc-threshold + "itimer-autosave" + #+toolbar "toolbar" + #+scrollbar "scrollbar" + #+menubar "menubar" + #+dialog "dialog" + #+mule "mule-charset" + #+mule "mule-coding" +;; Handle I/O of files with extended characters. + #+mule "mule-files" +;; Handle process with encoding/decoding non-ascii coding-system. + #+mule "mule-process" + #+mule "mule-help" +;; Load the remaining basic files. + #+mule "mule-category" + #+mule "mule-ccl" + #+mule "mule-misc" + #+mule "kinsoku" + #+(and mule x) "mule-x-init" + #+mule "mule-cmds" ; to sync with Emacs 20.1 + +;; after this goes the specific lisp routines for a particular input system +;; 97.2.5 JHod Shouldn't these go into a site-load file to allow site +;; or user switching of input systems??? +;(if (featurep 'wnn) +; (progn +; (load-gc "egg") +; (load-gc "egg-wnn") +; (setq egg-default-startup-file "eggrc-wnn"))) + +;; (if (and (boundp 'CANNA) CANNA) +;; (load-gc "canna") +;; ) + +;; Now load files to set up all the different languages/environments +;; that Mule knows about. + + #+mule "language/arabic" + #+mule "language/chinese" + #+mule "language/cyrillic" + #+mule "language/english" +;; #+mule "language/ethiopic" + #+mule "language/european" + #+mule "language/greek" + #+mule "language/hebrew" + #+mule "language/japanese" + #+mule "language/korean" + #+mule "language/misc-lang" +;; #+mule "language/thai" + #+mule "language/viet-chars" +;; #+mule "language/vietnamese" + + ;; Specialized language support + #+(and mule CANNA) "canna-leim" + #+(and mule wnn) "egg-leim" + +;; Set up the XEmacs environment for Mule. +;; Assumes the existence of various stuff above. + #+mule "mule-init" + +;; Enable Mule capability for Gnus, mail, etc... +;; Moved to sunpro-load.el - the default only for Sun. +;;(load-gc "mime-setup") +;;; mule-load.el ends here + #+window-system "gui" + #+window-system "mode-motion" + #+window-system "mouse" +;; preload the X code, for faster startup. + #+(and x menubar) "x-menubar" + #+x "x-faces" + #+x "x-iso8859-1" + #+x "x-mouse" + #+x "x-select" + #+(and x scrollbar) "x-scrollbar" + #+x "x-misc" + #+x "x-init" + #+(and x toolbar) "x-toolbar" +;; preload the mswindows code. + #+mswindows "msw-faces" + #+mswindows "msw-init" +;; preload the TTY init code. + #+tty "tty-init" +;;; Formerly in tooltalk/tooltalk-load.el + #+tooltalk "tooltalk/tooltalk-macros" + #+tooltalk "tooltalk/tooltalk-util" + #+tooltalk "tooltalk/tooltalk-init" + ;; "vc-hooks" ; Packaged. Available in two versions. + ;; "ediff-hook" ; Packaged. + "fontl-hooks" + "auto-show" +;; #+energize "energize/energize-load.el" +;;; formerly in sunpro/sunpro-load.el +;; #+(and mule sparcworks) "mime-setup" + #+sparcworks "cc-mode" ; Requires cc-mode package + #+sparcworks "sunpro-init" + #+sparcworks "ring" + #+sparcworks "comint" ; Requires comint package + #+sparcworks "annotations" +;;; formerly in eos/sun-eos-load.el +;; #+sparcworks "sun-eos-init" +;; #+sparcworks "sun-eos-common" +;; #+sparcworks "sun-eos-editor" +;; #+sparcworks "sun-eos-browser" +;; #+sparcworks "sun-eos-debugger" +;; #+sparcworks "sun-eos-debugger-extra" +;; #+sparcworks "sun-eos-menubar" + "loaddefs" ; <=== autoloads get loaded here +)) diff -r 43306a74e31c -r d44af0c54775 lisp/emulators/auto-autoloads.el --- a/lisp/emulators/auto-autoloads.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,152 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'emulators-autoloads) (error "Already loaded")) - -;;;### (autoloads (edt-emulation-on) "edt" "emulators/edt.el") - -(autoload 'edt-emulation-on "edt" "\ -Turn on EDT Emulation." t nil) - -;;;*** - -;;;### (autoloads (teco-command) "teco" "emulators/teco.el") - -(autoload 'teco-command "teco" "\ -Read and execute a Teco command string." t nil) - -;;;*** - -;;;### (autoloads (tpu-edt-on) "tpu-edt" "emulators/tpu-edt.el") - -(fset 'tpu-edt-mode 'tpu-edt-on) - -(fset 'tpu-edt 'tpu-edt-on) - -(autoload 'tpu-edt-on "tpu-edt" "\ -Turn on TPU/edt emulation." t nil) - -;;;*** - -;;;### (autoloads (tpu-set-cursor-bound tpu-set-cursor-free tpu-set-scroll-margins) "tpu-extras" "emulators/tpu-extras.el") - -(autoload 'tpu-set-scroll-margins "tpu-extras" "\ -Set scroll margins." t nil) - -(autoload 'tpu-set-cursor-free "tpu-extras" "\ -Allow the cursor to move freely about the screen." t nil) - -(autoload 'tpu-set-cursor-bound "tpu-extras" "\ -Constrain the cursor to the flow of the text." t nil) - -;;;*** - -;;;### (autoloads (wordstar-mode) "ws-mode" "emulators/ws-mode.el") - -(autoload 'wordstar-mode "ws-mode" "\ -Major mode with WordStar-like key bindings. - -BUGS: - - Help menus with WordStar commands (C-j just calls help-for-help) - are not implemented - - Options for search and replace - - Show markers (C-k h) is somewhat strange - - Search and replace (C-q a) is only available in forward direction - -No key bindings beginning with ESC are installed, they will work -Emacs-like. - -The key bindings are: - - C-a backward-word - C-b fill-paragraph - C-c scroll-up-line - C-d forward-char - C-e previous-line - C-f forward-word - C-g delete-char - C-h backward-char - C-i indent-for-tab-command - C-j help-for-help - C-k ordstar-C-k-map - C-l ws-repeat-search - C-n open-line - C-p quoted-insert - C-r scroll-down-line - C-s backward-char - C-t kill-word - C-u keyboard-quit - C-v overwrite-mode - C-w scroll-down - C-x next-line - C-y kill-complete-line - C-z scroll-up - - C-k 0 ws-set-marker-0 - C-k 1 ws-set-marker-1 - C-k 2 ws-set-marker-2 - C-k 3 ws-set-marker-3 - C-k 4 ws-set-marker-4 - C-k 5 ws-set-marker-5 - C-k 6 ws-set-marker-6 - C-k 7 ws-set-marker-7 - C-k 8 ws-set-marker-8 - C-k 9 ws-set-marker-9 - C-k b ws-begin-block - C-k c ws-copy-block - C-k d save-buffers-kill-emacs - C-k f find-file - C-k h ws-show-markers - C-k i ws-indent-block - C-k k ws-end-block - C-k p ws-print-block - C-k q kill-emacs - C-k r insert-file - C-k s save-some-buffers - C-k t ws-mark-word - C-k u ws-exdent-block - C-k C-u keyboard-quit - C-k v ws-move-block - C-k w ws-write-block - C-k x kill-emacs - C-k y ws-delete-block - - C-o c wordstar-center-line - C-o b switch-to-buffer - C-o j justify-current-line - C-o k kill-buffer - C-o l list-buffers - C-o m auto-fill-mode - C-o r set-fill-column - C-o C-u keyboard-quit - C-o wd delete-other-windows - C-o wh split-window-horizontally - C-o wo other-window - C-o wv split-window-vertically - - C-q 0 ws-find-marker-0 - C-q 1 ws-find-marker-1 - C-q 2 ws-find-marker-2 - C-q 3 ws-find-marker-3 - C-q 4 ws-find-marker-4 - C-q 5 ws-find-marker-5 - C-q 6 ws-find-marker-6 - C-q 7 ws-find-marker-7 - C-q 8 ws-find-marker-8 - C-q 9 ws-find-marker-9 - C-q a ws-query-replace - C-q b ws-to-block-begin - C-q c end-of-buffer - C-q d end-of-line - C-q f ws-search - C-q k ws-to-block-end - C-q l ws-undo - C-q p ws-last-cursorp - C-q r beginning-of-buffer - C-q C-u keyboard-quit - C-q w ws-last-error - C-q y ws-kill-eol - C-q DEL ws-kill-bol -" t nil) - -;;;*** - -(provide 'emulators-autoloads) diff -r 43306a74e31c -r d44af0c54775 lisp/emulators/crisp.el --- a/lisp/emulators/crisp.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,409 +0,0 @@ -;; @(#) crisp.el -- CRiSP/Brief Emacs emulator - -;; Author: Gary D. Foster -;; Created: 01 Mar 1996 -;; Version: 1.26 -;; Keywords: emulations brief crisp -;; X-Modified-by: -;; crisp.el,v -;; Revision 1.26 1997/11/18 05:41:02 gfoster -;; Added several new keybindings: -;; C-home top of window -;; C-end bottom of window -;; M-home beginning of line -;; M-end end-of-line -;; C-F format region -;; M-l mark line -;; M-m set mark -;; Added crisp-version function -;; -;; Revision 1.25 1997/11/18 04:19:09 gfoster -;; Shortened the version numbering, removed the release-version tracking -;; -;; Revision 1.24 1997/11/18 04:15:54 gfoster -;; Added `crisp-submit-bug-report' (shamelessly cribbed from Barry's -;; cc-mode. Thanks Barry!) -;; -;; Bound the above to C-c b -;; -;; Changed the behavior of `crisp-(kill|copy)-line' so (kill|copy)ing -;; works on the region from point to eol instead of the entire line, when -;; a region is not highlighted. -;; -;; Revision 1.23 1997/11/11 19:47:02 gfoster -;; Merged changes suggested by Hrvoje Niksic -;; make crisp-mode-map a sparse keymap parented from current-global-map -;; don't copy the keymap in (crisp-mode-original-keymap) -;; declare last-last-command to shut up the byte-compiler -;; make (crisp-mode) honor ARG -;; -;; Revision 1.22 1997/11/11 19:37:44 gfoster -;; kp-add/minus now copy/kill the current line if there is no highlighted -;; region. These also honor the universal prefix argument conventions. -;; -;; Revision 1.21 1997/10/16 18:52:54 gfoster -;; Fixed bogus XEmacs/Lucid string-match checking -;; made modeline entry mouse2-able -;; -;; Revision 1.20 1997/08/22 18:49:11 gfoster -;; Added next-buffer/previous-buffer keybindings (bound to M-n/M-p) -;; Added crisp-unbury-buffer function -;; Standardized headers for Steve -;; - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;; CRiSP is a registered trademark of Foxtrot Systems Ltd. - -;;; Commentary: - -;; Keybindings and minor functions to duplicate the functionality and -;; finger-feel of the CRiSP/Brief editor. This package is designed to -;; facilitate transitioning from Brief to (XE|E)macs with a minimum -;; amount of hassles. - -;; Enable this package by putting (require 'crisp) in your .emacs and -;; use M-x crisp-mode to toggle it on or off. - -;; This package will automatically load the scroll-lock.el package if -;; you put (setq crisp-load-scroll-lock t) in your .emacs before -;; loading this package. If this feature is enabled, it will bind -;; meta-f1 to the scroll-lock mode toggle. The scroll-lock package -;; duplicates the scroll-locking feature in CRiSP. - -;; Also, the default keybindings for brief/CRiSP override the M-x -;; key to exit the editor. If you don't like this functionality, you -;; can prevent this behavior (or redefine it dynamically) by setting -;; the value of `crisp-override-meta-x' either in your .emacs or -;; interactively. The default setting is nil, which means that M-x will -;; by default run `execute-extended-command' instead of the command -;; `save-buffers-kill-emacs'. - -;; Finally, if you want to change the string displayed in the modeline -;; when this mode is in effect, override the definition of -;; `crisp-mode-modeline-string' in your .emacs. The default value is -;; " *Crisp*" which may be a bit lengthy if you have a lot of things -;; being displayed there. - -;; All these overrides should go *before* the (require 'crisp) statement. - -;; Code: - -(require 'cl) - -;; local variables - -(defgroup crisp nil - "CRiSP emulator customizable settings." - :group 'emulations) - -(defvar crisp-mode-map (let ((map (make-sparse-keymap))) - (set-keymap-parent map (current-global-map)) - map) - "Local keymap for CRiSP emulation mode. -All the bindings are done here instead of globally to try and be -nice to the world.") - -(defcustom crisp-mode-modeline-string " *CRiSP*" - "*String to display in the modeline when CRiSP emulation mode is enabled." - :type 'string - :group 'crisp) - -(defvar crisp-mode-original-keymap (current-global-map) - "The original keymap before CRiSP emulation mode remaps anything. -This keymap is restored when CRiSP emulation mode is disabled.") - -(defvar crisp-mode-enabled nil - "Track status of CRiSP emulation mode. -A value of nil means CRiSP mode is not enabled. A value of t -indicates CRiSP mode is enabled.") - -(defcustom crisp-override-meta-x t - "*Controls overriding the normal Emacs M-x key binding in the CRiSP emulator. -Normally the CRiSP emulator rebinds M-x to save-buffers-exit-emacs and -provides the usual M-x functionality on the F10 key. If this variable -is non-nil, M-x will exit Emacs." - :type 'boolean - :group 'crisp) - -(defvar crisp-load-scroll-lock nil - "Controls loading of the Scroll Lock in the CRiSP emulator. -Its Default behavior is to load and enable the Scroll Lock minor mode -package when enabling the CRiSP emulator. - -If this variable is nil when you start the CRiSP emulator, it -does not load the scroll-lock package.") - -(defvar crisp-load-hook nil - "Hooks to run after loading the CRiSP emulator package.") - -(defconst crisp-version "1.26" - "The version of the CRiSP emulator.") - -(defconst crisp-mode-help-address "gfoster@suzieq.ragesoft.com, Gary.Foster@corp.Sun.COM" - "The email address of the CRiSP mode author/maintainer.") - -;; Silence the byte-compiler. -(defvar last-last-command) - -;; and now the keymap defines - -(define-key crisp-mode-map [(f1)] 'other-window) - -(define-key crisp-mode-map [(f2) (down)] 'enlarge-window) -(define-key crisp-mode-map [(f2) (left)] 'shrink-window-horizontally) -(define-key crisp-mode-map [(f2) (right)] 'enlarge-window-horizontally) -(define-key crisp-mode-map [(f2) (up)] 'shrink-window) -(define-key crisp-mode-map [(f3) (down)] 'split-window-vertically) -(define-key crisp-mode-map [(f3) (right)] 'split-window-horizontally) - -(define-key crisp-mode-map [(f4)] 'delete-window) -(define-key crisp-mode-map [(control f4)] 'delete-other-windows) - -(define-key crisp-mode-map [(f5)] 'search-forward-regexp) -(define-key crisp-mode-map [(f19)] 'search-forward-regexp) -(define-key crisp-mode-map [(meta f5)] 'search-backward-regexp) - -(define-key crisp-mode-map [(f6)] 'query-replace) - -(define-key crisp-mode-map [(f7)] 'start-kbd-macro) -(define-key crisp-mode-map [(meta f7)] 'end-kbd-macro) - -(define-key crisp-mode-map [(f8)] 'call-last-kbd-macro) -(define-key crisp-mode-map [(meta f8)] 'save-kbd-macro) - -(define-key crisp-mode-map [(f9)] 'find-file) -(define-key crisp-mode-map [(meta f9)] 'load-library) - -(define-key crisp-mode-map [(f10)] 'execute-extended-command) -(define-key crisp-mode-map [(meta f10)] 'compile) - -(define-key crisp-mode-map [(SunF37)] 'kill-buffer) -(define-key crisp-mode-map [(kp-add)] 'crisp-copy-line) -(define-key crisp-mode-map [(kp-subtract)] 'crisp-kill-line) -(define-key crisp-mode-map [(insert)] 'x-yank-clipboard-selection) -(define-key crisp-mode-map [(f16)] 'x-copy-primary-selection) ; copy on Sun5 kbd -(define-key crisp-mode-map [(f20)] 'x-kill-primary-selection) ; cut on Sun5 kbd -(define-key crisp-mode-map [(f18)] 'x-yank-clipboard-selection) ; paste on Sun5 kbd - -(define-key crisp-mode-map [(control f)] 'fill-paragraph-or-region) -(define-key crisp-mode-map [(meta d)] (lambda () - (interactive) - (beginning-of-line) (kill-line))) -(define-key crisp-mode-map [(meta e)] 'find-file) -(define-key crisp-mode-map [(meta g)] 'goto-line) -(define-key crisp-mode-map [(meta h)] 'help) -(define-key crisp-mode-map [(meta i)] 'overwrite-mode) -(define-key crisp-mode-map [(meta j)] 'bookmark-jump) -(define-key crisp-mode-map [(meta l)] 'crisp-mark-line) -(define-key crisp-mode-map [(meta m)] 'set-mark-command) -(define-key crisp-mode-map [(meta n)] 'bury-buffer) -(define-key crisp-mode-map [(meta p)] 'crisp-unbury-buffer) -(define-key crisp-mode-map [(meta u)] 'advertised-undo) -(define-key crisp-mode-map [(f14)] 'advertised-undo) -(define-key crisp-mode-map [(meta w)] 'save-buffer) -(define-key crisp-mode-map [(meta x)] 'crisp-meta-x-wrapper) -(define-key crisp-mode-map [(meta ?0)] (lambda () - (interactive) - (bookmark-set "0"))) -(define-key crisp-mode-map [(meta ?1)] (lambda () - (interactive) - (bookmark-set "1"))) -(define-key crisp-mode-map [(meta ?2)] (lambda () - (interactive) - (bookmark-set "2"))) -(define-key crisp-mode-map [(meta ?3)] (lambda () - (interactive) - (bookmark-set "3"))) -(define-key crisp-mode-map [(meta ?4)] (lambda () - (interactive) - (bookmark-set "4"))) -(define-key crisp-mode-map [(meta ?5)] (lambda () - (interactive) - (bookmark-set "5"))) -(define-key crisp-mode-map [(meta ?6)] (lambda () - (interactive) - (bookmark-set "6"))) -(define-key crisp-mode-map [(meta ?7)] (lambda () - (interactive) - (bookmark-set "7"))) -(define-key crisp-mode-map [(meta ?8)] (lambda () - (interactive) - (bookmark-set "8"))) -(define-key crisp-mode-map [(meta ?9)] (lambda () - (interactive) - (bookmark-set "9"))) - -(define-key crisp-mode-map [(shift right)] 'fkey-forward-word) -(define-key crisp-mode-map [(shift left)] 'fkey-backward-word) -(define-key crisp-mode-map [(shift delete)] 'kill-word) -(define-key crisp-mode-map [(shift backspace)] 'backward-kill-word) -(define-key crisp-mode-map [(control left)] 'backward-word) -(define-key crisp-mode-map [(control right)] 'forward-word) - -(define-key crisp-mode-map [(home)] 'crisp-home) -(define-key crisp-mode-map [(control home)] (lambda () - (interactive) - (move-to-window-line 0))) -(define-key crisp-mode-map [(meta home)] 'beginning-of-line) -(define-key crisp-mode-map [(end)] 'crisp-end) -(define-key crisp-mode-map [(control end)] (lambda () - (interactive) - (move-to-window-line -1))) -(define-key crisp-mode-map [(meta end)] 'end-of-line) - -(define-key crisp-mode-map [(control c) (b)] 'crisp-submit-bug-report) - -(defun crisp-version (&optional arg) - "Version number of the CRiSP emulator package. -If ARG, insert results at point." - (interactive "P") - (let ((foo (concat "CRiSP version " crisp-version))) - (if arg - (insert (message foo)) - (message foo)))) - -(defun crisp-mark-line (arg) - "Put mark at the end of line. Arg works as in `end-of-line'." - (interactive "p") - (mark-something 'crisp-mark-line 'end-of-line arg)) - -(defun crisp-kill-line (arg) - "Mark and kill line(s). -Marks from point to end of the current line (honoring prefix arguments), -copies the region to the kill ring and clipboard, and then deletes it." - (interactive "*p") - (if zmacs-region-active-p - (x-kill-primary-selection) - (crisp-mark-line arg) - (x-kill-primary-selection))) - -(defun crisp-copy-line (arg) - "Mark and copy line(s). -Marks from point to end of the current line (honoring prefix arguments), -copies the region to the kill ring and clipboard, and then deactivates -the region." - (interactive "*p") - (let ((curpos (point))) - (if zmacs-region-active-p - (x-copy-primary-selection) - (crisp-mark-line arg) - (x-copy-primary-selection) - (goto-char curpos)))) - -(defun crisp-home () - "\"Home\" the point, the way CRiSP would do it. -The first use moves point to beginning of the line. Second -consecutive use moves point to beginning of the screen. Third -consecutive use moves point to the beginning of the buffer." - (interactive nil) - (cond - ((and (eq last-command 'crisp-home) (eq last-last-command 'crisp-home)) - (goto-char (point-min))) - ((eq last-command 'crisp-home) - (move-to-window-line 0)) - (t - (beginning-of-line))) - (setq last-last-command last-command)) - -(defun crisp-end () - "\"End\" the point, the way CRiSP would do it. -The first use moves point to end of the line. Second -consecutive use moves point to the end of the screen. Third -consecutive use moves point to the end of the buffer." - (interactive nil) - (cond - ((and (eq last-command 'crisp-end) (eq last-last-command 'crisp-end)) - (goto-char (point-max))) - ((eq last-command 'crisp-end) - (move-to-window-line -1) - (end-of-line)) - (t - (end-of-line))) - (setq last-last-command last-command)) - -(defun crisp-unbury-buffer () - "Go back one buffer" - (interactive) - (switch-to-buffer (car (last (buffer-list))))) - -(defun crisp-meta-x-wrapper () - "Wrapper function to conditionally override the normal M-x bindings. -When `crisp-override-meta-x' is non-nil, M-x will exit Emacs (the -normal CRiSP binding) and when it is nil M-x will run -`execute-extended-command' (the normal Emacs binding)." - (interactive) - (if crisp-override-meta-x - (save-buffers-kill-emacs) - (call-interactively 'execute-extended-command))) - -;; bug reporter - -(defun crisp-submit-bug-report () - "Submit via mail a bug report on CC Mode." - (interactive) - (require 'cc-vars) - ;; load in reporter - (let ((reporter-prompt-for-summary-p t) - (reporter-dont-compact-list '(c-offsets-alist)) - (style c-indentation-style) - (hook c-special-indent-hook) - (c-features c-emacs-features)) - (and - (if (y-or-n-p "Do you want to submit a report on CRiSP Mode? ") - t (message "") nil) - (require 'reporter) - (reporter-submit-bug-report - crisp-mode-help-address - (concat "CRiSP Mode [" crisp-version "]") - nil - nil - nil - "Dear Gary," - )))) - -;; Now enable the mode - -(defun crisp-mode (&optional arg) - "Toggle CRiSP emulation minor mode. -With ARG, turn CRiSP mode on if ARG is positive, off otherwise." - (interactive "P") - (setq crisp-mode-enabled (if (null arg) - (not crisp-mode-enabled) - (> (prefix-numeric-value arg) 0))) - (cond - ((eq crisp-mode-enabled 't) - (use-global-map crisp-mode-map) - (if crisp-load-scroll-lock - (require 'scroll-lock)) - (if (featurep 'scroll-lock) - (define-key crisp-mode-map [(meta f1)] 'scroll-lock-mode)) - (run-hooks 'crisp-load-hook)) - ((eq crisp-mode-enabled 'nil) - (use-global-map crisp-mode-original-keymap)))) - -(if (fboundp 'add-minor-mode) - (add-minor-mode 'crisp-mode-enabled 'crisp-mode-modeline-string - nil nil 'crisp-mode) - (or (assq 'crisp-mode-enabled minor-mode-alist) - (setq minor-mode-alist - (cons '(crisp-mode-enabled crisp-mode-modeline-string) minor-mode-alist)))) - -(provide 'crisp) - -;;; crisp.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/emulators/custom-load.el --- a/lisp/emulators/custom-load.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,9 +0,0 @@ -;;; custom-load.el --- automatically extracted custom dependencies - - -;;; Code: - -(custom-add-loads 'crisp '("crisp")) -(custom-add-loads 'emulations '("crisp")) - -;;; custom-load.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/emulators/edt-lk201.el --- a/lisp/emulators/edt-lk201.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,57 +0,0 @@ -;;; edt-lk201.el --- Enhanced EDT Keypad Mode Emulation for LK-201 Keyboards - -;; Copyright (C) 1986, 1992, 1993, 1995 Free Software Foundation, Inc. - -;; Author: Kevin Gallagher -;; Maintainer: Kevin Gallagher -;; Keywords: emulations - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34 - -;;; Usage: - -;; See edt-user.doc in the Emacs etc directory. - -;; ==================================================================== - -;;;; -;;;; KEY TRANSLATIONS -;;;; - -;; Associate EDT keynames with Emacs terminal function vector names. -;; (Function key vector names for LK-201 are found in lisp/term/lk201.el.) -;; -;; F1 - F5 are not available on many DEC VT series terminals. -;; However, this is not always the case. So support for F1 - F5 is -;; provided here and in lisp/term/lk201.el. -(defconst *EDT-keys* - '(("KP0" . [kp-0]) ("KP1" . [kp-1]) ("KP2" . [kp-2]) ("KP3" . [kp-3]) - ("KP4" . [kp-4]) ("KP5" . [kp-5]) ("KP6" . [kp-6]) ("KP7" . [kp-7]) - ("KP8" . [kp-8]) ("KP9" . [kp-9]) ("KP," . [kp-separator]) - ("KP-" . [kp-subtract]) ("KPP" . [kp-decimal]) ("KPE" . [kp-enter]) - ("PF1" . [kp-f1]) ("PF2" . [kp-f2]) ("PF3" . [kp-f3]) ("PF4" . [kp-f4]) - ("UP" . [up]) ("DOWN" . [down]) ("RIGHT" . [right]) ("LEFT" . [left]) - ("FIND" . [find]) ("INSERT" . [insert]) ("REMOVE" . [delete]) - ("SELECT" . [select]) ("PREVIOUS" . [prior]) ("NEXT" . [next]) - ("F1" . [f1]) ("F2" . [f2]) ("F3" . [f3]) ("F4" . [f4]) ("F5" . [f5]) - ("F6" . [f6]) ("F7" . [f7]) ("F8" . [f8]) ("F9" . [f9]) ("F10" . [f10]) - ("F11" . [f11]) ("F12" . [f12]) ("F13" . [f13]) ("F14" . [f14]) - ("HELP" . [help]) ("DO" . [menu]) ("F17" . [f17]) ("F18" . [f18]) - ("F19" . [f19]) ("F20" . [f20]))) diff -r 43306a74e31c -r d44af0c54775 lisp/emulators/edt-mapper.el --- a/lisp/emulators/edt-mapper.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,407 +0,0 @@ -;;; edt-mapper.el --- Create an EDT LK-201 Map File for X-Windows Emacs - -;; Copyright (C) 1994, 1995 Free Software Foundation, Inc. - -;; Author: Kevin Gallagher -;; Maintainer: Kevin Gallagher -;; Keywords: emulations - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34 - -;;; Commentary: - -;; This emacs lisp program can be used to create an emacs lisp file -;; that defines the mapping of the user's keyboard under X-Windows to -;; the LK-201 keyboard function keys and keypad keys (around which -;; EDT has been designed). Please read the "Usage" AND "Known -;; Problems" sections before attempting to run this program. (The -;; design of this file, edt-mapper.el, was heavily influenced by -;; tpu-mapper.el.) - -;;; Usage: - -;; Simply load this file into the X-Windows version of emacs (version 19) -;; using the following command. - -;; emacs -q -l edt-mapper.el - -;; The "-q" option prevents loading of your .emacs file (commands therein -;; might confuse this program). - -;; An instruction screen showing the typical LK-201 terminal functions keys -;; will be displayed, and you will be prompted to press the keys on your -;; keyboard which you want to emulate the corresponding LK-201 keys. - -;; Finally, you will be prompted for the name of the file to store -;; the key definitions. If you chose the default, it will be found -;; and loaded automatically when the EDT emulation is started. If -;; you specify a different file name, you will need to set the -;; variable "edt-xkeys-file" before starting the EDT emulation. -;; Here's how you might go about doing that in your .emacs file. - -;; (setq edt-xkeys-file (expand-file-name "~/.my-emacs-x-keys")) - -;;; Known Problems: - -;; Sometimes, edt-mapper will ignore a key you press, and just continue to -;; prompt for the same key. This can happen when your window manager sucks -;; up the key and doesn't pass it on to emacs, or it could be an emacs bug. -;; Either way, there's nothing that edt-mapper can do about it. You must -;; press RETURN, to skip the current key and continue. Later, you and/or -;; your local X guru can try to figure out why the key is being ignored. - -;; ==================================================================== - -;;; -;;; Make sure we're running X-windows and Emacs version 19 -;;; -(cond - ((not (and window-system (not (string-lessp emacs-version "19")))) - (insert " - - Whoa! This isn't going to work... - - You must run edt-mapper.el under X-windows and Emacs version 19. - - Press any key to exit. ") - (sit-for 600) - (kill-emacs t))) - - -;;; -;;; Decide whether we're running GNU or Lucid emacs. -;;; -(defconst edt-lucid-emacs19-p (string-match "XEmacs" emacs-version) - "Non-NIL if we are running XEmacs.") - - -;;; -;;; Key variables -;;; -(defvar edt-key nil) -(defvar edt-enter nil) -(defvar edt-return nil) -(defvar edt-key-seq nil) -(defvar edt-enter-seq nil) -(defvar edt-return-seq nil) - - -;;; -;;; Make sure the window is big enough to display the instructions -;;; -(if edt-lucid-emacs19-p (set-screen-size nil 80 36) - (set-frame-size (selected-frame) 80 36)) - - -;;; -;;; Create buffers - Directions and Keys -;;; -(if (not (get-buffer "Directions")) (generate-new-buffer "Directions")) -(if (not (get-buffer "Keys")) (generate-new-buffer "Keys")) - -;;; -;;; Put header in the Keys buffer -;;; -(set-buffer "Keys") -(insert "\ -;; -;; Key definitions for the EDT emulation within GNU Emacs -;; - -(defconst *EDT-keys* - '( -") - -;;; -;;; Display directions -;;; -(switch-to-buffer "Directions") -(insert " - EDT MAPPER - - You will be asked to press keys to create a custom mapping (under - X-Windows) of your keypad keys and function keys so that they can emulate - the LK-201 keypad and function keys or the subset of keys found on a - VT-100 series terminal keyboard. (The LK-201 keyboard is the standard - keyboard attached to VT-200 series terminals, and above.) - - Sometimes, edt-mapper will ignore a key you press, and just continue to - prompt for the same key. This can happen when your window manager sucks - up the key and doesn't pass it on to emacs, or it could be an emacs bug. - Either way, there's nothing that edt-mapper can do about it. You must - press RETURN, to skip the current key and continue. Later, you and/or - your local X guru can try to figure out why the key is being ignored. - - Start by pressing the RETURN key, and continue by pressing the keys - specified in the mini-buffer. If you want to entirely omit a key, - because your keyboard does not have a corresponding key, for example, - just press RETURN at the prompt. - -") -(delete-other-windows) - -;;; -;;; Save for future reference -;;; -(cond - (edt-lucid-emacs19-p - (setq edt-return-seq (read-key-sequence "Hit carriage-return to continue ")) - (setq edt-return (concat "[" (format "%s" (event-key (aref edt-return-seq 0))) "]"))) - (t - (message "Hit carriage-return to continue ") - (setq edt-return-seq (read-event)) - (setq edt-return (concat "[" (format "%s" edt-return-seq) "]")))) - -;;; -;;; Display Keypad Diagram and Begin Prompting for Keys -;;; -(set-buffer "Directions") -(delete-region (point-min) (point-max)) -(insert " - - - - PRESS THE KEY SPECIFIED IN THE MINIBUFFER BELOW. - - - - - Here's a picture of the standard LK-201 keypad for reference: - - _______________________ _______________________________ - | HELP | DO | | F17 | F18 | F19 | F20 | - | | | | | | | | - |_______|_______________| |_______|_______|_______|_______| - _______________________ _______________________________ - | FIND |INSERT |REMOVE | | PF1 | PF2 | PF3 | PF4 | - | | | | | | | | | - |_______|_______|_______| |_______|_______|_______|_______| - |SELECT |PREVIOU| NEXT | | KP7 | KP8 | KP9 | KP- | - | | | | | | | | | - |_______|_______|_______| |_______|_______|_______|_______| - | UP | | KP4 | KP5 | KP6 | KP, | - | | | | | | | - _______|_______|_______ |_______|_______|_______|_______| - | LEFT | DOWN | RIGHT | | KP1 | KP2 | KP3 | | - | | | | | | | | | - |_______|_______|_______| |_______|_______|_______| KPE | - | KP0 | KPP | | - | | | | - |_______________|_______|_______| - -") - -;;; -;;; Key mapping functions -;;; -(defun edt-lucid-map-key (ident descrip) - (interactive) - (setq edt-key-seq (read-key-sequence (format "Press %s%s: " ident descrip))) - (setq edt-key (concat "[" (format "%s" (event-key (aref edt-key-seq 0))) "]")) - (cond ((not (equal edt-key edt-return)) - (set-buffer "Keys") - (insert (format " (\"%s\" . %s)\n" ident edt-key)) - (set-buffer "Directions")) - ;; bogosity to get next prompt to come up, if the user hits ! - ;; check periodically to see if this is still needed... - (t - (format "%s" edt-key))) - edt-key) - -(defun edt-gnu-map-key (ident descrip) - (interactive) - (message "Press %s%s: " ident descrip) - (setq edt-key-seq (read-event)) - (setq edt-key (concat "[" (format "%s" edt-key-seq) "]")) - (cond ((not (equal edt-key edt-return)) - (set-buffer "Keys") - (insert (format " (\"%s\" . %s)\n" ident edt-key)) - (set-buffer "Directions")) - ;; bogosity to get next prompt to come up, if the user hits ! - ;; check periodically to see if this is still needed... - (t - (set-buffer "Keys") - (insert (format " (\"%s\" . \"\" )\n" ident)) - (set-buffer "Directions"))) - edt-key) - -(fset 'edt-map-key (if edt-lucid-emacs19-p 'edt-lucid-map-key 'edt-gnu-map-key)) -(set-buffer "Keys") -(insert " -;; -;; Arrows -;; -") -(set-buffer "Directions") - -(edt-map-key "UP" " - The Up Arrow Key") -(edt-map-key "DOWN" " - The Down Arrow Key") -(edt-map-key "LEFT" " - The Left Arrow Key") -(edt-map-key "RIGHT" " - The Right Arrow Key") - - -(set-buffer "Keys") -(insert " -;; -;; PF keys -;; -") -(set-buffer "Directions") - -(edt-map-key "PF1" " - The PF1 (GOLD) Key") -(edt-map-key "PF2" " - The Keypad PF2 Key") -(edt-map-key "PF3" " - The Keypad PF3 Key") -(edt-map-key "PF4" " - The Keypad PF4 Key") - -(set-buffer "Keys") -(insert " -;; -;; KP0-9 KP- KP, KPP and KPE -;; -") -(set-buffer "Directions") - -(edt-map-key "KP0" " - The Keypad 0 Key") -(edt-map-key "KP1" " - The Keypad 1 Key") -(edt-map-key "KP2" " - The Keypad 2 Key") -(edt-map-key "KP3" " - The Keypad 3 Key") -(edt-map-key "KP4" " - The Keypad 4 Key") -(edt-map-key "KP5" " - The Keypad 5 Key") -(edt-map-key "KP6" " - The Keypad 6 Key") -(edt-map-key "KP7" " - The Keypad 7 Key") -(edt-map-key "KP8" " - The Keypad 8 Key") -(edt-map-key "KP9" " - The Keypad 9 Key") -(edt-map-key "KP-" " - The Keypad - Key") -(edt-map-key "KP," " - The Keypad , Key") -(edt-map-key "KPP" " - The Keypad . Key") -(edt-map-key "KPE" " - The Keypad Enter Key") -;; Save the enter key -(setq edt-enter edt-key) -(setq edt-enter-seq edt-key-seq) - - -(set-buffer "Keys") -(insert " -;; -;; Editing keypad (FIND, INSERT, REMOVE) -;; (SELECT, PREVIOUS, NEXT) -;; -") -(set-buffer "Directions") - -(edt-map-key "FIND" " - The Find key on the editing keypad") -(edt-map-key "INSERT" " - The Insert key on the editing keypad") -(edt-map-key "REMOVE" " - The Remove key on the editing keypad") -(edt-map-key "SELECT" " - The Select key on the editing keypad") -(edt-map-key "PREVIOUS" " - The Prev Scr key on the editing keypad") -(edt-map-key "NEXT" " - The Next Scr key on the editing keypad") - -(set-buffer "Keys") -(insert " -;; -;; F1-14 Help Do F17-F20 -;; -") -(set-buffer "Directions") - -(edt-map-key "F1" " - F1 Function Key") -(edt-map-key "F2" " - F2 Function Key") -(edt-map-key "F3" " - F3 Function Key") -(edt-map-key "F4" " - F4 Function Key") -(edt-map-key "F5" " - F5 Function Key") -(edt-map-key "F6" " - F6 Function Key") -(edt-map-key "F7" " - F7 Function Key") -(edt-map-key "F8" " - F8 Function Key") -(edt-map-key "F9" " - F9 Function Key") -(edt-map-key "F10" " - F10 Function Key") -(edt-map-key "F11" " - F11 Function Key") -(edt-map-key "F12" " - F12 Function Key") -(edt-map-key "F13" " - F13 Function Key") -(edt-map-key "F14" " - F14 Function Key") -(edt-map-key "HELP" " - HELP Function Key") -(edt-map-key "DO" " - DO Function Key") -(edt-map-key "F17" " - F17 Function Key") -(edt-map-key "F18" " - F18 Function Key") -(edt-map-key "F19" " - F19 Function Key") -(edt-map-key "F20" " - F20 Function Key") - -(set-buffer "Directions") -(delete-region (point-min) (point-max)) -(insert " - ADDITIONAL FUNCTION KEYS - - Your keyboard may have additional function keys which do not - correspond to any LK-201 keys. The EDT Emulation can be - configured to recognize those keys, since you may wish to add your - own key bindings to those keys. - - For example, suppose your keyboard has a keycap marked \"Line Del\" - and you wish to add it to the list of keys which can be customized - by the EDT Emulation. First, assign a unique single-word name to - the key for use by the EDT Emulation, let's say \"linedel\", in this - example. Then, at the \"EDT Key Name:\" prompt, enter \"linedel\", - followed by a press of the RETURN key. Finally, when prompted, - press the \"Line Del\" key. You now will be able to bind functions - to \"linedel\" and \"Gold-linedel\" in edt-user.el in just the same way - you can customize bindings of the standard LK-201 keys. - - When you have no additional function keys to specify, just press - RETURN at the \"EDT Key Name:\" prompt. (If you change your mind - AFTER you enter an EDT Key Name and before you press a key at the - \"Press\" prompt, you may omit the key by simply pressing RETURN at - the prompt.) -") -(switch-to-buffer "Directions") -;;; -;;; Add support for extras keys -;;; -(set-buffer "Keys") -(insert "\ -;; -;; Extra Keys -;; -") -(setq EDT-key-name "") -(while (not - (string-equal (setq EDT-key-name (read-string "EDT Key Name: ")) "")) - (edt-map-key EDT-key-name "")) - -; -; No more keys to add, so wrap up. -; -(set-buffer "Keys") -(insert "\ - ) - ) -") - -;;; -;;; Save the key mapping program and blow this pop stand -;;; -(let ((file (if edt-lucid-emacs19-p "~/.edt-lucid-keys" "~/.edt-gnu-keys"))) - (set-visited-file-name - (read-file-name (format "Save key mapping to file (default %s): " file) nil file))) -(save-buffer) - -(message "That's it! Press any key to exit") -(sit-for 600) -(kill-emacs t) - -;;; edt-mapper.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/emulators/edt-pc.el --- a/lisp/emulators/edt-pc.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,87 +0,0 @@ -;;; edt-pc.el --- Enhanced EDT Keypad Mode Emulation for PC 101 Keyboards - -;; Copyright (C) 1986, 1994, 1995 Free Software Foundation, Inc. - -;; Author: Kevin Gallagher -;; Maintainer: Kevin Gallagher -;; Keywords: emulations - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34 - -;;; Usage: - -;; See edt-user.doc in the Emacs etc directory. - -;; ==================================================================== - -;;;; -;;;; KEY TRANSLATIONS -;;;; - -;; Associate EDT keynames with Emacs terminal function vector names. -;; -;; To emulate the DEC LK-201 keypad keys on the PC 101 keyboard, -;; NumLock must be ON. -;; -;; The PC keypad keys are mapped to the corresponding DEC LK-201 -;; keypad keys according to the corresponding physical position on -;; the keyboard. Thus, the physical position of the PC keypad key -;; determines its function, not the PC keycap name. -;; -;; There are two LK-201 keypad keys needing special handling: PF1 and -;; the keypad comma key. -;; -;; PF1: -;; Most PC software does not see a press of the NumLock key. A TSR -;; program distributed with MS-Kermit to support its VT-100 emulation -;; solves this problem. The TSR, called GOLD, causes a press of the -;; keypad NumLock key to look as if the PC F1 key were pressed. So -;; the PC F1 key is mapped here to behave as the PF1 (GOLD) key. -;; Then with GOLD loaded, the NumLock key will behave as the GOLD key. -;; -;; By the way, with GOLD loaded, you can still toggle numlock on/off. -;; GOLD binds this to Shift-NumLock. -;; -;; Keypad Comma: -;; There is no physical PC keypad key to correspond to the LK-201 -;; keypad comma key. So, the EDT Emulation is configured below to -;; ignore attempts to bind functions to the keypad comma key. -;; -;; Finally, F2 through F12 are also available for making key bindings -;; in the EDT Emulation on the PC. F1 is reserved for the GOLD key, -;; so don't attempt to bind anything to it. Also, F13, F14, HELP, DO, -;; and F17 through F20 do not exist on the PC, so the EDT emulation is -;; configured below to ignore attempts to bind functions to those keys. -;; -(defconst *EDT-keys* - '(("KP0" . [kp-0]) ("KP1" . [kp-1]) ("KP2" . [kp-2]) ("KP3" . [kp-3]) - ("KP4" . [kp-4]) ("KP5" . [kp-5]) ("KP6" . [kp-6]) ("KP7" . [kp-7]) - ("KP8" . [kp-8]) ("KP9" . [kp-9]) ("KP," . "" ) - ("KP-" . [kp-add]) ("KPP" . [kp-decimal]) ("KPE" . [kp-enter]) - ("PF1" . [f1]) ("PF2" . [kp-divide]) ("PF3" . [kp-multiply]) - ("PF4" . [kp-subtract]) - ("UP" . [up]) ("DOWN" . [down]) ("RIGHT" . [right]) ("LEFT" . [left]) - ("FIND" . [insert]) ("INSERT" . [home]) ("REMOVE" . [prior]) - ("SELECT" . [delete]) ("PREVIOUS" . [end]) ("NEXT" . [next]) - ("F1" . "" ) ("F2" . [f2]) ("F3" . [f3]) ("F4" . [f4]) ("F5" . [f5]) - ("F6" . [f6]) ("F7" . [f7]) ("F8" . [f8]) ("F9" . [f9]) ("F10" . [f10]) - ("F11" . [f11]) ("F12" . [f12]) ("F13" . "" ) ("F14" . "" ) - ("HELP" . "" ) ("DO" . "" ) ("F17" . "" ) ("F18" . "" ) - ("F19" . "" ) ("F20" . "" ))) diff -r 43306a74e31c -r d44af0c54775 lisp/emulators/edt-vt100.el --- a/lisp/emulators/edt-vt100.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,46 +0,0 @@ -;;; edt-vt100.el --- Enhanced EDT Keypad Mode Emulation for VT Series Terminals - -;; Copyright (C) 1986, 1992, 1993, 1995 Free Software Foundation, Inc. - -;; Author: Kevin Gallagher -;; Maintainer: Kevin Gallagher -;; Keywords: emulations - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34 - -;;; Usage: - -;; See edt-user.doc in the Emacs etc directory. - -;; ==================================================================== - -;; Get keyboard function key mapping to EDT keys. -(load "edt-lk201" nil t) - -;; The following functions are called by the EDT screen width commands defined -;; in edt.el. - -(defun edt-set-term-width-80 () - "Set terminal width to 80 columns." - (vt100-wide-mode -1)) - -(defun edt-set-term-width-132 () - "Set terminal width to 132 columns." - (vt100-wide-mode 1)) diff -r 43306a74e31c -r d44af0c54775 lisp/emulators/edt.el --- a/lisp/emulators/edt.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2026 +0,0 @@ -;;; edt.el --- Enhanced EDT Keypad Mode Emulation for GNU Emacs 19 - -;; Copyright (C) 1986, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. - -;; Author: Kevin Gallagher -;; Maintainer: Kevin Gallagher -;; Keywords: emulations - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34 - -;;; Usage: - -;; See edt-user.doc in the Emacs etc directory. - -;; Maintainer's note: There was a very old edt.el here that wouldn't even -;; load, so I replaced it completely with the newer one from 19.34. -sb -;; ==================================================================== - -;;; Electric Help functions are used for keypad help displays. A few -;;; picture functions are used in rectangular cut and paste commands. -(require 'ehelp) -(require 'picture) - -;;;; -;;;; VARIABLES and CONSTANTS -;;;; - -(defvar edt-last-deleted-lines "" - "Last text deleted by an EDT emulation line delete command.") - -(defvar edt-last-deleted-words "" - "Last text deleted by an EDT emulation word delete command.") - -(defvar edt-last-deleted-chars "" - "Last text deleted by an EDT emulation character delete command.") - -(defvar edt-last-replaced-key-definition "" - "Key definition replaced with edt-define-key or edt-learn command.") - -(defvar edt-direction-string "" - "String indicating current direction of movement.") - -(defvar edt-select-mode nil - "Non-nil means select mode is active.") - -(defvar edt-select-mode-text "" - "Text displayed in mode line when select mode is active.") - -(defconst edt-select-mode-string " Select" - "String to indicate select mode is active.") - -(defconst edt-forward-string " ADVANCE" - "Direction string in mode line to indicate forward movement.") - -(defconst edt-backward-string " BACKUP" - "Direction string in mode line to indicate backward movement.") - -(defvar edt-default-map-active nil - "Non-nil indicates that default EDT emulation key bindings are active. -Nil means user-defined custom bindings are active.") - -(defvar edt-user-map-configured nil - "Non-nil indicates that user custom EDT key bindings are configured. -This means that an edt-user.el file was found in the user's load-path.") - -(defvar edt-keep-current-page-delimiter nil - "Non-nil leaves current value of page-delimiter unchanged. -Nil causes the page-delimiter variable to be set to to \"\\f\" -when edt-emulation-on is first invoked. Original value is restored -when edt-emulation-off is called.") - -(defvar edt-use-EDT-control-key-bindings nil - "Non-nil causes the control key bindings to be replaced with EDT bindings. -Nil (the default) means EDT control key bindings are not used and the current -control key bindings are retained for use in the EDT emulation.") - -(defvar edt-word-entities '(?\t) - "*Specifies the list of EDT word entity characters.") - -;;; -;;; Emacs version identifiers - currently referenced by -;;; -;;; o edt-emulation-on o edt-load-xkeys -;;; -(defconst edt-emacs19-p (not (string-lessp emacs-version "19")) - "Non-nil if we are running Lucid or GNU Emacs version 19.") - -(defconst edt-lucid-emacs19-p - (and edt-emacs19-p (string-match "Lucid" emacs-version)) - "Non-nil if we are running Lucid Emacs version 19.") - -(defconst edt-gnu-emacs19-p (and edt-emacs19-p (not edt-lucid-emacs19-p)) - "Non-nil if we are running GNU Emacs version 19.") - -(defvar edt-xkeys-file nil - "File mapping X function keys to LK-201 keyboard function and keypad keys.") - -;;;; -;;;; EDT Emulation Commands -;;;; - -;;; Almost all of EDT's keypad mode commands have equivalent -;;; counterparts in Emacs. Some behave the same way in Emacs as they -;;; do in EDT, but most do not. -;;; -;;; The following Emacs functions emulate, where practical, the exact -;;; behavior of the corresponding EDT keypad mode commands. In a few -;;; cases, the emulation is not exact, but it is close enough for most -;;; EDT die-hards. -;;; -;;; In a very few cases, we chose to use the superior Emacs way of -;;; handling things. For example, we do not emulate the EDT SUBS -;;; command. Instead, we chose to use the superior Emacs -;;; query-replace function. -;;; - -;;; -;;; PAGE -;;; -;;; Emacs uses the regexp assigned to page-delimiter to determine what -;;; marks a page break. This is normally "^\f", which causes the -;;; edt-page command to ignore form feeds not located at the beginning -;;; of a line. To emulate the EDT PAGE command exactly, -;;; page-delimiter is set to "\f" when EDT emulation is turned on, and -;;; restored to its original value when EDT emulation is turned off. -;;; But this can be overridden if the EDT definition is not desired by -;;; placing -;;; -;;; (setq edt-keep-current-page-delimiter t) -;;; -;;; in your .emacs file. - -(defun edt-page-forward (num) - "Move forward to just after next page delimiter. -Accepts a positive prefix argument for the number of page delimiters to move." - (interactive "p") - (edt-check-prefix num) - (if (eobp) - (error "End of buffer") - (progn - (forward-page num) - (if (eobp) - (edt-line-to-bottom-of-window) - (edt-line-to-top-of-window))))) - -(defun edt-page-backward (num) - "Move backward to just after previous page delimiter. -Accepts a positive prefix argument for the number of page delimiters to move." - (interactive "p") - (edt-check-prefix num) - (if (bobp) - (error "Beginning of buffer") - (progn - (backward-page num) - (edt-line-to-top-of-window)))) - -(defun edt-page (num) - "Move in current direction to next page delimiter. -Accepts a positive prefix argument for the number of page delimiters to move." - (interactive "p") - (if (equal edt-direction-string edt-forward-string) - (edt-page-forward num) - (edt-page-backward num))) - -;;; -;;; SECT -;;; -;;; EDT defaults a section size to be 16 lines of its one and only -;;; 24-line window. That's two-thirds of the window at a time. The -;;; EDT SECT commands moves the cursor, not the window. -;;; -;;; This emulation of EDT's SECT moves the cursor approximately two-thirds -;;; of the current window at a time. - -(defun edt-sect-forward (num) - "Move cursor forward two-thirds of a window. -Accepts a positive prefix argument for the number of sections to move." - (interactive "p") - (edt-check-prefix num) - (edt-line-forward (* (* (/ (- (window-height) 1) 3) 2) num))) - -(defun edt-sect-backward (num) - "Move cursor backward two-thirds of a window. -Accepts a positive prefix argument for the number of sections to move." - (interactive "p") - (edt-check-prefix num) - (edt-line-backward (* (* (/ (- (window-height) 1) 3) 2) num))) - -(defun edt-sect (num) - "Move in current direction a full window. -Accepts a positive prefix argument for the number windows to move." - (interactive "p") - (if (equal edt-direction-string edt-forward-string) - (edt-sect-forward num) - (edt-sect-backward num))) - -;;; -;;; BEGINNING OF LINE -;;; -;;; EDT's beginning-of-line command is not affected by current -;;; direction, for some unknown reason. - -(defun edt-beginning-of-line (num) - "Move backward to next beginning of line mark. -Accepts a positive prefix argument for the number of BOL marks to move." - (interactive "p") - (edt-check-prefix num) - (if (bolp) - (forward-line (* -1 num)) - (progn - (setq num (1- num)) - (forward-line (* -1 num))))) - -;;; -;;; EOL (End of Line) -;;; - -(defun edt-end-of-line-forward (num) - "Move forward to next end of line mark. -Accepts a positive prefix argument for the number of EOL marks to move." - (interactive "p") - (edt-check-prefix num) - (forward-char) - (end-of-line num)) - -(defun edt-end-of-line-backward (num) - "Move backward to next end of line mark. -Accepts a positive prefix argument for the number of EOL marks to move." - (interactive "p") - (edt-check-prefix num) - (end-of-line (1- num))) - -(defun edt-end-of-line (num) - "Move in current direction to next end of line mark. -Accepts a positive prefix argument for the number of EOL marks to move." - (interactive "p") - (if (equal edt-direction-string edt-forward-string) - (edt-end-of-line-forward num) - (edt-end-of-line-backward num))) - -;;; -;;; WORD -;;; -;;; This one is a tad messy. To emulate EDT's behavior everywhere in -;;; the file (beginning of file, end of file, beginning of line, end -;;; of line, etc.) it takes a bit of special handling. -;;; -;;; The variable edt-word-entities contains a list of characters which -;;; are to be viewed as distinct words where ever they appear in the -;;; buffer. This emulates the EDT line mode command SET ENTITY WORD. - - -(defun edt-one-word-forward () - "Move forward to first character of next word." - (interactive) - (if (eobp) - (error "End of buffer")) - (if (eolp) - (forward-char) - (progn - (if (memq (following-char) edt-word-entities) - (forward-char) - (while (and - (not (eolp)) - (not (eobp)) - (not (eq ?\ (char-syntax (following-char)))) - (not (memq (following-char) edt-word-entities))) - (forward-char))) - (while (and - (not (eolp)) - (not (eobp)) - (eq ?\ (char-syntax (following-char))) - (not (memq (following-char) edt-word-entities))) - (forward-char))))) - -(defun edt-one-word-backward () - "Move backward to first character of previous word." - (interactive) - (if (bobp) - (error "Beginning of buffer")) - (if (bolp) - (backward-char) - (progn - (backward-char) - (while (and - (not (bolp)) - (not (bobp)) - (eq ?\ (char-syntax (following-char))) - (not (memq (following-char) edt-word-entities))) - (backward-char)) - (if (not (memq (following-char) edt-word-entities)) - (while (and - (not (bolp)) - (not (bobp)) - (not (eq ?\ (char-syntax (preceding-char)))) - (not (memq (preceding-char) edt-word-entities))) - (backward-char)))))) - -(defun edt-word-forward (num) - "Move forward to first character of next word. -Accepts a positive prefix argument for the number of words to move." - (interactive "p") - (edt-check-prefix num) - (while (> num 0) - (edt-one-word-forward) - (setq num (1- num)))) - -(defun edt-word-backward (num) - "Move backward to first character of previous word. -Accepts a positive prefix argument for the number of words to move." - (interactive "p") - (edt-check-prefix num) - (while (> num 0) - (edt-one-word-backward) - (setq num (1- num)))) - -(defun edt-word (num) - "Move in current direction to first character of next word. -Accepts a positive prefix argument for the number of words to move." - (interactive "p") - (if (equal edt-direction-string edt-forward-string) - (edt-word-forward num) - (edt-word-backward num))) - -;;; -;;; CHAR -;;; - -(defun edt-character (num) - "Move in current direction to next character. -Accepts a positive prefix argument for the number of characters to move." - (interactive "p") - (edt-check-prefix num) - (if (equal edt-direction-string edt-forward-string) - (forward-char num) - (backward-char num))) - -;;; -;;; LINE -;;; -;;; When direction is set to BACKUP, LINE behaves just like BEGINNING -;;; OF LINE in EDT. So edt-line-backward is not really needed as a -;;; separate function. - -(defun edt-line-backward (num) - "Move backward to next beginning of line mark. -Accepts a positive prefix argument for the number of BOL marks to move." - (interactive "p") - (edt-beginning-of-line num)) - -(defun edt-line-forward (num) - "Move forward to next beginning of line mark. -Accepts a positive prefix argument for the number of BOL marks to move." - (interactive "p") - (edt-check-prefix num) - (forward-line num)) - -(defun edt-line (num) - "Move in current direction to next beginning of line mark. -Accepts a positive prefix argument for the number of BOL marks to move." - (interactive "p") - (if (equal edt-direction-string edt-forward-string) - (edt-line-forward num) - (edt-line-backward num))) - -;;; -;;; TOP -;;; - -(defun edt-top () - "Move cursor to the beginning of buffer." - (interactive) - (goto-char (point-min))) - -;;; -;;; BOTTOM -;;; - -(defun edt-bottom () - "Move cursor to the end of buffer." - (interactive) - (goto-char (point-max)) - (edt-line-to-bottom-of-window)) - -;;; -;;; FIND -;;; - -(defun edt-find-forward (&optional find) - "Find first occurrence of a string in forward direction and save it." - (interactive) - (if (not find) - (set 'search-last-string (read-string "Search forward: "))) - (if (search-forward search-last-string) - (search-backward search-last-string))) - -(defun edt-find-backward (&optional find) - "Find first occurrence of a string in the backward direction and save it." - (interactive) - (if (not find) - (set 'search-last-string (read-string "Search backward: "))) - (search-backward search-last-string)) - -(defun edt-find () - "Find first occurrence of string in current direction and save it." - (interactive) - (set 'search-last-string (read-string "Search: ")) - (if (equal edt-direction-string edt-forward-string) - (edt-find-forward t) - (edt-find-backward t))) - - -;;; -;;; FNDNXT -;;; - -(defun edt-find-next-forward () - "Find next occurrence of a string in forward direction." - (interactive) - (forward-char 1) - (if (search-forward search-last-string nil t) - (search-backward search-last-string) - (progn - (backward-char 1) - (error "Search failed: \"%s\"." search-last-string)))) - -(defun edt-find-next-backward () - "Find next occurrence of a string in backward direction." - (interactive) - (if (eq (search-backward search-last-string nil t) nil) - (progn - (error "Search failed: \"%s\"." search-last-string)))) - -(defun edt-find-next () - "Find next occurrence of a string in current direction." - (interactive) - (if (equal edt-direction-string edt-forward-string) - (edt-find-next-forward) - (edt-find-next-backward))) - -;;; -;;; APPEND -;;; - -(defun edt-append () - "Append this kill region to last killed region." - (interactive "*") - (edt-check-selection) - (append-next-kill) - (kill-region (mark) (point)) - (message "Selected text APPENDED to kill ring")) - -;;; -;;; DEL L -;;; - -(defun edt-delete-line (num) - "Delete from cursor up to and including the end of line mark. -Accepts a positive prefix argument for the number of lines to delete." - (interactive "*p") - (edt-check-prefix num) - (let ((beg (point))) - (forward-line num) - (if (not (eq (preceding-char) ?\n)) - (insert "\n")) - (setq edt-last-deleted-lines - (buffer-substring beg (point))) - (delete-region beg (point)))) - -;;; -;;; DEL EOL -;;; - -(defun edt-delete-to-end-of-line (num) - "Delete from cursor up to but excluding the end of line mark. -Accepts a positive prefix argument for the number of lines to delete." - (interactive "*p") - (edt-check-prefix num) - (let ((beg (point))) - (forward-char 1) - (end-of-line num) - (setq edt-last-deleted-lines - (buffer-substring beg (point))) - (delete-region beg (point)))) - -;;; -;;; SELECT -;;; - -(defun edt-select-mode (arg) - "Turn EDT select mode off if ARG is nil; otherwise, turn EDT select mode on. -In select mode, selected text is highlighted." - (if arg - (progn - (make-local-variable 'edt-select-mode) - (setq edt-select-mode 'edt-select-mode-text) - (setq rect-start-point (window-point))) - (progn - (kill-local-variable 'edt-select-mode))) - (force-mode-line-update)) - -(defun edt-select () - "Set mark at cursor and start text selection." - (interactive) - (set-mark-command nil)) - -(defun edt-reset () - "Cancel text selection." - (interactive) - (deactivate-mark)) - -;;; -;;; CUT -;;; - -(defun edt-cut () - "Deletes selected text but copies to kill ring." - (interactive "*") - (edt-check-selection) - (kill-region (mark) (point)) - (message "Selected text CUT to kill ring")) - -;;; -;;; DELETE TO BEGINNING OF LINE -;;; - -(defun edt-delete-to-beginning-of-line (num) - "Delete from cursor to beginning of line. -Accepts a positive prefix argument for the number of lines to delete." - (interactive "*p") - (edt-check-prefix num) - (let ((beg (point))) - (edt-beginning-of-line num) - (setq edt-last-deleted-lines - (buffer-substring (point) beg)) - (delete-region beg (point)))) - -;;; -;;; DEL W -;;; - -(defun edt-delete-word (num) - "Delete from cursor up to but excluding first character of next word. -Accepts a positive prefix argument for the number of words to delete." - (interactive "*p") - (edt-check-prefix num) - (let ((beg (point))) - (edt-word-forward num) - (setq edt-last-deleted-words (buffer-substring beg (point))) - (delete-region beg (point)))) - -;;; -;;; DELETE TO BEGINNING OF WORD -;;; - -(defun edt-delete-to-beginning-of-word (num) - "Delete from cursor to beginning of word. -Accepts a positive prefix argument for the number of words to delete." - (interactive "*p") - (edt-check-prefix num) - (let ((beg (point))) - (edt-word-backward num) - (setq edt-last-deleted-words (buffer-substring (point) beg)) - (delete-region beg (point)))) - -;;; -;;; DEL C -;;; - -(defun edt-delete-character (num) - "Delete character under cursor. -Accepts a positive prefix argument for the number of characters to delete." - (interactive "*p") - (edt-check-prefix num) - (setq edt-last-deleted-chars - (buffer-substring (point) (min (point-max) (+ (point) num)))) - (delete-region (point) (min (point-max) (+ (point) num)))) - -;;; -;;; DELETE CHAR -;;; - -(defun edt-delete-previous-character (num) - "Delete character in front of cursor. -Accepts a positive prefix argument for the number of characters to delete." - (interactive "*p") - (edt-check-prefix num) - (setq edt-last-deleted-chars - (buffer-substring (max (point-min) (- (point) num)) (point))) - (delete-region (max (point-min) (- (point) num)) (point))) - -;;; -;;; UND L -;;; - -(defun edt-undelete-line () - "Undelete previous deleted line(s)." - (interactive "*") - (point-to-register 1) - (insert edt-last-deleted-lines) - (register-to-point 1)) - -;;; -;;; UND W -;;; - -(defun edt-undelete-word () - "Undelete previous deleted word(s)." - (interactive "*") - (point-to-register 1) - (insert edt-last-deleted-words) - (register-to-point 1)) - -;;; -;;; UND C -;;; - -(defun edt-undelete-character () - "Undelete previous deleted character(s)." - (interactive "*") - (point-to-register 1) - (insert edt-last-deleted-chars) - (register-to-point 1)) - -;;; -;;; REPLACE -;;; - -(defun edt-replace () - "Replace marked section with last CUT (killed) text." - (interactive "*") - (exchange-point-and-mark) - (let ((beg (point))) - (exchange-point-and-mark) - (delete-region beg (point))) - (yank)) - -;;; -;;; ADVANCE -;;; - -(defun edt-advance () - "Set movement direction forward. -Also, execute command specified if in Minibuffer." - (interactive) - (setq edt-direction-string edt-forward-string) - (force-mode-line-update) - (if (string-equal " *Minibuf" - (substring (buffer-name) 0 (min (length (buffer-name)) 9))) - (exit-minibuffer))) - -;;; -;;; BACKUP -;;; - -(defun edt-backup () - "Set movement direction backward. -Also, execute command specified if in Minibuffer." - (interactive) - (setq edt-direction-string edt-backward-string) - (force-mode-line-update) - (if (string-equal " *Minibuf" - (substring (buffer-name) 0 (min (length (buffer-name)) 9))) - (exit-minibuffer))) - -;;; -;;; CHNGCASE -;;; -;; This function is based upon Jeff Kowalski's case-flip function in his -;; tpu.el. - -(defun edt-change-case (num) - "Change the case of specified characters. -If text selection IS active, then characters between the cursor and mark are -changed. If text selection is NOT active, there are two cases. First, if the -current direction is ADVANCE, then the prefix number of character(s) under and -following cursor are changed. Second, if the current direction is BACKUP, then -the prefix number of character(s) before the cursor are changed. Accepts a -positive prefix for the number of characters to change, but the prefix is -ignored if text selection is active." - (interactive "*p") - (edt-check-prefix num) - (if edt-select-mode - (let ((end (max (mark) (point))) - (point-save (point))) - (goto-char (min (point) (mark))) - (while (not (eq (point) end)) - (funcall (if (<= ?a (following-char)) - 'upcase-region 'downcase-region) - (point) (1+ (point))) - (forward-char 1)) - (goto-char point-save)) - (progn - (if (string= edt-direction-string edt-backward-string) - (backward-char num)) - (while (> num 0) - (funcall (if (<= ?a (following-char)) - 'upcase-region 'downcase-region) - (point) (1+ (point))) - (forward-char 1) - (setq num (1- num)))))) - -;;; -;;; DEFINE KEY -;;; - -(defun edt-define-key () - "Assign an interactively-callable function to a specified key sequence. -The current key definition is saved in edt-last-replaced-key-definition. -Use edt-restore-key to restore last replaced key definition." - (interactive) - (let (edt-function - edt-key-definition-string) - (setq edt-key-definition-string - (read-key-sequence "Press the key to be defined: ")) - (if (string-equal "\C-m" edt-key-definition-string) - (message "Key not defined") - (progn - (setq edt-function (read-command "Enter command name: ")) - (if (string-equal "" edt-function) - (message "Key not defined") - (progn - (setq edt-last-replaced-key-definition - (lookup-key (current-global-map) edt-key-definition-string)) - (define-key (current-global-map) - edt-key-definition-string edt-function))))))) - -;;; -;;; FORM FEED INSERT -;;; - -(defun edt-form-feed-insert (num) - "Insert form feed character at cursor position. -Accepts a positive prefix argument for the number of form feeds to insert." - (interactive "*p") - (edt-check-prefix num) - (while (> num 0) - (insert ?\f) - (setq num (1- num)))) - -;;; -;;; TAB INSERT -;;; - -(defun edt-tab-insert (num) - "Insert tab character at cursor position. -Accepts a positive prefix argument for the number of tabs to insert." - (interactive "*p") - (edt-check-prefix num) - (while (> num 0) - (insert ?\t) - (setq num (1- num)))) - -;;; -;;; Check Prefix -;;; - -(defun edt-check-prefix (num) - "Indicate error if prefix is not positive." - (if (<= num 0) - (error "Prefix must be positive"))) - -;;; -;;; Check Selection -;;; - -(defun edt-check-selection () - "Indicate error if EDT selection is not active." - (if (not edt-select-mode) - (error "Selection NOT active"))) - -;;;; -;;;; ENHANCEMENTS AND ADDITIONS FOR EDT KEYPAD MODE -;;;; - -;;; -;;; Several enhancements and additions to EDT keypad mode commands are -;;; provided here. Some of these have been motivated by similar -;;; TPU/EVE and EVE-Plus commands. Others are new. - -;;; -;;; CHANGE DIRECTION -;;; - -(defun edt-change-direction () - "Toggle movement direction." - (interactive) - (if (equal edt-direction-string edt-forward-string) - (edt-backup) - (edt-advance))) - -;;; -;;; TOGGLE SELECT -;;; - -(defun edt-toggle-select () - "Toggle to start (or cancel) text selection." - (interactive) - (if edt-select-mode - (edt-reset) - (edt-select))) - -;;; -;;; SENTENCE -;;; - -(defun edt-sentence-forward (num) - "Move forward to start of next sentence. -Accepts a positive prefix argument for the number of sentences to move." - (interactive "p") - (edt-check-prefix num) - (if (eobp) - (progn - (error "End of buffer")) - (progn - (forward-sentence num) - (edt-one-word-forward)))) - -(defun edt-sentence-backward (num) - "Move backward to next sentence beginning. -Accepts a positive prefix argument for the number of sentences to move." - (interactive "p") - (edt-check-prefix num) - (if (eobp) - (progn - (error "End of buffer")) - (backward-sentence num))) - -(defun edt-sentence (num) - "Move in current direction to next sentence. -Accepts a positive prefix argument for the number of sentences to move." - (interactive "p") - (if (equal edt-direction-string edt-forward-string) - (edt-sentence-forward num) - (edt-sentence-backward num))) - -;;; -;;; PARAGRAPH -;;; - -(defun edt-paragraph-forward (num) - "Move forward to beginning of paragraph. -Accepts a positive prefix argument for the number of paragraphs to move." - (interactive "p") - (edt-check-prefix num) - (while (> num 0) - (next-line 1) - (forward-paragraph) - (previous-line 1) - (if (eolp) - (next-line 1)) - (setq num (1- num)))) - -(defun edt-paragraph-backward (num) - "Move backward to beginning of paragraph. -Accepts a positive prefix argument for the number of paragraphs to move." - (interactive "p") - (edt-check-prefix num) - (while (> num 0) - (backward-paragraph) - (previous-line 1) - (if (eolp) (next-line 1)) - (setq num (1- num)))) - -(defun edt-paragraph (num) - "Move in current direction to next paragraph. -Accepts a positive prefix argument for the number of paragraph to move." - (interactive "p") - (if (equal edt-direction-string edt-forward-string) - (edt-paragraph-forward num) - (edt-paragraph-backward num))) - -;;; -;;; RESTORE KEY -;;; - -(defun edt-restore-key () - "Restore last replaced key definition. -Definition is stored in edt-last-replaced-key-definition." - (interactive) - (if edt-last-replaced-key-definition - (progn - (let (edt-key-definition-string) - (set 'edt-key-definition-string - (read-key-sequence "Press the key to be restored: ")) - (if (string-equal "\C-m" edt-key-definition-string) - (message "Key not restored") - (define-key (current-global-map) - edt-key-definition-string edt-last-replaced-key-definition)))) - (error "No replaced key definition to restore!"))) - -;;; -;;; WINDOW TOP -;;; - -(defun edt-window-top () - "Move the cursor to the top of the window." - (interactive) - (let ((start-column (current-column))) - (move-to-window-line 0) - (move-to-column start-column))) - -;;; -;;; WINDOW BOTTOM -;;; - -(defun edt-window-bottom () - "Move the cursor to the bottom of the window." - (interactive) - (let ((start-column (current-column))) - (move-to-window-line (- (window-height) 2)) - (move-to-column start-column))) - -;;; -;;; SCROLL WINDOW LINE -;;; - -(defun edt-scroll-window-forward-line () - "Move window forward one line leaving cursor at position in window." - (interactive) - (scroll-up 1)) - -(defun edt-scroll-window-backward-line () - "Move window backward one line leaving cursor at position in window." - (interactive) - (scroll-down 1)) - -(defun edt-scroll-line () - "Move window one line in current direction." - (interactive) - (if (equal edt-direction-string edt-forward-string) - (edt-scroll-window-forward-line) - (edt-scroll-window-backward-line))) - -;;; -;;; SCROLL WINDOW -;;; -;;; Scroll a window (less one line) at a time. Leave cursor in center of -;;; window. - -(defun edt-scroll-window-forward (num) - "Scroll forward one window in buffer, less one line. -Accepts a positive prefix argument for the number of windows to move." - (interactive "p") - (edt-check-prefix num) - (scroll-up (- (* (window-height) num) 2)) - (edt-line-forward (/ (- (window-height) 1) 2))) - -(defun edt-scroll-window-backward (num) - "Scroll backward one window in buffer, less one line. -Accepts a positive prefix argument for the number of windows to move." - (interactive "p") - (edt-check-prefix num) - (scroll-down (- (* (window-height) num) 2)) - (edt-line-backward (/ (- (window-height) 1) 2))) - -(defun edt-scroll-window (num) - "Scroll one window in buffer, less one line, in current direction. -Accepts a positive prefix argument for the number windows to move." - (interactive "p") - (if (equal edt-direction-string edt-forward-string) - (edt-scroll-window-forward num) - (edt-scroll-window-backward num))) - -;;; -;;; LINE TO BOTTOM OF WINDOW -;;; - -(defun edt-line-to-bottom-of-window () - "Move the current line to the bottom of the window." - (interactive) - (recenter -1)) - -;;; -;;; LINE TO TOP OF WINDOW -;;; - -(defun edt-line-to-top-of-window () - "Move the current line to the top of the window." - (interactive) - (recenter 0)) - -;;; -;;; LINE TO MIDDLE OF WINDOW -;;; - -(defun edt-line-to-middle-of-window () - "Move window so line with cursor is in the middle of the window." - (interactive) - (recenter '(4))) - -;;; -;;; GOTO PERCENTAGE -;;; - -(defun edt-goto-percentage (num) - "Move to specified percentage in buffer from top of buffer." - (interactive "NGoto-percentage: ") - (if (or (> num 100) (< num 0)) - (error "Percentage %d out of range 0 < percent < 100" num) - (goto-char (/ (* (point-max) num) 100)))) - -;;; -;;; FILL REGION -;;; - -(defun edt-fill-region () - "Fill selected text." - (interactive "*") - (edt-check-selection) - (fill-region (point) (mark))) - -;;; -;;; INDENT OR FILL REGION -;;; - -(defun edt-indent-or-fill-region () - "Fill region in text modes, indent region in programming language modes." - (interactive "*") - (if (string= paragraph-start "$\\|\f") - (indent-region (point) (mark) nil) - (fill-region (point) (mark)))) - -;;; -;;; MARK SECTION WISELY -;;; - -(defun edt-mark-section-wisely () - "Mark the section in a manner consistent with the major-mode. -Uses mark-defun for emacs-lisp and lisp, -mark-c-function for C, -mark-fortran-subsystem for fortran, -and mark-paragraph for other modes." - (interactive) - (if edt-select-mode - (progn - (edt-reset)) - (progn - (cond ((or (eq major-mode 'emacs-lisp-mode) - (eq major-mode 'lisp-mode)) - (mark-defun) - (message "Lisp defun selected")) - ((eq major-mode 'c-mode) - (mark-c-function) - (message "C function selected")) - ((eq major-mode 'fortran-mode) - (mark-fortran-subprogram) - (message "Fortran subprogram selected")) - (t (mark-paragraph) - (message "Paragraph selected")))))) - -;;; -;;; COPY -;;; - -(defun edt-copy () - "Copy selected region to kill ring, but don't delete it!" - (interactive) - (edt-check-selection) - (copy-region-as-kill (mark) (point)) - (edt-reset) - (message "Selected text COPIED to kill ring")) - -;;; -;;; CUT or COPY -;;; - -(defun edt-cut-or-copy () - "Cuts (or copies) selected text to kill ring. -Cuts selected text if buffer-read-only is nil. -Copies selected text if buffer-read-only is t." - (interactive) - (if buffer-read-only - (edt-copy) - (edt-cut))) - -;;; -;;; DELETE ENTIRE LINE -;;; - -(defun edt-delete-entire-line () - "Delete entire line regardless of cursor position in the line." - (interactive "*") - (beginning-of-line) - (edt-delete-line 1)) - -;;; -;;; DUPLICATE LINE -;;; - -(defun edt-duplicate-line (num) - "Duplicate a line of text. -Accepts a positive prefix argument for the number times to duplicate the line." - (interactive "*p") - (edt-check-prefix num) - (let ((old-column (current-column)) - (count num)) - (edt-delete-entire-line) - (edt-undelete-line) - (while (> count 0) - (edt-undelete-line) - (setq count (1- count))) - (edt-line-forward num) - (move-to-column old-column))) - -;;; -;;; DUPLICATE WORD -;;; - -(defun edt-duplicate-word() - "Duplicate word (or rest of word) found directly above cursor, if any." - (interactive "*") - (let ((start (point)) - (start-column (current-column))) - (forward-line -1) - (move-to-column start-column) - (if (and (not (equal start (point))) - (not (eolp))) - (progn - (if (and (equal ?\t (preceding-char)) - (< start-column (current-column))) - (backward-char)) - (let ((beg (point))) - (edt-one-word-forward) - (setq edt-last-copied-word (buffer-substring beg (point)))) - (forward-line) - (move-to-column start-column) - (insert edt-last-copied-word)) - (progn - (if (not (equal start (point))) - (forward-line)) - (move-to-column start-column) - (error "Nothing to duplicate!"))))) - -;;; -;;; KEY NOT ASSIGNED -;;; - -(defun edt-key-not-assigned () - "Displays message that key has not been assigned to a function." - (interactive) - (error "Key not assigned")) - -;;; -;;; TOGGLE CAPITALIZATION OF WORD -;;; - -(defun edt-toggle-capitalization-of-word () - "Toggle the capitalization of the current word and move forward to next." - (interactive "*") - (edt-one-word-forward) - (edt-one-word-backward) - (edt-change-case 1) - (edt-one-word-backward) - (edt-one-word-forward)) - -;;; -;;; ELIMINATE ALL TABS -;;; - -(defun edt-eliminate-all-tabs () - "Convert all tabs to spaces in the entire buffer." - (interactive "*") - (untabify (point-min) (point-max)) - (message "TABS converted to SPACES")) - -;;; -;;; DISPLAY THE TIME -;;; - -(defun edt-display-the-time () - "Display the current time." - (interactive) - (set 'time-string (current-time-string)) - (message "%s" time-string)) - -;;; -;;; LEARN -;;; - -(defun edt-learn () - "Learn a sequence of key strokes to bind to a key." - (interactive) - (if (eq defining-kbd-macro t) - (edt-remember) - (start-kbd-macro nil))) - -;;; -;;; REMEMBER -;;; - -(defun edt-remember () - "Store the sequence of key strokes started by edt-learn to a key." - (interactive) - (if (eq defining-kbd-macro nil) - (error "Nothing to remember!") - (progn - (end-kbd-macro nil) - (let (edt-key-definition-string) - (set 'edt-key-definition-string - (read-key-sequence "Enter key for binding: ")) - (if (string-equal "\C-m" edt-key-definition-string) - (message "Key sequence not remembered") - (progn - (set 'edt-learn-macro-count (+ edt-learn-macro-count 1)) - (setq edt-last-replaced-key-definition - (lookup-key (current-global-map) - edt-key-definition-string)) - (define-key (current-global-map) edt-key-definition-string - (name-last-kbd-macro - (intern (concat "last-learned-sequence-" - (int-to-string edt-learn-macro-count))))))))))) - -;;; -;;; EXIT -;;; - -(defun edt-exit () - "Save current buffer, ask to save other buffers, and then exit Emacs." - (interactive) - (save-buffer) - (save-buffers-kill-emacs)) - -;;; -;;; QUIT -;;; - -(defun edt-quit () - "Quit Emacs without saving changes." - (interactive) - (kill-emacs)) - -;;; -;;; SPLIT WINDOW -;;; - -(defun edt-split-window () - "Split current window and place cursor in the new window." - (interactive) - (split-window) - (other-window 1)) - -;;; -;;; COPY RECTANGLE -;;; - -(defun edt-copy-rectangle () - "Copy a rectangle of text between mark and cursor to register." - (interactive) - (edt-check-selection) - (copy-rectangle-to-register 3 (region-beginning) (region-end) nil) - (edt-reset) - (message "Selected rectangle COPIED to register")) - -;;; -;;; CUT RECTANGLE -;;; - -(defun edt-cut-rectangle-overstrike-mode () - "Cut a rectangle of text between mark and cursor to register. -Replace cut characters with spaces and moving cursor back to -upper left corner." - (interactive "*") - (edt-check-selection) - (setq edt-rect-start-point (region-beginning)) - (picture-clear-rectangle-to-register (region-beginning) (region-end) 3) - (set-window-point (get-buffer-window (window-buffer)) edt-rect-start-point) - (message "Selected rectangle CUT to register")) - -(defun edt-cut-rectangle-insert-mode () - "Cut a rectangle of text between mark and cursor to register. -Move cursor back to upper left corner." - (interactive "*") - (edt-check-selection) - (setq edt-rect-start-point (region-beginning)) - (picture-clear-rectangle-to-register (region-beginning) (region-end) 3 t) - (fixup-whitespace) - (set-window-point (get-buffer-window (window-buffer)) edt-rect-start-point) - (message "Selected rectangle CUT to register")) - -(defun edt-cut-rectangle () - "Cut a rectangular region of text to register. -If overwrite mode is active, cut text is replaced with whitespace." - (interactive "*") - (if overwrite-mode - (edt-cut-rectangle-overstrike-mode) - (edt-cut-rectangle-insert-mode))) - -;;; -;;; PASTE RECTANGLE -;;; - -(defun edt-paste-rectangle-overstrike-mode () - "Paste a rectangular region of text from register, replacing text at cursor." - (interactive "*") - (picture-yank-rectangle-from-register 3)) - -(defun edt-paste-rectangle-insert-mode () - "Paste previously deleted rectangular region, inserting text at cursor." - (interactive "*") - (picture-yank-rectangle-from-register 3 t)) - -(defun edt-paste-rectangle () - "Paste a rectangular region of text. -If overwrite mode is active, existing text is replace with text from register." - (interactive) - (if overwrite-mode - (edt-paste-rectangle-overstrike-mode) - (edt-paste-rectangle-insert-mode))) - -;;; -;;; DOWNCASE REGION -;;; - -(defun edt-lowercase () - "Change specified characters to lower case. -If text selection IS active, then characters between the cursor and -mark are changed. If text selection is NOT active, there are two -situations. If the current direction is ADVANCE, then the word under -the cursor is changed to lower case and the cursor is moved to rest at -the beginning of the next word. If the current direction is BACKUP, -the word prior to the word under the cursor is changed to lower case -and the cursor is left to rest at the beginning of that word." - (interactive "*") - (if edt-select-mode - (progn - (downcase-region (mark) (point))) - (progn - ;; Move to beginning of current word. - (if (and - (not (bobp)) - (not (eobp)) - (not (bolp)) - (not (eolp)) - (not (eq ?\ (char-syntax (preceding-char)))) - (not (memq (preceding-char) edt-word-entities)) - (not (memq (following-char) edt-word-entities))) - (edt-one-word-backward)) - (if (equal edt-direction-string edt-backward-string) - (edt-one-word-backward)) - (let ((beg (point))) - (edt-one-word-forward) - (downcase-region beg (point))) - (if (equal edt-direction-string edt-backward-string) - (edt-one-word-backward))))) - -;;; -;;; UPCASE REGION -;;; - -(defun edt-uppercase () - "Change specified characters to upper case. -If text selection IS active, then characters between the cursor and -mark are changed. If text selection is NOT active, there are two -situations. If the current direction is ADVANCE, then the word under -the cursor is changed to upper case and the cursor is moved to rest at -the beginning of the next word. If the current direction is BACKUP, -the word prior to the word under the cursor is changed to upper case -and the cursor is left to rest at the beginning of that word." - (interactive "*") - (if edt-select-mode - (progn - (upcase-region (mark) (point))) - (progn - ;; Move to beginning of current word. - (if (and - (not (bobp)) - (not (eobp)) - (not (bolp)) - (not (eolp)) - (not (eq ?\ (char-syntax (preceding-char)))) - (not (memq (preceding-char) edt-word-entities)) - (not (memq (following-char) edt-word-entities))) - (edt-one-word-backward)) - (if (equal edt-direction-string edt-backward-string) - (edt-one-word-backward)) - (let ((beg (point))) - (edt-one-word-forward) - (upcase-region beg (point))) - (if (equal edt-direction-string edt-backward-string) - (edt-one-word-backward))))) - - -;;; -;;; INITIALIZATION COMMANDS. -;;; - -;;; -;;; Emacs version 19 X-windows key definition support -;;; -(defvar edt-last-answer nil - "Most recent response to edt-y-or-n-p.") - -(defun edt-y-or-n-p (prompt &optional not-yes) - "Prompt for a y or n answer with positive default. -Optional second argument NOT-YES changes default to negative. -Like emacs y-or-n-p, also accepts space as y and DEL as n." - (message "%s[%s]" prompt (if not-yes "n" "y")) - (let ((doit t)) - (while doit - (setq doit nil) - (let ((ans (read-char))) - (cond ((or (= ans ?y) (= ans ?Y) (= ans ?\ )) - (setq edt-last-answer t)) - ((or (= ans ?n) (= ans ?N) (= ans ?\C-?)) - (setq edt-last-answer nil)) - ((= ans ?\r) (setq edt-last-answer (not not-yes))) - (t - (setq doit t) (beep) - (message "Please answer y or n. %s[%s]" - prompt (if not-yes "n" "y"))))))) - edt-last-answer) - -(defun edt-load-xkeys (file) - "Load the EDT X-windows key definitions FILE. -If FILE is nil, try to load a default file. The default file names are -~/.edt-xemacs-keys for XEmacs, and ~/.edt-gnu-keys for GNU emacs." - (interactive "fX key definition file: ") - (cond (file - (setq file (expand-file-name file))) - (edt-xkeys-file - (setq file (expand-file-name edt-xkeys-file))) - (edt-gnu-emacs19-p - (setq file (expand-file-name "~/.edt-gnu-keys"))) - (edt-lucid-emacs19-p - (setq file (expand-file-name "~/.edt-xemacs-keys")))) - (cond ((file-readable-p file) - (load-file file)) - (t - (switch-to-buffer "*scratch*") - (erase-buffer) - (insert " - - Ack!! You're running the Enhanced EDT Emulation under X-windows - without loading an EDT X key definition file. To create an EDT X - key definition file, run the edt-mapper.el program. But ONLY run - it from an XEmacs loaded without any of your own customizations - found in your .emacs file, etc. Some user customization confuse - the edt-mapper function. To do this, you need to invoke XEmacs - as follows: - - xemacs -q -l edt-mapper.el - - The file edt-mapper.el includes these same directions on how to - use it! Perhaps it's laying around here someplace. \n ") - (let ((file "edt-mapper.el") - (found nil) - (path nil) - (search-list (append (list (expand-file-name ".")) load-path))) - (while (and (not found) search-list) - (setq path (concat (car search-list) - (if (string-match "/$" (car search-list)) "" "/") - file)) - (if (and (file-exists-p path) (not (file-directory-p path))) - (setq found t)) - (setq search-list (cdr search-list))) - (cond (found - (insert (format - "Ah yes, there it is, in \n\n %s \n\n" path)) - (if (edt-y-or-n-p "Do you want to run it now? ") - (load-file path) - (error "EDT Emulation not configured."))) - (t - (insert "Nope, I can't seem to find it. :-(\n\n") - (sit-for 20) - (error "EDT Emulation not configured."))))))) - -;;;###autoload -(defun edt-emulation-on () - "Turn on EDT Emulation." - (interactive) - ;; If using MS-DOS, need to load edt-pc.el - (if (eq system-type 'ms-dos) - (setq edt-term "pc") - (setq edt-term (getenv "TERM"))) - ;; All DEC VT series terminals are supported by loading edt-vt100.el - (if (string-equal "vt" (substring edt-term 0 (min (length edt-term) 2))) - (setq edt-term "vt100")) - ;; Load EDT terminal specific configuration file. - (let ((term edt-term) - hyphend) - (while (and term - (not (load (concat "edt-" term) t t))) - ;; Strip off last hyphen and what follows, then try again - (if (setq hyphend (string-match "[-_][^-_]+$" term)) - (setq term (substring term 0 hyphend)) - (setq term nil))) - ;; Override terminal-specific file if running X Windows. X Windows support - ;; is handled differently in edt-load-xkeys - (if (eq window-system 'x) - (edt-load-xkeys nil) - (if (null term) - (error "Unable to load EDT terminal specific file for %s" edt-term))) - (setq edt-term term)) - (when (boundp 'transient-mark-mode) - (setq edt-orig-transient-mark-mode transient-mark-mode)) - (add-hook 'activate-mark-hook - (function - (lambda () - (edt-select-mode t)))) - (add-hook 'deactivate-mark-hook - (function - (lambda () - (edt-select-mode nil)))) - (if (load "edt-user" t t) - (edt-user-emulation-setup) - (edt-default-emulation-setup))) - -(defun edt-emulation-off() - "Select original global key bindings, disabling EDT Emulation." - (interactive) - (use-global-map global-map) - (if (not edt-keep-current-page-delimiter) - (setq page-delimiter edt-orig-page-delimiter)) - (setq edt-direction-string "") - (setq edt-select-mode-text nil) - (edt-reset) - (force-mode-line-update t) - (when (boundp 'transient-mark-mode) - (setq transient-mark-mode edt-orig-transient-mark-mode)) - (message "Original key bindings restored; EDT Emulation disabled")) - -(defun edt-default-emulation-setup (&optional user-setup) - "Setup emulation of DEC's EDT editor." - ;; Setup default EDT global map by copying global map bindings. - ;; This preserves ESC and C-x prefix bindings and other bindings we - ;; wish to retain in EDT emulation mode keymaps. It also permits - ;; customization of these bindings in the EDT global maps without - ;; disturbing the original bindings in global-map. - (fset 'edt-default-ESC-prefix (copy-keymap 'ESC-prefix)) - (setq edt-default-global-map (copy-keymap (current-global-map))) - (define-key edt-default-global-map "\e" 'edt-default-ESC-prefix) - (define-prefix-command 'edt-default-gold-map) - (edt-setup-default-bindings) - ;; If terminal has additional function keys, the terminal-specific - ;; initialization file can assign bindings to them via the optional - ;; function edt-setup-extra-default-bindings. - (if (fboundp 'edt-setup-extra-default-bindings) - (edt-setup-extra-default-bindings)) - ;; Variable needed by edt-learn. - (setq edt-learn-macro-count 0) - ;; Display EDT text selection active within the mode line - (or (assq 'edt-select-mode minor-mode-alist) - (setq minor-mode-alist - (cons '(edt-select-mode edt-select-mode) minor-mode-alist))) - ;; Display EDT direction of motion within the mode line - (or (assq 'edt-direction-string minor-mode-alist) - (setq minor-mode-alist - (cons - '(edt-direction-string edt-direction-string) minor-mode-alist))) - (if user-setup - (progn - (setq edt-user-map-configured t) - (fset 'edt-emulation-on (symbol-function 'edt-select-user-global-map))) - (progn - (fset 'edt-emulation-on (symbol-function 'edt-select-default-global-map)) - (edt-select-default-global-map)))) - -(defun edt-user-emulation-setup () - "Setup user custom emulation of DEC's EDT editor." - ;; Initialize EDT default bindings. - (edt-default-emulation-setup t) - ;; Setup user EDT global map by copying default EDT global map bindings. - (fset 'edt-user-ESC-prefix (copy-keymap 'edt-default-ESC-prefix)) - (setq edt-user-global-map (copy-keymap edt-default-global-map)) - (define-key edt-user-global-map "\e" 'edt-user-ESC-prefix) - ;; If terminal has additional function keys, the user's initialization - ;; file can assign bindings to them via the optional - ;; function edt-setup-extra-default-bindings. - (define-prefix-command 'edt-user-gold-map) - (fset 'edt-user-gold-map (copy-keymap 'edt-default-gold-map)) - (edt-setup-user-bindings) - (edt-select-user-global-map)) - -(defun edt-select-default-global-map() - "Select default EDT emulation key bindings." - (interactive) - (when (fboundp 'transient-mark-mode) - (transient-mark-mode 1)) - (use-global-map edt-default-global-map) - (if (not edt-keep-current-page-delimiter) - (progn - (setq edt-orig-page-delimiter page-delimiter) - (setq page-delimiter "\f"))) - (setq edt-default-map-active t) - (edt-advance) - (setq edt-select-mode-text 'edt-select-mode-string) - (edt-reset) - (message "Default EDT keymap active")) - -(defun edt-select-user-global-map() - "Select user EDT emulation custom key bindings." - (interactive) - (if edt-user-map-configured - (progn - (when (fboundp 'transient-mark-mode) - (transient-mark-mode 1)) - (use-global-map edt-user-global-map) - (if (not edt-keep-current-page-delimiter) - (progn - (setq edt-orig-page-delimiter page-delimiter) - (setq page-delimiter "\f"))) - (setq edt-default-map-active nil) - (edt-advance) - (setq edt-select-mode-text 'edt-select-mode-string) - (edt-reset) - (message "User EDT custom keymap active")) - (error "User EDT custom keymap NOT configured!"))) - -(defun edt-switch-global-maps () - "Toggle between default EDT keymap and user EDT keymap." - (interactive) - (if edt-default-map-active - (edt-select-user-global-map) - (edt-select-default-global-map))) - -;; There are three key binding functions needed: one for standard keys -;; (used to bind control keys, primarily), one for Gold sequences of -;; standard keys, and one for function keys. - -(defun edt-bind-gold-key (key gold-binding &optional default) - "Binds commands to a gold key sequence in the EDT Emulator." - (if default - (define-key 'edt-default-gold-map key gold-binding) - (define-key 'edt-user-gold-map key gold-binding))) - -(defun edt-bind-standard-key (key gold-binding &optional default) - "Bind commands to a gold key sequence in the default EDT keymap." - (if default - (define-key edt-default-global-map key gold-binding) - (define-key edt-user-global-map key gold-binding))) - -(defun edt-bind-function-key - (function-key binding gold-binding &optional default) - "Binds function keys in the EDT Emulator." - (catch 'edt-key-not-supported - (let ((key-vector (cdr (assoc function-key *EDT-keys*)))) - (if (stringp key-vector) - (throw 'edt-key-not-supported t)) - (if (not (null key-vector)) - (progn - (if default - (progn - (define-key edt-default-global-map key-vector binding) - (define-key 'edt-default-gold-map key-vector gold-binding)) - (progn - (define-key edt-user-global-map key-vector binding) - (define-key 'edt-user-gold-map key-vector gold-binding)))) - (error "%s is not a legal function key name" function-key))))) - -(defun edt-setup-default-bindings () - "Assigns default EDT Emulation keyboard bindings." - - ;; Function Key Bindings: Regular and GOLD. - - ;; VT100/VT200/VT300 PF1 (GOLD), PF2, PF3, PF4 Keys - (edt-bind-function-key "PF1" 'edt-default-gold-map 'edt-mark-section-wisely t) - (edt-bind-function-key "PF2" 'edt-electric-keypad-help 'describe-function t) - (edt-bind-function-key "PF3" 'edt-find-next 'edt-find t) - (edt-bind-function-key "PF4" 'edt-delete-line 'edt-undelete-line t) - - ;; VT100/VT200/VT300 Arrow Keys - (edt-bind-function-key "UP" 'previous-line 'edt-window-top t) - (edt-bind-function-key "DOWN" 'next-line 'edt-window-bottom t) - (edt-bind-function-key "LEFT" 'backward-char 'edt-sentence-backward t) - (edt-bind-function-key "RIGHT" 'forward-char 'edt-sentence-forward t) - - ;; VT100/VT200/VT300 Keypad Keys - (edt-bind-function-key "KP0" 'edt-line 'open-line t) - (edt-bind-function-key "KP1" 'edt-word 'edt-change-case t) - (edt-bind-function-key "KP2" 'edt-end-of-line 'edt-delete-to-end-of-line t) - (edt-bind-function-key "KP3" 'edt-character 'quoted-insert t) - (edt-bind-function-key "KP4" 'edt-advance 'edt-bottom t) - (edt-bind-function-key "KP5" 'edt-backup 'edt-top t) - (edt-bind-function-key "KP6" 'edt-cut 'yank t) - (edt-bind-function-key "KP7" 'edt-page 'execute-extended-command t) - (edt-bind-function-key "KP8" 'edt-sect 'edt-fill-region t) - (edt-bind-function-key "KP9" 'edt-append 'edt-replace t) - (edt-bind-function-key "KP-" 'edt-delete-word 'edt-undelete-word t) - (edt-bind-function-key "KP," 'edt-delete-character 'edt-undelete-character t) - (edt-bind-function-key "KPP" 'edt-select 'edt-reset t) - (edt-bind-function-key "KPE" 'other-window 'query-replace t) - - ;; VT200/VT300 Function Keys - ;; (F1 through F5, on the VT220, are not programmable, so we skip - ;; making default bindings to those keys. - (edt-bind-function-key "FIND" 'edt-find-next 'edt-find t) - (edt-bind-function-key "INSERT" 'yank 'edt-key-not-assigned t) - (edt-bind-function-key "REMOVE" 'edt-cut 'edt-copy t) - (edt-bind-function-key "SELECT" 'edt-toggle-select 'edt-key-not-assigned t) - (edt-bind-function-key "NEXT" 'edt-sect-forward 'edt-key-not-assigned t) - (edt-bind-function-key "PREVIOUS" 'edt-sect-backward 'edt-key-not-assigned t) - (edt-bind-function-key "F6" 'edt-key-not-assigned 'edt-key-not-assigned t) - (edt-bind-function-key "F7" 'edt-copy-rectangle 'edt-key-not-assigned t) - (edt-bind-function-key "F8" - 'edt-cut-rectangle-overstrike-mode 'edt-paste-rectangle-overstrike-mode t) - (edt-bind-function-key "F9" - 'edt-cut-rectangle-insert-mode 'edt-paste-rectangle-insert-mode t) - (edt-bind-function-key "F10" 'edt-cut-rectangle 'edt-paste-rectangle t) - ;; Under X, the F11 key can be bound. If using a VT-200 or higher terminal, - ;; the default emacs terminal support causes the VT F11 key to seem as if it - ;; is an ESC key when in emacs. - (edt-bind-function-key "F11" - 'edt-key-not-assigned 'edt-key-not-assigned t) - (edt-bind-function-key "F12" - 'edt-beginning-of-line 'delete-other-windows t) ;BS - (edt-bind-function-key "F13" - 'edt-delete-to-beginning-of-word 'edt-key-not-assigned t) ;LF - (edt-bind-function-key "F14" 'edt-key-not-assigned 'edt-key-not-assigned t) - (edt-bind-function-key "HELP" 'edt-electric-keypad-help 'edt-key-not-assigned t) - (edt-bind-function-key "DO" 'execute-extended-command 'edt-key-not-assigned t) - (edt-bind-function-key "F17" 'edt-key-not-assigned 'edt-key-not-assigned t) - (edt-bind-function-key "F18" 'edt-key-not-assigned 'edt-key-not-assigned t) - (edt-bind-function-key "F19" 'edt-key-not-assigned 'edt-key-not-assigned t) - (edt-bind-function-key "F20" 'edt-key-not-assigned 'edt-key-not-assigned t) - - ;; Control key bindings: Regular and GOLD - ;; - ;; Standard EDT control key bindings conflict with standard Emacs - ;; control key bindings. Normally, the standard Emacs control key - ;; bindings are left unchanged in the default EDT mode. However, if - ;; the variable edt-use-EDT-control-key-bindings is set to true - ;; before invoking edt-emulation-on for the first time, then the - ;; standard EDT bindings (with some enhancements) as defined here are - ;; used, instead. - (if edt-use-EDT-control-key-bindings - (progn - (edt-bind-standard-key "\C-a" 'edt-key-not-assigned t) - (edt-bind-standard-key "\C-b" 'edt-key-not-assigned t) - ;; Leave binding of C-c as original prefix key. - (edt-bind-standard-key "\C-d" 'edt-key-not-assigned t) - (edt-bind-standard-key "\C-e" 'edt-key-not-assigned t) - (edt-bind-standard-key "\C-f" 'edt-key-not-assigned t) - ;; Leave binding of C-g to keyboard-quit -; (edt-bind-standard-key "\C-g" 'keyboard-quit t) - ;; Standard EDT binding of C-h. To invoke Emacs help, use - ;; GOLD-C-h instead. - (edt-bind-standard-key "\C-h" 'edt-beginning-of-line t) - (edt-bind-standard-key "\C-i" 'edt-tab-insert t) - (edt-bind-standard-key "\C-j" 'edt-delete-to-beginning-of-word t) - (edt-bind-standard-key "\C-k" 'edt-define-key t) - (edt-bind-gold-key "\C-k" 'edt-restore-key t) - (edt-bind-standard-key "\C-l" 'edt-form-feed-insert t) - ;; Leave binding of C-m to newline. - (edt-bind-standard-key "\C-n" 'edt-set-screen-width-80 t) - (edt-bind-standard-key "\C-o" 'edt-key-not-assigned t) - (edt-bind-standard-key "\C-p" 'edt-key-not-assigned t) - (edt-bind-standard-key "\C-q" 'edt-key-not-assigned t) - ;; Leave binding of C-r to isearch-backward. - ;; Leave binding of C-s to isearch-forward. - (edt-bind-standard-key "\C-t" 'edt-display-the-time t) - (edt-bind-standard-key "\C-u" 'edt-delete-to-beginning-of-line t) - (edt-bind-standard-key "\C-v" 'redraw-display t) - (edt-bind-standard-key "\C-w" 'edt-set-screen-width-132 t) - ;; Leave binding of C-x as original prefix key. - (edt-bind-standard-key "\C-y" 'edt-key-not-assigned t) -; (edt-bind-standard-key "\C-z" 'suspend-emacs t) - ) - ) - - ;; GOLD bindings for a few Control keys. - (edt-bind-gold-key "\C-g" 'keyboard-quit t); Just in case. - (edt-bind-gold-key "\C-h" 'help-for-help t) - (edt-bind-gold-key [f1] 'help-for-help t) - (edt-bind-gold-key [help] 'help-for-help t) - (edt-bind-gold-key "\C-\\" 'split-window-vertically t) - - ;; GOLD bindings for regular keys. - (edt-bind-gold-key "a" 'edt-key-not-assigned t) - (edt-bind-gold-key "A" 'edt-key-not-assigned t) - (edt-bind-gold-key "b" 'buffer-menu t) - (edt-bind-gold-key "B" 'buffer-menu t) - (edt-bind-gold-key "c" 'compile t) - (edt-bind-gold-key "C" 'compile t) - (edt-bind-gold-key "d" 'delete-window t) - (edt-bind-gold-key "D" 'delete-window t) - (edt-bind-gold-key "e" 'edt-exit t) - (edt-bind-gold-key "E" 'edt-exit t) - (edt-bind-gold-key "f" 'find-file t) - (edt-bind-gold-key "F" 'find-file t) - (edt-bind-gold-key "g" 'find-file-other-window t) - (edt-bind-gold-key "G" 'find-file-other-window t) - (edt-bind-gold-key "h" 'edt-electric-keypad-help t) - (edt-bind-gold-key "H" 'edt-electric-keypad-help t) - (edt-bind-gold-key "i" 'insert-file t) - (edt-bind-gold-key "I" 'insert-file t) - (edt-bind-gold-key "j" 'edt-key-not-assigned t) - (edt-bind-gold-key "J" 'edt-key-not-assigned t) - (edt-bind-gold-key "k" 'edt-toggle-capitalization-of-word t) - (edt-bind-gold-key "K" 'edt-toggle-capitalization-of-word t) - (edt-bind-gold-key "l" 'edt-lowercase t) - (edt-bind-gold-key "L" 'edt-lowercase t) - (edt-bind-gold-key "m" 'save-some-buffers t) - (edt-bind-gold-key "M" 'save-some-buffers t) - (edt-bind-gold-key "n" 'next-error t) - (edt-bind-gold-key "N" 'next-error t) - (edt-bind-gold-key "o" 'switch-to-buffer-other-window t) - (edt-bind-gold-key "O" 'switch-to-buffer-other-window t) - (edt-bind-gold-key "p" 'edt-key-not-assigned t) - (edt-bind-gold-key "P" 'edt-key-not-assigned t) - (edt-bind-gold-key "q" 'edt-quit t) - (edt-bind-gold-key "Q" 'edt-quit t) - (edt-bind-gold-key "r" 'revert-buffer t) - (edt-bind-gold-key "R" 'revert-buffer t) - (edt-bind-gold-key "s" 'save-buffer t) - (edt-bind-gold-key "S" 'save-buffer t) - (edt-bind-gold-key "t" 'edt-key-not-assigned t) - (edt-bind-gold-key "T" 'edt-key-not-assigned t) - (edt-bind-gold-key "u" 'edt-uppercase t) - (edt-bind-gold-key "U" 'edt-uppercase t) - (edt-bind-gold-key "v" 'find-file-other-window t) - (edt-bind-gold-key "V" 'find-file-other-window t) - (edt-bind-gold-key "w" 'write-file t) - (edt-bind-gold-key "W" 'write-file t) - (edt-bind-gold-key "x" 'edt-key-not-assigned t) - (edt-bind-gold-key "X" 'edt-key-not-assigned t) - (edt-bind-gold-key "y" 'edt-emulation-off t) - (edt-bind-gold-key "Y" 'edt-emulation-off t) - (edt-bind-gold-key "z" 'edt-switch-global-maps t) - (edt-bind-gold-key "Z" 'edt-switch-global-maps t) - (edt-bind-gold-key "1" 'delete-other-windows t) - (edt-bind-gold-key "!" 'edt-key-not-assigned t) - (edt-bind-gold-key "2" 'edt-split-window t) - (edt-bind-gold-key "@" 'edt-key-not-assigned t) - (edt-bind-gold-key "3" 'edt-key-not-assigned t) - (edt-bind-gold-key "#" 'edt-key-not-assigned t) - (edt-bind-gold-key "4" 'edt-key-not-assigned t) - (edt-bind-gold-key "$" 'edt-key-not-assigned t) - (edt-bind-gold-key "5" 'edt-key-not-assigned t) - (edt-bind-gold-key "%" 'edt-goto-percentage t) - (edt-bind-gold-key "6" 'edt-key-not-assigned t) - (edt-bind-gold-key "^" 'edt-key-not-assigned t) - (edt-bind-gold-key "7" 'edt-key-not-assigned t) - (edt-bind-gold-key "&" 'edt-key-not-assigned t) - (edt-bind-gold-key "8" 'edt-key-not-assigned t) - (edt-bind-gold-key "*" 'edt-key-not-assigned t) - (edt-bind-gold-key "9" 'edt-key-not-assigned t) - (edt-bind-gold-key "(" 'edt-key-not-assigned t) - (edt-bind-gold-key "0" 'edt-key-not-assigned t) - (edt-bind-gold-key ")" 'edt-key-not-assigned t) - (edt-bind-gold-key " " 'undo t) - (edt-bind-gold-key "," 'edt-key-not-assigned t) - (edt-bind-gold-key "<" 'edt-key-not-assigned t) - (edt-bind-gold-key "." 'edt-key-not-assigned t) - (edt-bind-gold-key ">" 'edt-key-not-assigned t) - (edt-bind-gold-key "/" 'edt-key-not-assigned t) - (edt-bind-gold-key "?" 'edt-key-not-assigned t) - (edt-bind-gold-key "\\" 'edt-key-not-assigned t) - (edt-bind-gold-key "|" 'edt-key-not-assigned t) - (edt-bind-gold-key ";" 'edt-key-not-assigned t) - (edt-bind-gold-key ":" 'edt-key-not-assigned t) - (edt-bind-gold-key "'" 'edt-key-not-assigned t) - (edt-bind-gold-key "\"" 'edt-key-not-assigned t) - (edt-bind-gold-key "-" 'edt-key-not-assigned t) - (edt-bind-gold-key "_" 'edt-key-not-assigned t) - (edt-bind-gold-key "=" 'goto-line t) - (edt-bind-gold-key "+" 'edt-key-not-assigned t) - (edt-bind-gold-key "[" 'edt-key-not-assigned t) - (edt-bind-gold-key "{" 'edt-key-not-assigned t) - (edt-bind-gold-key "]" 'edt-key-not-assigned t) - (edt-bind-gold-key "}" 'edt-key-not-assigned t) - (edt-bind-gold-key "`" 'what-line t) - (edt-bind-gold-key "~" 'edt-key-not-assigned t) -) - -;;; -;;; DEFAULT EDT KEYPAD HELP -;;; - -;;; -;;; Upper case commands in the keypad diagram below indicate that the -;;; emulation should look and feel very much like EDT. Lower case -;;; commands are enhancements and/or additions to the EDT keypad -;;; commands or are native Emacs commands. -;;; - -(defun edt-keypad-help () - " - DEFAULT EDT Keypad Active - - F7: Copy Rectangle +----------+----------+----------+----------+ - F8: Cut Rect Overstrike |Prev Line |Next Line |Bkwd Char |Frwd Char | - G-F8: Paste Rect Overstrike | (UP) | (DOWN) | (LEFT) | (RIGHT) | - F9: Cut Rect Insert |Window Top|Window Bot|Bkwd Sent |Frwd Sent | - G-F9: Paste Rect Insert +----------+----------+----------+----------+ - F10: Cut Rectangle -G-F10: Paste Rectangle - F11: ESC - F12: Begining of Line +----------+----------+----------+----------+ -G-F12: Delete Other Windows | GOLD | HELP | FNDNXT | DEL L | - F13: Delete to Begin of Word | (PF1) | (PF2) | (PF3) | (PF4) | - HELP: Keypad Help |Mark Wisel|Desc Funct| FIND | UND L | - DO: Execute extended command +----------+----------+----------+----------+ - | PAGE | SECT | APPEND | DEL W | - C-g: Keyboard Quit | (7) | (8) | (9) | (-) | -G-C-g: Keyboard Quit |Ex Ext Cmd|Fill Regio| REPLACE | UND W | - C-h: Beginning of Line +----------+----------+----------+----------+ -G-C-h: Emacs Help | ADVANCE | BACKUP | CUT | DEL C | - C-i: Tab Insert | (4) | (5) | (6) | (,) | - C-j: Delete to Begin of Word | BOTTOM | TOP | Yank | UND C | - C-k: Define Key +----------+----------+----------+----------+ -G-C-k: Restore Key | WORD | EOL | CHAR | Next | - C-l: Form Feed Insert | (1) | (2) | (3) | Window | - C-n: Set Screen Width 80 | CHNGCASE | DEL EOL |Quoted Ins| ! - C-r: Isearch Backward +---------------------+----------+ (ENTER) | - C-s: Isearch Forward | LINE | SELECT | ! - C-t: Display the Time | (0) | (.) | Query | - C-u: Delete to Begin of Line | Open Line | RESET | Replace | - C-v: Redraw Display +---------------------+----------+----------+ - C-w: Set Screen Width 132 - C-z: Suspend Emacs +----------+----------+----------+ -G-C-\\: Split Window | FNDNXT | Yank | CUT | - | (FIND) | (INSERT) | (REMOVE) | - G-b: Buffer Menu | FIND | | COPY | - G-c: Compile +----------+----------+----------+ - G-d: Delete Window |SELECT/RES|SECT BACKW|SECT FORWA| - G-e: Exit | (SELECT) |(PREVIOUS)| (NEXT) | - G-f: Find File | | | | - G-g: Find File Other Window +----------+----------+----------+ - G-h: Keypad Help - G-i: Insert File - G-k: Toggle Capitalization Word - G-l: Downcase Region - G-m: Save Some Buffers - G-n: Next Error - G-o: Switch to Next Window - G-q: Quit - G-r: Revert File - G-s: Save Buffer - G-u: Upcase Region - G-v: Find File Other Window - G-w: Write file - G-y: EDT Emulation OFF - G-z: Switch to User EDT Key Bindings - G-1: Delete Other Windows - G-2: Split Window - G-%: Go to Percentage - G- : Undo (GOLD Spacebar) - G-=: Go to Line - G-`: What line" - - (interactive) - (describe-function 'edt-keypad-help)) - -(defun edt-electric-helpify (fun) - (let ((name "*Help*")) - (if (save-window-excursion - (let* ((p (symbol-function 'print-help-return-message)) - (b (get-buffer name)) - (m (buffer-modified-p b))) - (and b (not (get-buffer-window b)) - (setq b nil)) - (unwind-protect - (progn - (message "%s..." (capitalize (symbol-name fun))) - (and b - (save-excursion - (set-buffer b) - (set-buffer-modified-p t))) - (fset 'print-help-return-message 'ignore) - (call-interactively fun) - (and (get-buffer name) - (get-buffer-window (get-buffer name)) - (or (not b) - (not (eq b (get-buffer name))) - (not (buffer-modified-p b))))) - (fset 'print-help-return-message p) - (and b (buffer-name b) - (save-excursion - (set-buffer b) - (set-buffer-modified-p m)))))) - (with-electric-help 'delete-other-windows name t)))) - -(defun edt-electric-keypad-help () - "Display default EDT bindings." - (interactive) - (edt-electric-helpify 'edt-keypad-help)) - -(defun edt-electric-user-keypad-help () - "Display user custom EDT bindings." - (interactive) - (edt-electric-helpify 'edt-user-keypad-help)) - -;;; -;;; EDT emulation screen width commands. -;;; -;; Some terminals require modification of terminal attributes when changing the -;; number of columns displayed, hence the fboundp tests below. These functions -;; are defined in the corresponding terminal specific file, if needed. - -(defun edt-set-screen-width-80 () - "Set screen width to 80 columns." - (interactive) - (if (fboundp 'edt-set-term-width-80) - (edt-set-term-width-80)) - (set-screen-width 80) - (message "Screen width 80")) - -(defun edt-set-screen-width-132 () - "Set screen width to 132 columns." - (interactive) - (if (fboundp 'edt-set-term-width-132) - (edt-set-term-width-132)) - (set-screen-width 132) - (message "Screen width 132")) - -(provide 'edt) - -;;; edt.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/emulators/scroll-lock.el --- a/lisp/emulators/scroll-lock.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,137 +0,0 @@ -;; @(#) scroll-lock.el -- scroll-locking minor mode - -;; Authors: -;; Gary D. Foster -;; with contributions/suggestions/ideas from: -;; Rick Macdonald -;; Anders Lindgren -;; $Revision: 1.1.1.1 $ -;; Keywords: scroll crisp brief lock - -;; 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., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;; Commentary -;; This mode allows multiple buffers to be 'locked' so that scrolling -;; up or down lines in any buffer causes all the buffers to mirror -;; the scrolling. It hooks into the post-command-hook to check for -;; potential scrolling commands and if we're locked, mirrors them in all -;; windows. This allows us to grab line-at-a-time scrolling as well as -;; screen-at-a-time scrolling, and doesn't remap any of the keyboard -;; commands to do it. - -;; This minor mode is normally autoloaded from the scroll-lock package. -;; You can disable autoloading of this package by placing -;; (setq crisp-load-scroll-lock nil) in your .emacs before loading -;; the crisp package. If you want to use this package by itself, -;; you can enable it by placing the following in your .emacs: - -;; (require 'scroll-lock) - -;; In the first (autoloaded) case, meta-f1 is bound to the command to -;; toggle the scroll-lock mode. In the second (non-autoloaded) case, -;; you can enable and disable it with the 'scroll-lock-mode' command. - -(defvar scroll-lock-running-xemacs (string-match "XEmacs\\|Lucid" emacs-version)) - -(defvar scroll-lock-modeline-string " *SL*" - "String to display in the modeline when Scroll Lock mode is enabled.") - -(defvar scroll-lock-is-locked nil - "Track status of scroll locking.") -(if scroll-lock-running-xemacs - (add-minor-mode 'scroll-lock-is-locked scroll-lock-modeline-string) - (or (assq 'scroll-lock-is-locked minor-mode-alist) - (setq minor-mode-alist - (cons '(scroll-lock-is-locked scroll-lock-modeline-string) minor-mode-alist)))) - -(defun scroll-lock-scroll-down-all (arg) - "Scroll-down all visible windows." - (interactive "P") - (let ((num-windows (count-windows)) - (count 1)) - (if (> num-windows 1) - ( progn (other-window 1) - (while (< count num-windows) - (if (not (eq (point) (point-max))) - (progn (call-interactively 'next-line))) - (other-window 1) - (setq count (1+ count))))))) - -(defun scroll-lock-scroll-up-all (arg) - "Scroll-up all visible windows." - (interactive "P") - (let ((num-windows (count-windows)) - (count 1)) - (if (> num-windows 1) - ( progn (other-window 1) - (while (< count num-windows) - (if (not (eq (point) (point-min))) - (progn (call-interactively 'previous-line))) - (other-window 1) - (setq count (1+ count))))))) - -(defun scroll-lock-page-down-all (arg) - "Page-down all visible windows." - (interactive "P") - (let ((num-windows (count-windows)) - (count 1)) - (if (> num-windows 1) - (progn (other-window 1) - (while (< count num-windows) - (call-interactively 'fkey-scroll-up) - (other-window 1) - (setq count (1+ count))))))) - -(defun scroll-lock-page-up-all (arg) - "Page-up all visible windows." - (interactive "P") - (let ((num-windows (count-windows)) - (count 1)) - (if (> num-windows 1) - (progn (other-window 1) - (while (< count num-windows) - (call-interactively 'fkey-scroll-down) - (other-window 1) - (setq count (1+ count))))))) - - -(defun scroll-lock-check-to-scroll () - "Check last-command to see if a scroll was done." - (if (eq this-command 'next-line) - (call-interactively 'scroll-lock-scroll-down-all)) - (if (eq this-command 'previous-line) - (call-interactively 'scroll-lock-scroll-up-all)) - (if (eq this-command 'fkey-scroll-up) - (call-interactively 'scroll-lock-page-down-all)) - (if (eq this-command 'fkey-scroll-down) - (call-interactively 'scroll-lock-page-up-all))) - - -(defun scroll-lock-mode (arg) - "Toggle scroll-lock minor mode." - (interactive "P") - (setq scroll-lock-is-locked (not scroll-lock-is-locked)) - (cond - ((eq scroll-lock-is-locked 't) - (add-hook 'post-command-hook 'scroll-lock-check-to-scroll)) - ((eq scroll-lock-is-locked 'nil) - (remove-hook 'post-command-hook 'scroll-lock-check-to-scroll)))) - -(provide 'scroll-lock) - -;;; scroll-lock.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/emulators/teco.el --- a/lisp/emulators/teco.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1947 +0,0 @@ -;;; teco.el --- Teco interpreter for Gnu Emacs, version 1. - -;; Author: Dale R. Worley. -;; Keywords: emulators - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: Not in FSF - -;;; Commentary: - -;; This code has been tested some, but no doubt contains a zillion bugs. -;; You have been warned. - -;; Written by Dale R. Worley based on a C implementation by Matt Fichtenbaum. -;; Please send comments, bug fixes, enhancements, etc. to drw@math.mit.edu. - -;; Emacs Lisp version copyright (C) 1991 by Dale R. Worley. -;; Do what you will with it. - -;; Since much of this code is translated from the C version by -;; Matt Fichtenbaum, I include his copyright notice: -;; TECO for Ultrix. Copyright 1986 Matt Fichtenbaum. -;; This program and its components belong to GenRad Inc, Concord MA 01742. -;; They may be copied if this copyright notice is included. - -;; To invoke directly, do: -;; (global-set-key ?\C-z 'teco-command) -;; (autoload teco-command "teco" -;; "Read and execute a Teco command string." -;; t nil) - -;; Differences from other Tecos: -;; Character positions in the buffer are numbered in the Emacs way: The first -;; character is numbered 1 (or (point-min) if narrowing is in effect). The -;; B command returns that number. -;; Ends of lines are represented by a single character (newline), so C and R -;; skip over them, rather than 2C and 2R. -;; All file I/O is left to the underlying Emacs. Thus, almost all Ex commands -;; are omitted. - -;; Command set: -;; NUL Not a command. -;; ^A Output message to terminal (argument ends with ^A) -;; ^C Exit macro -;; ^C^C Stop execution -;; ^D Set radix to decimal -;; ^EA (match char) Match alphabetics -;; ^EC (match char) Match symbol constituents -;; ^ED (match char) Match numerics -;; ^EGq (match char) Match any char in q-reg -;; ^EL (match char) Match line terminators -;; ^EQq (string char) Use contents of q-reg -;; ^ER (match char) Match alphanumerics -;; ^ES (match char) Match non-null space/tab -;; ^EV (match char) Match lower case alphabetic -;; ^EW (match char) Match upper case alphabetic -;; ^EX (match char) Match any char -;; ^G^G (type-in) Kill command string -;; ^G (type-in) Retype current command line -;; ^G* (type-in) Retype current command input -;; TAB Insert tab and text -;; LF Line terminator; Ignored in commands -;; VT Ignored in commands -;; FF Ignored in commands -;; CR Ignored in commands -;; ^Nx (match char) Match all but x -;; ^O Set radix to octal -;; ^P Find matching parenthesis -;; ^Q Convert line argument into character argument -;; ^Qx (string char) Use x literally -;; n^R Set radix to n -;; :^R Enter recursive edit -;; ^S -(length of last referenced string) -;; ^S (match char) match separator char -;; ^T Ascii value of next character typed -;; n^T Output Ascii character with value n -;; ^U (type-in) Kill command line -;; ^Uq Put text argument into q-reg -;; n^Uq Put Ascii character 'n' into q-reg -;; :^Uq Append text argument to q-reg -;; n:^Uq Append character 'n' to q-reg -;; ^X Set/get search mode flag -;; ^X (match char) Match any character -;; ^Y Equivalent to '.+^S,.' -;; ^Z Not a Teco command -;; ESC String terminator; absorbs arguments -;; ESC ESC (type-in) End command -;; ^\ Not a Teco command -;; ^] Not a Teco command -;; ^^x Ascii value of the character x -;; ^_ One's complement (logical NOT) -;; ! Define label (argument ends with !) -;; " Start conditional -;; n"< Test for less than zero -;; n"> Test for greater than zero -;; n"= Test for equal to zero -;; n"A Test for alphabetic -;; n"C Test for symbol constituent -;; n"D Test for numeric -;; n"E Test for equal to zero -;; n"F Test for false -;; n"G Test for greater than zero -;; n"L Test for less than zero -;; n"N Test for not equal to zero -;; n"R Test for alphanumeric -;; n"S Test for successful -;; n"T Test for true -;; n"U Test for unsuccessful -;; n"V Test for lower case -;; n"W Test for upper case -;; # Logical OR -;; $ Not a Teco command -;; n%q Add n to q-reg and return result -;; & Logical AND -;; ' End conditional -;; ( Expression grouping -;; ) Expression grouping -;; * Multiplication -;; + Addition -;; , Argument separator -;; - Subtraction or negation -;; . Current pointer position -;; / Division -;; 0-9 Digit -;; n< Iterate n times -;; = Type in decimal -;; := Type in decimal, no newline -;; = Type in octal -;; := Type in octal, no newline -;; = Type in hexadecimal -;; := Type in hexadecimal, no newline -;; :: Make next search a compare -;; > End iteration -;; n:A Get Ascii code of character at relative position n -;; B Character position of beginning of buffer -;; nC Advance n characters -;; nD Delete n characters -;; n,mD Delete characters between n and m -;; Gq Get string from q-reg into buffer -;; :Gq Type out q-reg -;; H Equivalent to 'B,Z' -;; I Insert text argument -;; nJ Move pointer to character n -;; nK Kill n lines -;; n,mK Kill characters between n and m -;; nL Advance n lines -;; Mq Execute string in q-reg -;; O Goto label -;; nO Go to n-th label in list (0-origin) -;; Qq Number in q-reg -;; nQq Ascii value of n-th character in q-reg -;; :Qq Size of text in q-reg -;; nR Back up n characters -;; nS Search -;; nT Type n lines -;; n,mT Type chars from n to m -;; nUq Put number n into q-reg -;; nV Type n lines around pointer -;; nXq Put n lines into q-reg -;; n,mXq Put characters from n to m into q-reg -;; n:Xq Append n lines to q-reg q -;; n,m:Xq Append characters from n to m into q-reg -;; Z Pointer position at end of buffer -;; [q Put q-reg on stack -;; \ Value of digit string in buffer -;; n\ Convert n to digits and insert in buffer -;; ]q Pop q-reg from stack -;; :]q Test whether stack is empty and return value -;; ` Not a Teco command -;; a-z Treated the same as A-Z -;; { Not a Teco command -;; | Conditional 'else' -;; } Not a Teco command -;; ~ Not a Teco command -;; DEL Delete last character typed in - - -;;; Code: -(require 'backquote) - -;; set a range of elements of an array to a value -(defun teco-set-elements (array start end value) - (let ((i start)) - (while (<= i end) - (aset array i value) - (setq i (1+ i))))) - -;; set a range of elements of an array to their indexes plus an offset -(defun teco-set-elements-index (array start end offset) - (let ((i start)) - (while (<= i end) - (aset array i (+ i offset)) - (setq i (1+ i))))) - -(defvar teco-command-string "" - "The current command string being executed.") - -(defvar teco-command-pointer nil - "Pointer into teco-command-string showing next character to be executed.") - -(defvar teco-ctrl-r 10 - "Current number radix.") - -(defvar teco-digit-switch nil - "Set if we have just executed a digit.") - -(defvar teco-exp-exp nil - "Expression value preceding operator.") - -(defvar teco-exp-val1 nil - "Current argument value.") - -(defvar teco-exp-val2 nil - "Argument before comma.") - -(defvar teco-exp-flag1 nil - "t if argument is present.") - -(defvar teco-exp-flag2 nil - "t if argument before comma is present.") - -(defvar teco-exp-op nil - "Pending arithmetic operation on argument.") - -(defvar teco-exp-stack nil - "Stack for parenthesized expressions.") - -(defvar teco-macro-stack nil - "Stack for macro invocations.") - -(defvar teco-mapch-l nil - "Translation table to lower-case letters.") - - (setq teco-mapch-l (make-vector 256 0)) - (teco-set-elements-index teco-mapch-l 0 255 0) - (teco-set-elements-index teco-mapch-l ?A ?Z (- ?a ?A)) - -(defvar teco-trace nil - "t if tracing is on.") - -(defvar teco-at-flag nil - "t if an @ flag is pending.") - -(defvar teco-colon-flag nil - "1 if a : flag is pending, 2 if a :: flag is pending.") - -(defvar teco-qspec-valid nil - "Flags describing whether a character is a vaid q-register name. -3 means yes, 2 means yes but only for file and search operations.") - - (setq teco-qspec-valid (make-vector 256 0)) - (teco-set-elements teco-qspec-valid ?a ?z 3) - (teco-set-elements teco-qspec-valid ?0 ?9 3) - (aset teco-qspec-valid ?_ 2) - (aset teco-qspec-valid ?* 2) - (aset teco-qspec-valid ?% 2) - (aset teco-qspec-valid ?# 2) - -(defvar teco-exec-flags 0 - "Flags for iteration in process, ei macro, etc.") - -(defvar teco-iteration-stack nil - "Iteration list.") - -(defvar teco-cond-stack nil - "Conditional stack.") - -(defvar teco-qreg-text (make-vector 256 "") - "The text contents of the q-registers.") - -(defvar teco-qreg-number (make-vector 256 0) - "The number contents of the q-registers.") - -(defvar teco-qreg-stack nil - "The stack of saved q-registers.") - -(defconst teco-prompt "*" - "*Prompt to be used when inputting Teco command.") - -(defconst teco-exec-1 (make-vector 256 nil) - "Names of routines handling type 1 characters (characters that are -part of expression processing).") - -(defconst teco-exec-2 (make-vector 256 nil) - "Names of routines handling type 2 characters (characters that are -not part of expression processing).") - -(defvar teco-last-search-string "" - "Last string searched for.") - -(defvar teco-last-search-regexp "" - "Regexp version of teco-last-search-string.") - -(defmacro teco-define-type-1 (char &rest body) - "Define the code to process a type 1 character. -Transforms - (teco-define-type-1 ?x - code ...) -into - (defun teco-type-1-x () - code ...) -and does - (aset teco-exec-1 ?x 'teco-type-1-x)" - (let ((s (intern (concat "teco-type-1-" (char-to-string char))))) - (` (progn - (defun (, s) () - (,@ body)) - (aset teco-exec-1 (, char) '(, s)))))) - -(defmacro teco-define-type-2 (char &rest body) - "Define the code to process a type 2 character. -Transforms - (teco-define-type-2 ?x - code ...) -into - (defun teco-type-2-x () - code ...) -and does - (aset teco-exec-2 ?x 'teco-type-2-x)" - (let ((s (intern (concat "teco-type-2-" (char-to-string char))))) - (` (progn - (defun (, s) () - (,@ body)) - (aset teco-exec-2 (, char) '(, s)))))) - -(defconst teco-char-types (make-vector 256 0) - "Define the characteristics of characters, as tested by \": - 1 alphabetic - 2 alphabetic, $, or . - 4 digit - 8 alphabetic or digit - 16 lower-case alphabetic - 32 upper-case alphabetic") - - (teco-set-elements teco-char-types ?0 ?9 (+ 4 8)) - (teco-set-elements teco-char-types ?A ?Z (+ 1 2 8 32)) - (teco-set-elements teco-char-types ?a ?z (+ 1 2 8 16)) - (aset teco-char-types ?$ 2) - (aset teco-char-types ?. 2) - -(defconst teco-error-texts '(("BNI" . "> not in iteration") - ("CPQ" . "Can't pop Q register") - ("COF" . "Can't open output file ") - ("FNF" . "File not found ") - ("IEC" . "Invalid E character") - ("IFC" . "Invalid F character") - ("IIA" . "Invalid insert arg") - ("ILL" . "Invalid command") - ("ILN" . "Invalid number") - ("IPA" . "Invalid P arg") - ("IQC" . "Invalid \" character") - ("IQN" . "Invalid Q-reg name") - ("IRA" . "Invalid radix arg") - ("ISA" . "Invalid search arg") - ("ISS" . "Invalid search string") - ("IUC" . "Invalid ^ character") - ("LNF" . "Label not found") - ("MEM" . "Insufficient memory available") - ("MRP" . "Missing )") - ("NAB" . "No arg before ^_") - ("NAC" . "No arg before ,") - ("NAE" . "No arg before =") - ("NAP" . "No arg before )") - ("NAQ" . "No arg before \"") - ("NAS" . "No arg before ;") - ("NAU" . "No arg before U") - ("NFI" . "No file for input") - ("NFO" . "No file for output") - ("NYA" . "Numeric arg with Y") - ("OFO" . "Output file already open") - ("PDO" . "Pushdown list overflow") - ("POP" . "Pointer off page") - ("SNI" . "; not in iteration") - ("SRH" . "Search failure ") - ("STL" . "String too long") - ("UTC" . "Unterminated command") - ("UTM" . "Unterminated macro") - ("XAB" . "Execution interrupted") - ("YCA" . "Y command suppressed") - ("IWA" . "Invalid W arg") - ("NFR" . "Numeric arg with FR") - ("INT" . "Internal error") - ("EFI" . "EOF read from std input") - ("IAA" . "Invalid A arg") - )) - -(defconst teco-spec-chars - [ - 0 1 0 0 ; ^@ ^A ^B ^C - 0 64 0 0 ; ^D ^E ^F ^G - 0 2 128 128 ; ^H ^I ^J ^K - 128 0 64 0 ; ^L ^M ^N ^O - 0 64 64 64 ; ^P ^Q ^R ^S - 0 34 0 0 ; ^T ^U ^V ^W - 64 0 0 0 ; ^X ^Y ^Z ^\[ - 0 0 1 0 ; ^\ ^\] ^^ ^_ - 0 1 16 0 ; ! \" # - 0 0 0 16 ; $ % & ' - 0 0 0 0 ; \( \) * + - 0 0 0 0 ; , - . / - 0 0 0 0 ; 0 1 2 3 - 0 0 0 0 ; 4 5 6 7 - 0 0 0 0 ; 8 9 : ; - 16 0 16 0 ; < = > ? - 1 0 12 0 ; @ A B C - 0 1 1 32 ; D E F G - 0 6 0 0 ; H I J K - 0 32 10 2 ; L M N O - 0 32 4 10 ; P Q R S - 0 32 0 4 ; T U V W - 32 0 0 32 ; X Y Z \[ - 0 32 1 6 ; \ \] ^ _ - 0 0 12 0 ; ` a b c - 0 1 1 32 ; d e f g - 0 6 0 0 ; h i j k - 0 32 10 2 ; l m n o - 0 32 4 10 ; p q r s - 0 32 0 4 ; t u v w - 32 0 0 0 ; x y z { - 16 0 0 0 ; | } ~ DEL - ] - "The special properties of characters: - 1 skipto() special character - 2 command with std text argument - 4 E takes a text argument - 8 F takes a text argument - 16 char causes skipto() to exit - 32 command with q-register argument - 64 special char in search string - 128 character is a line separator") - - -(defun teco-execute-command (string) - "Execute teco command string." - ;; Initialize everything - (let ((teco-command-string string) - (teco-command-pointer 0) - (teco-digit-switch nil) - (teco-exp-exp nil) - (teco-exp-val1 nil) - (teco-exp-val2 nil) - (teco-exp-flag1 nil) - (teco-exp-flag2 nil) - (teco-exp-op 'start) - (teco-trace nil) - (teco-at-flag nil) - (teco-colon-flag nil) - (teco-exec-flags 0) - (teco-iteration-stack nil) - (teco-cond-stack nil) - (teco-exp-stack nil) - (teco-macro-stack nil) - (teco-qreg-stack nil)) - ;; initialize output - (teco-out-init) - ;; execute commands - (catch 'teco-exit - (while t - ;; get next command character - (let ((cmdc (teco-get-command0 teco-trace))) - ;; if it's ^, interpret the next character as a control character - (if (eq cmdc ?^) - (setq cmdc (logand (teco-get-command teco-trace) 31))) - (if (and (<= ?0 cmdc) (<= cmdc ?9)) - ;; process a number - (progn - (setq cmdc (- cmdc ?0)) - ;; check for invalid digit - (if (>= cmdc teco-ctrl-r) - (teco-error "ILN")) - (if teco-digit-switch - ;; later digits - (setq teco-exp-val1 (+ (* teco-exp-val1 teco-ctrl-r) cmdc)) - ;; first digit - (setq teco-exp-val1 cmdc) - (setq teco-digit-switch t)) - ;; indicate a value was read in - (setq teco-exp-flag1 t)) - ;; not a digit - (setq teco-digit-switch nil) - ;; cannonicalize the case - (setq cmdc (aref teco-mapch-l cmdc)) - ;; dispatch on the character, if it is a type 1 character - (let ((r (aref teco-exec-1 cmdc))) - (if r - (funcall r) - ;; if a value has been entered, process any pending operation - (if teco-exp-flag1 - (cond ((eq teco-exp-op 'start) - nil) - ((eq teco-exp-op 'add) - (setq teco-exp-val1 (+ teco-exp-exp teco-exp-val1)) - (setq teco-exp-op 'start)) - ((eq teco-exp-op 'sub) - (setq teco-exp-val1 (- teco-exp-exp teco-exp-val1)) - (setq teco-exp-op 'start)) - ((eq teco-exp-op 'mult) - (setq teco-exp-val1 (* teco-exp-exp teco-exp-val1)) - (setq teco-exp-op 'start)) - ((eq teco-exp-op 'div) - (setq teco-exp-val1 - (if (/= teco-exp-val1 0) - (/ teco-exp-exp teco-exp-val1) - 0)) - (setq teco-exp-op 'start)) - ((eq teco-exp-op 'and) - (setq teco-exp-val1 - (logand teco-exp-exp teco-exp-val1)) - (setq teco-exp-op 'start)) - ((eq teco-exp-op 'or) - (setq teco-exp-val1 - (logior teco-exp-exp teco-exp-val1)) - (setq teco-exp-op 'start)))) - ;; dispatch on a type 2 character - (let ((r (aref teco-exec-2 cmdc))) - (if r - (funcall r) - (teco-error "ILL"))))))))))) - -;; Type 1 commands - -(teco-define-type-1 - ?\m ; CR - nil) - -(teco-define-type-1 - ?\n ; LF - nil) - -(teco-define-type-1 - ?\^k ; VT - nil) - -(teco-define-type-1 - ?\^l ; FF - nil) - -(teco-define-type-1 - 32 ; SPC - nil) - -(teco-define-type-1 - ?\e ; ESC - (if (teco-peek-command ?\e) - ;; ESC ESC terminates macro or command - (teco-pop-macro-stack) - ;; otherwise, consume argument - (setq teco-exp-flag1 nil) - (setq teco-exp-op 'start))) - -(teco-define-type-1 - ?! ; ! - (while (/= (teco-get-command teco-trace) ?!) - nil)) - -(teco-define-type-1 - ?@ ; @ - ;; set at-flag - (setq teco-at-flag t)) - -(teco-define-type-1 - ?: ; : - ;; is it '::'? - (if (teco-peek-command ?:) - (progn - ;; skip second colon - (teco-get-command teco-trace) - ;; set flag to show two colons - (setq teco-colon-flag 2)) - ;; set flag to show one colon - (setq teco-colon-flag 1))) - -(teco-define-type-1 - ?? ; ? - ;; toggle trace - (setq teco-trace (not teco-trace))) - -(teco-define-type-1 - ?. ; . - ;; value is point - (setq teco-exp-val1 (point) - teco-exp-flag1 t)) - -(teco-define-type-1 - ?z ; z - ;; value is point-max - (setq teco-exp-val1 (point-max) - teco-exp-flag1 t)) - -(teco-define-type-1 - ?b ; b - ;; value is point-min - (setq teco-exp-val1 (point-min) - teco-exp-flag1 t)) - -(teco-define-type-1 - ?h ; h - ;; value is b,z - (setq teco-exp-val1 (point-max) - teco-exp-val2 (point-min) - teco-exp-flag1 t - teco-exp-flag2 t - teco-exp-op 'start)) - -(teco-define-type-1 - ?\^s ; ^s - ;; value is - length of last insert, etc. - (setq teco-exp-val1 teco-ctrl-s - teco-exp-flag1 t)) - -(teco-define-type-1 - ?\^y ; ^y - ;; value is .+^S,. - (setq teco-exp-val1 (+ (point) teco-ctrl-s) - teco-exp-val2 (point) - teco-exp-flag1 t - teco-exp-flag2 t - teco-exp-op 'start)) - -(teco-define-type-1 - ?\( ; \( - ;; push expression stack - (teco-push-exp-stack) - (setq teco-exp-flag1 nil - teco-exp-flag2 nil - teco-exp-op 'start)) - -(teco-define-type-1 - ?\^p ; ^p - (teco-do-ctrl-p)) - -(teco-define-type-1 - ?\C-^ ; ^^ - ;; get next command character - (setq teco-exp-val1 (teco-get-command teco-trace) - teco-exp-flag1 t)) - - -;; Type 2 commands -(teco-define-type-2 - ?+ ; + - (setq teco-exp-exp (if teco-exp-flag1 teco-exp-val1 0) - teco-exp-flag1 nil - teco-exp-op 'add)) - -(teco-define-type-2 - ?- ; - - (setq teco-exp-exp (if teco-exp-flag1 teco-exp-val1 0) - teco-exp-flag1 nil - teco-exp-op 'sub)) - -(teco-define-type-2 - ?* ; * - (setq teco-exp-exp (if teco-exp-flag1 teco-exp-val1 0) - teco-exp-flag1 nil - teco-exp-op 'mult)) - -(teco-define-type-2 - ?/ ; / - (setq teco-exp-exp (if teco-exp-flag1 teco-exp-val1 0) - teco-exp-flag1 nil - teco-exp-op 'div)) - -(teco-define-type-2 - ?& ; & - (setq teco-exp-exp (if teco-exp-flag1 teco-exp-val1 0) - teco-exp-flag1 nil - teco-exp-op 'and)) - -(teco-define-type-2 - ?# ; # - (setq teco-exp-exp (if teco-exp-flag1 teco-exp-val1 0) - teco-exp-flag1 nil - teco-exp-op 'or)) - -(teco-define-type-2 - ?\) ; \) - (if (or (not teco-exp-flag1) (not teco-exp-stack)) - (teco-error "NAP")) - (let ((v teco-exp-val1)) - (teco-pop-exp-stack) - (setq teco-exp-val1 v - teco-exp-flag1 t))) - -(teco-define-type-2 - ?, ; , - (if (not teco-exp-flag1) - (teco-error "NAC")) - (setq teco-exp-val2 teco-exp-val1 - teco-exp-flag2 t - teco-exp-flag1 nil)) - -(teco-define-type-2 - ?\^_ ; ^_ - (if (not teco-exp-flag1) - (teco-error "NAB") - (setq teco-exp-val1 (lognot teco-exp-val1)))) - -(teco-define-type-2 - ?\^d ; ^d - (setq teco-ctrl-r 10 - teco-exp-flag1 nil - teco-exp-op 'start)) - -(teco-define-type-2 - ?\^o ; ^o - (setq teco-ctrl-r 8 - teco-exp-flag1 nil - teco-exp-op 'start)) - -(teco-define-type-2 - ?\^r ; ^r - (if teco-colon-flag - (progn - (recursive-edit) - (setq teco-colon-flag nil)) - (if teco-exp-flag1 - ;; set radix - (progn - (if (and (/= teco-exp-val1 8) - (/= teco-exp-val1 10) - (/= teco-exp-val1 16)) - (teco-error "IRA")) - (setq teco-ctrl-r teco-exp-val1 - teco-exp-flag1 nil - teco-exp-op 'start)) - ;; get radix - (setq teco-exp-val1 teco-ctrl-r - teco-exp-flag1 t)))) - -(teco-define-type-2 - ?\^c ; ^c - (if (teco-peek-command ?\^c) - ;; ^C^C stops execution - (throw 'teco-exit nil) - (if teco-macro-stack - ;; ^C inside macro exits macro - (teco-pop-macro-stack) - ;; ^C in command stops execution - (throw 'teco-exit nil)))) - -(teco-define-type-2 - ?\^x ; ^x - ;; set/get search mode flag - (teco-set-var 'teco-ctrl-x)) - -(teco-define-type-2 - ?m ; m - (let ((macro-name (teco-get-qspec nil - (teco-get-command teco-trace)))) - (teco-push-macro-stack) - (setq teco-command-string (aref teco-qreg-text macro-name) - teco-command-pointer 0))) - -(teco-define-type-2 - ?< ; < - ;; begin iteration - (if (and teco-exp-flag1 (<= teco-exp-val1 0)) - ;; if this is not to be executed, just skip the - ;; intervening stuff - (teco-find-enditer) - ;; push iteration stack - (teco-push-iter-stack teco-command-pointer - teco-exp-flag1 teco-exp-val1) - ;; consume the argument - (setq teco-exp-flag1 nil))) - -(teco-define-type-2 - ?> ; > - ;; end iteration - (if (not teco-iteration-stack) - (teco-error "BNI")) - ;; decrement count and pop conditionally - (teco-pop-iter-stack nil) - ;; consume arguments - (setq teco-exp-flag1 nil - teco-exp-flag2 nil - teco-exp-op 'start)) - -(teco-define-type-2 - 59 ; ; - ;; semicolon iteration exit - (if (not teco-iteration-stack) - (teco-error "SNI")) - ;; if exit - (if (if (>= (if teco-exp-flag1 - teco-exp-val1 - teco-search-result) 0) - (not teco-colon-flag) - teco-colon-flag) - (progn - (teco-find-enditer) - (teco-pop-iter-stack t))) - ;; consume argument and colon - (setq teco-exp-flag1 nil - teco-colon-flag nil - teco-exp-op 'start)) - -(teco-define-type-2 - ?\" ; \" - ;; must be an argument - (if (not teco-exp-flag1) - (teco-error "NAQ")) - ;; consume argument - (setq teco-exp-flag1 nil - teco-exp-op 'start) - (let* (;; get the test specification - (c (aref teco-mapch-l (teco-get-command teco-trace))) - ;; determine whether the test is true - (test (cond ((eq c ?a) - (/= (logand (aref teco-char-types teco-exp-val1) - 1) 0)) - ((eq c ?c) - (/= (logand (aref teco-char-types teco-exp-val1) - 2) 0)) - ((eq c ?d) - (/= (logand (aref teco-char-types teco-exp-val1) - 4) 0)) - ((or (eq c ?e) (eq c ?f) (eq c ?u) (eq c ?=)) - (= teco-exp-val1 0)) - ((or (eq c ?g) (eq c ?>)) - (> teco-exp-val1 0)) - ((or (eq c ?l) (eq c ?s) (eq c ?t) (eq c ?<)) - (< teco-exp-val1 0)) - ((eq c ?n) - (/= teco-exp-val1 0)) - ((eq c ?r) - (/= (logand (aref teco-char-types teco-exp-val1) - 8) 0)) - ((eq c ?v) - (/= (logand (aref teco-char-types teco-exp-val1) - 16) 0)) - ((eq c ?w) - (/= (logand (aref teco-char-types teco-exp-val1) - 32) 0)) - (t - (teco-error "IQC"))))) - (if (not test) - ;; if the conditional isn't satisfied, read - ;; to matching | or ' - (let ((ll 1) - c) - (while (> ll 0) - (while (progn (setq c (teco-skipto)) - (and (/= c ?\") - (/= c ?|) - (/= c ?\'))) - (if (= c ?\") - (setq ll (1+ ll)) - (if (= c ?\') - (setq ll (1- ll)) - (if (= ll 1) - (break)))))))))) - -(teco-define-type-2 - ?' ; ' - ;; ignore it if executing - t) - -(teco-define-type-2 - ?| ; | - (let ((ll 1) - c) - (while (> ll 0) - (while (progn (setq c (teco-skipto)) - (and (/= c ?\") - (/= c ?\'))) - nil) - (if (= c ?\") - (setq ll (1+ ll)) - (setq ll (1- ll)))))) - -(teco-define-type-2 - ?u ; u - (if (not teco-exp-flag1) - (teco-error "NAU")) - (aset teco-qreg-number - (teco-get-qspec 0 (teco-get-command teco-trace)) - teco-exp-val1) - (setq teco-exp-flag1 teco-exp-flag2 ; command's value is second arg - teco-exp-val1 teco-exp-val2 - teco-exp-flag2 nil - teco-exp-op 'start)) - -(teco-define-type-2 - ?q ; q - ;; Qn is numeric val, :Qn is # of chars, mQn is mth char - (let ((mm (teco-get-qspec (or teco-colon-flag teco-exp-flag1) - (teco-get-command teco-trace)))) - (if (not teco-exp-flag1) - (setq teco-exp-val1 (if teco-colon-flag - ;; :Qn - (length (aref teco-qreg-text mm)) - ;; Qn - (aref teco-qreg-number mm)) - teco-exp-flag1 t) - ;; mQn - (let ((v (aref teco-qreg-text mm))) - (setq teco-exp-val1 (condition-case nil - (aref v teco-exp-val1) - (error -1)) - teco-exp-op 'start))) - (setq teco-colon-flag nil))) - -(teco-define-type-2 - ?% ; % - (let* ((mm (teco-get-qspec nil (teco-get-command teco-trace))) - (v (+ (aref teco-qreg-number mm) (teco-get-value 1)))) - (aset teco-qreg-number mm v) - (setq teco-exp-val1 v - teco-exp-flag1 t))) - -(teco-define-type-2 - ?c ; c - (let ((p (+ (point) (teco-get-value 1)))) - (if (or (< p (point-min)) (> p (point-max))) - (teco-error "POP") - (goto-char p) - (setq teco-exp-flag2 nil)))) - -(teco-define-type-2 - ?r ; r - (let ((p (- (point) (teco-get-value 1)))) - (if (or (< p (point-min)) (> p (point-max))) - (teco-error "POP") - (goto-char p) - (setq teco-exp-flag2 nil)))) - -(teco-define-type-2 - ?j ; j - (let ((p (teco-get-value (point-min)))) - (if (or (< p (point-min)) (> p (point-max))) - (teco-error "POP") - (goto-char p) - (setq teco-exp-flag2 nil)))) - -(teco-define-type-2 - ?l ; l - ;; move forward by lines - (forward-char (teco-lines (teco-get-value 1)))) - -(teco-define-type-2 - ?\C-q ; ^q - ;; number of characters until the nth line feed - (setq teco-exp-val1 (teco-lines (teco-get-value 1)) - teco-exp-flag1 t)) - -(teco-define-type-2 - ?= ; = - ;; print numeric value - (if (not teco-exp-flag1) - (teco-error "NAE")) - (teco-output (format - (if (teco-peek-command ?=) - ;; at least one more = - (progn - ;; read past it - (teco-get-command teco-trace) - (if (teco-peek-command ?=) - ;; another? - (progn - ;; read it too - (teco-get-command teco-trace) - ;; print in hex - "%x") - ;; print in octal - "%o")) - ;; print in decimal - "%d") - teco-exp-val1)) - ;; add newline if no colon - (if (not teco-colon-flag) - (teco-output ?\n)) - ;; absorb argument, etc. - (setq teco-exp-flag1 nil - teco-exp-flag2 nil - teco-colon-flag nil - teco-exp-op 'start)) - -(teco-define-type-2 - ?\t ; TAB - (if exp-flag1 - (teco-error "IIA")) - (let ((text (teco-get-text-arg))) - (insert ?\t text) - (setq teco-ctrl-s (1+ (length text)))) - ;; clear arguments - (setq teco-colon-flag nil - teco-exp-flag1 nil - teco-exp-flag2 nil)) - -(teco-define-type-2 - ?i ; i - (let ((text (teco-get-text-arg))) - (if teco-exp-flag1 - ;; if a nI$ command - (progn - ;; text argument must be null - (or (string-equal text "") (teco-error "IIA")) - ;; insert the character - (insert teco-exp-val1) - (setq teco-ctrl-s 1) - ;; consume argument - (setq teco-exp-op 'start)) - ;; otherwise, insert the text - (insert text) - (setq teco-ctrl-s (length text))) - ;; clear arguments - (setq teco-colon-flag nil - teco-exp-flag1 nil - teco-exp-flag2 nil))) - -(teco-define-type-2 - ?t ; t - (let ((args (teco-line-args nil))) - (teco-output (buffer-substring (car args) (cdr args))))) - -(teco-define-type-2 - ?v ; v - (let ((ll (teco-get-value 1))) - (teco-output (buffer-substring (+ (point) (teco-lines (- 1 ll))) - (+ (point) (teco-lines ll)))))) - -(teco-define-type-2 - ?\C-a ; ^a - (teco-output (teco-get-text-arg nil ?\C-a)) - (setq teco-at-flag nil - teco-colon-flag nil - teco-exp-flag1 nil - teco-exp-flag2 nil - teco-exp-op 'start)) - -(teco-define-type-2 - ?d ; d - (if (not teco-exp-flag2) - ;; if only one argument - (delete-char (teco-get-value 1)) - ;; if two arguments, treat as n,mK - (let ((ll (teco-line-args 1))) - (delete-region (car ll) (cdr ll))))) - -(teco-define-type-2 - ?k ; k - (let ((ll (teco-line-args 1))) - (delete-region (car ll) (cdr ll)))) - -(teco-define-type-2 - ?\C-u ; ^u - (let* ((mm (teco-get-qspec nil (teco-get-command teco-trace))) - (text-arg (teco-get-text-arg)) - (text (if (not teco-exp-flag1) - text-arg - (if (string-equal text-arg "") - (char-to-string teco-exp-val1) - (teco-error "IIA"))))) - ;; if :, append to the register - (aset teco-qreg-text mm (if teco-colon-flag - (concat (aref teco-qreg-text mm) text) - text)) - ;; clear various flags - (setq teco-exp-flag1 nil - teco-at-flag nil - teco-colon-flag nil - teco-exp-flag1 nil))) - -(teco-define-type-2 - ?x ; x - (let* ((mm (teco-get-qspec nil (teco-get-command teco-trace))) - (args (teco-line-args 0)) - (text (buffer-substring (car args) (cdr args)))) - ;; if :, append to the register - (aset teco-qreg-text mm (if teco-colon-flag - (concat (aref teco-qreg-text mm) text) - text)) - ;; clear various flags - (setq teco-exp-flag1 nil - teco-at-flag nil - teco-colon-flag nil - teco-exp-flag1 nil))) - -(teco-define-type-2 - ?g ; g - (let ((mm (teco-get-qspec t (teco-get-command teco-trace)))) - (if teco-colon-flag - (teco-output (aref teco-qreg-text mm)) - (insert (aref teco-qreg-text mm))) - (setq teco-colon-flag nil))) - -(teco-define-type-2 - ?\[ ; \[ - (let ((mm (teco-get-qspec t (teco-get-command teco-trace)))) - (setq teco-qreg-stack - (cons (cons (aref teco-qreg-text mm) - (aref teco-qreg-number mm)) - teco-qreg-stack)))) - -(teco-define-type-2 - ?\] ; \] - (let ((mm (teco-get-qspec t (teco-get-command teco-trace)))) - (if teco-colon-flag - (setq teco-exp-flag1 t - teco-exp-val1 (if teco-qreg-stack -1 0)) - (if teco-qreg-stack - (let ((pop (car teco-qreg-stack))) - (aset teco-qreg-text mm (car pop)) - (aset teco-qreg-number mm (cdr pop)) - (setq teco-qreg-stack (cdr teco-qreg-stack))) - (teco-error "CPQ"))) - (setq teco-colon-flag nil))) - -(teco-define-type-2 - ?\\ ; \ - (if (not teco-exp-flag1) - ;; no argument; read number - (let ((p (point)) - (sign +1) - (n 0) - c) - (setq c (char-after p)) - (if c - (if (= c ?+) - (setq p (1+ p)) - (if (= c ?-) - (setq p (1+ p) - sign -1)))) - (cond - ((= teco-ctrl-r 8) - (while (progn - (setq c (char-after p)) - (and c (>= c ?0) (<= c ?7))) - (setq p (1+ p) - n (+ c -48 (* n 8))))) - ((= teco-ctrl-r 10) - (while (progn - (setq c (char-after p)) - (and c (>= c ?0) (<= c ?9))) - (setq p (1+ p) - n (+ c -48 (* n 10))))) - (t - (while (progn - (setq c (char-after p)) - (and c - (or - (and (>= c ?0) (<= c ?9)) - (and (>= c ?a) (<= c ?f)) - (and (>= c ?A) (<= c ?F))))) - (setq p (1+ p) - n (+ c (if (> c ?F) - ;; convert 'a' to 10 - -87 - (if (> c ?9) - ;; convert 'A' to 10 - -55 - ;; convert '0' to 0 - -48)) - (* n 16)))))) - (setq teco-exp-val1 (* n sign) - teco-exp-flag1 t - teco-ctrl-s (- (point) p))) - ;; argument: insert it as a digit string - (insert (format (cond - ((= teco-ctrl-r 8) "%o") - ((= teco-ctrl-r 10) "%d") - (t "%x")) - teco-exp-val1)) - (setq teco-exp-flag1 nil - teco-exp-op 'start))) - -(teco-define-type-2 - ?\C-t ; ^t - (if teco-exp-flag1 - ;; type a character - (progn - (teco-output teco-exp-val1) - (setq teco-exp-flag1 nil)) - ;; input a character - (let* ((echo-keystrokes 0) - (c (read-char))) - (teco-output c) - (setq teco-exp-val1 c - teco-exp-flag1 t)))) - -(teco-define-type-2 - ?s ; s - (let ((arg (teco-get-text-arg)) - (count (if teco-exp-flag1 teco-expr-val1 1)) - regexp) - (if (not (string-equal arg "")) - (setq regexp (teco-parse-search-string arg) - teco-last-search-string arg - teco-last-search-regexp regexp) - (setq regexp (teco-last-search-regexp) - arg teco-last-search-string)) - (let ((p (point)) - (result (cond - ((> count 0) - (re-search-forward regexp nil t count)) - ((< count 0) - (re-search-backward regexp nil t count)) - (t - ;; 0s always is successful - t)))) - ;; if ::s, restore point - (if (eq teco-colon-flag 2) - (goto-char p)) - ;; if no real or implied colon, error if not found - (if (and (not result) - (not teco-colon-flag) - (/= (teco-peekcmdc) 34)) - (teco-error "SRH")) - ;; set return results - (setq teco-exp-flag2 nil - teco-colon-flag nil - teco-at-flag nil - teco-exp-op 'start) - (if teco-colon-flag - (setq teco-exp-flag1 t - teco-exp-val1 (if result -1 0)) - (setq teco-exp-flag1 nil))))) - -(defun teco-parse-search-string (s) - (let ((i 0) - (l (length s)) - (r "") - c) - (while (< i l) - (setq r (concat r (teco-parse-search-string-1)))) - r)) - -(defun teco-parse-search-string-1 () - (if (>= i l) - (teco-error "ISS")) - (setq c (aref s i)) - (setq i (1+ i)) - (cond - ((eq c ?\C-e) ; ^E - special match characters - (teco-parse-search-string-e)) - ((eq c ?\C-n) ; ^Nx - match all but x - (teco-parse-search-string-n)) - ((eq c ?\C-q) ; ^Qx - use x literally - (teco-parse-search-string-q)) - ((eq c ?\C-s) ; ^S - match separator chars - "[^A-Za-z0-9]") - ((eq c ?\C-x) ; ^X - match any character - "[\000-\377]") - (t ; ordinary character - (teco-parse-search-string-char c)))) - -(defun teco-parse-search-string-char (c) - (regexp-quote (char-to-string c))) - -(defun teco-parse-search-string-q () - (if (>= i l) - (teco-error "ISS")) - (setq c (aref s i)) - (setq i (1+ i)) - (teco-parse-search-string-char c)) - -(defun teco-parse-search-string-e () - (if (>= i l) - (teco-error "ISS")) - (setq c (aref s i)) - (setq i (1+ i)) - (cond - ((or (eq c ?a) (eq c ?A)) ; ^EA - match alphabetics - "[A-Za-z]") - ((or (eq c ?c) (eq c ?C)) ; ^EC - match symbol constituents - "[A-Za-z.$]") - ((or (eq c ?d) (eq c ?D)) ; ^ED - match numerics - "[0-9]") - ((eq c ?g) ; ^EGq - match any char in q-reg - (teco-parse-search-string-e-g)) - ((or (eq c ?l) (eq c ?L)) ; ^EL - match line terminators - "[\012\013\014]") - ((eq c ?q) ; ^EQq - use contents of q-reg - (teco-parse-search-string-e-q)) - ((eq c ?r) ; ^ER - match alphanumerics - "[A-Za-z0-9]") - ((eq c ?s) ; ^ES - match non-null space/tab seq - "[ \t]+") - ((eq c ?v) ; ^EV - match lower case alphabetic - "[a-z]") - ((eq c ?w) ; ^EW - match upper case alphabetic - "[A-Z]") - ((eq c ?x) ; ^EX - match any character - "[\000-\377]") - (t - (teco-error "ISS")))) - -(defun teco-parse-search-string-e-q () - (if (>= i l) - (teco-error "ISS")) - (setq c (aref s i)) - (setq i (1+ i)) - (regexp-quote (aref reco:q-reg-text c))) - -(defun teco-parse-search-string-e-g () - (if (>= i l) - (teco-error "ISS")) - (setq c (aref s i)) - (setq i (1+ i)) - (let* ((q (aref teco-qreg-text c)) - (len (length q)) - (null (= len 0)) - (one-char (= len 1)) - (dash-present (string-match "-" q)) - (caret-present (string-match "\\^" q)) - (outbracket-present (string-match "]" q)) - p) - (cond - (null - "[^\000-\377]") - (one-char - (teco-parse-search-string-char c)) - (t - (while (setq p (string-match "^]\\^")) - (setq q (concat (substring q 1 p) (substring q (1+ p))))) - (concat - "[" - (if outbracket-present "]" "") - (if dash-present "---" "") - q - (if caret-present "^" "")))))) - -(defun teco-parse-search-string-n () - (let ((p (teco-parse-search-string-1))) - (cond - ((= (aref p 0) ?\[) - (if (= (aref p 1) ?^) - ;; complement character set - (if (= (length p) 4) - ;; complement of one character - (teco-parse-search-string-char (aref p 2)) - ;; complement of more than one character - (concat "[" (substring p 2))) - ;; character set - invert it - (concat "[^" (substring p 1)))) - ((= (aref p 0) ?\\) - ;; single quoted character - (concat "[^" (substring p 1) "]")) - (t - ;; single character - (if (string-equal p "-") - "[^---]" - (concat "[^" p "]")))))) - -(teco-define-type-2 - ?o ; o - (let ((label (teco-get-text-arg)) - (index (and teco-exp-flag1 teco-exp-val1))) - (setq teco-exp-flag1 nil) - ;; handle computed goto by extracting the proper label - (if index - (if (< index 0) - ;; argument < 0 is a noop - (setq label "") - ;; otherwise, find the n-th label (0-origin) - (setq label (concat label ",")) - (let ((p 0)) - (while (and (> index 0) - (setq p (string-match "," label p)) - (setq p (1+ p))) - (setq index (1- index))) - (setq q (string-match "," label p)) - (setq label (substring label p q))))) - ;; if the label is non-null, find the correct label - ;; start from beginning of iteration or macro, and look for tag - (setq teco-command-pointer - (if teco-iteration-stack - ;; if in iteration, start at beginning of iteration - (aref (car teco-iteration-stack) 0) - ;; if not in iteration, start at beginning of command or macro - 0)) - ;; search for tag - (catch 'label - (let ((level 0) - c p l) - ;; look for interesting things, including ! - (while t - (setq c (teco-skipto t)) - (cond - ((= c ?<) ; start of iteration - (setq level (1+ level))) - ((= c ?>) ; end of iteration - (if (= level 0) - (teco-pop-iter-stack t) - (setq level (1- level)))) - ((= c ?!) ; start of tag - (setq p (string-match "!" teco-command-string teco-command-pointer)) - (if (and p - (string-equal label (substring teco-command-string - teco-command-pointer - p))) - (progn - (setq teco-command-pointer (1+ p)) - (throw 'label nil)))))))))) - -(teco-define-type-2 - ?a ; :a - ;; 'a' must be used as ':a' - (if (and teco-exp-flag1 teco-colon-flag) - (let ((char (+ (point) teco-exp-val1))) - (setq teco-exp-val1 - (if (and (>= char (point-min)) - (< char (point-max))) - (char-after char) - -1) - teco-colon-flag nil)) - (teco-error "ILL"))) - - -;; Routines to get next character from command buffer -;; getcmdc0, when reading beyond command string, pops -;; macro stack and continues. -;; getcmdc, in similar circumstances, reports an error. -;; If pushcmdc() has returned any chars, read them first -;; routines type characters as read, if argument != 0. - -(defun teco-get-command0 (trace) - ;; get the next character - (let (char) - (while (not (condition-case nil - (setq char (aref teco-command-string teco-command-pointer)) - ;; if we've exhausted the string, pop the macro stack - ;; if we exhaust the macro stack, exit - (error (teco-pop-macro-stack) - nil)))) - ;; bump the command pointer - (setq teco-command-pointer (1+ teco-command-pointer)) - ;; trace, if requested - (and trace (teco-trace-type char)) - ;; return the character - char)) - -;; while (cptr.dot >= cptr.z) /* if at end of this level, pop macro stack -;; { -;; if (--msp < &mstack[0]) /* pop stack; if top level -;; { -;; msp = &mstack[0]; /* restore stack pointer -;; cmdc = ESC; /* return an ESC (ignored) -;; exitflag = 1; /* set to terminate execution -;; return(cmdc); /* exit "while" and return -;; } -;; } -;; cmdc = cptr.p->ch[cptr.c++]; /* get char -;; ++cptr.dot; /* increment character count -;; if (trace) type_char(cmdc); /* trace -;; if (cptr.c > CELLSIZE-1) /* and chain if need be -;; { -;; cptr.p = cptr.p->f; -;; cptr.c = 0; -;; } -;; return(cmdc); -;; } - - -(defun teco-get-command (trace) - ;; get the next character - (let ((char (condition-case nil - (aref teco-command-string teco-command-pointer) - ;; if we've exhausted the string, give error - (error - (teco-error (if teco-macro-stack "UTM" "UTC")))))) - ;; bump the command pointer - (setq teco-command-pointer (1+ teco-command-pointer)) - ;; trace, if requested - (and trace (teco-trace-type char)) - ;; return the character - char)) - -;; char getcmdc(trace) -;; { -;; if (cptr.dot++ >= cptr.z) ERROR((msp <= &mstack[0]) ? E_UTC : E_UTM); -;; else -;; { -;; cmdc = cptr.p->ch[cptr.c++]; /* get char -;; if (trace) type_char(cmdc); /* trace -;; if (cptr.c > CELLSIZE-1) /* and chain if need be -;; { -;; cptr.p = cptr.p->f; -;; cptr.c = 0; -;; } -;; } -;; return(cmdc); -;; } - - -;; peek at next char in command string, return 1 if it is equal -;; (case independent) to argument - -(defun teco-peek-command (arg) - (condition-case nil - (eq (aref teco-mapch-l (aref teco-command-string teco-command-pointer)) - (aref teco-mapch-l arg)) - (error nil))) - -;; int peekcmdc(arg) -;; char arg; -;; { -;; return(((cptr.dot < cptr.z) && (mapch_l[cptr.p->ch[cptr.c]] == mapch_l[arg])) ? 1 : 0); -;; } - -(defun teco-get-text-arg (&optional term-char default-term-char) - ;; figure out what the terminating character is - (setq teco-term-char (or term-char - (if teco-at-flag - (teco-get-command teco-trace) - (or default-term-char - ?\e))) - teco-at_flag nil) - (let ((s "") - c) - (while (progn - (setq c (teco-get-command teco-trace)) - (/= c teco-term-char)) - (setq s (concat s (char-to-string c)))) - s)) - - -;; Routines to manipulate the stacks - -;; Pop the macro stack. Throw to 'teco-exit' if the stack is empty. -(defun teco-pop-macro-stack () - (if teco-macro-stack - (let ((frame (car teco-macro-stack))) - (setq teco-macro-stack (cdr teco-macro-stack) - teco-command-string (aref frame 0) - teco-command-pointer (aref frame 1) - teco-exec-flags (aref frame 2) - teco-iteration-stack (aref frame 3) - teco-cond-stack (aref frame 4))) - (throw 'teco-exit nil))) - -;; Push the macro stack. -(defun teco-push-macro-stack () - (setq teco-macro-stack - (cons (vector teco-command-string - teco-command-pointer - teco-exec-flags - teco-iteration-stack - teco-cond-stack) - teco-macro-stack))) - -;; Pop the expression stack. -(defun teco-pop-exp-stack () - (let ((frame (car teco-exp-stack))) - (setq teco-exp-stack (cdr teco-exp-stack) - teco-exp-val1 (aref frame 0) - teco-exp-flag1 (aref frame 1) - teco-exp-val2 (aref frame 2) - teco-exp-flag2 (aref frame 3) - teco-exp-exp (aref frame 4) - teco-exp-op (aref frame 5)))) - -;; Push the expression stack. -(defun teco-push-exp-stack () - (setq teco-exp-stack - (cons (vector teco-exp-val1 - teco-exp-flag1 - teco-exp-val2 - teco-exp-flag2 - teco-exp-exp - teco-exp-op) - teco-exp-stack))) - -;; Pop the iteration stack -;; if arg t, exit unconditionally -;; else check exit conditions and exit or reiterate -(defun teco-pop-iter-stack (arg) - (let ((frame (car teco-iteration-stack))) - (if (or arg - (not (aref frame 1)) - ;; test against 1, since one iteration has already been done - (<= (aref frame 2) 1)) - ;; exit iteration - (setq teco-iteration-stack (cdr teco-iteration-stack)) - ;; continue with iteration - ;; decrement count - (aset frame 2 (1- (aref frame 2))) - ;; reset command pointer - (setq teco-command-pointer (aref frame 0))))) - -;; Push the iteration stack -(defun teco-push-iter-stack (pointer flag count) - (setq teco-iteration-stack - (cons (vector pointer - flag - count) - teco-iteration-stack))) - -(defun teco-find-enditer () - (let ((icnt 1) - c) - (while (> icnt 0) - (while (progn (setq c (teco-skipto)) - (and (/= c ?<) - (/= c ?>))) - (if (= c ?<) - (setq icnt (1+ icnt)) - (setq icnt (1- icnt))))))) - - -;; I/O routines - -(defvar teco-output-buffer (get-buffer-create "*Teco Output*") - "The buffer into which Teco output is written.") - -(defun teco-out-init () - ;; Recreate the teco output buffer, if necessary - (setq teco-output-buffer (get-buffer-create "*Teco Output*")) - (save-excursion - (set-buffer teco-output-buffer) - ;; get a fresh line in output buffer - (goto-char (point-max)) - (insert ?\n) - ;; remember where to start displaying - (setq teco-output-start (point)) - ;; clear minibuffer, in case we have to display in it - (save-window-excursion - (select-window (minibuffer-window)) - (erase-buffer)) - ;; if output is visible, position it correctly - (let ((w (get-buffer-window teco-output-buffer))) - (if w - (progn - (set-window-start w teco-output-start) - (set-window-point w teco-output-start)))))) - -(defun teco-output (s) - (let ((w (get-buffer-window teco-output-buffer)) - (b (current-buffer)) - (sw (selected-window))) - ;; Put the text in the output buffer - (set-buffer teco-output-buffer) - (goto-char (point-max)) - (insert s) - (let ((p (point))) - (set-buffer b) - (if w - ;; if output is visible, move the window point to the end - (set-window-point w p) - ;; Otherwise, we have to figure out how to display the text - ;; Has a newline followed by another character been added to the - ;; output buffer? If so, we have to make the output buffer visible. - (if (save-excursion - (set-buffer teco-output-buffer) - (backward-char 1) - (search-backward "\n" teco-output-start t)) - ;; a newline has been seen, clear the minibuffer and make the - ;; output buffer visible - (progn - (save-window-excursion - (select-window (minibuffer-window)) - (erase-buffer)) - (let ((pop-up-windows t)) - (pop-to-buffer teco-output-buffer) - (goto-char p) - (set-window-start w teco-output-start) - (set-window-point w p) - (select-window sw))) - ;; a newline has not been seen, add output to minibuffer - (save-window-excursion - (select-window (minibuffer-window)) - (goto-char (point-max)) - (insert s))))))) - -;; Output a character of tracing information -(defun teco-trace-type (c) - (teco-output (if (= c ?\e) - ?$ - c))) - -;; Report an error -(defun teco-error (code) - (let ((text (cdr (assoc code teco-error-texts)))) - (teco-output (concat (if (save-excursion (set-buffer teco-output-buffer) - (/= (point) teco-output-start)) - "\n" - "") - "? " code " " text)) - (beep) - (if debug-on-error (debug nil code text)) - (throw 'teco-exit nil))) - - -;; Utility routines - -;; copy characters from command string to buffer -(defun teco-moveuntil (string pointer terminate trace) - (let ((count 0)) - (condition-case nil - (while (/= (aref string pointer) terminate) - (and teco-trace (teco-trace-type (aref string pointer))) - (insert (aref string pointer)) - (setq pointer (1+ pointer)) - (setq count (1+ count))) - (error (teco-error (if teco-macro-stack "UTM" "UTC")))) - count)) - -;; Convert character to q-register name -;; If file-or-search is t, allow _, *, %, # -(defun teco-get-qspec (file-or-search char) - ;; lower-case char - (setq char (aref teco-mapch-l char)) - ;; test that it's valid - (if (= (logand (aref teco-qspec-valid char) (if file-or-search 2 1)) 0) - (teco-error "IQN")) - char) - -;; Set or get value of a variable -(defun teco-set-var (var) - (if teco-exp-flag1 - (progn - (if teco-exp-flag2 - ;; if two arguments, they they are , - (set var (logior (logand (symbol-value var) (lognot teco-exp-val2)) - teco-exp-val1)) - ;; if one argument, it is the new value - (set var teco-exp-val1)) - ;; consume argument(s) - (setq teco-exp-flag2 nil - teco-exp-flag1 nil)) - ;; if no arguments, fetch the value - (setq teco-exp-val1 (symbol-value var) - teco-exp-flag1 t))) - -;; Get numeric argument -(defun teco-get-value (default) - (prog1 - (if teco-exp-flag1 - teco-exp-val1 - (if (eq teco-exp-op 'sub) - (- default) - default)) - ;; consume argument - (setq teco-exp-flag1 nil - teco-exp-op 'start))) - -;; Get argument measuring in lines -(defun teco-lines (r) - (- (save-excursion - (if (> r 0) - (if (search-forward "\n" nil t r) - (point) - (point-max)) - (if (search-backward "\n" nil t (- 1 r)) - (1+ (point)) - (point-min)))) - (point))) - -;; routine to handle args for K, T, X, etc. -;; if two args, 'char x' to 'char y' -;; if just one arg, then n lines (default 1) -(defun teco-line-args (arg) - (if teco-exp-flag2 - (cons teco-exp-val1 teco-exp-val2) - (cons (point) (+ (point) (teco-lines (if teco-exp-flag1 - teco-exp-val1 - 1)))))) - -;; routine to skip to next ", ', |, <, or > -;; skips over these chars embedded in text strings -;; stops in ! if argument is t -;; returns character found -(defun teco-skipto (&optional arg) - (catch 'teco-skip - (let (;; "at" prefix - (atsw nil) - ;; temp attributes - ta - ;; terminator - term - skipc) - (while t ; forever - (while (progn - (setq skipc (teco-get-command nil) - ta (aref teco-spec-chars skipc)) - ;; if char is ^, treat next char as control - (if (eq skipc ?^) - (setq skipc (logand 31 (teco-get-command nil)) - ta (aref teco-spec-chars skipc))) - (= (logand ta 51) 0)) ; read until something interesting - ; found - nil) - (if (/= (logand ta 32) 0) - (teco-get-command nil)) ; if command takes a Q spec, - ; skip the spec - (if (/= (logand ta 16) 0) ; sought char found: quit - (progn - (if (= skipc ?\") ; quote must skip next char - (teco-get-command nil)) - (throw 'teco-skip skipc))) - (if (/= (logand ta 1) 0) ; other special char - (cond - ((eq skipc ?@) ; use alternative text terminator - (setq atsw t)) - ((eq skipc ?\C-^) ; ^^ is value of next char - ; skip that char - (teco-get-command nil)) - ((eq skipc ?\C-a) ; type text - (setq term (if atsw (teco-get-command nil) ?\C-a) - atsw nil) - (while (/= (teco-get-command nil) term) - nil)) ; skip text - ((eq skipc ?!) ; tag - (if arg - (throw 'teco-skip skipc)) - (while (/= (teco-get-command nil) ?!) - nil)) ; skip until next ! - ((or (eq skipc ?e) - (eq skipc ?f)) ; first char of two-letter E or F - ; command - nil))) ; not implemented - (if (/= (logand ta 2) 0) ; command with a text - ; argument - (progn - (setq term (if atsw (teco-get-command nil) ?\e) - atsw nil) - (while (/= (teco-get-command nil) term) - nil) ; skip text - )))))) - - -(defvar teco-command-keymap - ;; This is what used to be (make-vector 128 'teco-command-self-insert) - ;; Oh well - (let ((map (make-keymap)) (n 127)) - (while (>= n 0) - (define-key map (if (< n 32) (list 'control (+ n 32)) n) - 'teco-command-self-insert) - (setq n (1- n))) - map) - "Keymap used while reading teco commands.") - -(define-key teco-command-keymap "\^g" 'teco-command-ctrl-g) -(define-key teco-command-keymap "\^m" 'teco-command-return) -(define-key teco-command-keymap "\^u" 'teco-command-ctrl-u) -(define-key teco-command-keymap "\e" 'teco-command-escape) -(define-key teco-command-keymap "\^?" 'teco-command-delete) - -(defvar teco-command-escapes nil - "Records where ESCs are, since they are represented in the command buffer -by $.") - -;;;###autoload -(defun teco-command () - "Read and execute a Teco command string." - (interactive) - (let* ((teco-command-escapes nil) - (command (catch 'teco-command-quit - (read-from-minibuffer teco-prompt nil - teco-command-keymap)))) - (if command - (progn - (while teco-command-escapes - (aset command (car teco-command-escapes) ?\e) - (setq teco-command-escapes (cdr teco-command-escapes))) - (setq teco-output-buffer (get-buffer-create "*Teco Output*")) - (save-excursion - (set-buffer teco-output-buffer) - (goto-char (point-max)) - (insert teco-prompt command)) - (teco-execute-command command))))) - -(defun teco-read-command () - "Read a teco command string from the user." - (let ((command (catch 'teco-command-quit - (read-from-minibuffer teco-prompt nil - teco-command-keymap))) - teco-command-escapes) - (if command - (while teco-command-escapes - (aset command (car teco-command-escapes ?\e)) - (setq teco-command-escapes (cdr teco-command-escapes)))) - command)) - -(defun teco-command-self-insert () - (interactive) - (insert last-command-char) - (if (not (pos-visible-in-window-p)) - (enlarge-window 1))) - -(defun teco-command-ctrl-g () - (interactive) - (beep) - (throw 'teco-command-quit nil)) - -(defun teco-command-return () - (interactive) - (setq last-command-char ?\n) - (teco-command-self-insert)) - -(defun teco-command-escape () - (interactive) - ;; Two ESCs in a row terminate the command string - (if (eq last-command 'teco-command-escape) - (throw 'teco-command-quit (buffer-string))) - (setq teco-command-escapes (cons (1- (point)) teco-command-escapes)) - (setq last-command-char ?$) - (teco-command-self-insert)) - -(defun teco-command-ctrl-u () - (interactive) - ;; delete the characters - (kill-line 0) - ;; forget that they were ESCs - (while (and teco-command-escapes (<= (point) (car teco-command-escapes))) - (setq teco-command-escapes (cdr teco-command-escapes))) - ;; decide whether to shrink the window - (while (let ((a (insert ?\n)) - (b (pos-visible-in-window-p)) - (c (backward-delete-char 1))) - b) - (shrink-window 1))) - -(defun teco-command-delete () - (interactive) - ;; delete the character - (backward-delete-char 1) - ;; forget that it was an ESC - (if (and teco-command-escapes (= (point) (car teco-command-escapes))) - (setq teco-command-escapes (cdr teco-command-escapes))) - ;; decide whether to shrink the window - (insert ?\n) - (if (prog1 (pos-visible-in-window-p) - (backward-delete-char 1)) - (shrink-window 1))) - -(provide 'teco) - -;;; teco.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/emulators/tpu-doc.el --- a/lisp/emulators/tpu-doc.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,472 +0,0 @@ -;;; tpu-doc.el --- Documentation for TPU-edt - -;; Copyright (C) 1993 Free Software Foundation, Inc. - -;; Author: Rob Riepel -;; Maintainer: Rob Riepel -;; Keywords: emulations - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -(defconst tpu-doc-revision "!Revision: 1.6 !" - "TPU-edt documentation revision number.") - - -;; This is documentation for the TPU-edt editor for GNU emacs. Major -;; sections of this document are separated with lines that begin with -;; ";; %% ", where is what is discussed in that section. - - -;; %% Contents - -;; % Introduction -;; % Terminal Support -;; % X-windows Support -;; % Differences Between TPU-edt and the Real Thing -;; % Starting TPU-edt -;; % TPU-edt Default Editing Keypad, Control and Gold Key Bindings -;; % Optional TPU-edt Extensions -;; % Customizing TPU-edt using the Emacs Initialization File -;; % Compiling TPU-edt -;; % Regular expressions in TPU-edt -;; % Etcetera - - -;; %% Introduction - -;; TPU-edt is based on tpu.el by Jeff Kowalski. TPU-edt endeavors -;; to be even more like TPU's EDT emulation than the original tpu.el. -;; Considerable effort has been expended to that end. Still, emacs -;; is emacs and there are differences between TPU-edt and the real -;; thing. Please read the "Differences Between TPU-edt and the Real -;; Thing" and "Starting TPU-edt" sections before running TPU-edt. - - -;; %% Terminal Support - -;; TPU-edt, like it's VMS cousin, works on VT-series terminals with -;; DEC style keyboards. VT terminal emulators, including xterm with -;; the appropriate key translations, work just fine too. - - -;; %% X-windows Support - -;; Starting with version 19 of emacs, TPU-edt works with X-windows. -;; This is accomplished through a TPU-edt X keymap. The emacs lisp -;; program tpu-mapper.el creates this map and stores it in a file. -;; Tpu-mapper will be run automatically the first time you invoke -;; the X-windows version of emacs, or you can run it by hand. See -;; the commentary in tpu-mapper.el for details. - - -;; %% Differences Between TPU-edt and the Real Thing (not Coke (r)) - -;; Emacs (version 18.58) doesn't support text highlighting, so selected -;; regions are not shown in inverse video. Emacs uses the concept of -;; "the mark". The mark is set at one end of a selected region; the -;; cursor is at the other. The letter "M" appears in the mode line -;; when the mark is set. The native emacs command ^X^X (Control-X -;; twice) exchanges the cursor with the mark; this provides a handy -;; way to find the location of the mark. - -;; In TPU the cursor can be either bound or free. Bound means the -;; cursor cannot wander outside the text of the file being edited. -;; Free means the arrow keys can move the cursor past the ends of -;; lines. Free is the default mode in TPU; bound is the only mode -;; in EDT. Bound is the only mode in the base version of TPU-edt; -;; optional extensions add an approximation of free mode. - -;; Like TPU, emacs uses multiple buffers. Some buffers are used to -;; hold files you are editing; other "internal" buffers are used for -;; emacs' own purposes (like showing you help). Here are some commands -;; for dealing with buffers. - -;; Gold-B moves to next buffer, including internal buffers -;; Gold-N moves to next buffer containing a file -;; Gold-M brings up a buffer menu (like TPU "show buffers") - -;; Emacs is very fond of throwing up new windows. Dealing with all -;; these windows can be a little confusing at first, so here are a few -;; commands to that may help: - -;; Gold-Next_Scr moves to the next window on the screen -;; Gold-Prev_Scr moves to the previous window on the screen -;; Gold-TAB also moves to the next window on the screen - -;; Control-x 1 deletes all but the current window -;; Control-x 0 deletes the current window - -;; Note that the buffers associated with deleted windows still exist! - -;; Like TPU, TPU-edt has a "command" function, invoked with Gold-KP7 or -;; Do. Most of the commands available are emacs commands. Some TPU -;; commands are available, they are: replace, exit, quit, include, and -;; Get (unfortunately, "get" is an internal emacs function, so we are -;; stuck with "Get" - to make life easier, Get is available as Gold-g). - -;; Support for recall of commands, file names, and search strings was -;; added to emacs in version 19. For version 18 of emacs, optional -;; extensions are available to add this recall capability (see "Optional -;; TPU-edt Extensions" below). The history of strings recalled in both -;; versions of emacs differs slightly from TPU/edt, but it is still very -;; convenient. - -;; Help is available! The traditional help keys (Help and PF2) display -;; a three page help file showing the default keypad layout, control key -;; functions, and Gold key functions. Pressing any key inside of help -;; splits the screen and prints a description of the function of the -;; pressed key. Gold-PF2 invokes the native emacs help, with it's -;; zillions of options. Gold-Help shows all the current key bindings. - -;; Thanks to emacs, TPU-edt has some extensions that may make your life -;; easier, or at least more interesting. For example, Gold-r toggles -;; TPU-edt rectangular mode. In rectangular mode, Remove and Insert work -;; on rectangles. Likewise, Gold-* toggles TPU-edt regular expression -;; mode. In regular expression mode Find, Find Next, and the line-mode -;; replace command work with regular expressions. [A regular expression -;; is a pattern that denotes a set of strings; like VMS wildcards.] - -;; Emacs also gives TPU-edt the undo and occur functions. Undo does -;; what it says; it undoes the last change. Multiple undos in a row -;; undo multiple changes. For your convenience, undo is available on -;; Gold-u. Occur shows all the lines containing a specific string in -;; another window. Moving to that window, and typing ^C^C (Control-C -;; twice) on a particular line moves you back to the original window -;; at that line. Occur is on Gold-o. - -;; Finally, as you edit, remember that all the power of emacs is at -;; your disposal. It really is a fantastic tool. You may even want to -;; take some time and read the emacs tutorial; perhaps not to learn the -;; native emacs key bindings, but to get a feel for all the things -;; emacs can do for you. The emacs tutorial is available from the -;; emacs help function: "Gold-PF2 t" - - -;; %% Starting TPU-edt - -;; In order to use TPU-edt, the TPU-edt editor definitions, contained -;; in tpu-edt.el, need to be loaded when emacs is run. This can be -;; done in a couple of ways. The first is by explicitly requesting -;; loading of the TPU-edt emacs definition file on the command line: - -;; prompt> emacs -l /path/to/definitions/tpu-edt.el - -;; If TPU-edt is installed on your system, that is, if tpu-edt.el is in -;; a directory like /usr/local/emacs/lisp, along with dozens of other -;; .el files, you should be able to use the command: - -;; prompt> emacs -l tpu-edt - -;; If you like TPU-edt and want to use it all the time, you can load -;; the TPU-edt definitions using the emacs initialization file, .emacs. -;; Simply create a .emacs file in your home directory containing the -;; line: - -;; (load "/path/to/definitions/tpu-edt") - -;; or, if (as above) TPU-edt is installed on your system: - -;; (load "tpu-edt") - -;; Once TPU-edt has been loaded, you will be using an editor with the -;; interface shown in the next section (A section that is suitable for -;; cutting out of this document and pasting next to your terminal!). - - -;; %% TPU-edt Default Editing Keypad, Control and Gold Key Bindings -;; -;; _______________________ _______________________________ -;; | HELP | Do | | | | | | -;; |KeyDefs| | | | | | | -;; |_______|_______________| |_______|_______|_______|_______| -;; _______________________ _______________________________ -;; | Find |Insert |Remove | | Gold | HELP |FndNxt | Del L | -;; | | |Sto Tex| | key |E-Help | Find |Undel L| -;; |_______|_______|_______| |_______|_______|_______|_______| -;; |Select |Pre Scr|Nex Scr| | Page | Sect |Append | Del W | -;; | Reset |Pre Win|Nex Win| | Do | Fill |Replace|Undel W| -;; |_______|_______|_______| |_______|_______|_______|_______| -;; |Move up| |Forward|Reverse|Remove | Del C | -;; | Top | |Bottom | Top |Insert |Undel C| -;; _______|_______|_______ |_______|_______|_______|_______| -;; |Mov Lef|Mov Dow|Mov Rig| | Word | EOL | Char | | -;; |StaOfLi|Bottom |EndOfLi| |ChngCas|Del EOL|SpecIns| Enter | -;; |_______|_______|_______| |_______|_______|_______| | -;; | Line |Select | Subs | -;; | Open Line | Reset | | -;; |_______________|_______|_______| -;; Control Characters -;; -;; ^A toggle insert and overwrite ^L insert page break -;; ^B recall ^R remember, re-center -;; ^E end of line ^U delete to beginning of line -;; ^G cancel current operation ^V quote -;; ^H beginning of line ^W refresh -;; ^J delete previous word ^Z exit -;; ^K learn ^X^X exchange point and mark -;; -;; -;; Gold- Functions -;; ----------------------------------------------------------------- -;; W Write - save current buffer -;; K Kill buffer - abandon edits and delete buffer -;; -;; E Exit - save current buffer and ask about others -;; X eXit - save all modified buffers and exit -;; Q Quit - exit without saving anything -;; -;; G Get - load a file into a new edit buffer -;; I Include - include a file in this buffer -;; -;; B next Buffer - display the next buffer (all buffers) -;; N Next file buffer - display next buffer containing a file -;; M buffer Menu - display a list of all buffers -;; -;; U Undo - undo the last edit -;; C Recall - edit and possibly repeat previous commands -;; -;; O Occur - show following lines containing REGEXP -;; S Search and substitute - line mode REPLACE command -;; -;; ? Spell check - check spelling in a region or entire buffer -;; -;; R Toggle Rectangular mode for remove and insert -;; * Toggle regular expression mode for search and substitute -;; -;; V Show TPU-edt version -;; ----------------------------------------------------------------- - - -;; %% Optional TPU-edt Extensions - -;; Several optional packages have been included in this distribution -;; of TPU-edt. The following is a brief description of each package. -;; See the {package}.el file for more detailed information and usage -;; instructions. - -;; tpu-extras - TPU/edt scroll margins and free cursor mode. -;; tpu-recall - String, file name, and command history. -;; vt-control - VTxxx terminal width and keypad controls. - -;; Packages are normally loaded from the emacs initialization file -;; (discussed below). If a package is not installed in the emacs -;; lisp directory, it can be loaded by specifying the complete path -;; to the package file. However, it is preferable to modify the -;; emacs load-path variable to include the directory where packages -;; are stored. This way, packages can be loaded by name, just as if -;; they were installed. The first part of the sample .emacs file -;; below shows how to make such a modification. - - -;; %% Customizing TPU-edt using the Emacs Initialization File - -;; .emacs - a sample emacs initialization file - -;; This is a sample emacs initialization file. It shows how to invoke -;; TPU-edt, and how to customize it. - -;; The load-path is where emacs looks for files to fulfill load requests. -;; If TPU-edt is not installed in a standard emacs directory, the load-path -;; should be updated to include the directory where the TPU-edt files are -;; stored. Modify and un-comment the following section if TPU-ed is not -;; installed on your system - be sure to leave the double quotes! - -;; (setq load-path -;; (append (list (expand-file-name "/path/to/tpu-edt/files")) -;; load-path)) - -;; Load TPU-edt -(load "tpu-edt") - -;; Load the optional goodies - scroll margins, free cursor mode, command -;; and string recall. But don't complain if the file aren't available. -(load "tpu-extras" t) -(load "tpu-recall" t) - -;; Uncomment this line to set scroll margins 10% (top) and 15% (bottom). -;(and (fboundp 'tpu-set-scroll-margins) (tpu-set-scroll-margins "10%" "15%")) - -;; Load the vtxxx terminal control functions, but don't complain if -;; the file is not found. -(load "vt-control" t) - -;; TPU-edt treats words like EDT; here's how to add word separators. -;; Note that backslash (\) and double quote (") are quoted with '\'. -(tpu-add-word-separators "]\\[-_,.\"=+()'/*#:!&;$") - -;; Emacs is happy to save files without a final newline; other Unix programs -;; hate that! This line will make sure that files end with newlines. -(setq require-final-newline t) - -;; Emacs has the ability to automatically run code embedded in files -;; you edit. This line makes emacs ask if you want to run the code. -(if tpu-emacs19-p (setq enable-local-variables "ask") - (setq inhibit-local-variables t)) - -;; Emacs uses Control-s and Control-q. Problems can occur when using emacs -;; on terminals that use these codes for flow control (Xon/Xoff flow control). -;; These lines disable emacs' use of these characters. -(global-unset-key "\C-s") -(global-unset-key "\C-q") - -;; top, bottom, bol, eol seem like a waste of Gold-arrow functions. The -;; following section re-maps up and down arrow keys to top and bottom of -;; screen, and left and right arrow keys to pan left and right (pan-left, -;; right moves the screen 16 characters left or right - try it, you'll -;; like it!). - -;; Re-map the Gold-arrow functions -(define-key GOLD-CSI-map "A" 'tpu-beginning-of-window) ; up-arrow -(define-key GOLD-CSI-map "B" 'tpu-end-of-window) ; down-arrow -(define-key GOLD-CSI-map "C" 'tpu-pan-right) ; right-arrow -(define-key GOLD-CSI-map "D" 'tpu-pan-left) ; left-arrow -(define-key GOLD-SS3-map "A" 'tpu-beginning-of-window) ; up-arrow -(define-key GOLD-SS3-map "B" 'tpu-end-of-window) ; down-arrow -(define-key GOLD-SS3-map "C" 'tpu-pan-right) ; right-arrow -(define-key GOLD-SS3-map "D" 'tpu-pan-left) ; left-arrow - -;; Re-map the Gold-arrow functions for X-windows TPU-edt (emacs version 19) -(cond - ((and tpu-emacs19-p window-system) - (define-key GOLD-map [up] 'tpu-beginning-of-window) ; up-arrow - (define-key GOLD-map [down] 'tpu-end-of-window) ; down-arrow - (define-key GOLD-map [right] 'tpu-pan-right) ; right-arrow - (define-key GOLD-map [left] 'tpu-pan-left))) ; left-arrow - -;; The emacs universal-argument function is very useful for native emacs -;; commands. This line maps universal-argument to Gold-PF1 -(define-key GOLD-SS3-map "P" 'universal-argument) ; Gold-PF1 - -;; Make KP7 move by paragraphs, instead of pages. -(define-key SS3-map "w" 'tpu-paragraph) ; KP7 - -;; TPU-edt assumes you have the ispell spelling checker; -;; Un-comment this line if you don't. -;(setq tpu-have-spell nil) - -;; Display the TPU-edt version. -(tpu-version) - -;; End of .emacs - a sample emacs initialization file - -;; After initialization with the .emacs file shown above, the editing -;; keys have been re-mapped to look like this: - -;; _______________________ _______________________________ -;; | HELP | Do | | | | | | -;; |KeyDefs| | | | | | | -;; |_______|_______________| |_______|_______|_______|_______| -;; _______________________ _______________________________ -;; | Find |Insert |Remove | | Gold | HELP |FndNxt | Del L | -;; | | |Sto Tex| | U Arg |E-Help | Find |Undel L| -;; |_______|_______|_______| |_______|_______|_______|_______| -;; |Select |Pre Scr|Nex Scr| |Paragra| Sect |Append | Del W | -;; | Reset |Pre Win|Nex Win| | Do | Fill |Replace|Undel W| -;; |_______|_______|_______| |_______|_______|_______|_______| -;; |Move up| |Forward|Reverse|Remove | Del C | -;; |Tscreen| |Bottom | Top |Insert |Undel C| -;; _______|_______|_______ |_______|_______|_______|_______| -;; |Mov Lef|Mov Dow|Mov Rig| | Word | EOL | Char | | -;; |PanLeft|Bscreen|PanRigh| |ChngCas|Del EOL|SpecIns| Enter | -;; |_______|_______|_______| |_______|_______|_______| | -;; | Line |Select | Subs | -;; | Open Line | Reset | | -;; |_______________|_______|_______| - -;; Astute emacs hackers will realize that on systems where TPU-edt is -;; installed, this documentation file can be loaded to produce the above -;; editing keypad layout. In fact, to get all the changes in the sample -;; initialization file, you only need a one line initialization file: - -;; (load "tpu-doc") - -;; wow! - - -;; %% Compiling TPU-edt - -;; It is not necessary to compile (byte-compile in emacs parlance) -;; TPU-edt to use it. However, byte-compiled code loads and runs -;; faster, and takes up less memory when loaded. To byte compile -;; TPU-edt, use the following command. - -;; emacs -batch -f batch-byte-compile tpu-edt.el - -;; This will produce a file named tpu-edt.elc. This new file can be -;; used in place of the original tpu-edt.el file. In commands where -;; the file type is not specified, emacs always attempts to use the -;; byte-compiled version before resorting to the source. - - -;; %% Regular expressions in TPU-edt - -;; Gold-* toggles TPU-edt regular expression mode. In regular expression -;; mode, find, find next, replace, and substitute accept emacs regular -;; expressions. A complete list of emacs regular expressions can be -;; found using the emacs "info" command (it's somewhat like the VMS help -;; command). Try the following sequence of commands: - -;; DO info -;; m regex - -;; Type "q" to quit out of info mode. - -;; There is a problem in regular expression mode when searching for -;; empty strings, like beginning-of-line (^) and end-of-line ($). -;; When searching for these strings, find-next may find the current -;; string, instead of the next one. This can cause global replace and -;; substitute commands to loop forever in the same location. For this -;; reason, commands like - -;; replace "^" "> " " to beginning of line> -;; replace "$" "00711" - -;; may not work properly. - -;; Commands like those above are very useful for adding text to the -;; beginning or end of lines. They might work on a line-by-line basis, -;; but go into an infinite loop if the "all" response is specified. If -;; the goal is to add a string to the beginning or end of a particular -;; set of lines TPU-edt provides functions to do this. - -;; Gold-^ Add a string at BOL in region or buffer -;; Gold-$ Add a string at EOL in region or buffer - -;; There is also a TPU-edt interface to the native emacs string -;; replacement commands. Gold-/ invokes this command. It accepts -;; regular expressions if TPU-edt is in regular expression mode. Given -;; a repeat count, it will perform the replacement without prompting -;; for confirmation. - -;; This command replaces empty strings correctly, however, it has its -;; drawbacks. As a native emacs command, it has a different interface -;; than the emulated TPU commands. Also, it works only in the forward -;; direction, regardless of the current TPU-edt direction. - - -;; %% Etcetera - -;; That's TPU-edt in a nutshell... - -;; Please send any bug reports, feature requests, or cookies to the -;; author, Rob Riepel, at the address shown by the tpu-version command -;; (Gold-V). - -;; Share and enjoy... Rob Riepel 7/93 - -;;; tpu-doc.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/emulators/tpu-edt.el --- a/lisp/emulators/tpu-edt.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2594 +0,0 @@ -;;; tpu-edt.el --- Emacs emulating TPU emulating EDT - -;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc. - -;; Author: Rob Riepel -;; Maintainer: Rob Riepel -;; Version: 4.2 -;; Keywords: emulations - -;; This file is part of XEmacs. -;; Modified for XEmacs by Kevin Oberman - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synced up with FSF 19.34 and XEmacs 19.16 - -;; TPU-edt is based on tpu.el by Jeff Kowalski and Bob Covey. - -;;; Commentary: - -;; %% TPU-edt -- Emacs emulating TPU emulating EDT - -;; %% Contents - -;; % Introduction -;; % Differences Between TPU-edt and DEC TPU/edt -;; % Starting TPU-edt -;; % Customizing TPU-edt using the Emacs Initialization File -;; % Regular Expressions in TPU-edt - - -;; %% Introduction - -;; TPU-edt emulates the popular DEC VMS editor EDT (actually, it emulates -;; DEC TPU's EDT emulation, hence the name TPU-edt). TPU-edt features the -;; following TPU/edt functionality: - -;; . EDT keypad -;; . On-line help -;; . Repeat counts -;; . Scroll margins -;; . Learn sequences -;; . Free cursor mode -;; . Rectangular cut and paste -;; . Multiple windows and buffers -;; . TPU line-mode REPLACE command -;; . Wild card search and substitution -;; . Configurable through an initialization file -;; . History recall of search strings, file names, and commands - -;; Please note that TPU-edt does NOT emulate TPU. It emulates TPU's EDT -;; emulation. Very few TPU line-mode commands are supported. - -;; TPU-edt, like its VMS cousin, works on VT-series terminals with DEC -;; style keyboards. VT terminal emulators, including xterm with the -;; appropriate key translations, work just fine too. - -;; TPU-edt works with X-windows. This is accomplished through a TPU-edt X -;; key map. The TPU-edt module tpu-mapper creates this map and stores it -;; in a file. Tpu-mapper will be run automatically the first time you -;; invoke the X-windows version of emacs, or you can run it by hand. See -;; the commentary in tpu-mapper.el for details. - - -;; %% Differences Between TPU-edt and DEC TPU/edt - -;; In some cases, Emacs doesn't support text highlighting, so selected -;; regions are not shown in inverse video. Emacs uses the concept of "the -;; mark". The mark is set at one end of a selected region; the cursor is -;; at the other. The letter "M" appears in the mode line when the mark is -;; set. The native emacs command ^X^X (Control-X twice) exchanges the -;; cursor with the mark; this provides a handy way to find the location of -;; the mark. - -;; In TPU the cursor can be either bound or free. Bound means the cursor -;; cannot wander outside the text of the file being edited. Free means -;; the arrow keys can move the cursor past the ends of lines. Free is the -;; default mode in TPU; bound is the only mode in EDT. Bound is the only -;; mode in the base version of TPU-edt; optional extensions add an -;; approximation of free mode, see the commentary in tpu-extras.el for -;; details. - -;; Like TPU, emacs uses multiple buffers. Some buffers are used to hold -;; files you are editing; other "internal" buffers are used for emacs' own -;; purposes (like showing you help). Here are some commands for dealing -;; with buffers. - -;; Gold-B moves to next buffer, including internal buffers -;; Gold-N moves to next buffer containing a file -;; Gold-M brings up a buffer menu (like TPU "show buffers") - -;; Emacs is very fond of throwing up new windows. Dealing with all these -;; windows can be a little confusing at first, so here are a few commands -;; to that may help: - -;; Gold-Next_Scr moves to the next window on the screen -;; Gold-Prev_Scr moves to the previous window on the screen -;; Gold-TAB also moves to the next window on the screen - -;; Control-x 1 deletes all but the current window -;; Control-x 0 deletes the current window - -;; Note that the buffers associated with deleted windows still exist! - -;; Like TPU, TPU-edt has a "command" function, invoked with Gold-KP7 or -;; Do. Most of the commands available are emacs commands. Some TPU -;; commands are available, they are: replace, exit, quit, include, and -;; Get (unfortunately, "get" is an internal emacs function, so we are -;; stuck with "Get" - to make life easier, Get is available as Gold-g). - -;; TPU-edt supports the recall of commands, file names, and search -;; strings. The history of strings recalled differs slightly from -;; TPU/edt, but it is still very convenient. - -;; Help is available! The traditional help keys (Help and PF2) display -;; a small help file showing the default keypad layout, control key -;; functions, and Gold key functions. Pressing any key inside of help -;; splits the screen and prints a description of the function of the -;; pressed key. Gold-PF2 invokes the native emacs help, with its -;; zillions of options. - -;; Thanks to emacs, TPU-edt has some extensions that may make your life -;; easier, or at least more interesting. For example, Gold-r toggles -;; TPU-edt rectangular mode. In rectangular mode, Remove and Insert work -;; on rectangles. Likewise, Gold-* toggles TPU-edt regular expression -;; mode. In regular expression mode Find, Find Next, and the line-mode -;; replace command work with regular expressions. [A regular expression -;; is a pattern that denotes a set of strings; like VMS wildcards.] - -;; Emacs also gives TPU-edt the undo and occur functions. Undo does -;; what it says; it undoes the last change. Multiple undos in a row -;; undo multiple changes. For your convenience, undo is available on -;; Gold-u. Occur shows all the lines containing a specific string in -;; another window. Moving to that window, and typing ^C^C (Control-C -;; twice) on a particular line moves you back to the original window -;; at that line. Occur is on Gold-o. - -;; Finally, as you edit, remember that all the power of emacs is at -;; your disposal. It really is a fantastic tool. You may even want to -;; take some time and read the emacs tutorial; perhaps not to learn the -;; native emacs key bindings, but to get a feel for all the things -;; emacs can do for you. The emacs tutorial is available from the -;; emacs help function: "Gold-PF2 t" - - -;; %% Starting TPU-edt - -;; All you have to do to start TPU-edt, is turn it on. This can be -;; done from the command line when running emacs. - -;; prompt> emacs -f tpu-edt - -;; If you've already started emacs, turn on TPU-edt using the tpu-edt -;; command. First press `M-x' (that's usually `ESC' followed by `x') -;; and type `tpu-edt' followed by a carriage return. - -;; If you like TPU-edt and want to use it all the time, you can start -;; TPU-edt using the emacs initialization file, .emacs. Simply create -;; a .emacs file in your home directory containing the line: - -;; (tpu-edt) - -;; That's all you need to do to start TPU-edt. - - -;; %% Customizing TPU-edt using the Emacs Initialization File - -;; The following is a sample emacs initialization file. It shows how to -;; invoke TPU-edt, and how to customize it. - -;; ; .emacs - a sample emacs initialization file - -;; ; Turn on TPU-edt -;; (tpu-edt) - -;; ; Set scroll margins 10% (top) and 15% (bottom). -;; (tpu-set-scroll-margins "10%" "15%") - -;; ; Load the vtxxx terminal control functions. -;; (load "vt-control" t) - -;; ; TPU-edt treats words like EDT; here's how to add word separators. -;; ; Note that backslash (\) and double quote (") are quoted with '\'. -;; (tpu-add-word-separators "]\\[-_,.\"=+()'/*#:!&;$") - -;; ; Emacs is happy to save files without a final newline; other Unix -;; ; programs hate that! Here we make sure that files end with newlines. -;; (setq require-final-newline t) - -;; ; Emacs uses Control-s and Control-q. Problems can occur when using -;; ; emacs on terminals that use these codes for flow control (Xon/Xoff -;; ; flow control). These lines disable emacs' use of these characters. -;; (global-unset-key "\C-s") -;; (global-unset-key "\C-q") - -;; ; The emacs universal-argument function is very useful. -;; ; This line maps universal-argument to Gold-PF1. -;; (define-key GOLD-SS3-map "P" 'universal-argument) ; Gold-PF1 - -;; ; Make KP7 move by paragraphs, instead of pages. -;; (define-key SS3-map "w" 'tpu-paragraph) ; KP7 - -;; ; Repeat the preceding mappings for X-windows. -;; (cond -;; (window-system -;; (global-set-key [kp_7] 'tpu-paragraph) ; KP7 -;; (define-key GOLD-map [kp_f1] 'universal-argument))) ; GOLD-PF1 - -;; ; Display the TPU-edt version. -;; (tpu-version) - - -;; %% Regular Expressions in TPU-edt - -;; Gold-* toggles TPU-edt regular expression mode. In regular expression -;; mode, find, find next, replace, and substitute accept emacs regular -;; expressions. A complete list of emacs regular expressions can be found -;; using the emacs "info" command (it's somewhat like the VMS help -;; command). Try the following sequence of commands: - -;; DO info -;; m emacs - -;; Type "q" to quit out of info mode. - -;; There is a problem in regular expression mode when searching for empty -;; strings, like beginning-of-line (^) and end-of-line ($). When searching -;; for these strings, find-next may find the current string, instead of the -;; next one. This can cause global replace and substitute commands to loop -;; forever in the same location. For this reason, commands like - -;; replace "^" "> " " to beginning of line> -;; replace "$" "00711" - -;; may not work properly. - -;; Commands like those above are very useful for adding text to the -;; beginning or end of lines. They might work on a line-by-line basis, but -;; go into an infinite loop if the "all" response is specified. If the -;; goal is to add a string to the beginning or end of a particular set of -;; lines TPU-edt provides functions to do this. - -;; Gold-^ Add a string at BOL in region or buffer -;; Gold-$ Add a string at EOL in region or buffer - -;; There is also a TPU-edt interface to the native emacs string replacement -;; commands. Gold-/ invokes this command. It accepts regular expressions -;; if TPU-edt is in regular expression mode. Given a repeat count, it will -;; perform the replacement without prompting for confirmation. - -;; This command replaces empty strings correctly, however, it has its -;; drawbacks. As a native emacs command, it has a different interface -;; than the emulated TPU commands. Also, it works only in the forward -;; direction, regardless of the current TPU-edt direction. - -;;; Code: - - -;;; -;;; Version Information -;;; -(defconst tpu-version "4.2X" "TPU-edt version number.") - - -;;; -;;; User Configurable Variables -;;; -(defconst tpu-have-ispell t - "*If non-nil (default), TPU-edt uses ispell for spell checking.") - -(defconst tpu-kill-buffers-silently nil - "*If non-nil, TPU-edt kills modified buffers without asking.") - -(defvar tpu-percent-scroll 75 - "*Percentage of the screen to scroll for next/previous screen commands.") - -(defvar tpu-pan-columns 16 - "*Number of columns the tpu-pan functions scroll left or right.") - - -;;; -;;; Emacs version identifiers - currently referenced by -;;; -;;; o tpu-mark o tpu-set-mark -;;; o tpu-string-prompt o tpu-regexp-prompt -;;; o tpu-edt-on o tpu-load-xkeys -;;; o tpu-update-mode-line o mode line section -;;; -(defconst tpu-emacs19-p (not (string-lessp emacs-version "19")) - "Non-nil if we are running Lucid Emacs or version 19.") - -(defconst tpu-lucid-emacs19-p - (and tpu-emacs19-p (string-match "Lucid" emacs-version)) - "Non-nil if we are running Lucid Emacs version 19.") - - -;;; -;;; Global Keymaps -;;; -(defvar CSI-map (make-sparse-keymap) - "Maps the CSI function keys on the VT100 keyboard. -CSI is DEC's name for the sequence [.") - -(defvar SS3-map (make-sparse-keymap) - "Maps the SS3 function keys on the VT100 keyboard. -SS3 is DEC's name for the sequence O.") - -(defvar GOLD-map (make-keymap) - "Maps the function keys on the VT100 keyboard preceded by PF1. -GOLD is the ASCII 7-bit escape sequence OP.") - -(defvar GOLD-CSI-map (make-sparse-keymap) - "Maps the function keys on the VT100 keyboard preceded by GOLD-CSI.") - -(defvar GOLD-SS3-map (make-sparse-keymap) - "Maps the function keys on the VT100 keyboard preceded by GOLD-SS3.") - -(defvar tpu-global-map nil "TPU-edt global keymap.") -(defvar tpu-original-global-map (copy-keymap global-map) - "Original global keymap.") - -(and tpu-lucid-emacs19-p - (defvar minibuffer-local-ns-map (make-sparse-keymap) - "Hack to give Lucid Emacs the same maps as ordinary Emacs.")) - - -;;; -;;; Global Variables -;;; -(defvar tpu-edt-mode nil - "If non-nil, TPU-edt mode is active.") - -(defvar tpu-last-replaced-text "" - "Last text deleted by a TPU-edt replace command.") -(defvar tpu-last-deleted-region "" - "Last text deleted by a TPU-edt remove command.") -(defvar tpu-last-deleted-lines "" - "Last text deleted by a TPU-edt line-delete command.") -(defvar tpu-last-deleted-words "" - "Last text deleted by a TPU-edt word-delete command.") -(defvar tpu-last-deleted-char "" - "Last character deleted by a TPU-edt character-delete command.") - -(defvar tpu-searching-forward t - "If non-nil, TPU-edt is searching in the forward direction.") -(defvar tpu-search-last-string "" - "Last text searched for by the TPU-edt search commands.") - -(defvar tpu-regexp-p nil - "If non-nil, TPU-edt uses regexp search and replace routines.") -(defvar tpu-rectangular-p nil - "If non-nil, TPU-edt removes and inserts rectangles.") -(defvar tpu-advance t - "True when TPU-edt is operating in the forward direction.") -(defvar tpu-reverse nil - "True when TPU-edt is operating in the backward direction.") -(defvar tpu-control-keys nil - "If non-nil, control keys are set to perform TPU functions.") -(defvar tpu-xkeys-file nil - "File containing TPU-edt X key map.") - -(defvar tpu-rectangle-string nil - "Mode line string to identify rectangular mode.") -(defvar tpu-direction-string nil - "Mode line string to identify current direction.") - -(defvar tpu-add-at-bol-hist nil - "History variable for tpu-edt-add-at-bol function.") -(defvar tpu-add-at-eol-hist nil - "History variable for tpu-edt-add-at-eol function.") -(defvar tpu-regexp-prompt-hist nil - "History variable for search and replace functions.") - - -;;; -;;; Buffer Local Variables -;;; -(defvar tpu-newline-and-indent-p nil - "If non-nil, Return produces a newline and indents.") -(make-variable-buffer-local 'tpu-newline-and-indent-p) - -(defvar tpu-newline-and-indent-string nil - "Mode line string to identify AutoIndent mode.") -(make-variable-buffer-local 'tpu-newline-and-indent-string) - -(defvar tpu-saved-delete-func nil - "Saved value of the delete key.") -(make-variable-buffer-local 'tpu-saved-delete-func) - -(defvar tpu-buffer-local-map nil - "TPU-edt buffer local key map.") -(make-variable-buffer-local 'tpu-buffer-local-map) - - -;;; -;;; Mode Line - Modify the mode line to show the following -;;; -;;; o If the mark is set. -;;; o Direction of motion. -;;; o Active rectangle mode. -;;; -(defvar tpu-original-mode-line mode-line-format) -(defvar tpu-original-mm-alist minor-mode-alist) - -(defvar tpu-mark-flag " ") -(make-variable-buffer-local 'tpu-mark-flag) - -(defun tpu-set-mode-line (for-tpu) - "Set the mode for TPU-edt, or reset it to default Emacs." - (cond ((not for-tpu) - (setq mode-line-format tpu-original-mode-line) - (setq minor-mode-alist tpu-original-mm-alist)) - (t - (setq-default mode-line-format - (list (purecopy "-") - 'mode-line-modified - 'mode-line-frame-identification - 'mode-line-buffer-identification - (purecopy " ") - 'global-mode-string - (purecopy " ") - 'tpu-mark-flag - (purecopy " %[(") - 'mode-name 'mode-line-process 'minor-mode-alist - (purecopy "%n") - (purecopy ")%]--") - (purecopy '(line-number-mode "L%l--")) - (purecopy '(column-number-mode "C%c--")) - (purecopy '(-3 . "%p")) - (purecopy "-%-"))) - (or (assq 'tpu-newline-and-indent-p minor-mode-alist) - (setq minor-mode-alist - (cons '(tpu-newline-and-indent-p - tpu-newline-and-indent-string) - minor-mode-alist))) - (or (assq 'tpu-rectangular-p minor-mode-alist) - (setq minor-mode-alist - (cons '(tpu-rectangular-p tpu-rectangle-string) - minor-mode-alist))) - (or (assq 'tpu-direction-string minor-mode-alist) - (setq minor-mode-alist - (cons '(tpu-direction-string tpu-direction-string) - minor-mode-alist)))))) - -(defun tpu-update-mode-line nil - "Make sure mode-line in the current buffer reflects all changes." - (setq tpu-mark-flag (if (tpu-mark) "M" " ")) - (cond (tpu-emacs19-p (force-mode-line-update)) - (t (set-buffer-modified-p (buffer-modified-p)) (sit-for 0)))) - -(cond (tpu-lucid-emacs19-p - (add-hook 'zmacs-deactivate-region-hook 'tpu-update-mode-line) - (add-hook 'zmacs-activate-region-hook 'tpu-update-mode-line)) - (tpu-emacs19-p - (add-hook 'activate-mark-hook 'tpu-update-mode-line) - (add-hook 'deactivate-mark-hook 'tpu-update-mode-line))) - - -;;; -;;; Match Markers - -;;; -;;; Set in: Search -;;; -;;; Used in: Replace, Substitute, Store-Text, Cut/Remove, -;;; Append, and Change-Case -;;; -(defvar tpu-match-beginning-mark (make-marker)) -(defvar tpu-match-end-mark (make-marker)) - -(defun tpu-set-match nil - "Set markers at match beginning and end." - ;; Add one to beginning mark so it stays with the first character of - ;; the string even if characters are added just before the string. - (setq tpu-match-beginning-mark (copy-marker (1+ (match-beginning 0)))) - (setq tpu-match-end-mark (copy-marker (match-end 0)))) - -(defun tpu-unset-match nil - "Unset match beginning and end markers." - (set-marker tpu-match-beginning-mark nil) - (set-marker tpu-match-end-mark nil)) - -(defun tpu-match-beginning nil - "Returns the location of the last match beginning." - (1- (marker-position tpu-match-beginning-mark))) - -(defun tpu-match-end nil - "Returns the location of the last match end." - (marker-position tpu-match-end-mark)) - -(defun tpu-check-match nil - "Returns t if point is between tpu-match markers. -Otherwise sets the tpu-match markers to nil and returns nil." - ;; make sure 1- marker is in this buffer - ;; 2- point is at or after beginning marker - ;; 3- point is before ending marker, or in the case of - ;; zero length regions (like bol, or eol) that the - ;; beginning, end, and point are equal. - (cond ((and - (equal (marker-buffer tpu-match-beginning-mark) (current-buffer)) - (>= (point) (1- (marker-position tpu-match-beginning-mark))) - (or - (< (point) (marker-position tpu-match-end-mark)) - (and (= (1- (marker-position tpu-match-beginning-mark)) - (marker-position tpu-match-end-mark)) - (= (marker-position tpu-match-end-mark) (point))))) t) - (t - (tpu-unset-match) nil))) - -(defun tpu-show-match-markers nil - "Show the values of the match markers." - (interactive) - (setq zmacs-region-stays t) - (if (markerp tpu-match-beginning-mark) - (let ((beg (marker-position tpu-match-beginning-mark))) - (message "(%s, %s) in %s -- current %s in %s" - (if beg (1- beg) nil) - (marker-position tpu-match-end-mark) - (marker-buffer tpu-match-end-mark) - (point) (current-buffer))))) - - -;;; -;;; Utilities -;;; -(defun tpu-caar (thingy) (car (car thingy))) -(defun tpu-cadr (thingy) (car (cdr thingy))) - -(defun tpu-mark nil - "TPU-edt version of the mark function. -Return the appropriate value of the mark for the current -version of Emacs." - (cond (tpu-lucid-emacs19-p (mark (not zmacs-regions))) - (tpu-emacs19-p (and mark-active (mark (not transient-mark-mode)))) - (t (mark)))) - -(defun tpu-set-mark (pos) - "TPU-edt verion of the `set-mark' function. -Sets the mark at POS and activates the region according to the -current version of Emacs." - (set-mark pos) - (and tpu-lucid-emacs19-p pos (zmacs-activate-region))) - -(defun tpu-string-prompt (prompt history-symbol) - "Read a string with PROMPT." - (if tpu-emacs19-p - (read-from-minibuffer prompt nil nil nil history-symbol) - (read-string prompt))) - -(defvar tpu-last-answer nil "Most recent response to tpu-y-or-n-p.") - -(defun tpu-y-or-n-p (prompt &optional not-yes) - "Prompt for a y or n answer with positive default. -Optional second argument NOT-YES changes default to negative. -Like Emacs `y-or-n-p', but also accepts space as y and DEL as n." - (message "%s[%s]" prompt (if not-yes "n" "y")) - (let ((doit t)) - (while doit - (setq doit nil) - (let ((ans (read-char))) - (cond ((or (= ans ?y) (= ans ?Y) (= ans ?\ )) - (setq tpu-last-answer t)) - ((or (= ans ?n) (= ans ?N) (= ans ?\C-?)) - (setq tpu-last-answer nil)) - ((= ans ?\r) (setq tpu-last-answer (not not-yes))) - (t - (setq doit t) (beep) - (message "Please answer y or n. %s[%s]" - prompt (if not-yes "n" "y"))))))) - tpu-last-answer) - -(defun tpu-local-set-key (key func) - "Replace a key in the TPU-edt local key map. -Create the key map if necessary." - (cond ((not (keymapp tpu-buffer-local-map)) - (setq tpu-buffer-local-map (if (current-local-map) - (copy-keymap (current-local-map)) - (make-sparse-keymap))) - (use-local-map tpu-buffer-local-map))) - (local-set-key key func)) - -(defun tpu-current-line nil - "Return the vertical position of point in the selected window. -Top line is 0. Counts each text line only once, even if it wraps." - (+ (count-lines (window-start) (point)) (if (= (current-column) 0) 1 0) -1)) - - -;;; -;;; Breadcrumbs -;;; -(defvar tpu-breadcrumb-plist nil - "The set of user-defined markers (breadcrumbs), as a plist.") - -(defun tpu-drop-breadcrumb (num) - "Drops a breadcrumb that can be returned to later with goto-breadcrumb." - (interactive "p") - (setq zmacs-region-stays t) - (put tpu-breadcrumb-plist num (list (current-buffer) (point))) - (message "Mark %d set." num)) - -(defun tpu-goto-breadcrumb (num) - "Returns to a breadcrumb set with drop-breadcrumb." - (interactive "p") - (setq zmacs-region-stays t) - (cond ((get tpu-breadcrumb-plist num) - (switch-to-buffer (car (get tpu-breadcrumb-plist num))) - (goto-char (tpu-cadr (get tpu-breadcrumb-plist num))) - (message "mark %d found." num)) - (t - (message "mark %d not found." num)))) - - -;;; -;;; Miscellaneous -;;; -(defun tpu-change-case (num) - "Change the case of the character under the cursor or region. -Accepts a prefix argument of the number of characters to invert." - (interactive "p") - (cond ((tpu-mark) - (let ((beg (region-beginning)) (end (region-end))) - (while (> end beg) - (funcall (if (= (downcase (char-after beg)) (char-after beg)) - 'upcase-region 'downcase-region) - beg (1+ beg)) - (setq beg (1+ beg))) - (tpu-unselect t))) - ((tpu-check-match) - (let ((beg (tpu-match-beginning)) (end (tpu-match-end))) - (while (> end beg) - (funcall (if (= (downcase (char-after beg)) (char-after beg)) - 'upcase-region 'downcase-region) - beg (1+ beg)) - (setq beg (1+ beg))) - (tpu-unset-match))) - (t - (while (> num 0) - (funcall (if (= (downcase (following-char)) (following-char)) - 'upcase-region 'downcase-region) - (point) (1+ (point))) - (forward-char (if tpu-reverse -1 1)) - (setq num (1- num)))))) - -(defun tpu-fill (num) - "Fill paragraph or marked region. -With argument, fill and justify." - (interactive "P") - (cond ((tpu-mark) - (fill-region (point) (tpu-mark) num) - (tpu-unselect t)) - (t - (fill-paragraph num)))) - -(defun tpu-version nil - "Print the TPU-edt version number." - (interactive) - (setq zmacs-region-stays t) - (message - "TPU-edt version %s by Rob Riepel (riepel@networking.stanford.edu)" - tpu-version)) - -(defun tpu-reset-screen-size (height width) - "Sets the screen size." - (interactive "nnew screen height: \nnnew screen width: ") - (setq zmacs-region-stays t) - (set-frame-height height) - (set-frame-width width)) - -(defun tpu-toggle-newline-and-indent nil - "Toggle between 'newline and indent' and 'simple newline'." - (interactive) - (setq zmacs-region-stays t) - (cond (tpu-newline-and-indent-p - (setq tpu-newline-and-indent-string "") - (setq tpu-newline-and-indent-p nil) - (tpu-local-set-key "\C-m" 'newline)) - (t - (setq tpu-newline-and-indent-string " AutoIndent") - (setq tpu-newline-and-indent-p t) - (tpu-local-set-key "\C-m" 'newline-and-indent))) - (tpu-update-mode-line) - (and (interactive-p) - (message "Carriage return inserts a newline%s" - (if tpu-newline-and-indent-p " and indents." ".")))) - -(defun tpu-spell-check nil - "Checks the spelling of the region, or of the entire buffer if no - region is selected." - (interactive) - (cond (tpu-have-ispell - (if (tpu-mark) (ispell-region (tpu-mark) (point)) (ispell-buffer))) - (t - (if (tpu-mark) (spell-region (tpu-mark) (point)) (spell-buffer)))) - (if (tpu-mark) (tpu-unselect t))) - -(defun tpu-toggle-overwrite-mode nil - "Switches in and out of overwrite mode" - (interactive) - (setq zmacs-region-stays t) - (cond (overwrite-mode - (tpu-local-set-key "\177" tpu-saved-delete-func) - (overwrite-mode 0)) - (t - (setq tpu-saved-delete-func (local-key-binding "\177")) - (tpu-local-set-key "\177" 'picture-backward-clear-column) - (overwrite-mode 1)))) - -(defun tpu-special-insert (num) - "Insert a character or control code according to -its ASCII decimal value." - (interactive "P") - (setq zmacs-region-stays t) - (if overwrite-mode (delete-char 1)) - (insert (if num num 0))) - -(defun tpu-quoted-insert (num) - "Read next input character and insert it. -This is useful for inserting control characters." - (interactive "*p") - (setq zmacs-region-stays t) - (let ((char (read-char)) ) - (if overwrite-mode (delete-char num)) - (insert-char char num))) - - -;;; -;;; TPU line-mode commands -;;; -(defun tpu-include (file) - "TPU-like include file" - (interactive "fInclude file: ") - (setq zmacs-region-stays t) - (save-excursion - (insert-file file) - (message ""))) - -(defun tpu-get (file) - "TPU-like get file" - (interactive "FFile to get: ") - (setq zmacs-region-stays t) - (find-file file)) - -(defun tpu-what-line nil - "Tells what line the point is on, - and the total number of lines in the buffer." - (interactive) - (setq zmacs-region-stays t) - (if (eobp) - (message "You are at the End of Buffer. The last line is %d." - (count-lines 1 (point-max))) - (message "Line %d of %d" - (count-lines 1 (1+ (point))) - (count-lines 1 (point-max))))) - -(defun tpu-exit nil - "Exit the way TPU does, save current buffer and ask about others." - (interactive) - (if (not (eq (recursion-depth) 0)) - (exit-recursive-edit) - (progn (save-buffer) (save-buffers-kill-emacs)))) - -(defun tpu-quit nil - "Quit the way TPU does, ask to make sure changes should be abandoned." - (interactive) - (let ((list (buffer-list)) - (working t)) - (while (and list working) - (let ((buffer (car list))) - (if (and (buffer-file-name buffer) (buffer-modified-p buffer)) - (if (tpu-y-or-n-p - "Modifications will not be saved, continue quitting? ") - (kill-emacs t) (setq working nil))) - (setq list (cdr list)))) - (if working (kill-emacs t)))) - - -;;; -;;; Command and Function Aliases -;;; -;;;###autoload -(fset 'tpu-edt-mode 'tpu-edt-on) -(fset 'TPU-EDT-MODE 'tpu-edt-on) - -;;;###autoload -(fset 'tpu-edt 'tpu-edt-on) -(fset 'TPU-EDT 'tpu-edt-on) - -(fset 'exit 'tpu-exit) -(fset 'EXIT 'tpu-exit) - -(fset 'Get 'tpu-get) -(fset 'GET 'tpu-get) - -(fset 'include 'tpu-include) -(fset 'INCLUDE 'tpu-include) - -(fset 'quit 'tpu-quit) -(fset 'QUIT 'tpu-quit) - -(fset 'spell 'tpu-spell-check) -(fset 'SPELL 'tpu-spell-check) - -(fset 'what\ line 'tpu-what-line) -(fset 'WHAT\ LINE 'tpu-what-line) - -(fset 'replace 'tpu-lm-replace) -(fset 'REPLACE 'tpu-lm-replace) - -;; Apparently TPU users really expect to do M-x help RET to get help. -;; So it is really necessary to redefine this. -(fset 'help 'tpu-help) -(fset 'HELP 'tpu-help) - -(fset 'set\ cursor\ free 'tpu-set-cursor-free) -(fset 'SET\ CURSOR\ FREE 'tpu-set-cursor-free) - -(fset 'set\ cursor\ bound 'tpu-set-cursor-bound) -(fset 'SET\ CURSOR\ BOUND 'tpu-set-cursor-bound) - -(fset 'set\ scroll\ margins 'tpu-set-scroll-margins) -(fset 'SET\ SCROLL\ MARGINS 'tpu-set-scroll-margins) - - -;; Around emacs version 18.57, function line-move was renamed to -;; next-line-internal. If we're running under an older emacs, -;; make next-line-internal equivalent to line-move. - -(if (not (fboundp 'next-line-internal)) (fset 'next-line-internal 'line-move)) - - -;;; -;;; Help -;;; -(defconst tpu-help-keypad-map "\f - _______________________ _______________________________ - | HELP | Do | | | | | | - |KeyDefs| | | | | | | - |_______|_______________| |_______|_______|_______|_______| - _______________________ _______________________________ - | Find |Insert |Remove | | Gold | HELP |FndNxt | Del L | - | | |Sto Tex| | key |E-Help | Find |Undel L| - |_______|_______|_______| |_______|_______|_______|_______| - |Select |Pre Scr|Nex Scr| | Page | Sect |Append | Del W | - | Reset |Pre Win|Nex Win| | Do | Fill |Replace|Undel W| - |_______|_______|_______| |_______|_______|_______|_______| - |Move up| |Forward|Reverse|Remove | Del C | - | Top | |Bottom | Top |Insert |Undel C| - _______|_______|_______ |_______|_______|_______|_______| - |Mov Lef|Mov Dow|Mov Rig| | Word | EOL | Char | | - |StaOfLi|Bottom |EndOfLi| |ChngCas|Del EOL|SpecIns| Enter | - |_______|_______|_______| |_______|_______|_______| | - | Line |Select | Subs | - | Open Line | Reset | | - |_______________|_______|_______| -") - -(defconst tpu-help-text " -\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\f - - Control Characters - - ^A toggle insert and overwrite - ^B recall - ^E end of line - - ^G Cancel current operation - ^H beginning of line - ^J delete previous word - - ^K learn - ^L insert page break - ^R remember (during learn), re-center - - ^U delete to beginning of line - ^V quote - ^W refresh - - ^Z exit - ^X^X exchange point and mark - useful for checking region boundaries - -\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\f - Gold- Functions - - B Next Buffer - display the next buffer (all buffers) - C Recall - edit and possibly repeat previous commands - E Exit - save current buffer and ask about others - G Get - load a file into a new edit buffer - - I Include - include a file in this buffer - K Kill Buffer - abandon edits and delete buffer - M Buffer Menu - display a list of all buffers - N Next File Buffer - display next buffer containing a file - - O Occur - show following lines containing REGEXP - Q Quit - exit without saving anything - R Toggle rectangular mode for remove and insert - S Search and substitute - line mode REPLACE command - - ^T Toggle control key bindings between TPU and emacs - U Undo - undo the last edit - W Write - save current buffer - X Exit - save all modified buffers and exit - -\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\f - - More extensive documentation on TPU-edt can be found in the `Commentary' - section of tpu-edt.el. This section can be accessed through the standard - Emacs help facility using the `p' option. Once you exit TPU-edt Help, one - of the following key sequences is sure to get you there. - - ^h p if you're not yet using TPU-edt - Gold-PF2 p if you're using TPU-edt - - Alternatively, fire up Emacs help from the command prompt, with - - M-x help-for-help p - - Where `M-x' might be any of `Gold-KP7', 'Do', or 'ESC-x'. - - When you successfully invoke this part of the Emacs help facility, you - will see a buffer named `*Finder*' listing a number of topics. Look for - tpu-edt under `emulations'. - -\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\f - - *** No more help, use P to view previous screen") - -(defvar tpu-help-enter (format "%s" "\eOM")) ; tpu-help enter key symbol -(defvar tpu-help-return (format "%s" "\r")) ; tpu-help enter key symbol -(defvar tpu-help-N "N") ; tpu-help "N" symbol -(defvar tpu-help-n "n") ; tpu-help "n" symbol -(defvar tpu-help-P "P") ; tpu-help "P" symbol -(defvar tpu-help-p "p") ; tpu-help "p" symbol - -(defun tpu-help nil - "Display TPU-edt help." - (interactive) - (setq zmacs-region-stays t) - ;; Save current window configuration - (save-window-excursion - ;; Create and fill help buffer if necessary - (if (not (get-buffer "*TPU-edt Help*")) - (progn (generate-new-buffer "*TPU-edt Help*") - (switch-to-buffer "*TPU-edt Help*") - (insert tpu-help-keypad-map) - (insert tpu-help-text) - (setq buffer-read-only t))) - - ;; Display the help buffer - (switch-to-buffer "*TPU-edt Help*") - (delete-other-windows) - (tpu-move-to-beginning) - (forward-line 1) - (tpu-line-to-top-of-window) - - ;; Prompt for keys to describe, based on screen state (split/not split) - (let ((key nil) (fkey nil) (split nil)) - (while (not (equal tpu-help-return fkey)) - (if split - (setq key - (read-key-sequence - "Press the key you want help on (RET=exit, ENTER=redisplay, N=next, -P=prev): ")) - (setq key - (read-key-sequence - "Press the key you want help on (RET to exit, N next screen, P prev -screen): "))) - - ;; Process the read key - ;; - ;; ENTER - Display just the help window - ;; N or n - Next help or describe-key screen - ;; P or p - Previous help or describe-key screen - ;; RETURN - Exit from TPU-help - ;; default - describe the key - ;; - (setq fkey (format "%s" key)) - (cond ((equal tpu-help-enter fkey) - (setq split nil) - (delete-other-windows)) - ((or (equal tpu-help-N fkey) (equal tpu-help-n fkey)) - (cond (split - (condition-case nil - (scroll-other-window 8) - (error nil))) - (t - (forward-page) - (forward-line 1) - (tpu-line-to-top-of-window)))) - ((or (equal tpu-help-P fkey) (equal tpu-help-p fkey)) - (cond (split - (condition-case nil - (scroll-other-window -8) - (error nil))) - (t - (backward-page) - (forward-line 1) - (tpu-line-to-top-of-window)))) - ((not (equal tpu-help-return fkey)) - (setq split t) - (describe-key key) - ;; If the key is undefined, leave the - ;; message in the mini-buffer for 3 seconds - (if (not (key-binding key)) (sit-for 3)))))))) - - -;;; -;;; Auto-insert -;;; -(defun tpu-insert-escape nil - "Inserts an escape character, and so becomes the escape-key alias." - (interactive) - (setq zmacs-region-stays t) - (insert "\e")) - -(defun tpu-insert-formfeed nil - "Inserts a formfeed character." - (interactive) - (setq zmacs-region-stays t) - (insert "\C-L")) - - -;;; -;;; Define key -;;; -(defvar tpu-saved-control-r nil "Saved value of Control-r.") - -(defun tpu-end-define-macro-key (key) - "Ends the current macro definition" - (interactive "kPress the key you want to use to do what was just learned: ") - (setq zmacs-region-stays t) - (end-kbd-macro nil) - (global-set-key key last-kbd-macro) - (global-set-key "\C-r" tpu-saved-control-r)) - -(defun tpu-define-macro-key nil - "Bind a set of keystrokes to a single key, or key combination." - (interactive) - (setq zmacs-region-stays t) - (setq tpu-saved-control-r (global-key-binding "\C-r")) - (global-set-key "\C-r" 'tpu-end-define-macro-key) - (start-kbd-macro nil)) - - -;;; -;;; Buffers and Windows -;;; -(defun tpu-kill-buffer nil - "Kills the current buffer. If tpu-kill-buffers-silently is non-nil, -kills modified buffers without asking." - (interactive) - (if tpu-kill-buffers-silently (set-buffer-modified-p nil)) - (kill-buffer (current-buffer))) - -(defun tpu-save-all-buffers-kill-emacs nil - "Save all buffers and exit emacs." - (interactive) - (let ((delete-old-versions t)) - (save-buffers-kill-emacs t))) - -(defun tpu-write-current-buffers nil - "Save all modified buffers without exiting." - (interactive) - (setq zmacs-region-stays t) - (save-some-buffers t)) - -(defun tpu-next-buffer nil - "Go to next buffer in ring." - (interactive) - (switch-to-buffer (car (reverse (buffer-list))))) - -(defun tpu-next-file-buffer nil - "Go to next buffer in ring that is visiting a file or directory." - (interactive) - (let ((list (tpu-make-file-buffer-list (buffer-list)))) - (setq list (delq (current-buffer) list)) - (if (not list) (error "No other buffers.")) - (switch-to-buffer (car (reverse list))))) - -(defun tpu-make-file-buffer-list (buffer-list) - "Returns names from BUFFER-LIST excluding those beginning with a space or -star." - (delq nil (mapcar '(lambda (b) - (if (or (= (aref (buffer-name b) 0) ? ) - (= (aref (buffer-name b) 0) ?*)) nil b)) - buffer-list))) - -(defun tpu-next-window nil - "Move to the next window." - (interactive) - (setq zmacs-region-stays t) - (if (one-window-p) (message "There is only one window on screen.") - (other-window 1))) - -(defun tpu-previous-window nil - "Move to the previous window." - (interactive) - (setq zmacs-region-stays t) - (if (one-window-p) (message "There is only one window on screen.") - (select-window (previous-window)))) - - -;;; -;;; Search -;;; -(defun tpu-toggle-regexp nil - "Switches in and out of regular expression search and replace mode." - (interactive) - (setq zmacs-region-stays t) - (setq tpu-regexp-p (not tpu-regexp-p)) - (tpu-set-search) - (and (interactive-p) - (message "Regular expression search and substitute %sabled." - (if tpu-regexp-p "en" "dis")))) - -(defun tpu-regexp-prompt (prompt) - "Read a string, adding 'RE' to the prompt if tpu-regexp-p is set." - (let ((re-prompt (concat (if tpu-regexp-p "RE ") prompt))) - (if tpu-emacs19-p - (read-from-minibuffer re-prompt nil nil nil 'tpu-regexp-prompt-hist) - (read-string re-prompt)))) - -(defun tpu-search nil - "Search for a string or regular expression. -The search is performed in the current direction." - (interactive) - (setq zmacs-region-stays t) - (tpu-set-search) - (tpu-search-internal "")) - -(defun tpu-search-forward nil - "Search for a string or regular expression. -The search is begins in the forward direction." - (interactive) - (setq zmacs-region-stays t) - (setq tpu-searching-forward t) - (tpu-set-search t) - (tpu-search-internal "")) - -(defun tpu-search-reverse nil - "Search for a string or regular expression. -The search is begins in the reverse direction." - (interactive) - (setq zmacs-region-stays t) - (setq tpu-searching-forward nil) - (tpu-set-search t) - (tpu-search-internal "")) - -(defun tpu-search-again nil - "Search for the same string or regular expression as last time. -The search is performed in the current direction." - (interactive) - (setq zmacs-region-stays t) - (tpu-search-internal tpu-search-last-string)) - -;; tpu-set-search defines the search functions used by the TPU-edt internal -;; search function. It should be called whenever the direction changes, or -;; the regular expression mode is turned on or off. It can also be called -;; to ensure that the next search will be in the current direction. It is -;; called from: - -;; tpu-advance tpu-backup -;; tpu-toggle-regexp tpu-toggle-search-direction (t) -;; tpu-search tpu-lm-replace -;; tpu-search-forward (t) tpu-search-reverse (t) -;; tpu-search-forward-exit (t) tpu-search-backward-exit (t) - -(defun tpu-set-search (&optional arg) - "Set the search functions and set the search direction to the current -direction. If an argument is specified, don't set the search direction." - (if (not arg) (setq tpu-searching-forward (if tpu-advance t nil))) - (cond (tpu-searching-forward - (cond (tpu-regexp-p - (fset 'tpu-emacs-search 're-search-forward) - (fset 'tpu-emacs-rev-search 're-search-backward)) - (t - (fset 'tpu-emacs-search 'search-forward) - (fset 'tpu-emacs-rev-search 'search-backward)))) - (t - (cond (tpu-regexp-p - (fset 'tpu-emacs-search 're-search-backward) - (fset 'tpu-emacs-rev-search 're-search-forward)) - (t - (fset 'tpu-emacs-search 'search-backward) - (fset 'tpu-emacs-rev-search 'search-forward)))))) - -(defun tpu-search-internal (pat &optional quiet) - "Search for a string or regular expression." - (setq tpu-search-last-string - (if (not (string= "" pat)) pat (tpu-regexp-prompt "Search: "))) - - (tpu-unset-match) - (tpu-adjust-search) - - (let ((case-fold-search - (and case-fold-search (tpu-check-search-case tpu-search-last-string)))) - - (cond ((tpu-emacs-search tpu-search-last-string nil t) - (tpu-set-match) (goto-char (tpu-match-beginning))) - - (t - (tpu-adjust-search t) - (let ((found nil) (pos nil)) - (save-excursion - (let ((tpu-searching-forward (not tpu-searching-forward))) - (tpu-adjust-search) - (setq found (tpu-emacs-rev-search tpu-search-last-string nil t)) - (setq pos (match-beginning 0)))) - - (cond - (found - (cond ((tpu-y-or-n-p - (format "Found in %s direction. Go there? " - (if tpu-searching-forward "reverse" "forward"))) - (goto-char pos) (tpu-set-match) - (tpu-toggle-search-direction)))) - - (t - (if (not quiet) - (message - "%sSearch failed: \"%s\"" - (if tpu-regexp-p "RE " "") tpu-search-last-string))))))))) - -(fset 'tpu-search-internal-core (symbol-function 'tpu-search-internal)) - -(defun tpu-check-search-case (string) - "Returns t if string contains upper case." - ;; if using regexp, eliminate upper case forms (\B \W \S.) - (if tpu-regexp-p - (let ((pat (copy-sequence string)) (case-fold-search nil) (pos 0)) - (while (setq pos (string-match "\\\\\\\\" pat)) (aset pat (+ 1 pos) ?.)) - (while (setq pos (string-match "\\\\B" pat)) (aset pat (+ 1 pos) ?.)) - (while (setq pos (string-match "\\\\W" pat)) (aset pat (+ 1 pos) ?.)) - (while (setq pos (string-match "\\\\S." pat)) - (aset pat (+ 1 pos) ?.) (aset pat (+ 2 pos) ?.)) - (string-equal pat (downcase pat))) - (string-equal string (downcase string)))) - -(defun tpu-adjust-search (&optional arg) - "For forward searches, move forward a character before searching, -and backward a character after a failed search. Arg means end of search." - (if tpu-searching-forward - (cond (arg (if (not (bobp)) (forward-char -1))) - (t (if (not (eobp)) (forward-char 1)))))) - -(defun tpu-toggle-search-direction nil - "Toggle the TPU-edt search direction. -Used for reversing a search in progress." - (interactive) - (setq zmacs-region-stays t) - (setq tpu-searching-forward (not tpu-searching-forward)) - (tpu-set-search t) - (and (interactive-p) - (message "Searching %sward." - (if tpu-searching-forward "for" "back")))) - -(defun tpu-search-forward-exit nil - "Set search direction forward and exit minibuffer." - (interactive) - (setq zmacs-region-stays t) - (setq tpu-searching-forward t) - (tpu-set-search t) - (exit-minibuffer)) - -(defun tpu-search-backward-exit nil - "Set search direction backward and exit minibuffer." - (interactive) - (setq zmacs-region-stays t) - (setq tpu-searching-forward nil) - (tpu-set-search t) - (exit-minibuffer)) - - -;;; -;;; Select / Unselect -;;; -(defun tpu-select (&optional quiet) - "Sets the mark to define one end of a region." - (interactive "P") - (cond ((tpu-mark) - (tpu-unselect quiet)) - (t - (tpu-set-mark (point)) - (tpu-update-mode-line) - (if (not quiet) (message "Move the text cursor to select text."))))) - -(defun tpu-unselect (&optional quiet) - "Removes the mark to unselect the current region." - (interactive "P") - (setq mark-ring nil) - (tpu-set-mark nil) - (tpu-update-mode-line) - (if (not quiet) (message "Selection canceled."))) - - -;;; -;;; Delete / Cut -;;; -(defun tpu-toggle-rectangle nil - "Toggle rectangular mode for remove and insert." - (interactive) - (setq zmacs-region-stays t) - (setq tpu-rectangular-p (not tpu-rectangular-p)) - (setq tpu-rectangle-string (if tpu-rectangular-p " Rect" "")) - (tpu-update-mode-line) - (and (interactive-p) - (message "Rectangular cut and paste %sabled." - (if tpu-rectangular-p "en" "dis")))) - -(defun tpu-arrange-rectangle nil - "Adjust point and mark to mark upper left and lower right -corners of a rectangle." - (let ((mc (current-column)) - (pc (progn (exchange-point-and-mark) (current-column)))) - - (cond ((> (point) (tpu-mark)) ; point on lower line - (cond ((> pc mc) ; point @ lower-right - (exchange-point-and-mark)) ; point -> upper-left - - (t ; point @ lower-left - (move-to-column-force mc) ; point -> lower-right - (exchange-point-and-mark) ; point -> upper-right - (move-to-column-force pc)))) ; point -> upper-left - - (t ; point on upper line - (cond ((> pc mc) ; point @ upper-right - (move-to-column-force mc) ; point -> upper-left - (exchange-point-and-mark) ; point -> lower-left - (move-to-column-force pc) ; point -> lower-right - (exchange-point-and-mark))))))) ; point -> upper-left - -(defun tpu-cut-text nil - "Delete the selected region. -The text is saved for the tpu-paste command." - (interactive) - (cond ((tpu-mark) - (cond (tpu-rectangular-p - (tpu-arrange-rectangle) - (picture-clear-rectangle (point) (tpu-mark) (not overwrite-mode)) - (tpu-unselect t)) - (t - (setq tpu-last-deleted-region - (buffer-substring (tpu-mark) (point))) - (delete-region (tpu-mark) (point)) - (tpu-unselect t)))) - ((tpu-check-match) - (let ((beg (tpu-match-beginning)) (end (tpu-match-end))) - (setq tpu-last-deleted-region (buffer-substring beg end)) - (delete-region beg end) - (tpu-unset-match))) - (t - (error "No selection active.")))) - -(defun tpu-store-text nil - "Copy the selected region to the cut buffer without deleting it. -The text is saved for the tpu-paste command." - (interactive) - (setq zmacs-region-stays t) - (cond ((tpu-mark) - (cond (tpu-rectangular-p - (save-excursion - (tpu-arrange-rectangle) - (setq picture-killed-rectangle - (extract-rectangle (point) (tpu-mark)))) - (tpu-unselect t)) - (t - (setq tpu-last-deleted-region - (buffer-substring (tpu-mark) (point))) - (tpu-unselect t)))) - ((tpu-check-match) - (setq tpu-last-deleted-region - (buffer-substring (tpu-match-beginning) (tpu-match-end))) - (tpu-unset-match)) - (t - (error "No selection active.")))) - -(defun tpu-cut (arg) - "Copy selected region to the cut buffer. In the absence of an -argument, delete the selected region too." - (interactive "P") - (if arg (tpu-store-text) (tpu-cut-text))) - -(defun tpu-append-region (arg) - "Append selected region to the tpu-cut buffer. In the absence of an -argument, delete the selected region too." - (interactive "P") - (cond ((tpu-mark) - (let ((beg (region-beginning)) (end (region-end))) - (setq tpu-last-deleted-region - (concat tpu-last-deleted-region - (buffer-substring beg end))) - (if (not arg) (delete-region beg end)) - (tpu-unselect t))) - ((tpu-check-match) - (let ((beg (tpu-match-beginning)) (end (tpu-match-end))) - (setq tpu-last-deleted-region - (concat tpu-last-deleted-region - (buffer-substring beg end))) - (if (not arg) (delete-region beg end)) - (tpu-unset-match))) - (t - (error "No selection active.")))) - -(defun tpu-delete-current-line (num) - "Delete one or specified number of lines after point. -This includes the newline character at the end of each line. -They are saved for the TPU-edt undelete-lines command." - (interactive "p") - (setq zmacs-region-stays t) - (let ((beg (point))) - (forward-line num) - (if (not (eq (preceding-char) ?\n)) - (insert "\n")) - (setq tpu-last-deleted-lines - (buffer-substring beg (point))) - (delete-region beg (point)))) - -(defun tpu-delete-to-eol (num) - "Delete text up to end of line. -With argument, delete up to to Nth line-end past point. -They are saved for the TPU-edt undelete-lines command." - (interactive "p") - (setq zmacs-region-stays t) - (let ((beg (point))) - (forward-char 1) - (end-of-line num) - (setq tpu-last-deleted-lines - (buffer-substring beg (point))) - (delete-region beg (point)))) - -(defun tpu-delete-to-bol (num) - "Delete text back to beginning of line. -With argument, delete up to to Nth line-end past point. -They are saved for the TPU-edt undelete-lines command." - (interactive "p") - (setq zmacs-region-stays t) - (let ((beg (point))) - (tpu-next-beginning-of-line num) - (setq tpu-last-deleted-lines - (buffer-substring (point) beg)) - (delete-region (point) beg))) - -(defun tpu-delete-current-word (num) - "Delete one or specified number of words after point. -They are saved for the TPU-edt undelete-words command." - (interactive "p") - (setq zmacs-region-stays t) - (let ((beg (point))) - (tpu-forward-to-word num) - (setq tpu-last-deleted-words - (buffer-substring beg (point))) - (delete-region beg (point)))) - -(defun tpu-delete-previous-word (num) - "Delete one or specified number of words before point. -They are saved for the TPU-edt undelete-words command." - (interactive "p") - (setq zmacs-region-stays t) - (let ((beg (point))) - (tpu-backward-to-word num) - (setq tpu-last-deleted-words - (buffer-substring (point) beg)) - (delete-region beg (point)))) - -(defun tpu-delete-current-char (num) - "Delete one or specified number of characters after point. The last -character deleted is saved for the TPU-edt undelete-char command." - (interactive "p") - (setq zmacs-region-stays t) - (while (and (> num 0) (not (eobp))) - (setq tpu-last-deleted-char (char-after (point))) - (cond (overwrite-mode - (picture-clear-column 1) - (forward-char 1)) - (t - (delete-char 1))) - (setq num (1- num)))) - - -;;; -;;; Undelete / Paste -;;; -(defun tpu-paste (num) - "Insert the last region or rectangle of killed text. -With argument reinserts the text that many times." - (interactive "p") - (setq zmacs-region-stays t) - (while (> num 0) - (cond (tpu-rectangular-p - (let ((beg (point))) - (save-excursion - (picture-yank-rectangle (not overwrite-mode)) - (message "")) - (goto-char beg))) - (t - (insert tpu-last-deleted-region))) - (setq num (1- num)))) - -(defun tpu-undelete-lines (num) - "Insert lines deleted by last TPU-edt line-deletion command. -With argument reinserts lines that many times." - (interactive "p") - (setq zmacs-region-stays t) - (let ((beg (point))) - (while (> num 0) - (insert tpu-last-deleted-lines) - (setq num (1- num))) - (goto-char beg))) - -(defun tpu-undelete-words (num) - "Insert words deleted by last TPU-edt word-deletion command. -With argument reinserts words that many times." - (interactive "p") - (setq zmacs-region-stays t) - (let ((beg (point))) - (while (> num 0) - (insert tpu-last-deleted-words) - (setq num (1- num))) - (goto-char beg))) - -(defun tpu-undelete-char (num) - "Insert character deleted by last TPU-edt character-deletion command. -With argument reinserts the character that many times." - (interactive "p") - (setq zmacs-region-stays t) - (while (> num 0) - (if overwrite-mode (prog1 (forward-char -1) (delete-char 1))) - (insert tpu-last-deleted-char) - (forward-char -1) - (setq num (1- num)))) - - -;;; -;;; Replace and Substitute -;;; -(defun tpu-replace nil - "Replace the selected region with the contents of the cut buffer." - (interactive) - (cond ((tpu-mark) - (let ((beg (region-beginning)) (end (region-end))) - (setq tpu-last-replaced-text (buffer-substring beg end)) - (delete-region beg end) - (insert tpu-last-deleted-region) - (tpu-unselect t))) - ((tpu-check-match) - (let ((beg (tpu-match-beginning)) (end (tpu-match-end))) - (setq tpu-last-replaced-text (buffer-substring beg end)) - (replace-match tpu-last-deleted-region - (not case-replace) (not tpu-regexp-p)) - (tpu-unset-match))) - (t - (error "No selection active.")))) - -(defun tpu-substitute (num) - "Replace the selected region with the contents of the cut buffer, and -repeat most recent search. A numeric argument serves as a repeat count. -A negative argument means replace all occurrences of the search string." - (interactive "p") - (cond ((or (tpu-mark) (tpu-check-match)) - (while (and (not (= num 0)) (or (tpu-mark) (tpu-check-match))) - (let ((beg (point))) - (tpu-replace) - (if tpu-searching-forward (forward-char -1) (goto-char beg)) - (if (= num 1) (tpu-search-internal tpu-search-last-string) - (tpu-search-internal-core tpu-search-last-string))) - (setq num (1- num)))) - (t - (error "No selection active.")))) - -(defun tpu-lm-replace (from to) - "Interactively search for OLD-string and substitute NEW-string." - (interactive (list (tpu-regexp-prompt "Old String: ") - (tpu-regexp-prompt "New String: "))) - - (let ((doit t) (strings 0)) - - ;; Can't replace null strings - (if (string= "" from) (error "No string to replace.")) - - ;; Find the first occurrence - (tpu-set-search) - (tpu-search-internal from t) - - ;; Loop on replace question - yes, no, all, last, or quit. - (while doit - (if (not (tpu-check-match)) (setq doit nil) - (progn (message "Replace? Type Yes, No, All, Last, or Quit: ") - (let ((ans (read-char))) - - (cond ((or (= ans ?y) (= ans ?Y) (= ans ?\r) (= ans ?\ )) - (let ((beg (point))) - (replace-match to (not case-replace) (not tpu-regexp-p)) - (setq strings (1+ strings)) - (if tpu-searching-forward (forward-char -1) (goto-char beg))) - (tpu-search-internal from t)) - - ((or (= ans ?n) (= ans ?N) (= ans ?\C-?)) - (tpu-search-internal from t)) - - ((or (= ans ?a) (= ans ?A)) - (save-excursion - (let ((beg (point))) - (replace-match to (not case-replace) (not tpu-regexp-p)) - (setq strings (1+ strings)) - (if tpu-searching-forward (forward-char -1) (goto-char beg))) - (tpu-search-internal-core from t) - (while (tpu-check-match) - (let ((beg (point))) - (replace-match to (not case-replace) (not tpu-regexp-p)) - (setq strings (1+ strings)) - (if tpu-searching-forward (forward-char -1) (goto-char beg))) - (tpu-search-internal-core from t))) - (setq doit nil)) - - ((or (= ans ?l) (= ans ?L)) - (let ((beg (point))) - (replace-match to (not case-replace) (not tpu-regexp-p)) - (setq strings (1+ strings)) - (if tpu-searching-forward (forward-char -1) (goto-char beg))) - (setq doit nil)) - - ((or (= ans ?q) (= ans ?Q)) - (setq doit nil))))))) - - (message "Replaced %s occurrence%s." strings - (if (not (= 1 strings)) "s" "")))) - -(defun tpu-emacs-replace (&optional dont-ask) - "A TPU-edt interface to the emacs replace functions. If TPU-edt is -currently in regular expression mode, the emacs regular expression -replace functions are used. If an argument is supplied, replacements -are performed without asking. Only works in forward direction." - (interactive "P") - (cond (dont-ask - (setq current-prefix-arg nil) - (call-interactively - (if tpu-regexp-p 'replace-regexp 'replace-string))) - (t - (call-interactively - (if tpu-regexp-p 'query-replace-regexp 'query-replace))))) - -(defun tpu-add-at-bol (text) - "Add text to the beginning of each line in a region, -or each line in the entire buffer if no region is selected." - (interactive - (list (tpu-string-prompt "String to add: " 'tpu-add-at-bol-hist))) - (setq zmacs-region-stays t) - (if (string= "" text) (error "No string specified.")) - (cond ((tpu-mark) - (save-excursion - (if (> (point) (tpu-mark)) (exchange-point-and-mark)) - (while (and (< (point) (tpu-mark)) (re-search-forward "^" (tpu-mark) t)) - (if (< (point) (tpu-mark)) (replace-match text)))) - (tpu-unselect t)) - (t - (save-excursion - (goto-char (point-min)) - (while (and (re-search-forward "^" nil t) (not (eobp))) - (replace-match text)))))) - -(defun tpu-add-at-eol (text) - "Add text to the end of each line in a region, -or each line of the entire buffer if no region is selected." - (interactive - (list (tpu-string-prompt "String to add: " 'tpu-add-at-eol-hist))) - (setq zmacs-region-stays t) - (if (string= "" text) (error "No string specified.")) - (cond ((tpu-mark) - (save-excursion - (if (> (point) (tpu-mark)) (exchange-point-and-mark)) - (while (< (point) (tpu-mark)) - (end-of-line) - (if (<= (point) (tpu-mark)) (insert text)) - (forward-line))) - (tpu-unselect t)) - (t - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (end-of-line) (insert text) (forward-line)))))) - -(defun tpu-trim-line-ends nil - "Removes trailing whitespace from every line in the buffer." - (interactive) - (setq zmacs-region-stays t) - (picture-clean)) - - -;;; -;;; Movement by character -;;; -(defun tpu-char (num) - "Move to the next character in the current direction. -A repeat count means move that many characters." - (interactive "p") - (setq zmacs-region-stays t) - (if tpu-advance (tpu-forward-char num) (tpu-backward-char num))) - -(defun tpu-forward-char (num) - "Move right ARG characters (left if ARG is negative)." - (interactive "p") - (setq zmacs-region-stays t) - (forward-char num)) - -(defun tpu-backward-char (num) - "Move left ARG characters (right if ARG is negative)." - (interactive "p") - (setq zmacs-region-stays t) - (backward-char num)) - - -;;; -;;; Movement by word -;;; -(defconst tpu-word-separator-list '() - "List of additional word separators.") -(defconst tpu-skip-chars "^ \t" - "Characters to skip when moving by word. -Additional word separators are added to this string.") - -(defun tpu-word (num) - "Move to the beginning of the next word in the current direction. -A repeat count means move that many words." - (interactive "p") - (setq zmacs-region-stays t) - (if tpu-advance (tpu-forward-to-word num) (tpu-backward-to-word num))) - -(defun tpu-forward-to-word (num) - "Move forward until encountering the beginning of a word. -With argument, do this that many times." - (interactive "p") - (setq zmacs-region-stays t) - (while (and (> num 0) (not (eobp))) - (let* ((beg (point)) - (end (prog2 (end-of-line) (point) (goto-char beg)))) - (cond ((eolp) - (forward-char 1)) - ((memq (char-after (point)) tpu-word-separator-list) - (forward-char 1) - (skip-chars-forward " \t" end)) - (t - (skip-chars-forward tpu-skip-chars end) - (skip-chars-forward " \t" end)))) - (setq num (1- num)))) - -(defun tpu-backward-to-word (num) - "Move backward until encountering the beginning of a word. -With argument, do this that many times." - (interactive "p") - (setq zmacs-region-stays t) - (while (and (> num 0) (not (bobp))) - (let* ((beg (point)) - (end (prog2 (beginning-of-line) (point) (goto-char beg)))) - (cond ((bolp) - ( forward-char -1)) - ((memq (char-after (1- (point))) tpu-word-separator-list) - (forward-char -1)) - (t - (skip-chars-backward " \t" end) - (skip-chars-backward tpu-skip-chars end) - (if (and (not (bolp)) (= ? (char-syntax (char-after (point))))) - (forward-char -1))))) - (setq num (1- num)))) - -(defun tpu-add-word-separators (separators) - "Add new word separators for TPU-edt word commands." - (interactive "sSeparators: ") - (setq zmacs-region-stays t) - (let* ((n 0) (length (length separators))) - (while (< n length) - (let ((char (aref separators n)) - (ss (substring separators n (1+ n)))) - (cond ((not (memq char tpu-word-separator-list)) - (setq tpu-word-separator-list - (append ss tpu-word-separator-list)) - (cond ((= char ?-) - (setq tpu-skip-chars (concat tpu-skip-chars "\\-"))) - ((= char ?\\) - (setq tpu-skip-chars (concat tpu-skip-chars "\\\\"))) - ((= char ?^) - (setq tpu-skip-chars (concat tpu-skip-chars "\\^"))) - (t - (setq tpu-skip-chars (concat tpu-skip-chars ss)))))) - (setq n (1+ n)))))) - -(defun tpu-reset-word-separators nil - "Reset word separators to default value." - (interactive) - (setq zmacs-region-stays t) - (setq tpu-word-separator-list nil) - (setq tpu-skip-chars "^ \t")) - -(defun tpu-set-word-separators (separators) - "Set new word separators for TPU-edt word commands." - (interactive "sSeparators: ") - (setq zmacs-region-stays t) - (tpu-reset-word-separators) - (tpu-add-word-separators separators)) - - -;;; -;;; Movement by line -;;; -(defun tpu-next-line (num) - "Move to next line. -Prefix argument serves as a repeat count." - (interactive "p") - (setq zmacs-region-stays t) - (line-move num) - (setq this-command 'next-line)) - -(defun tpu-previous-line (num) - "Move to previous line. -Prefix argument serves as a repeat count." - (interactive "p") - (setq zmacs-region-stays t) - (line-move (- num)) - (setq this-command 'previous-line)) - -(defun tpu-next-beginning-of-line (num) - "Move to beginning of line; if at beginning, move to beginning of next line. -Accepts a prefix argument for the number of lines to move." - (interactive "p") - (setq zmacs-region-stays t) - (backward-char 1) - (forward-line (- 1 num))) - -(defun tpu-end-of-line (num) - "Move to the next end of line in the current direction. -A repeat count means move that many lines." - (interactive "p") - (setq zmacs-region-stays t) - (if tpu-advance (tpu-next-end-of-line num) (tpu-previous-end-of-line num))) - -(defun tpu-next-end-of-line (num) - "Move to end of line; if at end, move to end of next line. -Accepts a prefix argument for the number of lines to move." - (interactive "p") - (setq zmacs-region-stays t) - (forward-char 1) - (end-of-line num)) - -(defun tpu-previous-end-of-line (num) - "Move EOL upward. -Accepts a prefix argument for the number of lines to move." - (interactive "p") - (setq zmacs-region-stays t) - (end-of-line (- 1 num))) - -(defun tpu-current-end-of-line nil - "Move point to end of current line." - (interactive) - (setq zmacs-region-stays t) - (let ((beg (point))) - (end-of-line) - (if (= beg (point)) (message "You are already at the end of a line.")))) - -(defun tpu-line (num) - "Move to the beginning of the next line in the current direction. -A repeat count means move that many lines." - (interactive "p") - (setq zmacs-region-stays t) - (if tpu-advance (tpu-forward-line num) (tpu-backward-line num))) - -(defun tpu-forward-line (num) - "Move to beginning of next line. -Prefix argument serves as a repeat count." - (interactive "p") - (setq zmacs-region-stays t) - (forward-line num)) - -(defun tpu-backward-line (num) - "Move to beginning of previous line. -Prefix argument serves as repeat count." - (interactive "p") - (setq zmacs-region-stays t) - (or (bolp) (>= 0 num) (setq num (- num 1))) - (forward-line (- num))) - - -;;; -;;; Movement by paragraph -;;; -(defun tpu-paragraph (num) - "Move to the next paragraph in the current direction. -A repeat count means move that many paragraphs." - (interactive "p") - (setq zmacs-region-stays t) - (if tpu-advance - (tpu-next-paragraph num) (tpu-previous-paragraph num))) - -(defun tpu-next-paragraph (num) - "Move to beginning of the next paragraph. -Accepts a prefix argument for the number of paragraphs." - (interactive "p") - (setq zmacs-region-stays t) - (beginning-of-line) - (while (and (not (eobp)) (> num 0)) - (if (re-search-forward "^[ \t]*$" nil t) - (if (re-search-forward "[^ \t\n]" nil t) - (goto-char (match-beginning 0)) - (goto-char (point-max)))) - (setq num (1- num))) - (beginning-of-line)) - - -(defun tpu-previous-paragraph (num) - "Move to beginning of previous paragraph. -Accepts a prefix argument for the number of paragraphs." - (interactive "p") - (setq zmacs-region-stays t) - (end-of-line) - (while (and (not (bobp)) (> num 0)) - (if (not (and (re-search-backward "^[ \t]*$" nil t) - (re-search-backward "[^ \t\n]" nil t) - (re-search-backward "^[ \t]*$" nil t) - (progn (re-search-forward "[^ \t\n]" nil t) - (goto-char (match-beginning 0))))) - (goto-char (point-min))) - (setq num (1- num))) - (beginning-of-line)) - - -;;; -;;; Movement by page -;;; -(defun tpu-page (num) - "Move to the next page in the current direction. -A repeat count means move that many pages." - (interactive "p") - (setq zmacs-region-stays t) - (if tpu-advance (forward-page num) (backward-page num)) - (if (eobp) (recenter -1))) - - -;;; -;;; Scrolling and movement within the buffer -;;; -(defun tpu-scroll-window (num) - "Scroll the display to the next section in the current direction. -A repeat count means scroll that many sections." - (interactive "p") - (setq zmacs-region-stays t) - (if tpu-advance (tpu-scroll-window-up num) (tpu-scroll-window-down num))) - -(defun tpu-scroll-window-down (num) - "Scroll the display down to the next section. -A repeat count means scroll that many sections." - (interactive "p") - (setq zmacs-region-stays t) - (let* ( - (beg (tpu-current-line)) - (height (1- (window-height))) - (lines (* num (/ (* height tpu-percent-scroll) 100)))) - (setq zmacs-region-stays t) - (line-move (- lines)) - (if (> lines beg) (recenter 0)))) - -(defun tpu-scroll-window-up (num) - "Scroll the display up to the next section. -A repeat count means scroll that many sections." - (interactive "p") - (setq zmacs-region-stays t) - (let* ( - (beg (tpu-current-line)) - (height (1- (window-height))) - (lines (* num (/ (* height tpu-percent-scroll) 100)))) - (setq zmacs-region-stays t) - (line-move lines) - (if (>= (+ lines beg) height) (recenter -1)))) - -(defun tpu-pan-right (num) - "Pan right tpu-pan-columns (16 by default). -Accepts a prefix argument for the number of tpu-pan-columns to scroll." - (interactive "p") - (setq zmacs-region-stays t) - (scroll-left (* tpu-pan-columns num))) - -(defun tpu-pan-left (num) - "Pan left tpu-pan-columns (16 by default). -Accepts a prefix argument for the number of tpu-pan-columns to scroll." - (interactive "p") - (setq zmacs-region-stays t) - (scroll-right (* tpu-pan-columns num))) - -(defun tpu-move-to-beginning nil - "Move cursor to the beginning of buffer, but don't set the mark." - (interactive) - (setq zmacs-region-stays t) - (goto-char (point-min))) - -(defun tpu-move-to-end nil - "Move cursor to the end of buffer, but don't set the mark." - (interactive) - (setq zmacs-region-stays t) - (goto-char (point-max)) - (recenter -1)) - -(defun tpu-goto-percent (perc) - "Move point to ARG percentage of the buffer." - (interactive "NGoto-percentage: ") - (setq zmacs-region-stays t) - (if (or (> perc 100) (< perc 0)) - (error "Percentage %d out of range 0 < percent < 100" perc) - (goto-char (/ (* (point-max) perc) 100)))) - -(defun tpu-beginning-of-window nil - "Move cursor to top of window." - (interactive) - (setq zmacs-region-stays t) - (move-to-window-line 0)) - -(defun tpu-end-of-window nil - "Move cursor to bottom of window." - (interactive) - (setq zmacs-region-stays t) - (move-to-window-line -1)) - -(defun tpu-line-to-bottom-of-window nil - "Move the current line to the bottom of the window." - (interactive) - (setq zmacs-region-stays t) - (recenter -1)) - -(defun tpu-line-to-top-of-window nil - "Move the current line to the top of the window." - (interactive) - (setq zmacs-region-stays t) - (recenter 0)) - - -;;; -;;; Direction -;;; -(defun tpu-advance-direction nil - "Set TPU Advance mode so keypad commands move forward." - (interactive) - (setq zmacs-region-stays t) - (setq tpu-direction-string " Advance") - (setq tpu-advance t) - (setq tpu-reverse nil) - (tpu-set-search) - (tpu-update-mode-line)) - -(defun tpu-backup-direction nil - "Set TPU Backup mode so keypad commands move backward." - (interactive) - (setq zmacs-region-stays t) - (setq tpu-direction-string " Reverse") - (setq tpu-advance nil) - (setq tpu-reverse t) - (tpu-set-search) - (tpu-update-mode-line)) - - -;;; -;;; Define keymaps -;;; -(define-key global-map "\e[" CSI-map) ; CSI map -(define-key global-map "\eO" SS3-map) ; SS3 map -(define-key SS3-map "P" GOLD-map) ; GOLD map -(define-key GOLD-map "\e[" GOLD-CSI-map) ; GOLD-CSI map -(define-key GOLD-map "\eO" GOLD-SS3-map) ; GOLD-SS3 map - - -;;; -;;; CSI-map key definitions -;;; -(define-key CSI-map "A" 'tpu-previous-line) ; up -(define-key CSI-map "B" 'tpu-next-line) ; down -(define-key CSI-map "D" 'tpu-backward-char) ; left -(define-key CSI-map "C" 'tpu-forward-char) ; right - -(define-key CSI-map "1~" 'tpu-search) ; Find -(define-key CSI-map "2~" 'tpu-paste) ; Insert Here -(define-key CSI-map "3~" 'tpu-cut) ; Remove -(define-key CSI-map "4~" 'tpu-select) ; Select -(define-key CSI-map "5~" 'tpu-scroll-window-down) ; Prev Screen -(define-key CSI-map "6~" 'tpu-scroll-window-up) ; Next Screen - -(define-key CSI-map "11~" 'nil) ; F1 -(define-key CSI-map "12~" 'nil) ; F2 -(define-key CSI-map "13~" 'nil) ; F3 -(define-key CSI-map "14~" 'nil) ; F4 -(define-key CSI-map "15~" 'nil) ; F5 -(define-key CSI-map "17~" 'nil) ; F6 -(define-key CSI-map "18~" 'nil) ; F7 -(define-key CSI-map "19~" 'nil) ; F8 -(define-key CSI-map "20~" 'nil) ; F9 -(define-key CSI-map "21~" 'tpu-exit) ; F10 -(define-key CSI-map "23~" 'tpu-insert-escape) ; F11 (ESC) -(define-key CSI-map "24~" 'tpu-next-beginning-of-line) ; F12 (BS) -(define-key CSI-map "25~" 'tpu-delete-previous-word) ; F13 (LF) -(define-key CSI-map "26~" 'tpu-toggle-overwrite-mode) ; F14 -(define-key CSI-map "28~" 'tpu-help) ; HELP -(define-key CSI-map "29~" 'execute-extended-command) ; DO -(define-key CSI-map "31~" 'tpu-goto-breadcrumb) ; F17 -(define-key CSI-map "32~" 'nil) ; F18 -(define-key CSI-map "33~" 'nil) ; F19 -(define-key CSI-map "34~" 'nil) ; F20 - - -;;; -;;; SS3-map key definitions -;;; -(define-key SS3-map "A" 'tpu-previous-line) ; up -(define-key SS3-map "B" 'tpu-next-line) ; down -(define-key SS3-map "C" 'tpu-forward-char) ; right -(define-key SS3-map "D" 'tpu-backward-char) ; left - -(define-key SS3-map "Q" 'tpu-help) ; PF2 -(define-key SS3-map "R" 'tpu-search-again) ; PF3 -(define-key SS3-map "S" 'tpu-delete-current-line) ; PF4 -(define-key SS3-map "p" 'tpu-line) ; KP0 -(define-key SS3-map "q" 'tpu-word) ; KP1 -(define-key SS3-map "r" 'tpu-end-of-line) ; KP2 -(define-key SS3-map "s" 'tpu-char) ; KP3 -(define-key SS3-map "t" 'tpu-advance-direction) ; KP4 -(define-key SS3-map "u" 'tpu-backup-direction) ; KP5 -(define-key SS3-map "v" 'tpu-cut) ; KP6 -(define-key SS3-map "w" 'tpu-page) ; KP7 -(define-key SS3-map "x" 'tpu-scroll-window) ; KP8 -(define-key SS3-map "y" 'tpu-append-region) ; KP9 -(define-key SS3-map "m" 'tpu-delete-current-word) ; KP- -(define-key SS3-map "l" 'tpu-delete-current-char) ; KP, -(define-key SS3-map "n" 'tpu-select) ; KP. -(define-key SS3-map "M" 'newline) ; KPenter - - -;;; -;;; GOLD-map key definitions -;;; -(define-key GOLD-map "\C-A" 'tpu-toggle-overwrite-mode) ; ^A -(define-key GOLD-map "\C-B" 'nil) ; ^B -(define-key GOLD-map "\C-C" 'nil) ; ^C -(define-key GOLD-map "\C-D" 'nil) ; ^D -(define-key GOLD-map "\C-E" 'nil) ; ^E -(define-key GOLD-map "\C-F" 'set-visited-file-name) ; ^F -(define-key GOLD-map "\C-g" 'keyboard-quit) ; safety first -(define-key GOLD-map "\C-h" 'delete-other-windows) ; BS -(define-key GOLD-map "\C-i" 'other-window) ; TAB -(define-key GOLD-map "\C-J" 'nil) ; ^J -(define-key GOLD-map "\C-K" 'tpu-define-macro-key) ; ^K -(define-key GOLD-map "\C-l" 'downcase-region) ; ^L -(define-key GOLD-map "\C-M" 'nil) ; ^M -(define-key GOLD-map "\C-N" 'nil) ; ^N -(define-key GOLD-map "\C-O" 'nil) ; ^O -(define-key GOLD-map "\C-P" 'nil) ; ^P -(define-key GOLD-map "\C-Q" 'nil) ; ^Q -(define-key GOLD-map "\C-R" 'nil) ; ^R -(define-key GOLD-map "\C-S" 'nil) ; ^S -(define-key GOLD-map "\C-T" 'tpu-toggle-control-keys) ; ^T -(define-key GOLD-map "\C-u" 'upcase-region) ; ^U -(define-key GOLD-map "\C-V" 'nil) ; ^V -(define-key GOLD-map "\C-w" 'tpu-write-current-buffers) ; ^W -(define-key GOLD-map "\C-X" 'nil) ; ^X -(define-key GOLD-map "\C-Y" 'nil) ; ^Y -(define-key GOLD-map "\C-Z" 'nil) ; ^Z -(define-key GOLD-map " " 'undo) ; SPC -(define-key GOLD-map "!" 'nil) ; ! -(define-key GOLD-map "#" 'nil) ; # -(define-key GOLD-map "$" 'tpu-add-at-eol) ; $ -(define-key GOLD-map "%" 'tpu-goto-percent) ; % -(define-key GOLD-map "&" 'nil) ; & -(define-key GOLD-map "(" 'nil) ; ( -(define-key GOLD-map ")" 'nil) ; ) -(define-key GOLD-map "*" 'tpu-toggle-regexp) ; * -(define-key GOLD-map "+" 'nil) ; + -(define-key GOLD-map "," 'tpu-goto-breadcrumb) ; , -(define-key GOLD-map "-" 'negative-argument) ; - -(define-key GOLD-map "." 'tpu-drop-breadcrumb) ; . -(define-key GOLD-map "/" 'tpu-emacs-replace) ; / -(define-key GOLD-map "0" 'digit-argument) ; 0 -(define-key GOLD-map "1" 'digit-argument) ; 1 -(define-key GOLD-map "2" 'digit-argument) ; 2 -(define-key GOLD-map "3" 'digit-argument) ; 3 -(define-key GOLD-map "4" 'digit-argument) ; 4 -(define-key GOLD-map "5" 'digit-argument) ; 5 -(define-key GOLD-map "6" 'digit-argument) ; 6 -(define-key GOLD-map "7" 'digit-argument) ; 7 -(define-key GOLD-map "8" 'digit-argument) ; 8 -(define-key GOLD-map "9" 'digit-argument) ; 9 -(define-key GOLD-map ":" 'nil) ; : -(define-key GOLD-map ";" 'tpu-trim-line-ends) ; ; -(define-key GOLD-map "<" 'nil) ; < -(define-key GOLD-map "=" 'nil) ; = -(define-key GOLD-map ">" 'nil) ; > -(define-key GOLD-map "?" 'tpu-spell-check) ; ? -(define-key GOLD-map "A" 'tpu-toggle-newline-and-indent) ; A -(define-key GOLD-map "B" 'tpu-next-buffer) ; B -(define-key GOLD-map "C" 'repeat-complex-command) ; C -(define-key GOLD-map "D" 'shell-command) ; D -(define-key GOLD-map "E" 'tpu-exit) ; E -(define-key GOLD-map "F" 'tpu-set-cursor-free) ; F -(define-key GOLD-map "G" 'tpu-get) ; G -(define-key GOLD-map "H" 'nil) ; H -(define-key GOLD-map "I" 'tpu-include) ; I -(define-key GOLD-map "K" 'tpu-kill-buffer) ; K -(define-key GOLD-map "L" 'tpu-what-line) ; L -(define-key GOLD-map "M" 'buffer-menu) ; M -(define-key GOLD-map "N" 'tpu-next-file-buffer) ; N -(define-key GOLD-map "O" 'occur) ; O -(define-key GOLD-map "P" 'lpr-buffer) ; P -(define-key GOLD-map "Q" 'tpu-quit) ; Q -(define-key GOLD-map "R" 'tpu-toggle-rectangle) ; R -(define-key GOLD-map "S" 'replace) ; S -(define-key GOLD-map "T" 'tpu-line-to-top-of-window) ; T -(define-key GOLD-map "U" 'undo) ; U -(define-key GOLD-map "V" 'tpu-version) ; V -(define-key GOLD-map "W" 'save-buffer) ; W -(define-key GOLD-map "X" 'tpu-save-all-buffers-kill-emacs) ; X -(define-key GOLD-map "Y" 'copy-region-as-kill) ; Y -(define-key GOLD-map "Z" 'suspend-emacs) ; Z -(define-key GOLD-map "[" 'blink-matching-open) ; [ -(define-key GOLD-map "\\" 'nil) ; \ -(define-key GOLD-map "]" 'blink-matching-open) ; ] -(define-key GOLD-map "^" 'tpu-add-at-bol) ; ^ -(define-key GOLD-map "_" 'split-window-vertically) ; - -(define-key GOLD-map "`" 'what-line) ; ` -(define-key GOLD-map "a" 'tpu-toggle-newline-and-indent) ; a -(define-key GOLD-map "b" 'tpu-next-buffer) ; b -(define-key GOLD-map "c" 'repeat-complex-command) ; c -(define-key GOLD-map "d" 'shell-command) ; d -(define-key GOLD-map "e" 'tpu-exit) ; e -(define-key GOLD-map "f" 'tpu-set-cursor-free) ; f -(define-key GOLD-map "g" 'tpu-get) ; g -(define-key GOLD-map "h" 'nil) ; h -(define-key GOLD-map "i" 'tpu-include) ; i -(define-key GOLD-map "k" 'tpu-kill-buffer) ; k -(define-key GOLD-map "l" 'goto-line) ; l -(define-key GOLD-map "m" 'buffer-menu) ; m -(define-key GOLD-map "n" 'tpu-next-file-buffer) ; n -(define-key GOLD-map "o" 'occur) ; o -(define-key GOLD-map "p" 'lpr-region) ; p -(define-key GOLD-map "q" 'tpu-quit) ; q -(define-key GOLD-map "r" 'tpu-toggle-rectangle) ; r -(define-key GOLD-map "s" 'replace) ; s -(define-key GOLD-map "t" 'tpu-line-to-top-of-window) ; t -(define-key GOLD-map "u" 'undo) ; u -(define-key GOLD-map "v" 'tpu-version) ; v -(define-key GOLD-map "w" 'save-buffer) ; w -(define-key GOLD-map "x" 'tpu-save-all-buffers-kill-emacs) ; x -(define-key GOLD-map "y" 'copy-region-as-kill) ; y -(define-key GOLD-map "z" 'suspend-emacs) ; z -(define-key GOLD-map "{" 'nil) ; { -(define-key GOLD-map "|" 'split-window-horizontally) ; | -(define-key GOLD-map "}" 'nil) ; } -(define-key GOLD-map "~" 'exchange-point-and-mark) ; ~ -(define-key GOLD-map "\177" 'delete-window) ; | -! +-------+-------+-------+-------+ -! | 52 | 53 | 54 | 78 | -! | | | | | -! | PF1 | PF2 | PF3 | PF4 | -! +-------+-------+-------+-------+ -! | 75 | 76 | 77 | 132 | -! | | | | | -! | 7 | 8 | 9 | - | Shift 8 is Up -! +-------+-------+-------+ | Shift 4 is Left -! | 98 | 99 | 100 | | Shift 6 is Right -! | | | | , | Shift 2 is Down -! | 4 | 5 | 6 | | -! +-------+-------+-------+-------+ To get the Sun4 keys as labelled -! | 119 | 120 | 121 | 97 | on the keypad be sure that -! | | | | | Shift is engaged (except for -! | 1 | 2 | 3 | E | the + key. -! +-------+-------+-------+ n | -! | 101 | 57 | t | -! | | | e | -! | 0 | . | r | -! +---------------+-------+-------+ -! -clear Mod4 -! Redefine the L1-L10 keys on left side of keyboard -keycode 8 = F21 -keycode 10 = F22 -keycode 32 = F23 -keycode 33 = F24 -keycode 56 = F25 -keycode 58 = F26 -keycode 79 = F31 -keycode 80 = F28 -keycode 102 = F29 -keycode 104 = F30 -! Redefine R1-R3 and NumLock for arrow keys ... Why no repeat no most? -keycode 28 = Up -keycode 29 = Down -keycode 30 = Left -keycode 105 = Right -keycode 52 = KP_F1 KP_Equal -keycode 53 = KP_F2 KP_Divide -keycode 54 = KP_F3 KP_Multiply -keycode 78 = KP_F4 KP_Subtract -! Redefine F1-F10 for F1-F20! (Use shift key) -keycode 12 = F1 F11 -keycode 13 = F2 F12 -keycode 15 = F3 F13 -keycode 17 = F4 F14 -keycode 19 = F5 F15 -keycode 21 = F6 F16 -keycode 23 = F7 F17 -keycode 24 = F8 F18 -keycode 25 = F9 F19 -keycode 14 = F10 F20 -!keycode 16 = -!keycode 18= -! The Sun4 + key is really 2 VT100 keys: , and - so use the Shift modifier -! to mimic this. This means the loss of the normal Sun4 function -keycode 132 = KP_Separator KP_Subtract KP_Add -keycode 75 = KP_7 F27 -keycode 76 = KP_8 Up -keycode 77 = KP_9 F29 -keycode 98 = KP_4 Left -!keycode 99 = KP_5 F31 -keycode 99 = KP_5 -keycode 100 = KP_6 Right -keycode 119 = KP_1 R13 -keycode 120 = KP_2 Down -keycode 121 = KP_3 F35 -keycode 101 = KP_0 Insert -keycode 57 = KP_Decimal -keycode 97 = KP_Enter - -clear mod2 -clear mod3 -clear mod4 -clear mod5 diff -r 43306a74e31c -r d44af0c54775 lisp/emulators/tpu-extras.el --- a/lisp/emulators/tpu-extras.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,498 +0,0 @@ -;;; tpu-extras.el --- Scroll margins and free cursor mode for TPU-edt - -;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc. - -;; Author: Rob Riepel -;; Maintainer: Rob Riepel -;; Keywords: emulations - -;; This file is part of XEmacs. -;; XEmacs modifications by Kevin Oberman - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synced up with FSF 19.34 and XEmacs 19.16 - -;;; Commentary: - -;; Use the functions defined here to customize TPU-edt to your tastes by -;; setting scroll margins and/or turning on free cursor mode. Here's an -;; example for your .emacs file. - -;; (tpu-set-cursor-free) ; Set cursor free. -;; (tpu-set-scroll-margins "10%" "15%") ; Set scroll margins. - -;; Scroll margins and cursor binding can be changed from within emacs using -;; the following commands: - -;; tpu-set-scroll-margins or set scroll margins -;; tpu-set-cursor-bound or set cursor bound -;; tpu-set-cursor-free or set cursor free - -;; Additionally, Gold-F toggles between bound and free cursor modes. - -;; Note that switching out of free cursor mode or exiting TPU-edt while in -;; free cursor mode strips trailing whitespace from every line in the file. - - -;;; Details: - -;; The functions contained in this file implement scroll margins and free -;; cursor mode. The following keys and commands are affected. - -;; key/command function scroll cursor - -;; Up-Arrow previous line x x -;; Down-Arrow next line x x -;; Right-Arrow next character x -;; Left-Arrow previous character x -;; KP0 next or previous line x -;; KP7 next or previous page x -;; KP8 next or previous screen x -;; KP2 next or previous end-of-line x x -;; Control-e current end-of-line x -;; Control-h previous beginning-of-line x -;; Next Scr next screen x -;; Prev Scr previous screen x -;; Search find a string x -;; Replace find and replace a string x -;; Newline insert a newline x -;; Paragraph next or previous paragraph x -;; Auto-Fill break lines on spaces x - -;; These functions are not part of the base TPU-edt for the following -;; reasons: - -;; Free cursor mode is implemented with the emacs picture-mode functions. -;; These functions support moving the cursor all over the screen, however, -;; when the cursor is moved past the end of a line, spaces or tabs are -;; appended to the line - even if no text is entered in that area. In -;; order for a free cursor mode to work exactly like TPU/edt, this trailing -;; whitespace needs to be dealt with in every function that might encounter -;; it. Such global changes are impractical, however, free cursor mode is -;; too valuable to abandon completely, so it has been implemented in those -;; functions where it serves best. - -;; The implementation of scroll margins adds overhead to previously -;; simple and often used commands. These commands are now responsible -;; for their normal operation and part of the display function. There -;; is a possibility that this display overhead could adversely affect the -;; performance of TPU-edt on slower computers. In order to support the -;; widest range of computers, scroll margin support is optional. - -;; It's actually not known whether the overhead associated with scroll -;; margin support is significant. If you find that it is, please send -;; a note describing the extent of the performance degradation. Be sure -;; to include a description of the platform where you're running TPU-edt. -;; Send your note to the address provided by Gold-V. - -;; Even with these differences and limitations, these functions implement -;; important aspects of the real TPU/edt. Those who miss free cursor mode -;; and/or scroll margins will appreciate these implementations. - -;;; Code: - - -;;; Gotta have tpu-edt - -(require 'tpu-edt) - - -;;; Customization variables - -(defconst tpu-top-scroll-margin 0 - "*Scroll margin at the top of the screen. -Interpreted as a percent of the current window size.") -(defconst tpu-bottom-scroll-margin 0 - "*Scroll margin at the bottom of the screen. -Interpreted as a percent of the current window size.") - -(defvar tpu-backward-char-like-tpu t - "*If non-nil, in free cursor mode backward-char (left-arrow) works -just like TPU/edt. Otherwise, backward-char will move to the end of -the previous line when starting from a line beginning.") - - -;;; Global variables - -(defvar tpu-cursor-free nil - "If non-nil, let the cursor roam free.") - - -;;; Hooks -- Set cursor free in picture mode. -;;; Clean up when writing a file from cursor free mode. - -(add-hook 'picture-mode-hook 'tpu-set-cursor-free) - -(defun tpu-write-file-hook nil - "Eliminate whitespace at ends of lines, if the cursor is free." - (if (and (buffer-modified-p) tpu-cursor-free) (picture-clean))) - -(or (memq 'tpu-write-file-hook write-file-hooks) - (setq write-file-hooks - (cons 'tpu-write-file-hook write-file-hooks))) - - -;;; Utility routines for implementing scroll margins - -(defun tpu-top-check (beg lines) - "Enforce scroll margin at the top of screen." - (let ((margin (/ (* (window-height) tpu-top-scroll-margin) 100))) - (cond ((< beg margin) (recenter beg)) - ((< (- beg lines) margin) (recenter margin))))) - -(defun tpu-bottom-check (beg lines) - "Enforce scroll margin at the bottom of screen." - (let* ((height (window-height)) - (margin (+ 1 (/ (* height tpu-bottom-scroll-margin) 100))) - ;; subtract 1 from height because it includes mode line - (difference (- height margin 1))) - (cond ((> beg difference) (recenter beg)) - ((> (+ beg lines) difference) (recenter (- margin)))))) - - -;;; Movement by character - -(defun tpu-forward-char (num) - "Move right ARG characters (left if ARG is negative)." - (interactive "p") - (setq zmacs-region-stays t) - (if tpu-cursor-free (picture-forward-column num) (forward-char num))) - -(defun tpu-backward-char (num) - "Move left ARG characters (right if ARG is negative)." - (interactive "p") - (setq zmacs-region-stays t) - (cond ((not tpu-cursor-free) - (backward-char num)) - (tpu-backward-char-like-tpu - (picture-backward-column num)) - ((bolp) - (backward-char 1) - (picture-end-of-line) - (picture-backward-column (1- num))) - (t - (picture-backward-column num)))) - - -;;; Movement by line - -(defun tpu-next-line (num) - "Move to next line. -Prefix argument serves as a repeat count." - (interactive "p") - (setq zmacs-region-stays t) - (let ((beg (tpu-current-line))) - (if tpu-cursor-free (or (eobp) (picture-move-down num)) - (next-line-internal num)) - (tpu-bottom-check beg num) - (setq this-command 'next-line))) - -(defun tpu-previous-line (num) - "Move to previous line. -Prefix argument serves as a repeat count." - (interactive "p") - (setq zmacs-region-stays t) - (let ((beg (tpu-current-line))) - (if tpu-cursor-free (picture-move-up num) (next-line-internal (- num))) - (tpu-top-check beg num) - (setq this-command 'previous-line))) - -(defun tpu-next-beginning-of-line (num) - "Move to beginning of line; if at beginning, move to beginning of next line. -Accepts a prefix argument for the number of lines to move." - (interactive "p") - (setq zmacs-region-stays t) - (let ((beg (tpu-current-line))) - (backward-char 1) - (forward-line (- 1 num)) - (tpu-top-check beg num))) - -(defun tpu-next-end-of-line (num) - "Move to end of line; if at end, move to end of next line. -Accepts a prefix argument for the number of lines to move." - (interactive "p") - (setq zmacs-region-stays t) - (let ((beg (tpu-current-line))) - (cond (tpu-cursor-free - (let ((beg (point))) - (if (< 1 num) (forward-line num)) - (picture-end-of-line) - (if (<= (point) beg) (progn (forward-line) (picture-end-of-line))))) - (t - (forward-char) - (end-of-line num))) - (tpu-bottom-check beg num))) - -(defun tpu-previous-end-of-line (num) - "Move EOL upward. -Accepts a prefix argument for the number of lines to move." - (interactive "p") - (setq zmacs-region-stays t) - (let ((beg (tpu-current-line))) - (cond (tpu-cursor-free - (picture-end-of-line (- 1 num))) - (t - (end-of-line (- 1 num)))) - (tpu-top-check beg num))) - -(defun tpu-current-end-of-line nil - "Move point to end of current line." - (interactive) - (setq zmacs-region-stays t) - (let ((beg (point))) - (if tpu-cursor-free (picture-end-of-line) (end-of-line)) - (if (= beg (point)) (message "You are already at the end of a line.")))) - -(defun tpu-forward-line (num) - "Move to beginning of next line. -Prefix argument serves as a repeat count." - (interactive "p") - (let ((beg (tpu-current-line))) - (next-line-internal num) - (tpu-bottom-check beg num) - (beginning-of-line))) - -(defun tpu-backward-line (num) - "Move to beginning of previous line. -Prefix argument serves as repeat count." - (interactive "p") - (setq zmacs-region-stays t) - (let ((beg (tpu-current-line))) - (or (bolp) (>= 0 num) (setq num (- num 1))) - (next-line-internal (- num)) - (tpu-top-check beg num) - (beginning-of-line))) - - -;;; Movement by paragraph - -(defun tpu-paragraph (num) - "Move to the next paragraph in the current direction. -A repeat count means move that many paragraphs." - (interactive "p") - (setq zmacs-region-stays t) - (let* ((left nil) - (beg (tpu-current-line)) - (height (window-height)) - (top-percent - (if (= 0 tpu-top-scroll-margin) 10 tpu-top-scroll-margin)) - (bottom-percent - (if (= 0 tpu-bottom-scroll-margin) 15 tpu-bottom-scroll-margin)) - (top-margin (/ (* height top-percent) 100)) - (bottom-up-margin (+ 1 (/ (* height bottom-percent) 100))) - (bottom-margin (max beg (- height bottom-up-margin 1))) - (top (save-excursion (move-to-window-line top-margin) (point))) - (bottom (save-excursion (move-to-window-line bottom-margin) (point))) - (far (save-excursion - (goto-char bottom) (forward-line (- height 2)) (point)))) - (cond (tpu-advance - (tpu-next-paragraph num) - (cond((> (point) far) - (setq left (save-excursion (forward-line height))) - (if (= 0 left) (recenter top-margin) - (recenter (- left bottom-up-margin)))) - (t - (and (> (point) bottom) (recenter bottom-margin))))) - (t - (tpu-previous-paragraph num) - (and (< (point) top) (recenter (min beg top-margin))))))) - - -;;; Movement by page - -(defun tpu-page (num) - "Move to the next page in the current direction. -A repeat count means move that many pages." - (interactive "p") - (setq zmacs-region-stays t) - (let* ((left nil) - (beg (tpu-current-line)) - (height (window-height)) - (top-percent - (if (= 0 tpu-top-scroll-margin) 10 tpu-top-scroll-margin)) - (bottom-percent - (if (= 0 tpu-bottom-scroll-margin) 15 tpu-bottom-scroll-margin)) - (top-margin (/ (* height top-percent) 100)) - (bottom-up-margin (+ 1 (/ (* height bottom-percent) 100))) - (bottom-margin (max beg (- height bottom-up-margin 1))) - (top (save-excursion (move-to-window-line top-margin) (point))) - (bottom (save-excursion (move-to-window-line bottom-margin) (point))) - (far (save-excursion - (goto-char bottom) (forward-line (- height 2)) (point)))) - (cond (tpu-advance - (forward-page num) - (cond((> (point) far) - (setq left (save-excursion (forward-line height))) - (if (= 0 left) (recenter top-margin) - (recenter (- left bottom-up-margin)))) - (t - (and (> (point) bottom) (recenter bottom-margin))))) - (t - (backward-page num) - (and (< (point) top) (recenter (min beg top-margin))))))) - - -;;; Scrolling - -(defun tpu-scroll-window-down (num) - "Scroll the display down to the next section. -A repeat count means scroll that many sections." - (interactive "p") - (setq zmacs-region-stays t) - (let* ((beg (tpu-current-line)) - (height (1- (window-height))) - (lines (* num (/ (* height tpu-percent-scroll) 100)))) - (next-line-internal (- lines)) - (tpu-top-check beg lines))) - -(defun tpu-scroll-window-up (num) - "Scroll the display up to the next section. -A repeat count means scroll that many sections." - (interactive "p") - (setq zmacs-region-stays t) - (let* ((beg (tpu-current-line)) - (height (1- (window-height))) - (lines (* num (/ (* height tpu-percent-scroll) 100)))) - (next-line-internal lines) - (tpu-bottom-check beg lines))) - - -;;; Replace the TPU-edt internal search function - -(defun tpu-search-internal (pat &optional quiet) - "Search for a string or regular expression." - (let* ((left nil) - (beg (tpu-current-line)) - (height (window-height)) - (top-percent - (if (= 0 tpu-top-scroll-margin) 10 tpu-top-scroll-margin)) - (bottom-percent - (if (= 0 tpu-bottom-scroll-margin) 15 tpu-bottom-scroll-margin)) - (top-margin (/ (* height top-percent) 100)) - (bottom-up-margin (+ 1 (/ (* height bottom-percent) 100))) - (bottom-margin (max beg (- height bottom-up-margin 1))) - (top (save-excursion (move-to-window-line top-margin) (point))) - (bottom (save-excursion (move-to-window-line bottom-margin) (point))) - (far (save-excursion - (goto-char bottom) (forward-line (- height 2)) (point)))) - (tpu-search-internal-core pat quiet) - (if tpu-searching-forward - (cond((> (point) far) - (setq left (save-excursion (forward-line height))) - (if (= 0 left) (recenter top-margin) - (recenter (- left bottom-up-margin)))) - (t - (and (> (point) bottom) (recenter bottom-margin)))) - (and (< (point) top) (recenter (min beg top-margin)))))) - - - -;;; Replace the newline, newline-and-indent, and do-auto-fill functions - -(or (fboundp 'tpu-old-newline) - (fset 'tpu-old-newline (symbol-function 'newline))) -(or (fboundp 'tpu-old-do-auto-fill) - (fset 'tpu-old-do-auto-fill (symbol-function 'do-auto-fill))) -(or (fboundp 'tpu-old-newline-and-indent) - (fset 'tpu-old-newline-and-indent (symbol-function 'newline-and-indent))) - -(defun newline (&optional num) - "Insert a newline. With arg, insert that many newlines. -In Auto Fill mode, can break the preceding line if no numeric arg. -This is the TPU-edt version that respects the bottom scroll margin." - (interactive "p") - (setq zmacs-region-stays t) - (let ((beg (tpu-current-line))) - (or num (setq num 1)) - (tpu-old-newline num) - (tpu-bottom-check beg num))) - -(defun newline-and-indent nil - "Insert a newline, then indent according to major mode. -Indentation is done using the current indent-line-function. -In programming language modes, this is the same as TAB. -In some text modes, where TAB inserts a tab, this indents -to the specified left-margin column. This is the TPU-edt -version that respects the bottom scroll margin." - (interactive) - (setq zmacs-region-stays t) - (let ((beg (tpu-current-line))) - (tpu-old-newline-and-indent) - (tpu-bottom-check beg 1))) - -(defun do-auto-fill nil - "TPU-edt version that respects the bottom scroll margin." - (let ((beg (tpu-current-line))) - (tpu-old-do-auto-fill) - (tpu-bottom-check beg 1))) - - -;;; Function to set scroll margins - -;;;###autoload -(defun tpu-set-scroll-margins (top bottom) - "Set scroll margins." - (interactive - "sEnter top scroll margin (N lines or N%% or RETURN for current value): \ -\nsEnter bottom scroll margin (N lines or N%% or RETURN for current value): ") - (setq zmacs-region-stays t) - ;; set top scroll margin - (or (string= top "") - (if (string= "%" (substring top -1)) - (setq tpu-top-scroll-margin (string-to-int top)) - (setq tpu-top-scroll-margin - (/ (1- (+ (* (string-to-int top) 100) (window-height))) - (window-height))))) - ;; set bottom scroll margin - (or (string= bottom "") - (if (string= "%" (substring bottom -1)) - (setq tpu-bottom-scroll-margin (string-to-int bottom)) - (setq tpu-bottom-scroll-margin - (/ (1- (+ (* (string-to-int bottom) 100) (window-height))) - (window-height))))) - ;; report scroll margin settings if running interactively - (and (interactive-p) - (message "Scroll margins set. Top = %s%%, Bottom = %s%%" - tpu-top-scroll-margin tpu-bottom-scroll-margin))) - - -;;; Functions to set cursor bound or free - -;;;###autoload -(defun tpu-set-cursor-free nil - "Allow the cursor to move freely about the screen." - (interactive) - (setq zmacs-region-stays t) - (setq tpu-cursor-free t) - (substitute-key-definition 'tpu-set-cursor-free - 'tpu-set-cursor-bound - GOLD-map) - (message "The cursor will now move freely about the screen.")) - -;;;###autoload -(defun tpu-set-cursor-bound nil - "Constrain the cursor to the flow of the text." - (interactive) - (setq zmacs-region-stays t) - (picture-clean) - (setq tpu-cursor-free nil) - (substitute-key-definition 'tpu-set-cursor-bound - 'tpu-set-cursor-free - GOLD-map) - (message "The cursor is now bound to the flow of your text.")) - -;;; tpu-extras.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/emulators/tpu-mapper.el --- a/lisp/emulators/tpu-mapper.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,400 +0,0 @@ -;;; tpu-mapper.el --- Create a TPU-edt X-windows keymap file - -;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc. - -;; Author: Rob Riepel -;; Maintainer: Rob Riepel -;; Keywords: emulations - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34 - -;;; Commentary: - -;; This emacs lisp program can be used to create an emacs lisp file that -;; defines the TPU-edt keypad for emacs running on x-windows. Please read -;; the "Usage" AND "Known Problems" sections before attempting to run this -;; program. - -;;; Usage: - -;; Simply load this file into the X-windows version of XEmacs using the -;; following command. - -;; xemacs -q -l tpu-mapper - -;; The "-q" option prevents loading of your .emacs file (commands therein -;; might confuse this program). - -;; An instruction screen showing the TPU-edt keypad will be displayed, and -;; you will be prompted to press the TPU-edt editing keys. Tpu-mapper uses -;; the keys you press to create an Emacs Lisp file that will define a -;; TPU-edt keypad for your X server. You can even re-arrange the standard -;; EDT keypad to suit your tastes (or to cope with those silly Sun and PC -;; keypads). - -;; Finally, you will be prompted for the name of the file to store the key -;; definitions. If you chose the default, TPU-edt will find it and load it -;; automatically. If you specify a different file name, you will need to -;; set the variable "tpu-xkeys-file" before starting TPU-edt. Here's how -;; you might go about doing that in your .emacs file. - -;; (setq tpu-xkeys-file (expand-file-name "~/.my-emacs-x-keys")) -;; (tpu-edt) - -;;; Known Problems: - -;; Sometimes, tpu-mapper will ignore a key you press, and just continue to -;; prompt for the same key. This can happen when your window manager sucks -;; up the key and doesn't pass it on to Emacs, or it could be an Emacs bug. -;; Either way, there's nothing that tpu-mapper can do about it. You must -;; press RETURN, to skip the current key and continue. Later, you and/or -;; your local X guru can try to figure out why the key is being ignored. - -;; NOTE: There was a very old tpu-edt in XEmacs 19.14 so I deleted it and -;; replaced it with the one in Emacs 19.34. -sb - -;;; Code: - - -;;; -;;; Make sure we're running X-windows and Emacs version 19 -;;; -(cond - ((not (and window-system (not (string-lessp emacs-version "19")))) - (error "tpu-mapper requires running in Emacs 19, with an X display"))) - - -;;; -;;; Decide whether we're running Lucid Emacs or Emacs itself. -;;; -(defconst tpu-lucid-emacs19-p (string-match "Lucid" emacs-version) - "Non-NIL if we are running Lucid Emacs version 19.") - - -;;; -;;; Key variables -;;; -(defvar tpu-kp4 nil) -(defvar tpu-kp5 nil) -(defvar tpu-key nil) -(defvar tpu-enter nil) -(defvar tpu-return nil) -(defvar tpu-key-seq nil) -(defvar tpu-enter-seq nil) -(defvar tpu-return-seq nil) - - -;;; -;;; Make sure the window is big enough to display the instructions -;;; -(if tpu-lucid-emacs19-p (set-screen-size (selected-screen) 80 36) - (set-frame-size (selected-frame) 80 36)) - - -;;; -;;; Create buffers - Directions, Keys, Gold-Keys -;;; -(if (not (get-buffer "Directions")) (generate-new-buffer "Directions")) -(if (not (get-buffer "Keys")) (generate-new-buffer "Keys")) -(if (not (get-buffer "Gold-Keys")) (generate-new-buffer "Gold-Keys")) - - -;;; -;;; Put headers in the Keys buffer -;;; -(set-buffer "Keys") -(insert "\ -;; Key definitions for TPU-edt -;; -") - - -;;; -;;; Display directions -;;; -(switch-to-buffer "Directions") -(insert " - This program prompts you to press keys to create a custom keymap file - for use with the x-windows version of Emacs and TPU-edt. - - Start by pressing the RETURN key, and continue by pressing the keys - specified in the mini-buffer. You can re-arrange the TPU-edt keypad - by pressing any key you want at any prompt. If you want to entirely - omit a key, just press RETURN at the prompt. - - Here's a picture of the standard TPU/edt keypad for reference: - - _______________________ _______________________________ - | HELP | Do | | | | | | - |KeyDefs| | | | | | | - |_______|_______________| |_______|_______|_______|_______| - _______________________ _______________________________ - | Find |Insert |Remove | | Gold | HELP |FndNxt | Del L | - | | |Sto Tex| | key |E-Help | Find |Undel L| - |_______|_______|_______| |_______|_______|_______|_______| - |Select |Pre Scr|Nex Scr| | Page | Sect |Append | Del W | - | Reset |Pre Win|Nex Win| | Do | Fill |Replace|Undel W| - |_______|_______|_______| |_______|_______|_______|_______| - |Move up| |Forward|Reverse|Remove | Del C | - | Top | |Bottom | Top |Insert |Undel C| - _______|_______|_______ |_______|_______|_______|_______| - |Mov Lef|Mov Dow|Mov Rig| | Word | EOL | Char | | - |StaOfLi|Bottom |EndOfLi| |ChngCas|Del EOL|SpecIns| Enter | - |_______|_______|_______| |_______|_______|_______| | - | Line |Select | Subs | - | Open Line | Reset | | - |_______________|_______|_______| - - -") -(delete-other-windows) -(goto-char (point-min)) - -;;; -;;; Save for future reference -;;; -(cond - (tpu-lucid-emacs19-p - (setq tpu-return-seq (read-key-sequence "Hit carriage-return to continue ")) - (setq tpu-return (concat "[" (format "%s" (event-key (aref tpu-return-seq 0))) "]"))) - (t - (message "Hit carriage-return to continue ") - (setq tpu-return-seq (read-event)) - (setq tpu-return (concat "[" (format "%s" tpu-return-seq) "]")))) - - -;;; -;;; Key mapping functions -;;; -(defun tpu-lucid-map-key (ident descrip func gold-func) - (interactive) - (setq tpu-key-seq (read-key-sequence (format "Press %s%s: " ident descrip))) - (setq tpu-key (concat "[" (format "%s" (event-key (aref tpu-key-seq 0))) "]")) - (cond ((not (equal tpu-key tpu-return)) - (set-buffer "Keys") - (insert (format"(global-set-key %s %s)\n" tpu-key func)) - (set-buffer "Gold-Keys") - (insert (format "(define-key GOLD-map %s %s)\n" tpu-key gold-func)) - (set-buffer "Directions")) - ;; bogosity to get next prompt to come up, if the user hits ! - ;; check periodically to see if this is still needed... - (t - (format "%s" tpu-key))) - tpu-key) - -(defun tpu-emacs-map-key (ident descrip func gold-func) - (interactive) - (message "Press %s%s: " ident descrip) - (setq tpu-key-seq (read-event)) - (setq tpu-key (concat "[" (format "%s" tpu-key-seq) "]")) - (cond ((not (equal tpu-key tpu-return)) - (set-buffer "Keys") - (insert (format"(global-set-key %s %s)\n" tpu-key func)) - (set-buffer "Gold-Keys") - (insert (format "(define-key GOLD-map %s %s)\n" tpu-key gold-func)) - (set-buffer "Directions")) - ;; bogosity to get next prompt to come up, if the user hits ! - ;; check periodically to see if this is still needed... - (t - (format "%s" tpu-key))) - tpu-key) - -(fset 'tpu-map-key (if tpu-lucid-emacs19-p 'tpu-lucid-map-key 'tpu-emacs-map-key)) - - -(set-buffer "Keys") -(insert " -;; Arrows -;; -") -(set-buffer "Gold-Keys") -(insert " -;; GOLD Arrows -;; -") -(set-buffer "Directions") - -(tpu-map-key "Up-Arrow" "" "'tpu-previous-line" "'tpu-move-to-beginning") -(tpu-map-key "Down-arrow" "" "'tpu-next-line" "'tpu-move-to-end") -(tpu-map-key "Right-arrow" "" "'tpu-forward-char" "'end-of-line") -(tpu-map-key "Left-arrow" "" "'tpu-backward-char" "'beginning-of-line") - - -(set-buffer "Keys") -(insert " -;; PF keys -;; -") -(set-buffer "Gold-Keys") -(insert " -;; GOLD PF keys -;; -") -(set-buffer "Directions") - -(tpu-map-key "PF1" " - The GOLD key" "GOLD-map" "'keyboard-quit") -(tpu-map-key "PF2" " - The Keypad Help key" "'tpu-help" "'help-for-help") -(tpu-map-key "PF3" " - The Find/Find-Next key" "'tpu-search-again" "'tpu-search") -(tpu-map-key "PF4" " - The Del/Undelete Line key" "'tpu-delete-current-line" "'tpu-undelete-lines") - -(set-buffer "Keys") -(insert " -;; KP0-9 KP- KP, KP. and KPenter -;; -") -(set-buffer "Gold-Keys") -(insert " -;; GOLD KP0-9 KP- KP, and KPenter -;; -") -(set-buffer "Directions") - -(tpu-map-key "KP-0" " - The Line/Open-Line key" "'tpu-line" "'open-line") -(tpu-map-key "KP-1" " - The Word/Change-Case key" "'tpu-word" "'tpu-change-case") -(tpu-map-key "KP-2" " - The EOL/Delete-EOL key" "'tpu-end-of-line" "'tpu-delete-to-eol") -(tpu-map-key "KP-3" " - The Character/Special-Insert key" "'tpu-char" "'tpu-special-insert") -(setq tpu-kp4 (tpu-map-key "KP-4" " - The Forward/Bottom key" "'tpu-advance-direction" "'tpu-move-to-end")) -(setq tpu-kp5 (tpu-map-key "KP-5" " - The Reverse/Top key" "'tpu-backup-direction" "'tpu-move-to-beginning")) -(tpu-map-key "KP-6" " - The Remove/Insert key" "'tpu-cut" "'tpu-paste") -(tpu-map-key "KP-7" " - The Page/Do key" "'tpu-page" "'execute-extended-command") -(tpu-map-key "KP-8" " - The Section/Fill key" "'tpu-scroll-window" "'tpu-fill") -(tpu-map-key "KP-9" " - The Append/Replace key" "'tpu-append-region" "'tpu-replace") -(tpu-map-key "KP--" " - The Delete/Undelete Word key" "'tpu-delete-current-word" "'tpu-undelete-words") -(tpu-map-key "KP-," " - The Delete/Undelete Character key" "'tpu-delete-current-char" "'tpu-undelete-char") -(tpu-map-key "KP-." " - The Select/Reset key" "'tpu-select" "'tpu-unselect") -(tpu-map-key "KP-Enter" " - The Enter key on the numeric keypad" "'newline" "'tpu-substitute") -;; Save the enter key -(setq tpu-enter tpu-key) -(setq tpu-enter-seq tpu-key-seq) - -(set-buffer "Keys") -(insert " -;; Editing keypad (find, insert, remove) -;; (select, prev, next) -;; -") -(set-buffer "Gold-Keys") -(insert " -;; GOLD Editing keypad (find, insert, remove) -;; (select, prev, next) -;; -") -(set-buffer "Directions") - -(tpu-map-key "Find" " - The Find key on the editing keypad" "'tpu-search" "'nil") -(tpu-map-key "Insert" " - The Insert key on the editing keypad" "'tpu-paste" "'nil") -(tpu-map-key "Remove" " - The Remove key on the editing keypad" "'tpu-cut" "'tpu-store-text") -(tpu-map-key "Select" " - The Select key on the editing keypad" "'tpu-select" "'tpu-unselect") -(tpu-map-key "Prev Scr" " - The Prev Scr key on the editing keypad" "'tpu-scroll-window-down" "'tpu-previous-window") -(tpu-map-key "Next Scr" " - The Next Scr key on the editing keypad" "'tpu-scroll-window-up" "'tpu-next-window") - -(set-buffer "Keys") -(insert " -;; F10-14 Help Do F17 -;; -") -(set-buffer "Gold-Keys") -(insert " -;; GOLD F10-14 Help Do F17 -;; -") -(set-buffer "Directions") - -(tpu-map-key "F10" " - Invokes the Exit function on VT200+ terminals" "'tpu-exit" "'nil") -(tpu-map-key "F11" " - Inserts an Escape character into the text" "'tpu-insert-escape" "'nil") -(tpu-map-key "Backspace" " - Not Delete nor ^H! Sometimes on the F12 key" "'tpu-next-beginning-of-line" "'nil") -(tpu-map-key "F13" " - Invokes the delete previous word function" "'tpu-delete-previous-word" "'nil") -(tpu-map-key "F14" " - Toggles insert/overstrike modes" "'tpu-toggle-overwrite-mode" "'nil") -(tpu-map-key "Help" " - Brings up the help screen, same as PF2" "'tpu-help" "'describe-bindings") -(tpu-map-key "Do" " - Invokes the COMMAND function" "'execute-extended-command" "'nil") -(tpu-map-key "F17" "" "'tpu-goto-breadcrumb" "'tpu-drop-breadcrumb") - -(set-buffer "Gold-Keys") -(cond - ((not (equal tpu-enter tpu-return)) - (insert " -;; Minibuffer map additions to make KP_enter = RET -;; -") - - (insert (format "(define-key minibuffer-local-map %s 'exit-minibuffer)\n" tpu-enter)) - (insert (format "(define-key minibuffer-local-ns-map %s 'exit-minibuffer)\n" tpu-enter)) - (insert (format "(define-key minibuffer-local-completion-map %s 'exit-minibuffer)\n" tpu-enter)) - (insert (format "(define-key minibuffer-local-must-match-map %s 'minibuffer-complete-and-exit)\n" tpu-enter)))) - -(cond - ((not (or (equal tpu-kp4 tpu-return) (equal tpu-kp5 tpu-return))) - (insert " -;; Minibuffer map additions to allow KP-4/5 termination of search strings. -;; -") - - (insert (format "(define-key minibuffer-local-map %s 'tpu-search-forward-exit)\n" tpu-kp4)) - (insert (format "(define-key minibuffer-local-map %s 'tpu-search-backward-exit)\n" tpu-kp5)))) - -(insert " -;; Define the tpu-help-enter/return symbols -;; -") - -(cond (tpu-lucid-emacs19-p - (insert (format "(setq tpu-help-enter \"%s\")\n" tpu-enter-seq)) - (insert (format "(setq tpu-help-return \"%s\")\n" tpu-return-seq)) - (insert "(setq tpu-help-N \"[#]\")\n") - (insert "(setq tpu-help-n \"[#]\")\n") - (insert "(setq tpu-help-P \"[#]\")\n") - (insert "(setq tpu-help-p \"[#]\")\n")) - (t - (insert (format "(setq tpu-help-enter \"%s\")\n" tpu-enter)))) - -(append-to-buffer "Keys" 1 (point)) -(set-buffer "Keys") - -;;; -;;; Save the key mapping program -;;; -(let ((file - (convert-standard-filename - (if tpu-lucid-emacs19-p "~/.tpu-lucid-keys" "~/.tpu-keys")))) - (set-visited-file-name - (read-file-name (format "Save key mapping to file (default %s): " file) "" file))) -(save-buffer) - -;;; -;;; Load the newly defined keys and clean up -;;; -(eval-current-buffer) -(kill-buffer (current-buffer)) -(kill-buffer "*scratch*") -(kill-buffer "Gold-Keys") - -;;; -;;; Let them know it worked. -;;; -(switch-to-buffer "Directions") -(erase-buffer) -(insert " - A custom TPU-edt keymap file has been created. - - Press GOLD-k to remove this buffer and continue editing. -") -(goto-char (point-min)) - -;;; tpu-mapper.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/emulators/ws-mode.el --- a/lisp/emulators/ws-mode.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,756 +0,0 @@ -;;; ws-mode.el --- WordStar emulation mode for GNU Emacs - -;; Copyright (C) 1991 Free Software Foundation, Inc. - -;; Author: Juergen Nickelsen -;; Version: 0.7 -;; Keywords: emulations - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34 - -;;; Commentary: - -;; This emulates WordStar, with a major mode. - -;;; Code: - -(defvar wordstar-mode-map nil "") -(defvar wordstar-C-j-map nil "") -(defvar wordstar-C-k-map nil "") -(defvar wordstar-C-o-map nil "") -(defvar wordstar-C-q-map nil "") - -(if wordstar-mode-map - () - (setq wordstar-mode-map (make-keymap)) - ;; (setq wordstar-C-j-map (make-keymap)) ; later, perhaps - (setq wordstar-C-k-map (make-keymap)) - (setq wordstar-C-o-map (make-keymap)) - (setq wordstar-C-q-map (make-keymap)) - - (define-key wordstar-mode-map "\C-a" 'backward-word) - (define-key wordstar-mode-map "\C-b" 'fill-paragraph) - (define-key wordstar-mode-map "\C-c" 'scroll-up) - (define-key wordstar-mode-map "\C-d" 'forward-char) - (define-key wordstar-mode-map "\C-e" 'previous-line) - (define-key wordstar-mode-map "\C-f" 'forward-word) - (define-key wordstar-mode-map "\C-g" 'delete-char) - (define-key wordstar-mode-map "\C-h" 'backward-char) - (define-key wordstar-mode-map "\C-i" 'indent-for-tab-command) - (define-key wordstar-mode-map "\C-j" 'help-for-help) - (define-key wordstar-mode-map "\C-k" wordstar-C-k-map) - (define-key wordstar-mode-map "\C-l" 'ws-repeat-search) - (define-key wordstar-mode-map "\C-n" 'open-line) - (define-key wordstar-mode-map "\C-o" wordstar-C-o-map) - (define-key wordstar-mode-map "\C-p" 'quoted-insert) - (define-key wordstar-mode-map "\C-q" wordstar-C-q-map) - (define-key wordstar-mode-map "\C-r" 'scroll-down) - (define-key wordstar-mode-map "\C-s" 'backward-char) - (define-key wordstar-mode-map "\C-t" 'kill-word) - (define-key wordstar-mode-map "\C-u" 'keyboard-quit) - (define-key wordstar-mode-map "\C-v" 'overwrite-mode) - (define-key wordstar-mode-map "\C-w" 'scroll-down-line) - (define-key wordstar-mode-map "\C-x" 'next-line) - (define-key wordstar-mode-map "\C-y" 'kill-complete-line) - (define-key wordstar-mode-map "\C-z" 'scroll-up-line) - - ;; wordstar-C-k-map - - (define-key wordstar-C-k-map " " ()) - (define-key wordstar-C-k-map "0" 'ws-set-marker-0) - (define-key wordstar-C-k-map "1" 'ws-set-marker-1) - (define-key wordstar-C-k-map "2" 'ws-set-marker-2) - (define-key wordstar-C-k-map "3" 'ws-set-marker-3) - (define-key wordstar-C-k-map "4" 'ws-set-marker-4) - (define-key wordstar-C-k-map "5" 'ws-set-marker-5) - (define-key wordstar-C-k-map "6" 'ws-set-marker-6) - (define-key wordstar-C-k-map "7" 'ws-set-marker-7) - (define-key wordstar-C-k-map "8" 'ws-set-marker-8) - (define-key wordstar-C-k-map "9" 'ws-set-marker-9) - (define-key wordstar-C-k-map "b" 'ws-begin-block) - (define-key wordstar-C-k-map "\C-b" 'ws-begin-block) - (define-key wordstar-C-k-map "c" 'ws-copy-block) - (define-key wordstar-C-k-map "\C-c" 'ws-copy-block) - (define-key wordstar-C-k-map "d" 'save-buffers-kill-emacs) - (define-key wordstar-C-k-map "\C-d" 'save-buffers-kill-emacs) - (define-key wordstar-C-k-map "f" 'find-file) - (define-key wordstar-C-k-map "\C-f" 'find-file) - (define-key wordstar-C-k-map "h" 'ws-show-markers) - (define-key wordstar-C-k-map "\C-h" 'ws-show-markers) - (define-key wordstar-C-k-map "i" 'ws-indent-block) - (define-key wordstar-C-k-map "\C-i" 'ws-indent-block) - (define-key wordstar-C-k-map "k" 'ws-end-block) - (define-key wordstar-C-k-map "\C-k" 'ws-end-block) - (define-key wordstar-C-k-map "p" 'ws-print-block) - (define-key wordstar-C-k-map "\C-p" 'ws-print-block) - (define-key wordstar-C-k-map "q" 'kill-emacs) - (define-key wordstar-C-k-map "\C-q" 'kill-emacs) - (define-key wordstar-C-k-map "r" 'insert-file) - (define-key wordstar-C-k-map "\C-r" 'insert-file) - (define-key wordstar-C-k-map "s" 'save-some-buffers) - (define-key wordstar-C-k-map "\C-s" 'save-some-buffers) - (define-key wordstar-C-k-map "t" 'ws-mark-word) - (define-key wordstar-C-k-map "\C-t" 'ws-mark-word) - (define-key wordstar-C-k-map "u" 'ws-exdent-block) - (define-key wordstar-C-k-map "\C-u" 'keyboard-quit) - (define-key wordstar-C-k-map "v" 'ws-move-block) - (define-key wordstar-C-k-map "\C-v" 'ws-move-block) - (define-key wordstar-C-k-map "w" 'ws-write-block) - (define-key wordstar-C-k-map "\C-w" 'ws-write-block) - (define-key wordstar-C-k-map "x" 'save-buffers-kill-emacs) - (define-key wordstar-C-k-map "\C-x" 'save-buffers-kill-emacs) - (define-key wordstar-C-k-map "y" 'ws-delete-block) - (define-key wordstar-C-k-map "\C-y" 'ws-delete-block) - - ;; wordstar-C-j-map not yet implemented - - ;; wordstar-C-o-map - - (define-key wordstar-C-o-map " " ()) - (define-key wordstar-C-o-map "c" 'wordstar-center-line) - (define-key wordstar-C-o-map "\C-c" 'wordstar-center-line) - (define-key wordstar-C-o-map "b" 'switch-to-buffer) - (define-key wordstar-C-o-map "\C-b" 'switch-to-buffer) - (define-key wordstar-C-o-map "j" 'justify-current-line) - (define-key wordstar-C-o-map "\C-j" 'justify-current-line) - (define-key wordstar-C-o-map "k" 'kill-buffer) - (define-key wordstar-C-o-map "\C-k" 'kill-buffer) - (define-key wordstar-C-o-map "l" 'list-buffers) - (define-key wordstar-C-o-map "\C-l" 'list-buffers) - (define-key wordstar-C-o-map "m" 'auto-fill-mode) - (define-key wordstar-C-o-map "\C-m" 'auto-fill-mode) - (define-key wordstar-C-o-map "r" 'set-fill-column) - (define-key wordstar-C-o-map "\C-r" 'set-fill-column) - (define-key wordstar-C-o-map "\C-u" 'keyboard-quit) - (define-key wordstar-C-o-map "wd" 'delete-other-windows) - (define-key wordstar-C-o-map "wh" 'split-window-horizontally) - (define-key wordstar-C-o-map "wo" 'other-window) - (define-key wordstar-C-o-map "wv" 'split-window-vertically) - - ;; wordstar-C-q-map - (define-key wordstar-C-q-map " " ()) - (define-key wordstar-C-q-map "0" 'ws-find-marker-0) - (define-key wordstar-C-q-map "1" 'ws-find-marker-1) - (define-key wordstar-C-q-map "2" 'ws-find-marker-2) - (define-key wordstar-C-q-map "3" 'ws-find-marker-3) - (define-key wordstar-C-q-map "4" 'ws-find-marker-4) - (define-key wordstar-C-q-map "5" 'ws-find-marker-5) - (define-key wordstar-C-q-map "6" 'ws-find-marker-6) - (define-key wordstar-C-q-map "7" 'ws-find-marker-7) - (define-key wordstar-C-q-map "8" 'ws-find-marker-8) - (define-key wordstar-C-q-map "9" 'ws-find-marker-9) - (define-key wordstar-C-q-map "a" 'ws-query-replace) - (define-key wordstar-C-q-map "\C-a" 'ws-query-replace) - (define-key wordstar-C-q-map "b" 'ws-goto-block-begin) - (define-key wordstar-C-q-map "\C-b" 'ws-goto-block-begin) - (define-key wordstar-C-q-map "c" 'end-of-buffer) - (define-key wordstar-C-q-map "\C-c" 'end-of-buffer) - (define-key wordstar-C-q-map "d" 'end-of-line) - (define-key wordstar-C-q-map "\C-d" 'end-of-line) - (define-key wordstar-C-q-map "f" 'ws-search) - (define-key wordstar-C-q-map "\C-f" 'ws-search) - (define-key wordstar-C-q-map "k" 'ws-goto-block-end) - (define-key wordstar-C-q-map "\C-k" 'ws-goto-block-end) - (define-key wordstar-C-q-map "l" 'ws-undo) - (define-key wordstar-C-q-map "\C-l" 'ws-undo) - (define-key wordstar-C-q-map "p" 'ws-last-cursorp) - (define-key wordstar-C-q-map "\C-p" 'ws-last-cursorp) - (define-key wordstar-C-q-map "r" 'beginning-of-buffer) - (define-key wordstar-C-q-map "\C-r" 'beginning-of-buffer) - (define-key wordstar-C-q-map "s" 'beginning-of-line) - (define-key wordstar-C-q-map "\C-s" 'beginning-of-line) - (define-key wordstar-C-q-map "\C-u" 'keyboard-quit) - (define-key wordstar-C-q-map "w" 'ws-last-error) - (define-key wordstar-C-q-map "\C-w" 'ws-last-error) - (define-key wordstar-C-q-map "y" 'ws-kill-eol) - (define-key wordstar-C-q-map "\C-y" 'ws-kill-eol) - (define-key wordstar-C-q-map "\177" 'ws-kill-bol)) - -;;;###autoload -(defun wordstar-mode () - "Major mode with WordStar-like key bindings. - -BUGS: - - Help menus with WordStar commands (C-j just calls help-for-help) - are not implemented - - Options for search and replace - - Show markers (C-k h) is somewhat strange - - Search and replace (C-q a) is only available in forward direction - -No key bindings beginning with ESC are installed, they will work -Emacs-like. - -The key bindings are: - - C-a backward-word - C-b fill-paragraph - C-c scroll-up-line - C-d forward-char - C-e previous-line - C-f forward-word - C-g delete-char - C-h backward-char - C-i indent-for-tab-command - C-j help-for-help - C-k ordstar-C-k-map - C-l ws-repeat-search - C-n open-line - C-p quoted-insert - C-r scroll-down-line - C-s backward-char - C-t kill-word - C-u keyboard-quit - C-v overwrite-mode - C-w scroll-down - C-x next-line - C-y kill-complete-line - C-z scroll-up - - C-k 0 ws-set-marker-0 - C-k 1 ws-set-marker-1 - C-k 2 ws-set-marker-2 - C-k 3 ws-set-marker-3 - C-k 4 ws-set-marker-4 - C-k 5 ws-set-marker-5 - C-k 6 ws-set-marker-6 - C-k 7 ws-set-marker-7 - C-k 8 ws-set-marker-8 - C-k 9 ws-set-marker-9 - C-k b ws-begin-block - C-k c ws-copy-block - C-k d save-buffers-kill-emacs - C-k f find-file - C-k h ws-show-markers - C-k i ws-indent-block - C-k k ws-end-block - C-k p ws-print-block - C-k q kill-emacs - C-k r insert-file - C-k s save-some-buffers - C-k t ws-mark-word - C-k u ws-exdent-block - C-k C-u keyboard-quit - C-k v ws-move-block - C-k w ws-write-block - C-k x kill-emacs - C-k y ws-delete-block - - C-o c wordstar-center-line - C-o b switch-to-buffer - C-o j justify-current-line - C-o k kill-buffer - C-o l list-buffers - C-o m auto-fill-mode - C-o r set-fill-column - C-o C-u keyboard-quit - C-o wd delete-other-windows - C-o wh split-window-horizontally - C-o wo other-window - C-o wv split-window-vertically - - C-q 0 ws-find-marker-0 - C-q 1 ws-find-marker-1 - C-q 2 ws-find-marker-2 - C-q 3 ws-find-marker-3 - C-q 4 ws-find-marker-4 - C-q 5 ws-find-marker-5 - C-q 6 ws-find-marker-6 - C-q 7 ws-find-marker-7 - C-q 8 ws-find-marker-8 - C-q 9 ws-find-marker-9 - C-q a ws-query-replace - C-q b ws-to-block-begin - C-q c end-of-buffer - C-q d end-of-line - C-q f ws-search - C-q k ws-to-block-end - C-q l ws-undo - C-q p ws-last-cursorp - C-q r beginning-of-buffer - C-q C-u keyboard-quit - C-q w ws-last-error - C-q y ws-kill-eol - C-q DEL ws-kill-bol -" - (interactive) - (kill-all-local-variables) - (use-local-map wordstar-mode-map) - (setq mode-name "WordStar") - (setq major-mode 'wordstar-mode)) - - -(defun wordstar-center-paragraph () - "Center each line in the paragraph at or after point. -See `wordstar-center-line' for more info." - (interactive) - (save-excursion - (forward-paragraph) - (or (bolp) (newline 1)) - (let ((end (point))) - (backward-paragraph) - (wordstar-center-region (point) end)))) - -(defun wordstar-center-region (from to) - "Center each line starting in the region. -See `wordstar-center-line' for more info." - (interactive "r") - (if (> from to) - (let ((tem to)) - (setq to from from tem))) - (save-excursion - (save-restriction - (narrow-to-region from to) - (goto-char from) - (while (not (eobp)) - (wordstar-center-line) - (forward-line 1))))) - -(defun wordstar-center-line () - "Center the line point is on, within the width specified by `fill-column'. -This means adjusting the indentation to match -the distance between the end of the text and `fill-column'." - (interactive) - (save-excursion - (let (line-length) - (beginning-of-line) - (delete-horizontal-space) - (end-of-line) - (delete-horizontal-space) - (setq line-length (current-column)) - (beginning-of-line) - (indent-to - (+ left-margin - (/ (- fill-column left-margin line-length) 2)))))) - -(defun scroll-down-line () - "Scroll one line down." - (interactive) - (scroll-down 1)) - -(defun scroll-up-line () - "Scroll one line up." - (interactive) - (scroll-up 1)) - -;;;;;;;;;;; -;; wordstar special variables: - -(defvar ws-marker-0 nil "Position marker 0 in WordStar mode.") -(defvar ws-marker-1 nil "Position marker 1 in WordStar mode.") -(defvar ws-marker-2 nil "Position marker 2 in WordStar mode.") -(defvar ws-marker-3 nil "Position marker 3 in WordStar mode.") -(defvar ws-marker-4 nil "Position marker 4 in WordStar mode.") -(defvar ws-marker-5 nil "Position marker 5 in WordStar mode.") -(defvar ws-marker-6 nil "Position marker 6 in WordStar mode.") -(defvar ws-marker-7 nil "Position marker 7 in WordStar mode.") -(defvar ws-marker-8 nil "Position marker 8 in WordStar mode.") -(defvar ws-marker-9 nil "Position marker 9 in WordStar mode.") - -(defvar ws-block-begin-marker nil "Beginning of \"Block\" in WordStar mode.") -(defvar ws-block-end-marker nil "End of \"Block\" in WordStar mode.") - -(defvar ws-search-string nil "String of last search in WordStar mode.") -(defvar ws-search-direction t - "Direction of last search in WordStar mode. T if forward, NIL if backward.") - -(defvar ws-last-cursorposition nil - "Position before last search etc. in WordStar mode.") - -(defvar ws-last-errormessage nil - "Last error message issued by a WordStar mode function.") - -;;;;;;;;;;; -;; wordstar special functions: - -(defun ws-error (string) - "Report error of a WordStar special function. Error message is saved -in ws-last-errormessage for recovery with C-q w." - (setq ws-last-errormessage string) - (error string)) - -(defun ws-set-marker-0 () - "In WordStar mode: Set marker 0 to current cursor position." - (interactive) - (setq ws-marker-0 (point-marker)) - (message "Marker 0 set")) - -(defun ws-set-marker-1 () - "In WordStar mode: Set marker 1 to current cursor position." - (interactive) - (setq ws-marker-1 (point-marker)) - (message "Marker 1 set")) - -(defun ws-set-marker-2 () - "In WordStar mode: Set marker 2 to current cursor position." - (interactive) - (setq ws-marker-2 (point-marker)) - (message "Marker 2 set")) - -(defun ws-set-marker-3 () - "In WordStar mode: Set marker 3 to current cursor position." - (interactive) - (setq ws-marker-3 (point-marker)) - (message "Marker 3 set")) - -(defun ws-set-marker-4 () - "In WordStar mode: Set marker 4 to current cursor position." - (interactive) - (setq ws-marker-4 (point-marker)) - (message "Marker 4 set")) - -(defun ws-set-marker-5 () - "In WordStar mode: Set marker 5 to current cursor position." - (interactive) - (setq ws-marker-5 (point-marker)) - (message "Marker 5 set")) - -(defun ws-set-marker-6 () - "In WordStar mode: Set marker 6 to current cursor position." - (interactive) - (setq ws-marker-6 (point-marker)) - (message "Marker 6 set")) - -(defun ws-set-marker-7 () - "In WordStar mode: Set marker 7 to current cursor position." - (interactive) - (setq ws-marker-7 (point-marker)) - (message "Marker 7 set")) - -(defun ws-set-marker-8 () - "In WordStar mode: Set marker 8 to current cursor position." - (interactive) - (setq ws-marker-8 (point-marker)) - (message "Marker 8 set")) - -(defun ws-set-marker-9 () - "In WordStar mode: Set marker 9 to current cursor position." - (interactive) - (setq ws-marker-9 (point-marker)) - (message "Marker 9 set")) - -(defun ws-begin-block () - "In WordStar mode: Set block begin marker to current cursor position." - (interactive) - (setq ws-block-begin-marker (point-marker)) - (message "Block begin marker set")) - -(defun ws-show-markers () - "In WordStar mode: Show block markers." - (interactive) - (if (or ws-block-begin-marker ws-block-end-marker) - (save-excursion - (if ws-block-begin-marker - (let () - (goto-char ws-block-begin-marker) - (message "Block begin marker") - (sit-for 2)) - (message "Block begin marker not set") - (sit-for 2)) - (if ws-block-end-marker - (let () - (goto-char ws-block-end-marker) - (message "Block end marker") - (sit-for 2)) - (message "Block end marker not set")) - (message "")) - (message "Block markers not set"))) - - -(defun ws-indent-block () - "In WordStar mode: Indent block (not yet implemented)." - (interactive) - (ws-error "Indent block not yet implemented")) - -(defun ws-end-block () - "In WordStar mode: Set block end marker to current cursor position." - (interactive) - (setq ws-block-end-marker (point-marker)) - (message "Block end marker set")) - -(defun ws-print-block () - "In WordStar mode: Print block." - (interactive) - (message "Don't do this. Write block to a file (C-k w) and print this file.")) - -(defun ws-mark-word () - "In WordStar mode: Mark current word as block." - (interactive) - (save-excursion - (forward-word 1) - (sit-for 1) - (ws-end-block) - (forward-word -1) - (sit-for 1) - (ws-begin-block))) - -(defun ws-exdent-block () - "I don't know what this (C-k u) should do." - (interactive) - (ws-error "This won't be done -- not yet implemented.")) - -(defun ws-move-block () - "In WordStar mode: Move block to current cursor position." - (interactive) - (if (and ws-block-begin-marker ws-block-end-marker) - (let () - ;; XEmacs - (kill-region ws-block-begin-marker ws-block-end-marker 'silent) - (yank) - (save-excursion - (goto-char (region-beginning)) - (setq ws-block-begin-marker (point-marker)) - (goto-char (region-end)) - (setq ws-block-end-marker (point-marker)))) - (ws-error (cond (ws-block-begin-marker "Block end marker not set") - (ws-block-end-marker "Block begin marker not set") - (t "Block markers not set"))))) - -(defun ws-write-block () - "In WordStar mode: Write block to file." - (interactive) - (if (and ws-block-begin-marker ws-block-end-marker) - (let ((filename (read-file-name "Write block to file: "))) - (write-region ws-block-begin-marker ws-block-end-marker filename)) - (ws-error (cond (ws-block-begin-marker "Block end marker not set") - (ws-block-end-marker "Block begin marker not set") - (t "Block markers not set"))))) - - -(defun ws-delete-block () - "In WordStar mode: Delete block." - (interactive) - (if (and ws-block-begin-marker ws-block-end-marker) - (let () - (kill-region ws-block-begin-marker ws-block-end-marker) - (setq ws-block-end-marker nil) - (setq ws-block-begin-marker nil)) - (ws-error (cond (ws-block-begin-marker "Block end marker not set") - (ws-block-end-marker "Block begin marker not set") - (t "Block markers not set"))))) - -(defun ws-find-marker-0 () - "In WordStar mode: Go to marker 0." - (interactive) - (if ws-marker-0 - (let () - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-marker-0)) - (ws-error "Marker 0 not set"))) - -(defun ws-find-marker-1 () - "In WordStar mode: Go to marker 1." - (interactive) - (if ws-marker-1 - (let () - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-marker-1)) - (ws-error "Marker 1 not set"))) - -(defun ws-find-marker-2 () - "In WordStar mode: Go to marker 2." - (interactive) - (if ws-marker-2 - (let () - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-marker-2)) - (ws-error "Marker 2 not set"))) - -(defun ws-find-marker-3 () - "In WordStar mode: Go to marker 3." - (interactive) - (if ws-marker-3 - (let () - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-marker-3)) - (ws-error "Marker 3 not set"))) - -(defun ws-find-marker-4 () - "In WordStar mode: Go to marker 4." - (interactive) - (if ws-marker-4 - (let () - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-marker-4)) - (ws-error "Marker 4 not set"))) - -(defun ws-find-marker-5 () - "In WordStar mode: Go to marker 5." - (interactive) - (if ws-marker-5 - (let () - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-marker-5)) - (ws-error "Marker 5 not set"))) - -(defun ws-find-marker-6 () - "In WordStar mode: Go to marker 6." - (interactive) - (if ws-marker-6 - (let () - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-marker-6)) - (ws-error "Marker 6 not set"))) - -(defun ws-find-marker-7 () - "In WordStar mode: Go to marker 7." - (interactive) - (if ws-marker-7 - (let () - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-marker-7)) - (ws-error "Marker 7 not set"))) - -(defun ws-find-marker-8 () - "In WordStar mode: Go to marker 8." - (interactive) - (if ws-marker-8 - (let () - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-marker-8)) - (ws-error "Marker 8 not set"))) - -(defun ws-find-marker-9 () - "In WordStar mode: Go to marker 9." - (interactive) - (if ws-marker-9 - (let () - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-marker-9)) - (ws-error "Marker 9 not set"))) - -(defun ws-goto-block-begin () - "In WordStar mode: Go to block begin marker." - (interactive) - (if ws-block-begin-marker - (let () - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-block-begin-marker)) - (ws-error "Block begin marker not set"))) - -(defun ws-search (string) - "In WordStar mode: Search string, remember string for repetition." - (interactive "sSearch for: ") - (message "Forward (f) or backward (b)") - (let ((direction - (read-char))) - (cond ((equal (upcase direction) ?\F) - (setq ws-search-string string) - (setq ws-search-direction t) - (setq ws-last-cursorposition (point-marker)) - (search-forward string)) - ((equal (upcase direction) ?\B) - (setq ws-search-string string) - (setq ws-search-direction nil) - (setq ws-last-cursorposition (point-marker)) - (search-backward string)) - (t (keyboard-quit))))) - -(defun ws-goto-block-end () - "In WordStar mode: Go to block end marker." - (interactive) - (if ws-block-end-marker - (let () - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-block-end-marker)) - (ws-error "Block end marker not set"))) - -(defun ws-undo () - "In WordStar mode: Undo and give message about undoing more changes." - (interactive) - (undo) - (message "Repeat C-q l to undo more changes.")) - -(defun ws-goto-last-cursorposition () - "In WordStar mode: " - (interactive) - (if ws-last-cursorposition - (let () - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-last-cursorposition)) - (ws-error "No last cursor position available."))) - -(defun ws-last-error () - "In WordStar mode: repeat last error message. -This will only work for errors raised by WordStar mode functions." - (interactive) - (if ws-last-errormessage - (message ws-last-errormessage) - (message "No WordStar error yet."))) - -(defun ws-kill-eol () - "In WordStar mode: Kill to end of line (like WordStar, not like Emacs)." - (interactive) - (let ((p (point))) - (end-of-line) - (kill-region p (point)))) - -(defun ws-kill-bol () - "In WordStar mode: Kill to beginning of line -\(like WordStar, not like Emacs)." - (interactive) - (let ((p (point))) - (beginning-of-line) - (kill-region (point) p))) - -(defun kill-complete-line () - "Kill the complete line." - (interactive) - (beginning-of-line) - (if (eobp) (error "End of buffer")) - (let ((beg (point))) - (forward-line 1) - (kill-region beg (point)))) - -(defun ws-repeat-search () - "In WordStar mode: Repeat last search." - (interactive) - (setq ws-last-cursorposition (point-marker)) - (if ws-search-string - (if ws-search-direction - (search-forward ws-search-string) - (search-backward ws-search-string)) - (ws-error "No search to repeat"))) - -(defun ws-query-replace (from to) - "In WordStar mode: Search string, remember string for repetition." - (interactive "sReplace: -sWith: " ) - (setq ws-search-string from) - (setq ws-search-direction t) - (setq ws-last-cursorposition (point-marker)) - (query-replace from to)) - -(defun ws-copy-block () - "In WordStar mode: Copy block to current cursor position." - (interactive) - (if (and ws-block-begin-marker ws-block-end-marker) - (let () - (copy-region-as-kill ws-block-begin-marker ws-block-end-marker) - (yank) - (save-excursion - (goto-char (region-beginning)) - (setq ws-block-begin-marker (point-marker)) - (goto-char (region-end)) - (setq ws-block-end-marker (point-marker)))) - (ws-error (cond (ws-block-begin-marker "Block end marker not set") - (ws-block-end-marker "Block begin marker not set") - (t "Block markers not set"))))) - -;;; ws-mode.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/eos/Makefile --- a/lisp/eos/Makefile Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,80 +0,0 @@ -### Makefile --- The makefile to build EOS - -## Copyright (C) 1995 Sun Microsystems, Inc. - -## Maintainer: Eduardo Pelegri-Llopart -## Author: Eduardo Pelegri-Llopart - -## Keywords: SPARCworks EOS Era on SPARCworks make makefile - -### Commentary: - -## Please send feedback to eduardo.pelegri-llopart@eng.sun.com - -### Code: - -# what emacs is called on your system -EMACS = ../../src/xemacs - -# compile with noninteractive and relatively clean environment -BATCHFLAGS = -batch -q -no-site-file - -# files that contain variables and macros that everything else depends on -CORE = sun-eos-common.el - -OBJECTS = \ - sun-eos-browser.elc sun-eos-common.elc sun-eos-debugger-extra.elc \ - sun-eos-debugger.elc sun-eos-editor.elc sun-eos-init.elc \ - sun-eos-menubar.elc sun-eos-toolbar.elc sun-eos-load.elc - -SOURCES = \ - sun-eos-browser.el sun-eos-common.el sun-eos-debugger-extra.el \ - sun-eos-debugger.el sun-eos-editor.el sun-eos-init.el \ - sun-eos-menubar.el sun-eos-toolbar.el sun-eos-load.el - -EXTRA = custom-load.elc - -all: $(OBJECTS) - -clean: - rm -f $(OBJECTS) - -custom-load.elc: auto-autoloads.el - ${EMACS} ${BATCHFLAGS} -f batch-byte-compile custom-load.el - -sun-eos-browser.elc: sun-eos-browser.el $(CORE) - ${EMACS} ${BATCHFLAGS} -f batch-byte-compile sun-eos-browser.el - -sun-eos-debugger.elc: sun-eos-debugger.el $(CORE) - ${EMACS} ${BATCHFLAGS} -f batch-byte-compile sun-eos-debugger.el - -sun-eos-debugger-extra.elc: sun-eos-debugger-extra.el $(CORE) - ${EMACS} ${BATCHFLAGS} -f batch-byte-compile sun-eos-debugger-extra.el - -sun-eos-editor.elc: sun-eos-editor.el $(CORE) - ${EMACS} ${BATCHFLAGS} -f batch-byte-compile sun-eos-editor.el - -sun-eos-toolbar.elc: sun-eos-toolbar.el $(CORE) - ${EMACS} ${BATCHFLAGS} -f batch-byte-compile sun-eos-toolbar.el - -sun-eos-menubar.elc: sun-eos-menubar.el $(CORE) - ${EMACS} ${BATCHFLAGS} -f batch-byte-compile sun-eos-menubar.el - -sun-eos-common.elc: sun-eos-common.el - ${EMACS} ${BATCHFLAGS} -f batch-byte-compile sun-eos-common.el - -sun-eos-init.elc: sun-eos-init.el - ${EMACS} ${BATCHFLAGS} -f batch-byte-compile sun-eos-init.el - -sun-eos-load.elc: sun-eos-load.el - ${EMACS} ${BATCHFLAGS} -f batch-byte-compile sun-eos-load.el - -autoloads: custom-load.el - -custom-load.el: $(SOURCES) - $(EMACS) -batch -q -no-site-file \ - -eval '(setq autoload-target-directory "'`pwd`'/")' \ - -l autoload \ - -f batch-update-autoloads $? - -### Makefile ends here diff -r 43306a74e31c -r d44af0c54775 lisp/eos/eos.el --- a/lisp/eos/eos.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,21 +0,0 @@ -;;; eos.el --- Intereactively loads the XEmacs/SPARCworks interface -;;; this file is an alias for sun-eos.el - -;; Copyright (C) 1995 Sun Microsystems, Inc. - -;; Maintainer: Eduardo Pelegri-Llopart -;; Author: Eduardo Pelegri-Llopart - -;; Keywords: SPARCworks EOS Era on SPARCworks load - -;;; Commentary: - -;; If manual loading is desired... -;; Please send feedback to eduardo.pelegri-llopart@eng.sun.com - -;;; Code: - -(load "sun-eos-load.el") -(eos::start) - -;;; sun-eos-eos.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/eos/sun-eos-browser.el --- a/lisp/eos/sun-eos-browser.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,162 +0,0 @@ -;;; sun-eos-browser.el --- Implements the XEmacs/SPARCworks SourceBrowser interface - -;; Copyright (C) 1995 Sun Microsystems, Inc. - -;; Maintainer: Eduardo Pelegri-Llopart -;; Author: Eduardo Pelegri-Llopart - -;; Keywords: SPARCworks EOS Era on SPARCworks SBrowser Source Browser - -;;; Commentary: -;; Please send feedback to eduardo.pelegri-llopart@eng.sun.com - -;;; Code: - -(require 'eos-common "sun-eos-common") - -;; ================ -;; Browser Protocol -;; ================ -;; -;; three notifications -;; -;; SPRO_SBENG_START -;; SPRO_SBENG_CURRENT_ELEMENT CONTEXT_UID filename lineno center==0 -;; SPRO_SBENG_QUIT - -(defvar eos::currentMatch-inst "/* XPM */ -static char * file[] = { -\"14 11 5 1\", -\" s background c #FFFFFFFFFFFF\", -\". c #000000000000\", -\"X c #0000FFFF0000\", -\"o c #000077770000\", -\"O c #000044440000\", -\" \", -\" oo \", -\" oXOo \", -\" oXXXOo \", -\" oXXXXXOo \", -\" oXXXXXXXo. \", -\" oXXXXXOo \", -\" oXXXOo \", -\" oXOo \", -\" oo \", -\" \"};") - -(defvar eos::currentMatch-inst-alt "/* XPM */ -static char * file[] = { -\"14 11 5 1\", -\" s background c #FFFFFFFFFFFF\", -\". c #000000000000\", -\"X c #0000FFFF0000\", -\"o c #000077770000\", -\"O c #000044440000\", -\" \", -\" oo \", -\" oXOo \", -\" oXXXOo \", -\" oXXXXXOo \", -\" oXXXXXXXo. \", -\" oXXXXXOo \", -\" oXXXOo \", -\" oXOo \", -\" oo .. \", -\" .. \"};") - -(defvar sbrowser-pattern-list nil) - - -(defun eos::browser-startup () - ;; Actions to do at startup for eos-browser.el - (make-face 'sbrowse-arrow-face) - - (set-face-foreground 'sbrowse-arrow-face - eos::sbrowse-arrow-color) - (set-face-background 'sbrowse-arrow-face - (face-background (get-face 'default))) - - (setq sbrowser-pattern-list ; list of browser TT patterns - (eos::create-sbrowser-patterns)) - - ;; now register glyphs and faces... - - (eos::annotation-set-inst 'sbrowser 'x eos::currentMatch-inst [nothing]) - (eos::annotation-set-inst 'sbrowser 'tty "|>" [nothing]) - (eos::annotation-set-face 'sbrowser 'x - (get-face 'sbrowse-arrow-face) - (get-face 'sbrowse-arrow-face)) - (eos::annotation-set-face 'sbrowser 'tty - (get-face 'highlight) - (get-face 'highlight)) -) - -(defvar eos::current-match nil) - -(defun eos::spro_sbeng_current_element (msg pat) - ;; SPRO_SBENG_CURRENT_ELEMENT CONTEXT_UID filename lineno center==0 - (let* ((filename - (get-tooltalk-message-attribute msg 'arg_val 1)) - (lineno - (read (get-tooltalk-message-attribute msg 'arg_ival 2))) - ) - (setq eos::current-match - (eos::make-annotation-visible eos::current-match - filename - lineno - 'sbrowser)) - (return-tooltalk-message msg) - )) - -(defun eos::spro_sbeng_start (msg pat) - (eos::make-annotation-invisible eos::current-match) - (return-tooltalk-message msg) - ) - -(defun eos::spro_sbeng_quit (msg pat) - (eos::make-annotation-invisible eos::current-match) - (return-tooltalk-message msg) - ) - -(defun eos::create-sbrowser-patterns () - ;; returns list of patterns - (list - (make-an-observer "SPRO_SBENG_CURRENT_ELEMENT" - 'eos::spro_sbeng_current_element) - (make-an-observer "SPRO_SBENG_START" - 'eos::spro_sbeng_start) - (make-an-observer "SPRO_SBENG_QUIT" - 'eos::spro_sbeng_quit) - )) - -(defun eos::register-sbrowser-patterns () - ;; register all sbrowser patterns - (mapcar 'register-tooltalk-pattern sbrowser-pattern-list)) - -(defun eos::unregister-sbrowser-patterns () - ;; unregister all sbrowser patterns - (mapcar 'unregister-tooltalk-pattern sbrowser-pattern-list)) - -;; Actions to start a sourcebrowser in the background. - -(defvar eos::sbrowser-process nil - "sbrowser process for the background. Only one per XEmacs") - -(defun eos::start-sbrowser () - ;; Start an "sbrowser -editor" in the background. Will ask for confirmation if - ;; XEmacs somehow believes there is already one running - (interactive) - (if (or (not (processp eos::sbrowser-process)) - (not (eq (process-status eos::sbrowser-process) 'run)) - (yes-or-no-p - "Warning! XEmacs believes there already is a sbrowser -editor, proceed?")) - (progn - (setq eos::sbrowser-process - (start-process "*eos sbrowser*" nil "sbrowser" "-editor")) - (message "Starting SBrowser subprocess") - (eos::select-sbrowser-frame (selected-frame)) - ))) - -(provide 'eos-browser) - -;;; sun-eos-browser.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/eos/sun-eos-common.el --- a/lisp/eos/sun-eos-common.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,533 +0,0 @@ -;; Copyright (C) 1995, Sun Microsystems -;; -;; Light Weight Editor Integration for Sparcworks. -;; "Era on Sparcworks" (EOS) -;; -;; Author: Eduardo Pelegri-Llopart -;; -;; Please send feedback to eduardo.pelegri-llopart@eng.sun.com - -;; Common routines for EOS - -(defvar eos::version "1.5.2" - "Version of Eos") - -(defvar eos::left-margin-width 5 - "size of left margin") - -(defvar eos::stop-color "red" - "foreground color for stop signs") -(defvar eos::solid-arrow-color "purple" - "foreground color for solid arrow") -(defvar eos::hollow-arrow-color "purple" - "foreground color for hollow arrow") -(defvar eos::sbrowse-arrow-color "blue" - "foreground color for browser glyphs") - -(defun eos::recompute-presentation () - (set-face-foreground 'stop-face eos::stop-color) - (set-face-foreground 'solid-arrow-face eos::solid-arrow-color) - (set-face-foreground 'hollow-arrow-face eos::hollow-arrow-color) - (set-face-foreground 'sbrowse-arrow-face eos::sbrowse-arrow-color) - ) - -;; - -(defvar eos::displayed-initial-message nil - "Whether we have shown the initial display message") - -(defconst eos::startup-message-lines - '("Please send feedback to eos-comments@cs.uiuc.edu." - "The latest Eos news are under SPARCworks->News" - "See Options->SPARCworks for configuration and Help->SPARCworks for help" - )) - -;; copied from vm - -(defun eos::display-initial-message () - ;; Display initial Eos message - REMOVED - ) - -(defun eos-old::display-initial-message () - ;; Display initial Eos message - (if (not eos::displayed-initial-message) - (let ((lines eos::startup-message-lines)) - (message "Eos %s, Copyright (C) 1995 Sun MicroSystems" - eos::version) - (setq eos::displayed-initial-message t) - (while (and (sit-for 3) lines) - (message (car lines)) - (setq lines (cdr lines)))) - (message ""))) - -;; misc - -(defun eos::line-at (pos) - ;; At what line is POS - (save-restriction - (widen) - (save-excursion - (goto-char pos) - (beginning-of-line) - (1+ (count-lines 1 (point)))))) - -;; frame-specific enabling -;; -;; will maintain at most one frame to debugger, one to sbrowser -;; annotations have a type, either -;; -;; sbrowser -;; debugger-solid-arrow -;; debugger-holow-arrow -;; debugger-stop -;; debugger-visit -;; -;; adding an annotation of type sbrowser will be only on frame sbrowser -;; adding an annotation of type debugger will be only on frame debugger -;; -;; turn off patterns when there is no frame. - - -;;; -;;; Common ToolTalk function -;;; - -(defun make-an-observer (op callback) - (let ((pattern-desc - (list - 'category 'TT_OBSERVE - 'scope 'TT_SESSION - 'class 'TT_NOTICE - 'op op - 'callback callback))) - (make-tooltalk-pattern pattern-desc) - )) - -;;; -;;; Frame management -;;; - -(defun eos::log (msg) - (if (fboundp 'ut-log-text) - (ut-log-text "eos version: %s; %s" eos::version msg))) - -(defvar eos::sbrowser-frame nil) -(defvar eos::debugger-frame nil) - -(defun eos::update-specifiers (type old-frame new-frame) - ;; Change the database for annotations of TYPE, so that OLD-FRAME is - ;; now using the alternate specifier, while NEW-FRAME uses the main one - (let* ((device-type (device-type (selected-device))) - (g (eos::annotation-get-glyph type device-type)) - (im (and (glyphp g) (glyph-image g))) - (new-instantiator (eos::annotation-get-inst type device-type)) - (alt-instantiator (eos::annotation-get-inst-alt type device-type)) - ) - (if (eq device-type 'x) - (progn - (if (frame-live-p old-frame) - (progn - (remove-specifier im old-frame) - (add-spec-to-specifier im alt-instantiator old-frame))) - (if new-frame - (progn - (add-spec-to-specifier im new-instantiator new-frame) - )))))) - - -(defun eos::select-sbrowser-frame (frame) - (require 'eos-toolbar "sun-eos-toolbar") - (let ((toolbar (eos::toolbar-position))) - (eos::display-initial-message) - ;; logging - (if frame - (eos::log "selected frame for sbrowser") - (eos::log "unselected frame for sbrowser")) - ;; TT patterns - (cond - ((and (null eos::sbrowser-frame) frame) - (eos::register-sbrowser-patterns)) - ((and (null frame) eos::sbrowser-frame) - (eos::unregister-sbrowser-patterns))) - ;; adjust toolbars - (if (frame-live-p eos::sbrowser-frame) - (remove-specifier toolbar eos::sbrowser-frame)) - (if (frame-live-p eos::debugger-frame) - (remove-specifier toolbar eos::debugger-frame)) - ;; then add - (cond - ((and (frame-live-p eos::debugger-frame) (frame-live-p frame) - (equal eos::debugger-frame frame)) - (add-spec-to-specifier toolbar eos::debugger-sbrowser-toolbar frame)) - ((and (frame-live-p eos::debugger-frame) (frame-live-p frame)) - (add-spec-to-specifier toolbar eos::sbrowser-toolbar frame) - (add-spec-to-specifier toolbar eos::debugger-toolbar eos::debugger-frame)) - ((frame-live-p frame) - (add-spec-to-specifier toolbar eos::sbrowser-toolbar frame)) - ((frame-live-p eos::debugger-frame) - (add-spec-to-specifier toolbar eos::debugger-toolbar eos::debugger-frame)) - ) - ;; adjust specifiers for glyphs - (eos::update-specifiers 'sbrowser eos::sbrowser-frame frame) - (if (frame-live-p eos::sbrowser-frame) - (progn - (remove-specifier use-left-overflow eos::sbrowser-frame) - (remove-specifier left-margin-width eos::sbrowser-frame))) - (if (frame-live-p frame) - (progn - (add-spec-to-specifier use-left-overflow t frame) - (add-spec-to-specifier left-margin-width eos::left-margin-width frame) - (add-spec-to-specifier left-margin-width 0 (minibuffer-window)))) - (if (frame-live-p eos::debugger-frame) - (progn - (add-spec-to-specifier use-left-overflow t eos::debugger-frame) - (add-spec-to-specifier left-margin-width eos::left-margin-width eos::debugger-frame) - (add-spec-to-specifier left-margin-width 0 (minibuffer-window)))) - ;; - (setq eos::sbrowser-frame frame) - (set-menubar-dirty-flag) - )) - -(defun eos::select-debugger-frame (frame) - (require 'eos-toolbar "sun-eos-toolbar") - (let ((toolbar (eos::toolbar-position))) - (eos::display-initial-message) - (save-excursion - (eos::ensure-debugger-buffer) - (bury-buffer)) - ;; logging - (if frame - (eos::log "selected frame for debugger") - (eos::log "unselected frame for debugger")) - ;; TT patterns - (cond - ((and (null eos::debugger-frame) frame) - (eos::register-debugger-patterns) - (eos::register-visit-file-pattern)) - ((and (null frame) eos::debugger-frame) - (eos::unregister-debugger-patterns) - (eos::unregister-visit-file-pattern))) - ;; adjust toolbars, remove - (if (frame-live-p eos::sbrowser-frame) - (remove-specifier toolbar eos::sbrowser-frame)) - (if (frame-live-p eos::debugger-frame) - (remove-specifier toolbar eos::debugger-frame)) - ;; then add - (cond - ((and (frame-live-p eos::sbrowser-frame) (frame-live-p frame) - (equal eos::sbrowser-frame frame)) - (add-spec-to-specifier toolbar eos::debugger-sbrowser-toolbar frame)) - ((and (frame-live-p eos::sbrowser-frame) (frame-live-p frame)) - (add-spec-to-specifier toolbar eos::debugger-toolbar frame) - (add-spec-to-specifier toolbar eos::sbrowser-toolbar eos::sbrowser-frame)) - ((frame-live-p frame) - (add-spec-to-specifier toolbar eos::debugger-toolbar frame)) - ((frame-live-p eos::sbrowser-frame) - (add-spec-to-specifier toolbar eos::sbrowser-toolbar eos::sbrowser-frame)) - ) - ;; update glyph specifiers - (eos::update-specifiers 'debugger-solid-arrow eos::debugger-frame frame) - (eos::update-specifiers 'debugger-hollow-arrow eos::debugger-frame frame) - (eos::update-specifiers 'debugger-stop eos::debugger-frame frame) - (if (frame-live-p eos::debugger-frame) - (progn - (remove-specifier use-left-overflow eos::debugger-frame) - (remove-specifier left-margin-width eos::debugger-frame))) - (if (frame-live-p frame) - (progn - (add-spec-to-specifier use-left-overflow t frame) - (add-spec-to-specifier left-margin-width eos::left-margin-width frame) - (add-spec-to-specifier left-margin-width 0 (minibuffer-window)))) - (if (frame-live-p eos::sbrowser-frame) - (progn - (add-spec-to-specifier use-left-overflow t eos::sbrowser-frame) - (add-spec-to-specifier left-margin-width eos::left-margin-width eos::sbrowser-frame) - (add-spec-to-specifier left-margin-width 0 (minibuffer-window)))) - ;; - (setq eos::debugger-frame frame) - (set-menubar-dirty-flag) - )) - -;; HERE use file-truename - -(defun eos::select-frame (type) - ;; Select a frame; return nil if should skip - (cond ((eq type 'sbrowser) - (if (frame-live-p eos::sbrowser-frame) - eos::sbrowser-frame - (message "selecting destroyed frame; will ignore") - (eos::select-sbrowser-frame nil) - nil)) - ((or (eq type 'debugger-solid-arrow) - (eq type 'debugger-hollow-arrow) - (eq type 'debugger-stop) - (eq type 'debugger-visit)) - (if (frame-live-p eos::debugger-frame) - eos::debugger-frame - (message "selecting destroyed frame; will ignore") - (eos::select-debugger-frame nil) - nil)) - (t (selected-frame)))) - -(defun eos::select-window (win) - ;; Will select a window if it is not showing neither of eos::debugger-buffer or - ;; eos::toolbar-buffer" - (let ((name (buffer-name (window-buffer win)))) - (if (and (>= (length name) 4) - (equal (substring name 0 4) "*Eos")) - nil - (select-window win) - (throw 'found t) - ))) - -(defun eos::find-line (file line type) - ;; Show FILE at LINE; returns frame or nil if inappropriate - ;; if type is nil - (if (eos::null-file file) - (selected-frame) - (let ((sc (eos::select-frame type)) - (win (selected-window))) - (if (null sc) - nil - (select-frame sc) - (if (catch 'found - (eos::select-window (selected-window)) - (walk-windows 'eos::select-window) - nil) - nil ; do nothing, already there - (select-window win) - (split-window-vertically) - (other-window 1) - ) - (switch-to-buffer (find-file-noselect file t)) ;; no warn! - (if (eq (device-type) 'x) (x-disown-selection)) - (goto-line line) - sc - )))) - -(defun eos::null-file (file) - ;; returns t if FILE is nil or the empty string - (or (null file) (equal file ""))) - -;;; -;;; Annotation handling -;;; - -(defun eos::valid-annotation (annotation) - ;; returns t if ANNOTATION is an annotation and its buffer exists - (and (annotationp annotation) - (bufferp (extent-buffer annotation)) - (buffer-name (extent-buffer annotation))) - ) - -(defvar eos::annotation-list nil - "list of annotations set") - -(defun eos::add-to-annotation-list (ann type) - (if (not (eq type 'debugger-stop)) - (error "not implemented")) - (setq eos::annotation-list (cons ann - eos::annotation-list)) - ) - -(defun eos::remove-from-annotation-list (ann type) - (if (not (eq type 'debugger-stop)) - (error "not implemented")) - (setq eos::annotation-list (delq ann eos::annotation-list)) - ) - -(defun eos::remove-all-from-annotation-list (type) - (if (not (eq type 'debugger-stop)) - (error "not implemented")) - (mapcar (function (lambda (annot) - (if (extent-live-p annot) - (delete-annotation annot)))) - eos::annotation-list) - (setq eos::annotation-list nil)) - -(defun eos::add-annotation (type file line uid) - (let ((anot nil) - (fr (selected-frame)) - (win (selected-window)) - ) - (if (eos::null-file file) - (setq anot nil) - (if (null (eos::find-line file line type)) - (error "No frame to select")) - (let* ((device-type (device-type (selected-device))) - (graphics (eos::annotation-get-glyph type device-type)) - (face (eos::annotation-get-face type device-type)) - ) - (setq anot (make-annotation graphics (point) 'outside-margin)) - (set-annotation-data anot uid) - (set-extent-face anot face) - (eos::add-to-annotation-list anot type) - )) - (select-frame fr) - (select-window win) - anot - )) - -(defun eos::compare-uid (extent uid) - (and (annotationp extent) - (equal (annotation-data extent) uid) - extent)) - -(defun eos::delete-annotation (type file line uid) - ;; ignore file and line, they are here for backward compatibility - (let ((anot nil) - (alist eos::annotation-list) - ) - (if (not (eq type 'debugger-stop)) - (error "not implemented")) - (while (and alist - (not (equal (annotation-data (car alist)) uid))) - (setq alist (cdr alist))) - (if (null alist) - (error "Event UID not found; ignored") - (setq anot (car alist)) - (delete-annotation anot) - (eos::remove-from-annotation-list anot type)) - )) - -;; probably type should not be given here... (already stored in the annotation-data -;; field) but it is a bit more robust this way. - -(defun eos::make-annotation-visible (annotation file line type) - ;; returns nil or moves the ANNOTATION to FILE and LINE; annotation is of TYPE - (let ((back nil) - (fr (selected-frame)) - (win (selected-window)) - ) - ;; (save-window-excursion - (if (not (eos::null-file file)) - (progn - (if (eos::valid-annotation annotation) - (detach-extent annotation) ; should operate on annotations - ) - (if (null (eos::find-line file line type)) - (error "No frame to select")) - (let* ((device-type (device-type (selected-device))) - (graphics (eos::annotation-get-glyph type device-type)) - (face (eos::annotation-get-face type device-type)) - ) - (if (and (eos::valid-annotation annotation) - (extent-detached-p annotation)) - (progn - (setq back (insert-extent annotation (point) (point) t)) - (set-annotation-glyph back graphics 'whitespace) - ) - (setq back (make-annotation graphics (point) 'whitespace)) - ) - (set-annotation-data back type) - (set-extent-face back face) - ))) - ;; ) - (if (not (eq (selected-frame) fr)) - (select-frame fr)) - (select-window win) - back - )) - -(defun eos::make-annotation-invisible (annotation) - ;; make this ANNOTATION invisible - (if (eos::valid-annotation annotation) - (detach-extent annotation) ;; should operate on annotations - )) - - -;; mapping between annotation types and their screen representations. - -(defvar eos::alist-annotation-glyph nil) ; assoc list of annotation type - ; device type, and glyph -(defvar eos::alist-annotation-inst nil) ; assoc list of annotation type - ; device type, and instantiator -(defvar eos::alist-annotation-inst-alt nil) ; alternate assoc list of annotation type - ; device type, and instantiator - -(defvar eos::alist-annotation-face nil) ;; assoc list of annotation type, - ;; device type and face - -;; PUBLIC - -;; TBD! merge both instance lists. - -(defun eos::annotation-set-inst (annotation-type device-type inst inst-alt) - "define the instantiator for ANNOTATION-TYPE on DEVICE-TYPE to be -INST for the frame enabled for this type and INST-ALT for other frames" - (interactive) - (setq eos::alist-annotation-inst - (cons (cons (cons annotation-type device-type) inst) - eos::alist-annotation-inst)) - (setq eos::alist-annotation-inst-alt - (cons (cons (cons annotation-type device-type) inst-alt) - eos::alist-annotation-inst-alt)) ) - -(defun eos::annotation-set-face (annotation-type device-type face-1 face-2) - "define the face for ANNOTATION-TYPE on DEVICE-TYPE to be -FACE-1 for the frame enabled for this type and FACE-2 for other frames" - (interactive) - (setq eos::alist-annotation-face - (cons (cons (cons annotation-type device-type) face-1) - eos::alist-annotation-face)) - ) - -;; PRIVATE - -(defun eos::annotation-get-glyph (annotation-type device-type) - ;; Get the glyph for ANNOTATION-TYPE on DEVICE-TYPE - (interactive) - (let ((found (assoc (cons annotation-type device-type) - eos::alist-annotation-glyph))) - (if found - (cdr found) - (let ((inst (eos::annotation-get-inst annotation-type device-type)) - (alt-inst (eos::annotation-get-inst-alt annotation-type device-type)) - (glyph nil) - (frame (selected-frame))) - (if (null inst) - nil - (setq glyph (make-glyph `((global . (nil . ,alt-inst))))) - (add-spec-to-specifier (glyph-image glyph) inst frame) - (setq eos::alist-annotation-glyph - (cons (cons (cons annotation-type device-type) glyph) - eos::alist-annotation-glyph)) - glyph)) - ))) - -(defun eos::annotation-get-inst (annotation-type device-type) - ;; Get the primary instantiator for ANNOTATION-TYPE on DEVICE-TYPE - (interactive) - (let ((found (assoc (cons annotation-type device-type) - eos::alist-annotation-inst))) - (if found - (cdr found) - nil))) - -(defun eos::annotation-get-inst-alt (annotation-type device-type) - ;; Get the alternate instantiator for ANNOTATION-TYPE on DEVICE-TYPE - (interactive) - (let ((found (assoc (cons annotation-type device-type) - eos::alist-annotation-inst-alt))) - (if found - (cdr found) - nil))) - -(defun eos::annotation-get-face (annotation-type device-type) - ;; Get the face for ANNOTATION-TYPE on DEVICE-TYPE - (interactive) - (let ((found (assoc (cons annotation-type device-type) - eos::alist-annotation-face)) - ) - (if found - (cdr found) - nil - )) - ) - - -(defun eos::common-startup () ) -;; - - -(provide 'eos-common) diff -r 43306a74e31c -r d44af0c54775 lisp/eos/sun-eos-debugger-extra.el --- a/lisp/eos/sun-eos-debugger-extra.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,854 +0,0 @@ -;;; sun-eos-debugger.el --- Implements the XEmacs/SPARCworks Debugger interface - -;; Copyright (C) Sun Microsystems, Inc. - -;; Maintainer: Eduardo Pelegri-Llopart -;; Author: Eduardo Pelegri-Llopart - -;; Keywords: SPARCworks EOS Era on SPARCworks Debugger dbx - -;;; Commentary: -;; Please send feedback to eduardo.pelegri-llopart@eng.sun.com - -;;; Code: - -;; debugger buffer - -(require 'eos-common "sun-eos-common") -(require 'eos-debugger "sun-eos-debugger") -(require 'eos-menubar "sun-eos-menubar") - -(defvar eos::debugger-buffer "*Eos Debugger Log*" - "name of buffer where to log debugger activity; see eos::use-debugger-buffer") -(defvar eos::dbx-buffer nil) -(defvar eos::key-mode 'none "Style of key mode interaction for Eos") - -(defun eos::ensure-debugger-buffer () - ;; will ensure a debugger buffer, with the proper major mode - (let ((buf (get-buffer eos::debugger-buffer))) - (if buf - (switch-to-buffer buf) - (setq buf (get-buffer-create eos::debugger-buffer)) - (set-buffer buf) - (eos::debugger-mode) - (toggle-read-only -1) ; writeable - (eos::insert-string-as-extent "[Debugger] " t (get-face 'bold)) - (toggle-read-only 1) ; read-only - ))) - -(defun eos::synchronize-debugger-buffer () - ;; ensure all views of this buffer are at the end - (eos::ensure-debugger-buffer) - (let ((x (point-max))) - (goto-char x) - (mapcar (function - (lambda (win) - (set-window-point win x))) - (get-buffer-window-list eos::debugger-buffer)) - )) - -(defvar eos::debugger-mode-map nil) - -(if eos::debugger-mode-map - nil - (progn - (setq eos::debugger-mode-map (make-keymap)) - (set-keymap-name eos::debugger-mode-map 'eos::debugger-mode-map) - (define-key eos::debugger-mode-map [(meta p)] 'eos::debugger-previous-cmd) - (define-key eos::debugger-mode-map [(meta n)] 'eos::debugger-next-cmd) - (define-key eos::debugger-mode-map [return] 'eos::debugger-send-cmd) - )) - -(defun eos::debugger-mode () - (interactive) - "local mode" - (kill-all-local-variables) - (setq major-mode 'eos::debugger-mode) - (setq mode-name "eos::debugger") - (setq truncate-lines t) - (set-syntax-table emacs-lisp-mode-syntax-table) - (use-local-map eos::debugger-mode-map)) - - -;; Handling of command lists - -(defvar eos::current-command nil "Current command navigated; as an extent") -(defvar eos::last-command nil "last command sent to debugger, as an extent") - -(defun eos::debugger-previous-cmd () - ;; present the previous command - (interactive) - (save-excursion - (let ((xt nil)) - (if (null eos::current-command) - (setq xt eos::last-command) - (setq xt (extent-property - eos::current-command - 'previous-command))) - (if xt - (progn - (eos::debugger-delete-last-cmd-line) - (goto-char (point-max)) - (insert (buffer-substring - (extent-start-position xt) - (1- (extent-end-position xt)) ; remove - )) - (setq eos::current-command xt)) - (error "no previous command") - )) - )) - -(defun eos::debugger-next-cmd () - ;; present the next command - (interactive) - (save-excursion - (let ((xt nil)) - (if (null eos::current-command) - (error "no next command") - (setq xt (extent-property - eos::current-command - 'next-command))) - (eos::debugger-delete-last-cmd-line) - (if xt - (progn - (goto-char (point-max)) - (insert (buffer-substring - (extent-start-position xt) - (1- (extent-end-position xt)) ; remove - )) - (setq eos::current-command xt)) - (setq eos::current-command nil) - )) - )) - -(defun eos::debugger-delete-last-cmd-line () - ;; delete the last command line, not yet inputed, returns that cmd line - (goto-char (point-max)) - (let ((e (point))) - (beginning-of-line) - (let* ((xt (extent-at (point))) - (p (extent-end-position xt)) - (str (buffer-substring p e)) - ) - (delete-region p e) - str - ))) - -(defun eos::debugger-send-cmd () - ;; send the message in the current line - (interactive) - (end-of-line) - (let ((e (point))) - (beginning-of-line) - (let* ((xt (extent-at (point))) - (p (extent-end-position xt)) - (str (buffer-substring p e)) - ) - (delete-region p e) - (eos::send-spider-current-do-msg (concat str "\n")) - (goto-char (point-max)) - (setq eos::current-command nil) - ))) - -;; client -;; - -(defun get-buffer-window-list (buffer) - ;; like get-buffer-window except that will generate a list of windows - ;; instead of just the first one" - (let* ((buf (get-buffer buffer)) - (win1 (next-window nil 'foo t t)) - (win win1) - (first t) - (ret nil) - ) - (if (null buf) - nil - (while (or - (and first win) - (not (or first (equal win win1))) - ) - (setq first nil) - (if (equal - buf - (window-buffer win)) - (setq ret (cons win ret))) - (setq win (next-window win t t t)) - ) - ret))) - -(defun eos::dbx-process () - ;; Returns nil, or the corresponding process where to insert - (let ((pl (process-list)) - (found-proc nil) - ) - (while (and pl (null found-proc)) - (let* ((proc (car pl)) - (name (process-name proc)) - ) - (if (and (>= (length name) 3) - (equal (substring name 0 3) "Eos")) - (setq found-proc proc) - (setq pl (cdr pl)) - ) - )) - found-proc - )) - -(defun eos::insert-echo (process string) - (if (null process) - nil - (save-excursion - (set-buffer (process-buffer process)) - (goto-char (point-max)) -;; (let ((beg (point))) -;; (insert-before-markers string)) - (insert-before-markers string) - (if (process-mark process) - (set-marker (process-mark process) (point-max)))) - (if (eq (process-buffer process) - (current-buffer)) - (goto-char (point-max))) - )) - - -(defun eos::insert-on-debugger-buffer (msg rdonly face &optional previous-command) - ;; will insert MSG at end of debugger buffer with RDONLY property and with FACE. - ;; If PREVIOUS-COMMAND is given, the newly created extent will be doubly linked into this one - ;; using 'previous-command and 'next-command properties - (save-window-excursion - (let ((fr (selected-frame)) - (buf (current-buffer)) - (xt nil)) - (eos::ensure-debugger-buffer) - (toggle-read-only -1) ; not read-only - (eos::insert-echo (eos::dbx-process) msg) - (setq xt (eos::insert-string-as-extent msg rdonly face)) - (if previous-command - (progn - (set-extent-property xt 'previous-command previous-command) - (set-extent-property previous-command 'next-command xt) - )) - (toggle-read-only 1) ; now read-only - (switch-to-buffer buf) - (select-frame fr) - xt - )) - ) - -(defun eos::insert-string-as-extent (msg rdonly face) - ;; insert MSG as a extent with RDONLY and FACE. Returns the extent - (let ((here nil) - (xt nil)) - (goto-char (point-max)) - (setq here (point)) - (insert msg) - (setq xt (make-extent here (point) nil)) - (if rdonly - (progn - (set-extent-property xt 'read-only t) - (set-extent-property xt 'duplicable nil) - )) - (set-extent-face xt face) - (eos::synchronize-debugger-buffer) - xt - )) - - -(require 'comint) - -(defvar eos::dbx-program "dbx") -(defvar eos::dbx-switches (list "-editor")) - -(defun eos::expand-file-name (file) - ;; expand file name depending on first character - (cond - ((null file) - nil) - ((eq (elt file 0) ?~) - (expand-file-name file)) - ((eq (elt file 0) ?$) - (substitute-in-file-name file)) - (t file))) - -(defun eos::read-dbx-request (program switches) - ;; will prompt to the user with PROGRAM and SWITCHES, let her modify this - ;; and then will read the result and split it into program and switches. - (let* ((prompt - (concat program " " (mapconcat 'identity switches " "))) - (ret (read-from-minibuffer "Run dbx as: " prompt)) - (ret2 (split-string ret " "))) - ;; some testing - (cons (car ret2) (cdr ret2)) - )) - -(defun eos::dbx () -;; Run an inferior dbx -editor process, with I/O through buffer *Eos Dbx*. -;; If buffer exists but dbx process is not running, make new dbx. -;; If buffer exists and dbx process is running, -;; just switch to buffer `*Eos Dbx*'. - (let ((buffer "*Eos Dbx*") - (buffer-name "Eos Dbx") - (input nil)) - (cond ((not (comint-check-proc buffer)) - (setq input (eos::read-dbx-request eos::dbx-program - eos::dbx-switches)) - (setq eos::dbx-program (car input)) - (setq eos::dbx-switches (cdr input)) - (message "Starting Dbx subprocess") - (setq buffer - (set-buffer - (apply 'make-comint - buffer-name - (eos::expand-file-name eos::dbx-program) - nil - (mapcar 'eos::expand-file-name eos::dbx-switches)))) - (comint-mode) - (if (and (eq (device-type (frame-device (selected-frame))) 'tty) - (eq eos::key-mode 'none) - (yes-or-no-p - "Do you want the prefix map activated?")) - (eos::set-key-mode 'prefix)) - (setq eos::dbx-or-debugger 'dbx) - (setq eos::dbx-buffer (current-buffer)) - (make-local-variable 'kill-buffer-hook) - (setq kill-buffer-hook - (list (function (lambda () - (cond - ((null (eos::dbx-process)) t) - ((not (eq (process-status (eos::dbx-process)) 'run)) t) - ((yes-or-no-p - "Warning! Killing this buffer will kill a dbx process, proceed? ") - (eos::internal-clear-annotations t t t t)) - (t (error "kill-buffer aborted!"))) - )))) - ) - (t - (message "Reusing existing dbx buffer and dbx process"))) - (switch-to-buffer buffer) - )) - - -;; Actions to start a debugger in the background. - -(defvar eos::debugger-process nil - "Debugger process for the background. Only one per XEmacs") - -(defvar eos::dbx-or-debugger nil) - -(defun eos::start-debugger () - "Start an \"debugger -editor\" in the background. Will ask for confirmation if -XEmacs somehow believes there is already one running" - (interactive) - (if (and (or (not (processp eos::debugger-process)) - (not (eq (process-status eos::debugger-process) 'run)) - (yes-or-no-p - "Warning! XEmacs believes there already is a debugger -editor, proceed? ")) - (or (not (eos::dbx-process)) - (not (eq (process-status (eos::dbx-process)) 'run)) - (yes-or-no-p - "Warning! XEmacs believes there already is a dbx -editor, proceed? "))) - (progn - (setq eos::debugger-process - (start-process "*eos debugger*" nil "debugger" "-editor")) - (message "Starting Debugger subprocess") - (eos::select-debugger-frame (selected-frame)) - (setq eos::dbx-or-debugger 'debugger) - ))) - -;; Ditto for dbx. - -(defun eos::start-dbx () - "Start an \"dbx -editor\" as a subprocess. Will ask for confirmation if -XEmacs somehow believes there is already one running" - (interactive) - (if (and (or (not (processp eos::debugger-process)) - (not (eq (process-status eos::debugger-process) 'run)) - (yes-or-no-p - "Warning! XEmacs believes there already is a debugger -editor, proceed? ")) - (or (not (eos::dbx-process)) - (not (eq (process-status (eos::dbx-process)) 'run)) - (yes-or-no-p - "Warning! XEmacs believes there already is a dbx -editor, proceed? "))) - (progn - (eos::select-debugger-frame (selected-frame)) - (eos::dbx) - ))) - - -;; -;; Communication commands -;; - -(defun eos::spider-do-callback (msg pat) - ;; Callback after processing a spider_do request - (eos::insert-on-debugger-buffer - (format "%s" (get-tooltalk-message-attribute msg 'arg_val 2)) - t - (get-face 'bold)) - (destroy-tooltalk-message msg) - ) - -(defvar eos::last-command-was-print nil "(eos:: internal)") - -(defun eos::spro_spider_output (msg pat) - ;; For spider output - (let ((s (get-tooltalk-message-attribute msg 'arg_val 1)) - (err (get-tooltalk-message-attribute msg 'arg_val 2)) - ) - (message (format "%s" s)) - (eos::insert-on-debugger-buffer (format "%s" s) - t - (get-face 'default)) - (if (and err (not (string-equal err ""))) - (eos::insert-on-debugger-buffer - (insert (format "STDERR> %s" err)) - t - (get-face 'default)) - ) - (destroy-tooltalk-message msg))) - -(defun eos::spro_spider_output-common (msg pat) - ;; For spider output - (if eos::last-command-was-print - (eos::spro_spider_print_output msg pat) - (eos::spro_spider_output msg pat))) - -(defmacro eos::spider-tt-args (cmd spider-id clique-id) - (` (list - 'class TT_REQUEST - 'address TT_HANDLER - 'scope TT_SESSION - 'handler (, spider-id) - 'op "SPRO_SPIDER_DO" - 'callback 'eos::spider-do-callback - 'args (list - (list 'TT_IN (, clique-id) "Context_ID") - (list 'TT_IN (, cmd) "string") - (list 'TT_OUT)) - ))) - -(defun eos::send-spider-do-msg (cmd spider-id clique-id) - ;; Send CMD, a string, to SPIDER-ID, using CLIQUE-ID - (let ((msg (make-tooltalk-message - (eos::spider-tt-args cmd spider-id clique-id)))) - (setq eos::last-command - (eos::insert-on-debugger-buffer - cmd - t - (get-face 'italic) - eos::last-command)) - (setq eos::current-command eos::last-command) - (send-tooltalk-message msg) - (destroy-tooltalk-message msg) - )) - -(defvar eos::no-connection-box - '("XEmacs does not know the ID of a debugger to connect to. -You may need to reissue a debug or attach command from the debugger. -Consult the introduction to Eos (Help->SPARCworks...) for more details." - ["Dismiss" (message "Command aborted") t])) - -(defun eos::send-spider-current-do-msg (cmd) - ;; Send CMD to the current dbx engine using the current debugger clique; - ;;The cmd ends in a new-line. - (if (null eos::current-debugger-clique-id) - (popup-dialog-box eos::no-connection-box) - (eos::send-spider-do-msg cmd - eos::current-dbx-proc-id - eos::current-debugger-clique-id))) - -(defun eos::dbx-cmd (arg) - "Send CMD to the current dbx engine using the current debugger clique; -The cmd does not end in a new-line; a new-line will be added" - (interactive "sDbx cmd: ") - (eos::send-spider-current-do-msg (concat arg "\n"))) - - -;; -;; Extra patterns - -(defvar eos::dbx-extra-pattern-list nil) - -(defun eos::debugger-extra-startup () - ;; Actions to do at startup for eos-debugger-extra.el - (setq eos::dbx-extra-pattern-list ; list of extra TT patterns - (eos::create-debugger-extra-patterns)) - (eos::ensure-available-print-frame) - (eos::define-prefix-map) ; initialize keymap - ) - -(defun eos::create-debugger-extra-patterns () - ;; returns a list of patterns - (list - (make-an-observer "SPRO_SPIDER_OUTPUT" 'eos::spro_spider_output-common) - )) - -(defun eos::register-debugger-extra-patterns () - ;; register additional dbx patterns - (mapcar 'register-tooltalk-pattern eos::dbx-extra-pattern-list)) - -(defun eos::unregister-debugger-extra-patterns () - ;; unregister additional dbx patterns - (mapcar 'unregister-tooltalk-pattern eos::dbx-extra-pattern-list)) - -;; -;; Common commands -;; - - -(defun eos::type () (interactive) - (if (eq eos::dbx-or-debugger 'debugger) - (call-interactively 'eos::dbx-cmd) - (if (buffer-live-p eos::dbx-buffer) - (switch-to-buffer eos::dbx-buffer) - (message "no dbx subprocess buffer known")))) - -(defun eos::run () (interactive) (eos::dbx-cmd "run")) -(defun eos::fix () (interactive) (eos::dbx-cmd "fix")) -(defun eos::build () (interactive) (eos::dbx-cmd "make")) - -(defun eos::cont () (interactive) (eos::dbx-cmd "cont")) -(defun eos::cont-and-dismiss () (interactive) - (eos::dismiss-print-frame) (eos::cont)) -(defun eos::clear-all () (interactive) (eos::dbx-cmd "clear")) -(defun eos::next () (interactive) (eos::dbx-cmd "next")) -(defun eos::next-and-dismiss () (interactive) - (eos::dismiss-print-frame) (eos::next)) -(defun eos::step () (interactive) (eos::dbx-cmd "step")) -(defun eos::step-and-dismiss () (interactive) - (eos::dismiss-print-frame) (eos::step)) -(defun eos::step-up () (interactive) (eos::dbx-cmd "step up")) - -(defun eos::up () (interactive) (eos::dbx-cmd "up" )) -(defun eos::down () (interactive) (eos::dbx-cmd "down")) -(defun eos::pop () (interactive) (eos::dbx-cmd "pop")) - - -(defun eos::stop-at () - (interactive) - (let ((name (buffer-file-name))) - (if (null name) (error "Buffer has no associated file")) - (eos::dbx-cmd - (format "stop at \"%s\":%d" name (eos::line-at (point)))) - )) - -(defun eos::clear-at () - (interactive) - (let ((name (buffer-file-name))) - (if (null name) (error "Buffer has no associated file")) - (eos::dbx-cmd - (format "clear \"%s\":%d" name (eos::line-at (point)))) - )) - -(defun eos::stop-in () - (interactive) - (eos::dbx-cmd - (format "stop in %s" - (if (eq 'x (device-type (selected-device))) - (x-get-selection) - (buffer-substring (point) (mark))) - )) - (setq zmacs-region-stays t)) - -(defun eos::func () - (interactive) - (eos::dbx-cmd - (format "func %s" - (if (eq 'x (device-type (selected-device))) - (x-get-selection) - (buffer-substring (point) (mark))) - )) - (setq zmacs-region-stays t)) - -(defun eos::cont-to () - (interactive) - (let ((name (buffer-file-name))) - (if (null name) (error "Buffer has no associated file")) - (eos::dbx-cmd - (format "stop at \"%s\":%d -temp; cont" name (eos::line-at (point)))) - )) - -(defun eos::print-normal () - (interactive) - (eos::dbx-cmd - (format "print %s" - (if (eq 'x (device-type (selected-device))) - (x-get-selection) - (buffer-substring (point) (mark))) - )) - (setq zmacs-region-stays t)) - -(defun eos::print*-normal () - (interactive) - (eos::dbx-cmd - (format "print *(%s)" - (if (eq 'x (device-type (selected-device))) - (x-get-selection) - (buffer-substring (point) (mark))) - )) - (setq zmacs-region-stays t)) - -;; specialization for print commands - -(defun eos::send-spider-print-msg (expr) - ;; Print EXPR using separate frame - (setq eos::last-command-was-print t) - (eos::dbx-cmd (format "print %s" expr))) - -(defun eos::send-spider-print*-msg (expr) - ;; Send *EXPR using separate frame - (setq eos::last-command-was-print t) - (eos::dbx-cmd (format "print *(%s)" expr))) - -(defun eos::print () (interactive) - (eos::send-spider-print-msg - (if (eq 'x (device-type (selected-device))) - (x-get-selection) - (buffer-substring (point) (mark))) - ) - (setq zmacs-region-stays t)) - -(defun eos::print* () (interactive) - (eos::send-spider-print*-msg - (if (eq 'x (device-type (selected-device))) - (x-get-selection) - (buffer-substring (point) (mark))) - ) - (setq zmacs-region-stays t)) - - -;; -;; -;; Print on separate frame - - -(defun eos::buffer-line-size (buffer) - (interactive) - (or (bufferp buffer) - (setq buffer (current-buffer))) - (save-excursion - (switch-to-buffer buffer) - (eos::line-at (point-max)))) - -;; -;; Handling of a collection of print frames -;; (currently only one) - -(defvar eos::print-frame nil "Frame for prints") -(defvar eos::print-buffer " *Eos Print Output*" "Buffer for prints") - -(defun eos::new-available-print-frame() - ;; returns an available print frame - ;; currently just returns the one frame - (require 'eos-toolbar "sun-eos-toolbar") - (let ((scr (selected-frame)) - (buf (current-buffer))) - - ;; create frames - (if (and - (frame-live-p eos::print-frame) - (or (not (frame-live-p eos::debugger-frame)) - (not (eq eos::print-frame - eos::debugger-frame)))) - (progn - (make-frame-visible eos::print-frame) - eos::print-frame) - (setq eos::print-frame (make-frame)) - ;; no modeline visible... - (set-face-background 'modeline - (face-background (get-face 'default)) - eos::print-frame) - (set-face-foreground 'modeline - (face-background (get-face 'default)) - eos::print-frame) - ;; there is redundancy below. - (select-frame eos::print-frame) - (switch-to-buffer eos::print-buffer) - (set-buffer-menubar nil) - (add-spec-to-specifier (eos::toolbar-position) eos::print-toolbar (selected-frame)) - (add-spec-to-specifier has-modeline-p nil (selected-frame)) - (select-frame scr) - (switch-to-buffer buf) - eos::print-frame - ))) - -;; set delete-frame-hook and check for this frame... then do - - - -(defun eos::ensure-available-print-frame () - ;; ensures that there is at least one available print frame - t) - -(defun eos::show-print-frame () - (interactive) - (setq eos::print-frame (eos::new-available-print-frame)) - (select-frame eos::print-frame) - (switch-to-buffer eos::print-buffer) - (set-frame-height eos::print-frame - (+ 1 (eos::buffer-line-size eos::print-buffer))) - (goto-char (point-min)) - ) - -(defun eos::dismiss-print-frame () - (interactive) - (if (frame-live-p eos::print-frame) - (progn - (make-frame-invisible eos::print-frame) - (select-frame (car (visible-frame-list)))))) -;; -;; print output -;; - -(defun eos::spro_spider_print_output (msg pat) - ;; For spider print output (switched with spro_spider_output - (let ((buf (current-buffer)) - (scr (selected-frame))) - (save-excursion ; does not work in callbacks? - (switch-to-buffer eos::print-buffer) - (delete-region (point-min) (point-max)) - (goto-char (point-max)) - (insert (format "%s" (get-tooltalk-message-attribute msg - 'arg_val 1))) - (let ((err (get-tooltalk-message-attribute msg - 'arg_val 2))) - (if (and err (not (string-equal err ""))) - (insert (format "STDERR> %s" err)))) - (eos::show-print-frame) - (select-frame scr) - (switch-to-buffer buf) - ) - (destroy-tooltalk-message msg) - (setq eos::last-command-was-print nil) - )) - - -;; User interface - -(defvar eos::prefix-map (make-keymap)) - -(defun eos::define-prefix-map () - - (define-key eos::prefix-map "%" 'eos::dbx-cmd) - (define-key eos::prefix-map "r" 'eos::run) - (define-key eos::prefix-map "f" 'eos::fix) - - (define-key eos::prefix-map "p" 'eos::print) - (define-key eos::prefix-map "\C-p" 'eos::print*) - - (define-key eos::prefix-map "c" 'eos::cont) - (define-key eos::prefix-map "b" 'eos::stop-at) - (define-key eos::prefix-map "\C-b" 'eos::clear-at) - - (define-key eos::prefix-map "n" 'eos::next) - (define-key eos::prefix-map "s" 'eos::step) - (define-key eos::prefix-map "\C-s" 'eos::step-up) - - (define-key eos::prefix-map "u" 'eos::up) - (define-key eos::prefix-map "d" 'eos::down) - -) - -(defun eos::set-key-mode (mode) - ;; Set the key MODE to either 'none, 'prefix, or 'function - (setq eos::key-mode mode) - (cond - ((eq eos::key-mode 'none) - (define-key global-map "\C-cd" nil) - (eos::remove-function-keys) - (add-submenu nil (append '("SPARCworks") eos::short-menu)) - ) - ((eq eos::key-mode 'prefix) - (define-key global-map "\C-cd" eos::prefix-map) - (eos::remove-function-keys) - (add-submenu nil (append '("SPARCworks") eos::long-menu)) - ) - ((eq eos::key-mode 'function) - (define-key global-map "\C-cd" nil) - (eos::add-function-keys) - (add-submenu nil (append '("SPARCworks") eos::long-menu)) - ) - (t - (error "unimplemented") - ))) - -(defun eos::add-function-keys () - (interactive) - - ;; - (global-set-key [f6] 'eos::dbx-cmd) - (global-set-key [(control f6)] 'eos::run) - (global-set-key [(shift f6)] 'eos::fix) - ;; - (global-set-key [f7] 'eos::print) - (global-set-key [(control f7)] 'eos::print*) - (global-set-key [(shift f7)] 'eos::dismiss-print-frame) - ;; - (global-set-key [f8] 'eos::cont) - (global-set-key [(control f8)] 'eos::stop-at) - (global-set-key [(shift f8)] 'eos::clear-at) - ;; - (global-set-key [f9] 'eos::next) - (global-set-key [(control f9)] 'eos::step) - (global-set-key [(shift f9)] 'eos::step-up) - ;; - ) - -(defun eos::remove-function-keys () - (interactive) - - ;; - (global-set-key [f6] nil) - (global-set-key [(control f6)] nil) - (global-set-key [(shift f6)] nil) - ;; - (global-set-key [f7] nil) - (global-set-key [(control f7)] nil) - (global-set-key [(shift f7)] nil) - ;; - (global-set-key [f8] nil) - (global-set-key [(control f8)] nil) - (global-set-key [(shift f8)] nil) - ;; - (global-set-key [f9] nil) - (global-set-key [(control f9)] nil) - (global-set-key [(shift f9)] nil) - ;; - ) - -;; Provides popup access - -(defvar eos::popup-mode nil) -(defvar eos::saved-global-popup-menu nil) - -(defun eos::toggle-popup-menu () - ;; Toggle whether to use or not popup menus for SPARCworks - (interactive) - (if eos::popup-mode - (setq global-popup-menu eos::saved-global-popup-menu) - (eos::push-popup-menu)) - (setq eos::popup-mode (null eos::popup-mode)) - ) - -(defun eos::push-popup-menu () - (setq eos::saved-global-popup-menu global-popup-menu) - (setq global-popup-menu - (append - '("SPARCworks Command" - ["Stop At" eos::stop-at t] - ["Clear At" eos::clear-at t] - ["Stop In" eos::stop-in t] - ["Cont To" eos::cont-to t] - ["Print" eos::print t] - ["Print*" eos::print* t] - "---" - ["Read a Dbx Command" eos::dbx-cmd t] - "---") - (list - eos::saved-global-popup-menu)) - )) - -(provide 'eos-debugger) - -;;; sun-eos-debugger.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/eos/sun-eos-debugger.el --- a/lisp/eos/sun-eos-debugger.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,594 +0,0 @@ -;;; sun-eos-debugger.el --- Implements the XEmacs/SPARCworks interface - -;; Copyright (C) 1995 Sun Microsystems, Inc. - -;; Maintainer: Eduardo Pelegri-Llopart -;; Author: Eduardo Pelegri-Llopart - -;; Keywords: SPARCworks EOS Era on SPARCworks Debugger dbx - -;;; Commentary: - -;; Please send feedback to eduardo.pelegri-llopart@eng.sun.com - -;;; Code: - -(require 'eos-common "sun-eos-common") - -;;; ================= -;;; debugger protocol -;;; ================= - -(defvar eos::current-hollow-arrow nil) -(defvar eos::current-solid-arrow nil) -(defvar eos::current-dbx-proc-id nil - "TT id for the current dbx") -(defvar eos::current-debugger-clique-id nil - "Clique_ID for the current debugger/dbx") - -;; currentpc.color - -(defvar eos::currentpc-inst "/* XPM */ -static char * file[] = { -\"16 11 5 1\", -\" s background c #BDBDBDBDBDBD\", -\". c #000000000000\", -\"X c #0000FFFF0000\", -\"o c #000077770000\", -\"O c #000044440000\", -\" . \", -\" .. \", -\" .X. \", -\" .........XX. \", -\" .XXXXXXXXXoX. \", -\" .Xooooooooooo. \", -\" .oOOOOOOOOoO. \", -\" .........OO. \", -\" .O. \", -\" .. \", -\" . \"};") - -(defvar eos::currentpc-inst-alt - "/* XPM */ -static char * file[] = { -\"16 11 5 1\", -\" s background c #BDBDBDBDBDBD\", -\". c #000000000000\", -\"X c #0000FFFF0000\", -\"o c #000077770000\", -\"O c #000044440000\", -\" . \", -\" .. \", -\" .X. \", -\" .........XX. \", -\" .XXXXXXXXXoX. \", -\" .Xooooooooooo. \", -\" .oOOOOOOOOoO. \", -\" .........OO. \", -\" .O. \", -\" .. ..\", -\" . ..\"};") - -(defvar eos::visitedpc-inst - "/* XPM */ -static char * file[] ={ -\"16 11 5 1\", -\" s background c #BDBDBDBDBDBD\", -\". c #000000000000\", -\"X c #AFAFAFAFAFAF\", -\"o c #7E7E7E7EA9A9\", -\"O c #666633339999\", -\" . \", -\" .. \", -\" .X. \", -\" .........XX. \", -\" .XXXXXXXXXoX. \", -\" .XooooooooooO. \", -\" .XOOOOOOOOoO. \", -\" .........OO. \", -\" .O. \", -\" .. \", -\" . \"};") - -(defvar eos::visitedpc-inst-alt - "/* XPM */ -static char * file[] ={ -\"16 11 5 1\", -\" s background c #BDBDBDBDBDBD\", -\". c #000000000000\", -\"X c #AFAFAFAFAFAF\", -\"o c #7E7E7E7EA9A9\", -\"O c #666633339999\", -\" . \", -\" .. \", -\" .X. \", -\" .........XX. \", -\" .XXXXXXXXXoX. \", -\" .XooooooooooO. \", -\" .XOOOOOOOOoO. \", -\" .........OO. \", -\" .O. \", -\" .. ..\", -\" . ..\"};") - -(defvar eos::breakpoint-inst - "/* XPM */ -static char * file[] ={ -\"11 11 5 1\", -\" s background c #BDBDBDBDBDBD\", -\". c #000000000000\", -\"X c #FFFF66666666\", -\"o c #FFFF00000000\", -\"O c #777700000000\", -\" ..... \", -\" .XXXXX. \", -\" .XXoooXX. \", -\".XXoooooXO.\", -\".XoooooooO.\", -\".XoooooooO.\", -\".XoooooooO.\", -\".XXoooooOO.\", -\" .XXoooOO. \", -\" .OOOOO. \", -\" ..... \"};") - -(defvar eos::breakpoint-inst-alt - "/* XPM */ -static char * file[] ={ -\"11 11 5 1\", -\" s background c #BDBDBDBDBDBD\", -\". c #000000000000\", -\"X c #FFFF66666666\", -\"o c #FFFF00000000\", -\"O c #777700000000\", -\" ..... \", -\" .XXXXX. \", -\" .XXoooXX. \", -\".XXoooooXO.\", -\".XoooooooO.\", -\".XoooooooO.\", -\".XoooooooO.\", -\".XXoooooOO.\", -\" .XXoooOO. \", -\" .OOOOO...\", -\" ..... ..\"};") - -;; The TT protocol does not provide enough information to -;; use the eos::disabledBreakpoint glyph. - -(defvar eos::disabledBreakpoint-inst - "/* XPM */ -static char * file[] ={ -\"11 11 4 1\", -\" s background c #BDBDBDBDBDBD\", -\". c #000000000000\", -\"X c Grey\", -\"O c Grey80\", -\" ..... \", -\" .XXXXX. \", -\" .XXXXXXX. \", -\".XXXXXXXXO.\", -\".XXXXXXXXO.\", -\".XXXXXXXXO.\", -\".XXXXXXXXO.\", -\".XXXXXXXOO.\", -\" .XXXXXOO. \", -\" .OOOOO. \", -\" ..... \"};") - -(defvar eos::disabledBreakpoint-inst-alt - "/* XPM */ -static char * file[] ={ -\"11 11 4 1\", -\" s background c #BDBDBDBDBDBD\", -\". c #000000000000\", -\"X c Grey\", -\"O c Grey80\", -\" ..... \", -\" .XXXXX. \", -\" .XXXXXXX. \", -\".XXXXXXXXO.\", -\".XXXXXXXXO.\", -\".XXXXXXXXO.\", -\".XXXXXXXXO.\", -\".XXXXXXXOO.\", -\" .XXXXXOO. \", -\" .OOOOO...\", -\" ..... ..\"};") - -(defvar eos::dbx-pattern-list nil) - -(defun eos::debugger-startup () - ;; Actions to do at startup for eos-debugger.el - (make-face 'stop-face) - (make-face 'solid-arrow-face) - (make-face 'hollow-arrow-face) - - (set-face-foreground 'stop-face eos::stop-color) - (set-face-background 'stop-face - (face-background (get-face 'default))) - (set-face-foreground 'solid-arrow-face eos::solid-arrow-color) - (set-face-background 'solid-arrow-face - (face-background (get-face 'default))) - (set-face-foreground 'hollow-arrow-face eos::hollow-arrow-color) - (set-face-background 'hollow-arrow-face - (face-background (get-face 'default))) - - (setq eos::dbx-pattern-list ; list of dbx TT patterns - (eos::create-debugger-patterns)) - -;; should there be only one stop-face, with different properties depending -;; on the frame/device? - - (eos::annotation-set-inst 'debugger-stop 'x eos::breakpoint-inst [nothing]) - (eos::annotation-set-inst 'debugger-stop 'tty "[S]" [nothing]) - (eos::annotation-set-face 'debugger-stop 'x - (get-face 'stop-face) (get-face 'stop-face)) - (eos::annotation-set-face 'debugger-stop 'tty - (get-face 'highlight) (get-face 'highlight)) - - (eos::annotation-set-inst 'debugger-hollow-arrow 'x eos::visitedpc-inst [nothing]) - (eos::annotation-set-inst 'debugger-hollow-arrow 'tty "[]>" [nothing]) - (eos::annotation-set-face 'debugger-hollow-arrow 'x - (get-face 'hollow-arrow-face) - (get-face 'hollow-arrow-face)) - (eos::annotation-set-face 'debugger-hollow-arrow 'tty - (get-face 'highlight) (get-face 'highlight)) - - (eos::annotation-set-inst 'debugger-solid-arrow 'x eos::currentpc-inst [nothing]) - (eos::annotation-set-inst 'debugger-solid-arrow 'tty "=>" [nothing]) - (eos::annotation-set-face 'debugger-solid-arrow 'x - (get-face 'solid-arrow-face) - (get-face 'solid-arrow-face)) - (eos::annotation-set-face 'debugger-solid-arrow 'tty - (get-face 'highlight) (get-face 'highlight)) -) - -;; Not yet ready for prime time. - -(defvar eos::fill-stack-buffer nil - "when t don't try any stack tracing") - -(defvar eos::stack-buffer "*Eos Stack*" - "name of buffer where to log Stack") - -(defun eos::empty-stack () - ;; No valid stack data - e.g. resume/run program - - (if eos::fill-stack-buffer - (progn - (set-buffer (get-buffer-create eos::stack-buffer)) - (toggle-read-only -1) - (delete-region (point-min) (point-max)) - (toggle-read-only 1) - ))) - -(defun eos::load-stack () - ;; Should send a TT message requesting for the stack information; - ;; with the real work done in a callback - (if eos::fill-stack-buffer - (eos::stack-test 1))) - -(defun eos::visit-stack (stackpos) - (if eos::fill-stack-buffer - (progn - (eos::empty-stack) - (eos::stack-test 1) - ))) - -(defun eos::create-stack-patterns () - ;; returns a list of patterns - (list - (make-an-observer "SPRO_SPIDER_FRAMES" 'eos::spro_spider_frames) - )) - -(defun eos::spro_spider_frames (msg pat) - ;; We have received a SPRO_SPIDER_FRAMES notice - (let ((count (get-tooltalk-message-attribute msg 'args_count)) - (i 1)) - (set-buffer (get-buffer-create eos::stack-buffer)) - (toggle-read-only -1) - (while (< i count) - ;; optional leading comment - (if (equal (get-tooltalk-message-attribute msg 'arg_type i) - "Stack_Info1") - (progn - (insert (get-tooltalk-message-attribute msg 'arg_val i)) - (setq i (1+ i)))) - ;; current frame? - (insert (if (equal (get-tooltalk-message-attribute msg 'arg_ival i) - "0") " " "> ")) - (setq i (1+ i)) - (insert (format "[%s] %s%s %s:%s" - ;; frameno - (get-tooltalk-message-attribute msg 'arg_ival i) - ;; funcname - (get-tooltalk-message-attribute msg 'arg_val (+ i 1)) - ;; funcargs - (get-tooltalk-message-attribute msg 'arg_val (+ i 2)) - ;; source - (get-tooltalk-message-attribute msg 'arg_val (+ i 3)) - ;; line - (get-tooltalk-message-attribute msg 'arg_val (+ i 4)))) - (setq i (+ i 5)) - (if (equal (get-tooltalk-message-attribute msg 'arg_type i) - "Stack_Info2") - (progn - (insert (get-tooltalk-message-attribute msg 'arg_val i)) - (setq i (1+ i)))) - (insert "\n")) - (toggle-read-only 1) -;; (return-tooltalk-message msg) - )) - -(defun eos::spider-stack-callback (msg pat) - ;; Callback after processing a spider_stack request - (destroy-tooltalk-message msg) - ) - -(defmacro eos::stack-tt-args (spider-id clique-id hidden verbose quick starting-index count) - (` (list - 'class TT_REQUEST - 'address TT_HANDLER - 'scope TT_SESSION - 'handler (, spider-id) - 'op "SPRO_SPIDER_STACK" - 'callback 'eos::spider-stack-callback - 'args (list - (list 'TT_IN (, clique-id) "Context_ID") - (list 'TT_IN (, hidden) "Boolean") - (list 'TT_IN (, verbose) "Boolean") - (list 'TT_IN (, quick) "Boolean") - (list 'TT_IN (, starting-index) "int") - (list 'TT_IN (, count) "int")) - ))) - -(defun eos::stack-test (starting-index) - (let ((msg (make-tooltalk-message - (eos::stack-tt-args eos::current-dbx-proc-id - eos::current-debugger-clique-id - 0 ; hidden - 1 ; verbose - 0 ; quick - starting-index - 4 ; count - )))) - (send-tooltalk-message msg) -;; (destroy-tooltalk-message msg) - )) - -;; (setq eos::fill-stack-buffer t) -;; (setq eos::fill-stack-buffer nil) -;; (setq eos::stack-pattern-list (eos::create-stack-patterns)) -;; (mapcar 'register-tooltalk-pattern eos::stack-pattern-list) -;; (mapcar 'unregister-tooltalk-pattern eos::stack-pattern-list) -;; (eos::stack-test 1) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -;; - -(defun eos::spro_te_eventset (msg pat) - ;; thread_id trap_id string string filename lineno string string - (let* ((trap-id - (get-tooltalk-message-attribute msg 'arg_val 1)) - (filename - (get-tooltalk-message-attribute msg 'arg_val 4)) - (lineno - (read (get-tooltalk-message-attribute msg 'arg_ival 5)))) - (eos::add-annotation 'debugger-stop filename lineno trap-id) -;; (return-tooltalk-message msg) - )) - -(defun eos::spro_te_eventdel (msg pat) - ;; trap_id string string filename lineno string string - (let* ((trap-id - (get-tooltalk-message-attribute msg 'arg_val 0)) - (filename - (get-tooltalk-message-attribute msg 'arg_val 3)) - (lineno - (read (get-tooltalk-message-attribute msg 'arg_ival 4)))) - (eos::delete-annotation 'debugger-stop filename lineno trap-id) -;; (return-tooltalk-message msg) - )) - -(defun eos::spro_te_stopped (msg pat) - ;; thread_id filename procname lineno filename procname lineno - (let* ((filename-hollow - (get-tooltalk-message-attribute msg 'arg_val 1)) - (procname-hollow - (get-tooltalk-message-attribute msg 'arg_val 2)) - (lineno-hollow - (read (get-tooltalk-message-attribute msg 'arg_ival 3))) - (filename-solid - (get-tooltalk-message-attribute msg 'arg_val 4)) - (lineno-solid - (read (get-tooltalk-message-attribute msg 'arg_ival 6))) - ) - (setq eos::current-solid-arrow - (eos::make-annotation-visible eos::current-solid-arrow - filename-solid - lineno-solid - 'debugger-solid-arrow)) - (if (or (not (equal filename-solid filename-hollow)) - (not (equal lineno-solid lineno-hollow))) - (setq eos::current-hollow-arrow - (eos::make-annotation-visible eos::current-hollow-arrow - filename-hollow - lineno-hollow - 'debugger-hollow-arrow))) -;; (return-tooltalk-message msg) - (eos::load-stack) - )) - -;; Tracking current id's -;; - -(defun eos::update-dbx-proc-id (msg) - (setq eos::current-dbx-proc-id - (get-tooltalk-message-attribute msg 'sender)) - ;; the following is needed to make toolbar entries be active or not - ;; I think it is not needed in 19.13 - (eos::select-debugger-frame eos::debugger-frame) - ) - -(defun eos::update-current-debugger-clique-id (msg) - (setq eos::current-debugger-clique-id - (get-tooltalk-message-attribute msg 'arg_val 0)) - ) - -;; -;; Updating arrows -;; - - -(defun eos::update-pids (msg) - (eos::update-dbx-proc-id msg) - (eos::update-current-debugger-clique-id msg)) - -(defun eos::internal-clear-annotations (stack arrows stops &optional clique) - (if stack - (eos::empty-stack)) - (if arrows - (progn - (eos::make-annotation-invisible eos::current-hollow-arrow) - (eos::make-annotation-invisible eos::current-solid-arrow))) - (if clique - (progn - (setq eos::current-debugger-clique-id nil) - ;; not needed in 19.13? - (eos::select-debugger-frame eos::debugger-frame))) - (if stops - (eos::remove-all-from-annotation-list 'debugger-stop))) - - -(defun eos::clear-arrows (msg pat) - (eos::internal-clear-annotations t t nil) -;; (return-tooltalk-message msg) - ) - -(defun eos::update-clear-stops (msg pat) - (eos::update-pids msg) - (eos::internal-clear-annotations t nil t) -;; (return-tooltalk-message msg) - ) - -(defun eos::update-clear-arrows-stops (msg pat) - (eos::update-pids msg) - (eos::internal-clear-annotations t t t) -;; (return-tooltalk-message msg) - ) - -(defun eos::clear-arrows-stops (msg pat) - (let ((this-proc-id - (get-tooltalk-message-attribute msg 'sender))) - (if (equal eos::current-dbx-proc-id this-proc-id) - (progn - (eos::internal-clear-annotations t t t) - ;; (return-tooltalk-message msg) - )))) - -;; - -;; - -(defun eos::spro_detach (msg pat) - ;; a detach notification has been received. this means dbx/debugger - ;; is exiting - (eos::internal-clear-annotations t t t t) - (eos::dismiss-print-frame)) - -(defun eos::spro_te_location (msg pat) - ;; thread_id filename procname lineno filename procname lineno - (let* ((filename-hollow - (get-tooltalk-message-attribute msg 'arg_val 1)) - (lineno-hollow - (read (get-tooltalk-message-attribute msg 'arg_ival 3))) - (filename-solid - (get-tooltalk-message-attribute msg 'arg_val 4)) - (lineno-solid - (read (get-tooltalk-message-attribute msg 'arg_ival 6))) - ) - (setq eos::current-solid-arrow - (eos::make-annotation-visible eos::current-solid-arrow - filename-solid - lineno-solid - 'debugger-solid-arrow)) - (if (or (not (equal filename-solid filename-hollow)) - (not (equal lineno-solid lineno-hollow))) - (setq eos::current-hollow-arrow - (eos::make-annotation-visible eos::current-hollow-arrow - filename-hollow - lineno-hollow - 'debugger-hollow-arrow))) -;; (return-tooltalk-message msg) - )) - -(defun eos::spro_te_visit (msg pat) - ;; thread_id filename procname lineno stackpos - (let* ((filename - (get-tooltalk-message-attribute msg 'arg_val 1)) - (procname - (get-tooltalk-message-attribute msg 'arg_val 2)) - (lineno - (read (get-tooltalk-message-attribute msg 'arg_ival 3))) - (stackpos - (read (get-tooltalk-message-attribute msg 'arg_ival 4))) - ) - (eos::make-annotation-invisible eos::current-hollow-arrow) - (if (equal stackpos 1) - (progn - (eos::make-annotation-invisible eos::current-solid-arrow) - (setq eos::current-solid-arrow - (eos::make-annotation-visible eos::current-solid-arrow - filename - lineno - 'debugger-solid-arrow)) - ) - (setq eos::current-hollow-arrow - (eos::make-annotation-visible eos::current-hollow-arrow - filename - lineno - 'debugger-hollow-arrow)) - ) -;; (return-tooltalk-message msg) - (eos::visit-stack stackpos) - )) - -;; generate a list of patterns -;; so it can be registered and unregistered. - - -(defun eos::create-debugger-patterns () - ;; returns a list of patterns - (list - (make-an-observer "SPRO_TE_STOPPED" 'eos::spro_te_stopped) - (make-an-observer "SPRO_SE_STARTED" 'eos::clear-arrows) - (make-an-observer "SPRO_TE_STEPPED" 'eos::clear-arrows) - (make-an-observer "SPRO_TE_CONTINUED" 'eos::clear-arrows) - (make-an-observer "SPRO_SE_DROPPED" 'eos::clear-arrows-stops) - (make-an-observer "SPRO_SE_DEBUGGED" 'eos::update-clear-stops) - (make-an-observer "SPRO_SE_REVIVED" 'eos::update-clear-arrows-stops) - (make-an-observer "SPRO_SE_ATTACHED" 'eos::update-clear-arrows-stops) - (make-an-observer "SPRO_SE_GONE" 'eos::clear-arrows) - (make-an-observer "SPRO_TE_LOCATION" 'eos::spro_te_location) - (make-an-observer "SPRO_TE_VISIT" 'eos::spro_te_visit) - (make-an-observer "SPRO_TE_EVENTSET" 'eos::spro_te_eventset) - (make-an-observer "SPRO_TE_EVENTDEL" 'eos::spro_te_eventdel) - (make-an-observer "SPRO_DETACH" 'eos::spro_detach) - )) - -(defun eos::register-debugger-patterns () - ;; register all dbx patterns - (mapcar 'register-tooltalk-pattern eos::dbx-pattern-list) - (eos::register-debugger-extra-patterns)) - -(defun eos::unregister-debugger-patterns () - ;; unregister all dbx patterns - (mapcar 'unregister-tooltalk-pattern eos::dbx-pattern-list) - (eos::unregister-debugger-extra-patterns)) - -(provide 'eos-debugger) - -;;; sun-eos-debugger.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/eos/sun-eos-editor.el --- a/lisp/eos/sun-eos-editor.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,114 +0,0 @@ -;;; sun-eos-editor.el --- Implements the XEmacs/SPARCworks editor protocol - -;; Copyright (C) 1995 Sun Microsystems, Inc. - -;; Maintainer: Eduardo Pelegri-Llopart -;; Author: Eduardo Pelegri-Llopart - -;; Keywords: SPARCworks EOS Era on SPARCworks editor - -;;; Commentary: - -;; Please send feedback to eduardo.pelegri-llopart@eng.sun.com - -;;; Code: - -(require 'eos-common "sun-eos-common") - -;; =============== -;; Editor protocol -;; -;; message is -;; SPRO_Visit_File CONTEXT_UID filename lineno center==0 - -(defvar eos::visit-file-pattern) -(defvar eos::get-src-line-pattern) - -(defun eos::editor-startup () - ;; Actions to do at startup time for eos-editor - (setq eos::visit-file-pattern - (eos::create-visit-file-pattern)) - (setq eos::get-src-line-pattern - (eos::create-get-src-line-pattern)) - (eos::register-get-src-line-pattern) - ) - -(defun eos::visit-file-callback (msg pat) - ;; A callback for a SPRO_Visit_File message - ;; really should be discarded in the pattern - (let* ((filename - (get-tooltalk-message-attribute msg 'arg_val 1)) - (lineno-dot - (read - (get-tooltalk-message-attribute msg 'arg_ival 2))) - ) - (if (null (eos::find-line filename lineno-dot 'debugger-visit)) - (message "No frame to select")) - (return-tooltalk-message msg) - )) - -(defun eos::create-visit-file-pattern () - ;; Create Visit File pattern - (let* ((pattern-desc '(category TT_HANDLE - scope TT_SESSION - class TT_REQUEST - op "SPRO_Visit_File" - callback eos::visit-file-callback)) - (pattern (make-tooltalk-pattern pattern-desc)) - ) - pattern - )) - -(defun eos::register-visit-file-pattern () - ;; Register Visit File pattern - (register-tooltalk-pattern eos::visit-file-pattern)) - -(defun eos::unregister-visit-file-pattern () - ;; Unregister Visit File pattern - (unregister-tooltalk-pattern eos::visit-file-pattern)) - -;; -;; ==================== -;; -;; Auxiliary TT message to get source and lineno. -;; -;; message is -;; SPRO_Get_Src_Line CONTEXT_UID (INOUT filename) (INOUT lineno) - -;; - -(defun eos::get-src-line-callback (msg pat) - ;; A callback for a SPRO_Get_Src_Line message - ;; really should be discarded in the pattern - (let* ((filename - (buffer-file-name)) - (lineno - (format "%d" (eos::line-at (point))))) - (set-tooltalk-message-attribute filename msg 'arg_val 1) - (set-tooltalk-message-attribute lineno msg 'arg_val 2) - (return-tooltalk-message msg) - )) - -(defun eos::create-get-src-line-pattern () - ;; Create a pattern to get filename and lineno - (let* ((pattern-desc '(category TT_HANDLE - scope TT_SESSION - class TT_REQUEST - op "SPRO_Get_Src_Line" - callback eos::get-src-line-callback)) - (pattern (make-tooltalk-pattern pattern-desc)) - ) - pattern - )) - -(defun eos::register-get-src-line-pattern () - ;; Register Get Src Line pattern - (register-tooltalk-pattern eos::get-src-line-pattern)) - -(defun eos::unregister-get-src-line-pattern () - ;; Unregister Get Src Line pattern - (unregister-tooltalk-pattern eos::get-src-line-pattern)) - -(provide 'eos-editor) - -;;; sun-eos-debugger.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/eos/sun-eos-init.el --- a/lisp/eos/sun-eos-init.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,38 +0,0 @@ -;;; sun-eos-init.el --- Initializes the XEmacs/SPARCworks interface - -;; Copyright (C) 1996 Sun Microsystems, Inc. - -;; Maintainer: Eduardo Pelegri-Llopart -;; Author: Eduardo Pelegri-Llopart - -;; Keywords: SPARCworks EOS Era on SPARCworks initialize - -;;; Commentary: - -;; Initialize EOS -;; Please send feedback to eduardo.pelegri-llopart@eng.sun.com - -;;; Code: - -;; This stuff needs to be done at startup time -(defun eos::start () - "Initialization needed at start-up time. Should be done by automatic -loading of eos" - (if (not (and (string-match "XEmacs" emacs-version) - (emacs-version>= 19 12))) - (error "Eos version %s only runs on XEmacs 19.12 and later" - eos::version)) - (if (not noninteractive) - (progn - (eos::common-startup) - (eos::editor-startup) - (eos::debugger-startup) - (eos::debugger-extra-startup) - (eos::browser-startup) - (eos::menubar-startup)))) - -;(add-hook 'before-init-hook 'eos::start t) ; append to the end of hook list - -(provide 'eos-init) - -;;; sun-eos-init.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/eos/sun-eos-load.el --- a/lisp/eos/sun-eos-load.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,28 +0,0 @@ -;;; sun-eos-load.el --- Loads the XEmacs/SPARCworks interface code - -;; Copyright (C) 1995 Sun Microsystems, Inc. - -;; Maintainer: Eduardo Pelegri-Llopart -;; Author: Eduardo Pelegri-Llopart - -;; Keywords: SPARCworks EOS Era on SPARCworks Debugger dbx - -;;; Commentary: - -;; Load EOS code -;; Please send feedback to eduardo.pelegri-llopart@eng.sun.com - -;;; Code: - -(load "sun-eos-init" nil t) -(load "sun-eos-common" nil t) -(load "sun-eos-editor" nil t) -(load "sun-eos-browser" nil t) -(load "sun-eos-debugger" nil t) -(load "sun-eos-debugger-extra" nil t) -(load "sun-eos-menubar" nil t) -;; don't load toolbar (load "sun-eos-toolbar" nil t) - -(provide 'eos-load) - -;;; sun-eos-load.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/eos/sun-eos-menubar.el --- a/lisp/eos/sun-eos-menubar.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,555 +0,0 @@ -;;; sun-eos-menu.el --- Implements the XEmacs/SPARCworks menubar - -;; Copyright (C) 1995 Sun Microsystems, Inc. - -;; Maintainer: Eduardo Pelegri-Llopart -;; Author: Eduardo Pelegri-Llopart - -;; Keywords: SPARCworks EOS Era on SPARCworks menubar - -;;; Commentary: -;; This file contains functions that populate a SPARCworks menu -;; Please send feedback to eduardo.pelegri-llopart@eng.sun.com - -;;; Code: - -(require 'eos-common "sun-eos-common") - -(defun eos::toggle-sbrowser-selected-frame () - ;; Toggle whether this frame is selected for SBrowser - (interactive) - (if (equal eos::sbrowser-frame (selected-frame)) - (eos::select-sbrowser-frame nil) - (eos::select-sbrowser-frame (selected-frame))) - ) - -(defun eos::toggle-debugger-selected-frame () - ;; Toggle whether this frame is selected for Debugger - (interactive) - (if (equal eos::debugger-frame (selected-frame)) - (eos::select-debugger-frame nil) - (eos::select-debugger-frame (selected-frame))) - ) - -(defvar eos::long-menu - '( - ["Read and Execute a Dbx Command" eos::dbx-cmd (not (eq eos::key-mode 'none))] - ["Run" eos::run (not (eq eos::key-mode 'none))] - ["Fix" eos::fix (not (eq eos::key-mode 'none))] - "-----" - ["Print" eos::print (not (eq eos::key-mode 'none))] - ["Print *" eos::print* (not (eq eos::key-mode 'none))] - ["Dismiss Print" eos::dismiss-print-frame (not (eq eos::key-mode 'none))] - "-----" - ["Continue" eos::cont (not (eq eos::key-mode 'none))] - ["Stop" eos::stop-at (not (eq eos::key-mode 'none))] - ["Clear" eos::clear-at (not (eq eos::key-mode 'none))] - ["Next" eos::next (not (eq eos::key-mode 'none))] - ["Step" eos::step (not (eq eos::key-mode 'none))] - ["Step Up" eos::step-up (not (eq eos::key-mode 'none))] - ["Continue To" eos::cont-to (not (eq eos::key-mode 'none))] - "-----" - ["Stack Up" eos::up (not (eq eos::key-mode 'none))] - ["Stack Down" eos::down (not (eq eos::key-mode 'none))] - "-----" - ("Start Tool and Enable Frame" - ["Debugger" eos::start-debugger t] - ["Dbx" eos::start-dbx t] - ["SBrowser" eos::start-sbrowser t] - ) - "-----" - ["Enable Frame for SBrowser" - eos::toggle-sbrowser-selected-frame - :style toggle - :selected (equal eos::sbrowser-frame - (selected-frame))] - ["Enable Frame for Debugger and Dbx" - eos::toggle-debugger-selected-frame - :style toggle - :selected (equal eos::debugger-frame - (selected-frame))] - "-----" - ["News..." eos::sw-news t] - ) - ) - -(defvar eos::short-menu - '( - ("Start Tool and Enable Frame" - ["Debugger" eos::start-debugger t] - ["Dbx" eos::start-dbx t] - ["SBrowser" eos::start-sbrowser t] - ) - "-----" - ["Enable Frame for SBrowser" - eos::toggle-sbrowser-selected-frame - :style toggle - :selected (equal eos::sbrowser-frame - (selected-frame))] - ["Enable Frame for Debugger and Dbx" - eos::toggle-debugger-selected-frame - :style toggle - :selected (equal eos::debugger-frame - (selected-frame))] - "-----" - ["News..." eos::sw-news t] - ) - ) - -(defun eos::menubar-startup () - ;; Actions to do at startup for eos-menubar.el - (if (and (eq (device-type (selected-device)) 'x) - (or (not (local-variable-p 'current-menubar (current-buffer))) - (yes-or-no-p - "SPARCworks menu will be local (menubar is buffer-local); proceed?"))) - (progn - (add-menu-button '("Help") ["SPARCworks..." eos::sw-intro t]) - (add-submenu nil - (append '("SPARCworks") (copy-tree eos::short-menu)) - "Version Control" - ) - ))) - -;; -;; Insertion of text with a font -;; - -(defun eos::insert-italics (a-string) - (eos::insert-with-font a-string 'italic)) - -(defun eos::insert-bold (a-string) - (eos::insert-with-font a-string 'bold)) - -(defun eos::insert-with-font (a-string a-font) - (interactive "") - (let (a b ext) - (setq a (point)) - (insert a-string) - (setq b (point)) - (setq ext (make-extent a b)) - (set-extent-face ext (find-face a-font)) - )) - -;; -;; Generic insert code -;; - -(defun eos::insert (s) - (let ((len (length s)) - (pos 0) - (newpos 0) - (state 'normal)) - (while (< pos len) - (setq newpos (string-match "#[bnir]" s pos)) - (if (and newpos (> newpos pos)) - (progn - (cond ((equal (aref s (+ newpos 1)) ?b) ; bold - (if (equal state 'normal) - (progn - (insert (substring s pos newpos)) - (setq state 'bold)) - (error "found bold when not in normal"))) - ((equal (aref s (+ newpos 1)) ?r) ; red - (if (equal state 'normal) - (progn - (insert (substring s pos newpos)) - (setq state 'red)) - (error "found red when not in normal"))) - ((equal (aref s (+ newpos 1)) ?i) ; italics - (if (equal state 'normal) - (progn - (insert (substring s pos newpos)) - (setq state 'italics)) - (error "found italics when not in normal"))) - ((equal (aref s (+ newpos 1)) ?n) ; normal - (cond ((equal state 'italics) - (eos::insert-italics (substring s pos newpos)) - (setq state 'normal)) - ((equal state 'bold) - (eos::insert-bold (substring s pos newpos)) - (setq state 'normal)) - ((equal state 'normal) - (error "found normal when in normal")))) - (t - (error "internal error")) - ) - (setq pos (+ newpos 2)) - ) - (if (equal state 'normal) - (progn - (insert (substring s pos)) - (setq pos len)) - (error "eos::insert with unclosed special font")) - )) - )) - -;; -;; Introduction File -;; - -(defun eos::sw-intro () - "Generate an intro buffer." - (interactive) - (let ((buffer1 (get-buffer-create " *SPARCworks Intro*")) - ) - (switch-to-buffer buffer1) - (setq buffer-read-only nil) - (delete-region (point-min) (point-max)) - (eos::insert " - #bSPARCworks Editor Integration#n - Eos is copyright (c) 1995 by Sun Microsystems. - -#bIntroduction (for Eos 1.5.x)#n - -#iSPARCworks#n is a set of integrated programming tools from SunSoft that -support the program development cycle. #iXEmacs#n is a version of the Emacs -editor that includes interfaces to the selection service and to the -#iToolTalk#n service. The #iEos#n package uses these two interfaces to provide -a simple yet useful editor integration with three SPARCworks tools: -the #iSourceBrowser#n, the #iDebugger#n and #iDbx#n. Eos requires XEmacs 19.12 -or above, and SW3.0.1 or above. - -When used with Eos, the Debugger and SourceBrowser do not include a -source pane for displaying of sources and instead use an XEmacs frame. -Then the user can interact with the XEmacs frame in a way very similar -to how the source panes of the SW tools would be used. The user can also -start Dbx and request that sources be shown in XEmacs. - -#bSimple Startup#n - -In most cases, the user will start an interaction with Eos as follows: - - (1) Start XEmacs, - - (2) Load \"eos.el\" to add a SPARCworks submenu to the menubar (this -step might not be needed if Eos is preloaded to your XEmacs binary), and - - (3) On some XEmacs frame use the SPARCworks submenu and start the -desired tool and simultaneously enable that frame to display sources. - -The toolbar for the enabled frame will change after (3) to show that -this frame will behave as the source display for the SW tool and to -indicate that some actions on the tool can be performed from this frame. - -The actions available depend on the SW tool. The interaction model for -the Debugger and the SourceBrowser can be described as #iselect on the -XEmacs frame and then click on the button on the SW tool#n. As an example, -a browser query can be performed by selecting some text and then clicking -on the query button on the SBrowser tool; the source for the first match -will appear in the XEmacs frame, together with a glyph showing the match. - -The Debugger and Dbx can also be driven from XEmacs. Most frequently -this will be done using the ToolBar. Entries in the toolbar of a frame -enabled for debugging are deactivated when there is not enough information -to invoke their associated commands (due to technical reasons, it is -necessary for XEmacs to have had a frame enabled for Debugger/Dbx when -a debug or attach command was issued to Debugger/Dbx to make most toolbar -commands active). As an example, to set a breakpoint at some line, select -a position in that line and then click on the toolbar icon with the stop -with the arrow inside. - -#bDetails#n - -#iManual Startup#n - -In the scenario described above, the user simultaneously starts a tool -and enables a frame for that tool. The two actions can also be done -independently. The tools (Source Browser, Debugger, and Dbx) have to -be started with the \"-editor\" option and the XEmacs frame can be -enabled manually using the SPARCworks submenu. The most common use -of this feature is to disable and re-enable a frame, be it to recover -the default toolbar, or to avoid conflicts with other active tools -(see the paragraph below on multiple active tools). - -#iFrame Enabling#n - -At any given time there can be at most one frame enabled to display -Source Browser sources, and at most one frame enabled to display -Debugger and Dbx sources. The same XEmacs frame can be used for both -types of sources. The toolbar of an enabled frame always starts with -an informational icon. This icon is a large-font #ii#n with either a -smaller-font #iB#n, if the frame has browsing enabled, and/or a smaller-font -#iD#n, if the frame has debugging enabled. - -If no frames are enabled for a given tool, the editor integration for -that tool is disabled. This means that XEmacs deregisters the TT -patterns relevant to this tool, and XEmacs does not receive any -messages from that tool. - -#iMultiple Active Tools#n - -In order to provide a simpler user model, Eos has no provisions to -#igracefully#n support more than one simultaneous active tool of a -given class per TT session. A Debugger and a SourceBrowser, or a Dbx -and a SourceBrowser, can coexist gracefully, but a Debugger and a Dbx -cannot, and neither can two SourceBrowsers, two Debuggers, or two -dbxs. This simplification is consistent with the needs of most users. - -The implementation of Eos notifies the user if she attempts to start two -conflicting tools, but it does not enforce the restriction. In some -cases two conflicting tools can be used profitably by a careful user, -but in others the result is likely to be chaos. An example of the first -is using two SourceBrowsers, and one of the later is attempting to send -debugging commands from XEmacs to two debuggers. - -If a user really needs to have multiple active tools, she can do this -in a safe way by creating several TT sessions (e.g. using #ittsession --c /bin/csh#n, see the man page for ttsession), and placing the tools -with their own XEmacses in separate TT sessions. - -#iA Visual Data Inspector in XEmacs#n - -Users that choose to drive the debugger from XEmacs also have -available a #ivery simple#n but fast visual data inspector. The results -of #iprint#n and #iprint*#n commands are formatted into an XEmacs buffer -(#i\"*Eos Print Output*\"#n) and presented into a separate frame. -This frame is mapped and unmapped so that, except for the first time, -it appears quickly. - -#iBuffers for Debugger/Dbx Interaction#n - -When starting dbx as a subprocess, a buffer will be created to interact -with dbx. The name of this buffer is of the form #i\"*Eos dbx*\"#n. - -If a dbx engine is receiving requests from both Debugger and XEmacs -(e.g. it was started via #idebugger -editor#n), the responses to -commands sent by XEmacs will be shown in the echo area and will be -recorded in a read-only buffer (#i\"*Eos Debugger Log*\"#n), but responses -to Debugger commands will not appear. Conversely, responses to Debugger -commands will appear in the Debugger transcript pane but not in XEmacs's -log buffer. This is a limitation of the underlying TT protocols. - -#bTTY Support#n - -Although tty support is not an official part of Eos, it is possible -with some extra effort and specialized knowledge from the user. - -#iStarting a ToolTalk Session#n - -Eos requires a ToolTalk communication. This may require starting a TT -session by: - - (0) Start a ToolTalk session, and a shell so that all processes -started from this shell will use the new TT session. Do this by -executing \"ttsession -c /bin/csh\" - or whatever shell you use - -At this point, you can start your XEmacs on that shell, as shown in -step (1) above. Note that, since there is no TTY toolbar in 19.12 -(nor 19.13), an alternative mechanism must be used to enable the -(tty) frame. - -A typical use for tty is to interact with dbx. The command -#ieos::start-dbx#n will select the tty frame for debugging and will start -a dbx buffer. From this point on, dbx will use this tty frame to show -its sources. The introduction and news messages can be generated -using the commands #ieos::sw-intro#n and #ieos::sw-news#n. You can interact -with the dbx subprocess by typing to its associated input buffer or -using some key bindings. - -#iKey Bindings#n - -A tty user can interact with Eos by invoking directly the Eos -commands, evaluating elisp expressions, or through some key-bindings. -The expert user may provide her own key bindings. Eos also provides two -set of global bindings, which are activated by evaluating the -expressions (eos::set-key-mode 'prefix) or (eos::set-key-mode -'function). - -#bKnown Bugs#n - -Due to a bug in the internal subprocess machinery of XEmacs 19.12, the -default prompt of dbx subprocesses will show the full path to the binary. -The prompt can be overridden using the ksh variable PS1\; one way to do -this is by adding the following line to your ~/.dbxrc: - - PS1='(dbx) ' - -#bFeedback#n - -You are encouraged to send us feedback via the Comments button in -the About Box of either SPARCworks tool, or directly to -eos-comments@cs.uiuc.edu. - -#bEnjoy.#n") - (setq buffer-read-only t) - (goto-char (point-min)) - (view-mode nil 'kill-buffer) ;; assume the new view-less - )) - -;; -;; Cheat Sheets for keyboard mappings -;; -;; This depends on the mapping being used! -;; - -(defun eos::sw-cheat-sheet () - "Generate buffer that has a description of the key maps that can be -printed, cut and then taped somewhere (like on the keyboard or on your -monitor). This is particularly useful for the function keys" - (interactive) - (let ((buffer1 (get-buffer-create " *Cheat Sheets*")) - ) - (switch-to-buffer buffer1) - (setq buffer-read-only nil) - (delete-region (point-min) (point-max)) - (eos::insert " - #bCheat Sheets for Eos#n - -This buffer has a description of the key maps that can be printed, cut -and then taped somewhere (like on the keyboard or on your monitor). -This is particularly useful for the function keys since their numbers -don't any particular mnemonic value. - - -#bWhen using function keys#n #i[Options->SPARCworks->Use Function Keys]#n - ----------------------------------------- - -F6 F7 F8 F9 - -Do Print Cont ---- Next -Run Print* Stop Step -Fix Dismiss Clear Step Up - - ----------------------------------------- - -#bWhen using prefix map#n #i[Options->SPARCworks->Use C-c d Prefix Map]#n - ----------------------------------------- -Basic prefix: C-c d - - - Do % - Run r - Fix f - - Print p - Print* C-p - - Cont c - Stop b (for breakpoint) - Clear C-b - - Next n - Step s - Step up C-s - - Up u - Down d ----------------------------------------- - -") - (setq buffer-read-only t) - (goto-char (point-min)) - (view-mode nil 'kill-buffer) ;; assume the new view-less - )) - -;; -;; News files -;; - -(defun eos::sw-news () - "Generate a News buffer." - (interactive) - (let ((buffer1 (get-buffer-create " *Eos News*")) - ) - (switch-to-buffer buffer1) - (setq buffer-read-only nil) - (delete-region (point-min) (point-max)) - (eos::insert " - #bEos News#n - -See the #iHelp#n top-level menu for additional information on the -SPARCworks lightweight editor integration (Eos). The current version -of Eos is available as the contents of the variable eos::version. - -#bversion 1.5.2#n - - Support for 19.12 and 19.13. Works on TTYs. Uses real ToolBar. - Toolbars for debugger & content inspector are frame-local. - Better icons and glyphs. Support for (load-library \"eos\"). - Ease-of-use: startup for tools. - Icon files are now defined \"in-line\" to simplify administration. - - Removed the following to simplify use: - - Textual toolbar (from 1.4). - - Option submenu to add keymaps for debugger use. - - Popup menu. - - Any pretenses to support SW3.0; use SW3.0.1 instead. - -#bversion 1.4.1#n - - Added eos::add-button interface. - -#bversion 1.4#n - - Added toolbar like in dbxtool. Toolbar uses echo-help to show - meaning of buttons, (setq inhibit-help-echo t) if you don't - want it. - - Selection now remains after \"print\"-like commands. Now it - is possible to have the *debugger* buffer in the frame selected - for displaying debugged sources. - - Added a command to relayout debugger buffers so they show in - a layout similar to that of dbxtool. - -#bversion 1.3#n - - Provided popup-menu bindings for those debugger actions - that operate on the contents of the selection or its position; - selectable via options. - - The *debugger* buffer now support M-p and M-n. - -#bversion 1.2#n - - Better support for interactions via *debugger* buffer and directly - using a prefix map and function keys. - - Converted to use new toggle and radio menus, reorganizing - SPARCworks menu to factor out help and options into submenus, - which are now available under the Options and Help top-level menus. - -#bversion 1.1#n - - Some internal cleanup. - - Eos now provides basic machinery to drive the debugger - engine directly using ToolTalk messages. This feature is - not yet very well polished. You can try using it at your own risk, - or await for release 1.2 (soon to come) that will provide a better - interface and improved functionality, as well as documentation - for the interface. - -#bversion 1.0#n - - First widely available release. Supports simple #iselect and click#n model. - -#bPossible Future Enhancements#n - -* Add a \"peek-in-source\" mechanism to show the values of - expressions in the sources. - -* The comint package should be generalized to allow for TT-based - interpreters and it should be used in Eos. - -* Key & popup bindings should probably be a minor mode (currently - it conflicts with cc-mode). - -* Should support locking a print frame to force new print frames. Also, - should allow for following fields in print frames. - - -#bFeedback#n - - Send feedback to #ieos-comments@cs.uiuc.edu#n") - (setq buffer-read-only t) - (goto-char (point-min)) - (view-mode nil 'kill-buffer) ;; assume the new view-less - )) - -(provide 'eos-menubar) - -;;; sun-eos-debugger.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/eos/sun-eos-toolbar.el --- a/lisp/eos/sun-eos-toolbar.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1110 +0,0 @@ -;;; sun-eos-toolbar.el --- Implements the EOS toolbar interface - -;; Copyright (C) Sun Microsystems, Inc. - -;; Maintainer: Eduardo Pelegri-Llopart -;; Author: Eduardo Pelegri-Llopart - -;; Keywords: SPARCworks EOS Era on SPARCworks toolbar - -;;; Commentary: - -;; Please send feedback to eduardo.pelegri-llopart@eng.sun.com - -;;; Code: - -(defvar eos::toolbar-icon-directory - (file-name-as-directory (locate-data-directory "eos"))) - -(defvar eos::toolbar-run-icon - (if (featurep 'xpm) - (toolbar-make-button-list - "/* XPM */ -static char * file[] = { -\"28 28 5 1\", -\" c #C8C8C8C8C8C8 s backgroundToolBarColor\", -\". s FgColor c #000000000000\", -\"X c #0000FFFF0000\", -\"+ c #000077770000\", -\"@ c #000044440000\", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" ....... \", -\" \", -\" ..... \", -\" .X+@. ....... \", -\" .X+@. \", -\" ......@.... \", -\" .XXX++++. ....... \", -\" .XX++@. \", -\" .@+@. \", -\" .@. ....... \", -\" . \", -\" \", -\" ....... \", -\" \", -\" \", -\" ....... \", -\" \", -\" \", -\" \", -\" \", -\" \"};") - (toolbar-make-button-list - (expand-file-name "eos-run.xbm" eos::toolbar-icon-directory))) - "A Run icon pair.") - -(defvar eos::toolbar-type-icon - (if (featurep 'xpm) - (toolbar-make-button-list - "/* XPM */ -static char * file[] = { -\"28 28 2 1\", -\" c #C8C8C8C8C8C8 s backgroundToolBarColor\", -\"X c #000000000000\", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" XX XX \", -\" XX XX \", -\" XXXX XXXX XX XX \", -\" XX XX XX XX XX XX XXX X \", -\" XX XX XX XX XXX X X X \", -\" XX XX XX XX X XXXX \", -\" XX XX XX XX XXX XXXX \", -\" XX XX XX XX XX XX X X X \", -\" XXX XXX XX XX X XXX \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \"};") - (toolbar-make-button-list - (expand-file-name "eos-type.xbm" eos::toolbar-icon-directory))) - "A Type-at icon pair.") - - -(defvar eos::toolbar-stop-at-icon - (if (featurep 'xpm) - (toolbar-make-button-list - "/* XPM */ -static char * file[] = { -\"28 28 5 1\", -\" c #C8C8C8C8C8C8 s backgroundToolBarColor\", -\". c #4B4B4B4B4B4B\", -\"X c #FFFFFFFFFFFF\", -\"o c #AFAFAFAFAFAF\", -\"O c #FFFF00000000\", -\" \", -\" \", -\" \", -\" \", -\" ........ \", -\" .XXXXXXXX. \", -\" .XoOOOOOOoX. \", -\" .XoOOOOOOOOoX. \", -\" .XoOOOOOOOOOOoX. \", -\" .XoOOOOOOOOOOOOoX. \", -\" .XoOOOOOOOOXOOOOOoX. \", -\" .XOOOOOOOOOXXOOOOOX. \", -\" .XOOOOXXXXXXXXOOOOX. \", -\" .XOOOOXXXXXXXXXOOOX. \", -\" .XOOOOXXXXXXXXOOOOX. \", -\" .XOOOOOOOOOXXOOOOOX. \", -\" .XOOOOOOOOOXOOOOOOX. \", -\" .XoOOOOOOOOOOOOOOoX. \", -\" .XoOOOOOOOOOOOOOX. \", -\" .XoOOOOOOOOOOoX. \", -\" .XoOOOOOOOOoX. \", -\" .XoOOOOOOoX. \", -\" .XXXXXXXX. \", -\" ........ \", -\" \", -\" \", -\" \", -\" \"};") - (toolbar-make-button-list - (expand-file-name "eos-stop.xbm" eos::toolbar-icon-directory))) - "A Stop At icon pair.") - -(defvar eos::toolbar-clear-at-icon - (if (featurep 'xpm) - (toolbar-make-button-list - "/* XPM */ -static char * file[] = { -\"28 28 5 1\", -\" c #C8C8C8C8C8C8 s backgroundToolBarColor\", -\". c #4B4B4B4B4B4B\", -\"X c #FFFFFFFFFFFF\", -\"o c #AFAFAFAFAFAF\", -\"O c #FFFF00000000\", -\" \", -\" \", -\" \", -\" \", -\" ........ \", -\" .XXXXXXXX. \", -\" .XoOOOOOOoX. \", -\" .XoOOOOOOOOoX. \", -\" .XoOOOOOOOOOOoX. \", -\" .XoOOOOOOOOOOOOoX. \", -\" .XoOOOXXOOOOXXOOOoX. \", -\" .XOOOOOXXOOXXOOOOOX. \", -\" .XOOOOOOXXXXOOOOOOX. \", -\" .XOOOOOOOXXOOOOOOOX. \", -\" .XOOOOOOXXXXOOOOOOX. \", -\" .XOOOOOXXOOXXOOOOOX. \", -\" .XOOOOXXOOOOXXOOOOX. \", -\" .XoOOOXOOOOOOXOOOoX. \", -\" .XoOOOOOOOOOOOOoX. \", -\" .XoOOOOOOOOOOoX. \", -\" .XoOOOOOOOOoX. \", -\" .XoOOOOOOoX. \", -\" .XXXXXXXX. \", -\" ........ \", -\" \", -\" \", -\" \", -\" \"};") - (toolbar-make-button-list - (expand-file-name "eos-clear-at.xbm" eos::toolbar-icon-directory))) - "A Clear At icon pair.") - -(defvar eos::toolbar-stop-in-icon - (if (featurep 'xpm) - (toolbar-make-button-list - "/* XPM */ -static char * file[] = { -\"28 28 5 1\", -\" c #C8C8C8C8C8C8 s backgroundToolBarColor\", -\". c #4B4B4B4B4B4B\", -\"X c #FFFFFFFFFFFF\", -\"o c #AFAFAFAFAFAF\", -\"O c #FFFF00000000\", -\" \", -\" \", -\" \", -\" \", -\" ........ \", -\" .XXXXXXXX. \", -\" .XoOOOOOOoX. \", -\" .XoOOOOOOOOoX. \", -\" .XoOOOOOOOOOOoX. \", -\" .XoOOOOOOOOOOOOoX. \", -\" .XoOOOOOOOOOXOXOOoX. \", -\" .XOOOXXXXOOXOOOXOOX. \", -\" .XOOOXOOOOOXOOOXOOX. \", -\" .XOOOXOOOOOXOOOXOOX. \", -\" .XOOOXXXOOXOOOOOXOX. \", -\" .XOOOXOOOOOXOOOXOOX. \", -\" .XOOOXOOOOOXOOOXOOX. \", -\" .XoOOXOOOOOXOOOXOoX. \", -\" .XoOOOOOOOOXOXOoX. \", -\" .XoOOOOOOOOOOoX. \", -\" .XoOOOOOOOOoX. \", -\" .XoOOOOOOoX. \", -\" .XXXXXXXX. \", -\" ........ \", -\" \", -\" \", -\" \", -\" \"};") - (toolbar-make-button-list - (expand-file-name "eos-stop-in.xbm" eos::toolbar-icon-directory))) - "A Stop in icon pair.") - -(defvar eos::toolbar-step-into-icon - (if (featurep 'xpm) - (toolbar-make-button-list - "/* XPM */ -static char * file[] = { -\"28 28 5 1\", -\" c #C8C8C8C8C8C8 s backgroundToolBarColor\", -\". c #000000000000\", -\"O c #0000FFFF0000\", -\"+ c #000077770000\", -\"@ c #000044440000\", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" ..... ....... \", -\" .OOOO. \", -\" .O++++. \", -\" .O+.... ........ \", -\" .O+. \", -\" .O+. . \", -\" .O+. .. \", -\" .O+. .O. \", -\" .O+...O@. ....... \", -\" .O++OOO+@. \", -\" .O+++++++@. \", -\" .++++++@. ....... \", -\" ....O@. \", -\" .O. \", -\" .. ....... \", -\" . \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \"};") - (toolbar-make-button-list - (expand-file-name "eos-step-into.xbm" eos::toolbar-icon-directory))) - "A Step Into icon pair.") - -(defvar eos::toolbar-step-up-icon - (if (featurep 'xpm) - (toolbar-make-button-list - "/* XPM */ -static char * file[] = { -\"28 28 5 1\", -\" c #C8C8C8C8C8C8 s backgroundToolBarColor\", -\". c #000000000000\", -\"O c #0000FFFF0000\", -\"+ c #000077770000\", -\"@ c #000044440000\", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" . \", -\" .. ....... \", -\" .O. \", -\" ....O@. \", -\" .++++++@. ....... \", -\" .O+++++++@. \", -\" .O++OOO+@. \", -\" .O+...O@. ....... \", -\" .O+. .O. \", -\" .O+. .. \", -\" .O+. . \", -\" .O+. \", -\" .O+.... ........ \", -\" .O++++. \", -\" .OOOO. \", -\" ..... ....... \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \"};") - (toolbar-make-button-list - (expand-file-name "eos-step-up.xbm" eos::toolbar-icon-directory))) - "A Step up icon pair.") - -(defvar eos::toolbar-step-over-icon - (if (featurep 'xpm) - (toolbar-make-button-list - "/* XPM */ -static char * file[] = { -\"28 28 5 1\", -\" c #C8C8C8C8C8C8 s backgroundToolBarColor\", -\". c #000000000000\", -\"X c #0000FFFF0000\", -\"+ c #000077770000\", -\"@ c #000044440000\", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" ..... \", -\" .XXXX. ....... \", -\" .X++++. \", -\" .X+.... \", -\" .X+. ....... \", -\" .X+. . \", -\" .X+. .. \", -\" .X+. .X. ....... \", -\" .X+...X@. \", -\" .X++XXX+@. \", -\" .X+++++++@. ....... \", -\" .++++++@. \", -\" ....X@. \", -\" .X. ....... \", -\" .. \", -\" . \", -\" ....... \", -\" \", -\" \", -\" \", -\" \", -\" \"};") - (toolbar-make-button-list - (expand-file-name "eos-step-over.xbm" eos::toolbar-icon-directory))) - "A Step Over icon pair.") - -(defvar eos::toolbar-evaluate-icon - (if (featurep 'xpm) - (toolbar-make-button-list - "/* XPM */ -static char * file[] = { -\"28 28 2 1\", -\" c #C8C8C8C8C8C8 s backgroundToolBarColor\", -\". c #000000000000\", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" .... \", -\" .. .. ...... \", -\" .. .. ...... \", -\" .. .. \", -\" .. .. ...... \", -\" .. .. ...... \", -\" .... \", -\" .. \", -\" .. \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \"};") - (toolbar-make-button-list - (expand-file-name "eos-evaluate.xbm" eos::toolbar-icon-directory))) - "A Evaluate icon pair.") - -(defvar eos::toolbar-evaluate-star-icon - (if (featurep 'xpm) - (toolbar-make-button-list - "/* XPM */ -static char * file[] = { -\"28 28 2 1\", -\" c #C8C8C8C8C8C8 s backgroundToolBarColor\", -\"X c #000000000000\", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" XX XX \", -\" XXX \", -\" XXXXXXX \", -\" XXX XXXX \", -\" XX XX XX XX XXXXXX \", -\" XX XX XXXXXX \", -\" XX XX \", -\" XX XX XXXXXX \", -\" XX XX XXXXXX \", -\" XXXX \", -\" XX \", -\" XX \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \"};") - (toolbar-make-button-list - (expand-file-name "eos-evaluate-star.xbm" eos::toolbar-icon-directory))) - "A Evaluate Star icon pair.") - -(defvar eos::toolbar-fix-icon - (if (featurep 'xpm) - (toolbar-make-button-list - "/* XPM */ -static char * file[] = { -\"28 28 8 1\", -\" c #C8C8C8C8C8C8 s backgroundToolBarColor\", -\". c #7D7D7D7D7D7D\", -\"X c #000000000000\", -\"o c #FFFFFFFF0000\", -\"O c #FFFF99990000\", -\"+ c #FFFFCCCC3333\", -\"@ c #CCCC9999FFFF\", -\"# c #99996666CCCC\", -\" \", -\" \", -\" \", -\" \", -\" .XX. \", -\" XoOXX. \", -\" .Xo+OOXXX. \", -\" Xo++++OOOXXX \", -\" .Xo+++++++OOOX. \", -\" Xo++++++OOOXX. \", -\" .Xo++++OOXXX. \", -\" Xo++OOOXX. \", -\" .XoOOOXXXXXXXXXXXX \", -\" XoOXXX@@@@@@@@@@@X \", -\" XXX##############X \", -\" X@##############X \", -\" XXXXXXXXXXXXXXXXX \", -\" X@@@@X X@@@@X \", -\" X@###X X@###X \", -\" X@###X X@###X \", -\" X@###X X@###X \", -\" X@###X X@###X \", -\" XXXXXX XXXXXX \", -\" \", -\" \", -\" \", -\" \", -\" \"};") - (toolbar-make-button-list - (expand-file-name "eos-fix.xbm" eos::toolbar-icon-directory))) - "A Fix icon pair.") - -(defvar eos::toolbar-run2-icon - (if (featurep 'xpm) - (toolbar-make-button-list - "/* XPM */ -static char * file[] = { -\"28 28 5 1\", -\" c #C8C8C8C8C8C8 s backgroundToolBarColor\", -\". s FgColor c #000000000000\", -\"X c #0000FFFF0000\", -\"o c #000077770000\", -\"O c #000044440000\", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" . \", -\" .. \", -\" .X. \", -\" ............XX. \", -\" .XXXXXXXXXXXXoX. \", -\" .XoooooooooooooX. \", -\" .Xooooooooooooooo. \", -\" .XoooooooooooooO. \", -\" .oOOOOOOOOOOOoO. \", -\" ............OO. \", -\" .O. \", -\" .. \", -\" . \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \"};") - (toolbar-make-button-list - (expand-file-name "eos-run2.xbm" eos::toolbar-icon-directory))) - "A Run icon pair.") - -(defvar eos::toolbar-cont-icon - (if (featurep 'xpm) - (toolbar-make-button-list - "/* XPM */ -static char * file[] = { -\"28 28 6 1\", -\" c #C8C8C8C8C8C8 s backgroundToolBarColor\", -\". c #000000000000\", -\"O c #0000FFFF0000\", -\"+ c #000077770000\", -\"@ c #000044440000\", -\"o c #FFFF00000000\", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" ..... ....... \", -\" .OOOO. \", -\" .O++++. \", -\" .O+.... ........ \", -\" .O+. \", -\" .O+. . \", -\" .O+. .. \", -\" .O+. .O. \", -\" .O+...O@. .. \", -\" .O++OOO+@. .oo. \", -\" .O+++++++@. .oooo. \", -\" .++++++@. .oooo. \", -\" ....O@. .oo. \", -\" .O. .. \", -\" .. \", -\" . \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \"};") - (toolbar-make-button-list - (expand-file-name "eos-cont.xbm" eos::toolbar-icon-directory))) - "A Cont icon pair.") - - -(defvar eos::toolbar-up-icon - (if (featurep 'xpm) - (toolbar-make-button-list - "/* XPM */ -static char * file[] = { -\"28 28 8 1\", -\" c #C8C8C8C8C8C8 s backgroundToolBarColor\", -\". s FgColor c #000000000000\", -\"X c #CCCC9999FFFF\", -\"o c #99996666CCCC\", -\"O c #FFFFFFFF0000\", -\"+ c #FFFFCCCC3333\", -\"@ c #0000FFFF0000\", -\"# c #000077770000\", -\" \", -\" \", -\" \", -\" \", -\" . \", -\" ... \", -\" ........ ..... \", -\" .XXXXXX. ....... \", -\" .Xooooo. ... \", -\" .Xooooo. ... \", -\" .Xooooo. ... \", -\" .Xooooo. ... \", -\" .O+++++. ... \", -\" .O+++++. ... \", -\" .O+++++. \", -\" .O+++++. \", -\" .O+++++. \", -\" .@#####. \", -\" .@#####. \", -\" .@#####. \", -\" .@#####. \", -\" .@#####. \", -\" ........ \", -\" \", -\" \", -\" \", -\" \", -\" \"};") - (toolbar-make-button-list - (expand-file-name "eos-up.xbm" eos::toolbar-icon-directory))) - "A Up icon pair.") - -(defvar eos::toolbar-down-icon - (if (featurep 'xpm) - (toolbar-make-button-list - "/* XPM */ -static char * file[] = { -\"28 28 8 1\", -\" c #C8C8C8C8C8C8 s backgroundToolBarColor\", -\". s FgColor c #000000000000\", -\"X c #CCCC9999FFFF\", -\"o c #99996666CCCC\", -\"O c #FFFFFFFF0000\", -\"+ c #FFFFCCCC3333\", -\"@ c #0000FFFF0000\", -\"# c #000077770000\", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" ........ \", -\" .XXXXXX. \", -\" .Xooooo. \", -\" .Xooooo. \", -\" .Xooooo. \", -\" .Xooooo. \", -\" .O+++++. ... \", -\" .O+++++. ... \", -\" .O+++++. ... \", -\" .O+++++. ... \", -\" .O+++++. ... \", -\" .@#####. ... \", -\" .@#####. ....... \", -\" .@#####. ..... \", -\" .@#####. ... \", -\" .@#####. . \", -\" ........ \", -\" \", -\" \", -\" \", -\" \", -\" \"};") - (toolbar-make-button-list - (expand-file-name "eos-down.xbm" eos::toolbar-icon-directory))) - "A Down icon pair.") - -(defvar eos::toolbar-build-icon - (if (featurep 'xpm) - (toolbar-make-button-list - "/* XPM */ -static char * file[] = { -\"28 28 8 1\", -\" c #C8C8C8C8C8C8 s backgroundToolBarColor\", -\". c #000000000000\", -\"X c #CCCC9999FFFF\", -\"o c #99996666CCCC\", -\"O c #FFFFFFFF0000\", -\"+ c #FFFFCCCC3333\", -\"@ c #FFFF99990000\", -\"# c #FFFF66666666\", -\" \", -\" \", -\" \", -\" \", -\" ...... \", -\" .XXXX. \", -\" .Xooo. \", -\" .Xooo. \", -\" .Xooo. \", -\" .Xooo. \", -\" . .Xooo. \", -\" .O. .Xooo. \", -\" .O+@. .Xooo. \", -\" .O+++@. .Xooo. \", -\" .O+++++@..Xooo. \", -\" .O+++++++@.Xooo. \", -\" .O+++.............. \", -\" .O@@@@. . \", -\" ....... ###########. \", -\" . ###########. \", -\" . ###########. \", -\" .............. \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \"};") - (toolbar-make-button-list - (expand-file-name "eos-build.xbm" eos::toolbar-icon-directory))) - "A Build icon pair.") - -(defvar eos::toolbar-dismiss-icon - (if (featurep 'xpm) - (toolbar-make-button-list - "/* XPM */ -static char * file[] = { -\"28 28 5 1\", -\" c #C8C8C8C8C8C8 s backgroundToolBarColor\", -\"X c #4B4B4B4B4B4B\", -\". c #FFFFFFFFFFFF\", -\"o c #AFAFAFAFAFAF\", -\"O c #FFFF00000000\", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" X X \", -\" XX XX \", -\" XX XX \", -\" XX XX \", -\" XX XX \", -\" XX XX \", -\" XXXX \", -\" XX \", -\" XXXX \", -\" XX XX \", -\" XX XX \", -\" XX XX \", -\" XX XX \", -\" XX XX \", -\" X X \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \", -\" \"};") - (toolbar-make-button-list - (expand-file-name "eos-dismiss.xbm" eos::toolbar-icon-directory))) - "A Dismiss icon pair.") - -(defvar eos::toolbar-intro-icon - (if (featurep 'xpm) - (toolbar-make-button-list - "/* XPM */ -static char * info[] = { -\"28 28 2 1\", -\"X c Gray75 s backgroundToolBarColor\", -\"o c #000077770000\", -\"XXXXXXXXXXXXXXXXXXXXXXXXXXXX\", -\"XXXXXXXXXXXXXXXXXXXXXXXXXXXX\", -\"XXXXXXXXXXXXXXXXXXXXXXXXXXXX\", -\"XXXXXXXXXXXXXoXXXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXoooooooXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXXXoXXXXXXXXXXXXXX\", -\"XXXXXXXXXXXXXXXXXXXXXXXXXXXX\", -\"XXXXXXXXXXooooooXXXXXXXXXXXX\", -\"XXXXXXXXXoooooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXoooooooXXXXXXXXXXX\", -\"XXXXXXXXXoooooooooXXXXXXXXXX\", -\"XXXXXXXXXXXXXXXXXXXXXXXXXXXX\", -\"XXXXXXXXXXXXXXXXXXXXXXXXXXXX\", -\"XXXXXXXXXXXXXXXXXXXXXXXXXXXX\", -\"XXXXXXXXXXXXXXXXXXXXXXXXXXXX\"};") - (toolbar-make-button-list - (expand-file-name "eos-intro.xbm" eos::toolbar-icon-directory))) - "An intro icon pair.") - -(defvar eos::toolbar-introD-icon - (if (featurep 'xpm) - (toolbar-make-button-list - "/* XPM */ -static char * info[] = { -\"28 28 2 1\", -\"X c Gray75 s backgroundToolBarColor\", -\"o c #000077770000\", -\"XXXXXXXXXXXXXXXXXXXXXXXXXXXX\", -\"XXXXXXXXXXXXXXXXXXXXXXXXXXXX\", -\"XXXXXXXXXXXXXXXXXXXXXXXXXXXX\", -\"XXXXXXXXXXXXXoXXXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXoooooooXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXXXoXXXXXXXXXXXXXX\", -\"XXXXXXXXXXXXXXXXXXXXXXXXXXXX\", -\"XXXXXXXXXXooooooXXXXXXXXXXXX\", -\"XXXXXXXXXoooooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXoooXXXXXXoooooXXXXXXXXXXXX\", -\"XXoXXoXXXXXoooooXXXXXXXXXXXX\", -\"XXoXXoXXXXoooooooXXXXXXXXXXX\", -\"XXoXXoXXXoooooooooXXXXXXXXXX\", -\"XXoXXoXXXXXXXXXXXXXXXXXXXXXX\", -\"XXoXXoXXXXXXXXXXXXXXXXXXXXXX\", -\"XXoooXXXXXXXXXXXXXXXXXXXXXXX\", -\"XXXXXXXXXXXXXXXXXXXXXXXXXXXX\"};") - (toolbar-make-button-list - (expand-file-name "eos-introD.xbm" eos::toolbar-icon-directory))) - "An intro icon pair.") - -(defvar eos::toolbar-introDB-icon - (if (featurep 'xpm) - (toolbar-make-button-list - "/* XPM */ -static char * info[] = { -\"28 28 2 1\", -\"X c Gray75 s backgroundToolBarColor\", -\"o c #000077770000\", -\"XXXXXXXXXXXXXXXXXXXXXXXXXXXX\", -\"XXXXXXXXXXXXXXXXXXXXXXXXXXXX\", -\"XXXXXXXXXXXXXXXXXXXXXXXXXXXX\", -\"XXXXXXXXXXXXXoXXXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXoooooooXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXXXoXXXXXXXXXXXXXX\", -\"XXXXXXXXXXXXXXXXXXXXXXXXXXXX\", -\"XXXXXXXXXXooooooXXXXXXXXXXXX\", -\"XXXXXXXXXoooooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXoooXXXXXXoooooXXXXXXoooXXX\", -\"XXoXXoXXXXXoooooXXXXXXoXXoXX\", -\"XXoXXoXXXXoooooooXXXXXoXXoXX\", -\"XXoXXoXXXoooooooooXXXXoooXXX\", -\"XXoXXoXXXXXXXXXXXXXXXXoXXoXX\", -\"XXoXXoXXXXXXXXXXXXXXXXoXXoXX\", -\"XXoooXXXXXXXXXXXXXXXXXoooXXX\", -\"XXXXXXXXXXXXXXXXXXXXXXXXXXXX\"};") - (toolbar-make-button-list - (expand-file-name "eos-introDB.xbm" eos::toolbar-icon-directory))) - "An intro icon pair.") - -(defvar eos::toolbar-introB-icon - (if (featurep 'xpm) - (toolbar-make-button-list - "/* XPM */ -static char * info[] = { -\"28 28 2 1\", -\"X c Gray75 s backgroundToolBarColor\", -\"o c #000077770000\", -\"XXXXXXXXXXXXXXXXXXXXXXXXXXXX\", -\"XXXXXXXXXXXXXXXXXXXXXXXXXXXX\", -\"XXXXXXXXXXXXXXXXXXXXXXXXXXXX\", -\"XXXXXXXXXXXXXoXXXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXoooooooXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXXXoXXXXXXXXXXXXXX\", -\"XXXXXXXXXXXXXXXXXXXXXXXXXXXX\", -\"XXXXXXXXXXooooooXXXXXXXXXXXX\", -\"XXXXXXXXXoooooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXXXXXXX\", -\"XXXXXXXXXXXoooooXXXXXXoooXXX\", -\"XXXXXXXXXXXoooooXXXXXXoXXoXX\", -\"XXXXXXXXXXoooooooXXXXXoXXoXX\", -\"XXXXXXXXXoooooooooXXXXoooXXX\", -\"XXXXXXXXXXXXXXXXXXXXXXoXXoXX\", -\"XXXXXXXXXXXXXXXXXXXXXXoXXoXX\", -\"XXXXXXXXXXXXXXXXXXXXXXoooXXX\", -\"XXXXXXXXXXXXXXXXXXXXXXXXXXXX\"};") - (toolbar-make-button-list - (expand-file-name "eos-introB.xbm" eos::toolbar-icon-directory))) - "An intro icon pair.") - - -(defvar eos::debugger-toolbar - '( - [eos::toolbar-introD-icon - eos::sw-intro - t - "Show Introduction to Eos"] - [eos::toolbar-stop-at-icon - eos::stop-at - eos::current-debugger-clique-id - "stop at: Stop at selected position"] - [eos::toolbar-stop-in-icon - eos::stop-in - eos::current-debugger-clique-id - "stop in: Stop in function whose name is selected"] - [eos::toolbar-clear-at-icon - eos::clear-at - eos::current-debugger-clique-id - "clear at: Clear at selected position"] - [eos::toolbar-run-icon - eos::run - eos::current-debugger-clique-id - "run: Run current program"] - [eos::toolbar-evaluate-icon - eos::print - eos::current-debugger-clique-id - "print: Evaluate selected expression; shows in separate XEmacs frame"] - [eos::toolbar-evaluate-star-icon - eos::print* - eos::current-debugger-clique-id - "print *: Evaluate selected expression as a pointer; shows in separate XEmacs frame"] - [eos::toolbar-up-icon - eos::up - eos::current-debugger-clique-id - "up: move in stack towards \"cooler\" (less recently visited) frames"] - [eos::toolbar-down-icon - eos::down - eos::current-debugger-clique-id - "down: move in stack towards \"warmer\" (more recently visited) frames)"] - [eos::toolbar-cont-icon - eos::cont - eos::current-debugger-clique-id - "cont: Continue current program"] - [eos::toolbar-step-over-icon - eos::next - eos::current-debugger-clique-id - "next: Step over subprogram calls"] - [eos::toolbar-step-into-icon - eos::step - eos::current-debugger-clique-id - "step: Step into subprogram calls)"] - [eos::toolbar-step-up-icon - eos::step-up - eos::current-debugger-clique-id - "step up: Step up from subprogram calls)"] - [eos::toolbar-build-icon - eos::build - eos::current-debugger-clique-id - "make: Build target"] - [eos::toolbar-fix-icon - eos::fix - eos::current-debugger-clique-id - "fix: Fix file"] - [eos::toolbar-type-icon - eos::type - (or (and (eq eos::dbx-or-debugger 'debugger) - eos::current-debugger-clique-id) - (and (eq eos::dbx-or-debugger 'dbx) - (eos::dbx-process) - (eq (process-status (eos::dbx-process)) 'run))) - "Type a Dbx command"] - )) - -(defvar eos::debugger-sbrowser-toolbar - '( - [eos::toolbar-introDB-icon - eos::sw-intro - t - "Show Introduction to Eos"] - [eos::toolbar-stop-at-icon - eos::stop-at - eos::current-debugger-clique-id - "stop at: Stop at selected position"] - [eos::toolbar-stop-in-icon - eos::stop-in - eos::current-debugger-clique-id - "stop in: Stop in function whose name is selected"] - [eos::toolbar-clear-at-icon - eos::clear-at - eos::current-debugger-clique-id - "clear at: Clear at selected position"] - [eos::toolbar-run-icon - eos::run - eos::current-debugger-clique-id - "run: Run current program"] - [eos::toolbar-evaluate-icon - eos::print - eos::current-debugger-clique-id - "print: Evaluate selected expression; shows in separate XEmacs frame"] - [eos::toolbar-evaluate-star-icon - eos::print* - eos::current-debugger-clique-id - "print *: Evaluate selected expression as a pointer; shows in separate XEmacs frame"] - [eos::toolbar-up-icon - eos::up - eos::current-debugger-clique-id - "up: move in stack towards \"cooler\" (less recently visited) frames"] - [eos::toolbar-down-icon - eos::down - eos::current-debugger-clique-id - "down: move in stack towards \"warmer\" (more recently visited) frames)"] - [eos::toolbar-cont-icon - eos::cont - eos::current-debugger-clique-id - "cont: Continue current program"] - [eos::toolbar-step-over-icon - eos::next - eos::current-debugger-clique-id - "next: Step over subprogram calls"] - [eos::toolbar-step-into-icon - eos::step - eos::current-debugger-clique-id - "step: Step into subprogram calls)"] - [eos::toolbar-step-up-icon - eos::step-up - eos::current-debugger-clique-id - "step up: Step up from subprogram calls)"] - [eos::toolbar-build-icon - eos::build - eos::current-debugger-clique-id - "make: Build target"] - [eos::toolbar-fix-icon - eos::fix - eos::current-debugger-clique-id - "fix: Fix file"] - [eos::toolbar-type-icon - eos::type - (or (and (eq eos::dbx-or-debugger 'debugger) - eos::current-debugger-clique-id) - (and (eq eos::dbx-or-debugger 'dbx) - (eos::dbx-process) - (eq (process-status (eos::dbx-process)) 'run))) - "Type a Dbx command"] - )) - -(defvar eos::sbrowser-toolbar - '([eos::toolbar-introB-icon - eos::sw-intro - t - "Show Introduction to Eos"] - )) - -(defvar eos::print-toolbar - '( - [eos::toolbar-intro-icon - eos::sw-intro - t - "Show Introduction to Eos"] - [eos::toolbar-evaluate-icon - eos::print - eos::current-debugger-clique-id - "print: Evaluate selected expression; shows in separate XEmacs frame"] - [eos::toolbar-evaluate-star-icon - eos::print* - eos::current-debugger-clique-id - "print *: Evaluate selected expression as a pointer; shows in separate XEmacs frame"] - [eos::toolbar-cont-icon - eos::cont-and-dismiss - eos::current-debugger-clique-id - "cont & dismiss: Continue current program and dismiss this frame"] - [eos::toolbar-step-over-icon - eos::next-and-dismiss - eos::current-debugger-clique-id - "next & dismiss: Step over subprogram calls and dismiss this frame"] - [eos::toolbar-step-into-icon - eos::step-and-dismiss - eos::current-debugger-clique-id - "step & dismiss: Step into subprogram calls and dismiss this frame)"] - [eos::toolbar-dismiss-icon - eos::dismiss-print-frame - t - "dismiss (make invisible) this print frame"] - )) - -(defun eos::toolbar-position () - (let ((pos (default-toolbar-position))) - (cond ((eq pos 'top) top-toolbar) - ((eq pos 'bottom) bottom-toolbar) - ((eq pos 'left) left-toolbar) - ((eq pos 'right) right-toolbar) - (t top-toolbar)))) - -(provide 'eos-toolbar) - -;;; sun-eos-toolbar.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/eos/sun-eos.el --- a/lisp/eos/sun-eos.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,20 +0,0 @@ -;;; sun-eos.el --- Intereactively loads the XEmacs/SPARCworks interface - -;; Copyright (C) 1995 Sun Microsystems, Inc. - -;; Maintainer: Eduardo Pelegri-Llopart -;; Author: Eduardo Pelegri-Llopart - -;; Keywords: SPARCworks EOS Era on SPARCworks load - -;;; Commentary: - -;; If manual loading is desired... -;; Please send feedback to eduardo.pelegri-llopart@eng.sun.com - -;;; Code: - -(load "sun-eos-load.el") -(eos::start) - -;;; sun-eos-eos.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/etags.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/etags.el Mon Aug 13 10:08:34 2007 +0200 @@ -0,0 +1,1219 @@ +;;; etags.el --- etags facility for Emacs + +;; Copyright 1985, 1986, 1988, 1990 Free Software Foundation, Inc. + +;; Keywords: tools + +;; This file is part of XEmacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + +;;; Synched up with: Not synched with FSF. (This file is almost +;;; completely different from FSF's etags.el. It appears that an +;;; early version of this file (tags.el) was rewritten by two +;;; different people; we got one, FSF got the other. Various +;;; people have said that our version is better and faster. + + +;; TODO: +;; 1. place cursor in echo area while searching +;; 2. document! +;; 3. determine semantics of interactively setting the tags file for a buffer + +;; Comments with **** mean something is left to be done. + +;; Derived from the original lisp/tags.el. + +;; Ideas and code from the work of the following people: +;; Andy Norman , author of ange-tags.el +;; Ramana Rao +;; John Sturdy , author of tags-helper.el +;; Henry Kautz , author of tag-completion.el +;; Dan LaLiberte , author of local-tags.el +;; Tom Dietterich , author of quest.el +;; The author(s) of lisp/simple.el +;; Duke Briscoe +;; Lynn Slater , author of location.el +;; Shinichirou Sugou +;; an unidentified anonymous elisp hacker +;; Kyle Jones +;; added "Exact match, then inexact" code +;; added support for include directive. + +(require 'thing) + + +;; Auxiliary functions + +(defun tags-delete (item list) + "Delete the item from the list, testing with equal. Copies the list." + (delete item (copy-list list))) + +(defun tags-remove-duplicates (list) + "Delete equal duplicates from the list; copies the list." + (let (res) + (dolist (el list) + (unless (member el res) + (push el res))) + (nreverse res))) + + +;; Tag tables for a buffer + +(defgroup etags nil + "Etags facility for Emacs" + :prefix "tags-" + :group 'tools) + + +;;;###autoload +(defcustom tags-build-completion-table 'ask + "*If this variable is nil, then tags completion is disabled. +If this variable is t, then things which prompt for tags will do so with + completion across all known tags. +If this variable is the symbol `ask', then you will be asked whether each + tags table should be added to the completion list as it is read in. + (With the exception that for very small tags tables, you will not be asked, + since they can be parsed quickly.)" + :type '(radio (const :tag "Disabled" nil) + (const :tag "Complete All" t) + (const :tag "Ask" ask)) + :group 'etags) + +;;;###autoload +(defcustom tags-always-exact nil + "*If this variable is non-nil, then tags always looks for exact matches." + :type 'boolean + :group 'etags) + +;;;###autoload +(defcustom tag-table-alist nil + "*A list which determines which tags files are active for a buffer. +This is not really an association list, in that all elements are +checked. The CAR of each element of this list is a pattern against +which the buffer's file name is compared; if it matches, then the CDR +of the list should be the name of the tags table to use. If more than +one element of this list matches the buffer's file name, then all of +the associated tags tables will be used. Earlier ones will be +searched first. + +If the CAR of elements of this list are strings, then they are treated +as regular-expressions against which the file is compared (like the +auto-mode-alist). If they are not strings, then they are evaluated. +If they evaluate to non-nil, then the current buffer is considered to +match. + +If the CDR of the elements of this list are strings, then they are +assumed to name a TAGS file. If they name a directory, then the string +\"TAGS\" is appended to them to get the file name. If they are not +strings, then they are evaluated, and must return an appropriate string. + +For example: + (setq tag-table-alist + '((\"/usr/src/public/perl/\" . \"/usr/src/public/perl/perl-3.0/\") + (\"\\\\.el$\" . \"/usr/local/emacs/src/\") + (\"/jbw/gnu/\" . \"/usr15/degree/stud/jbw/gnu/\") + (\"\" . \"/usr/local/emacs/src/\") + )) + +This means that anything in the /usr/src/public/perl/ directory should use +the TAGS file /usr/src/public/perl/perl-3.0/TAGS; and file ending in .el should +use the TAGS file /usr/local/emacs/src/TAGS; and anything in or below the +directory /jbw/gnu/ should use the TAGS file /usr15/degree/stud/jbw/gnu/TAGS. +A file called something like \"/usr/jbw/foo.el\" would use both the TAGS files +/usr/local/emacs/src/TAGS and /usr15/degree/stud/jbw/gnu/TAGS (in that order) +because it matches both patterns. + +If the buffer-local variable `buffer-tag-table' is set, then it names a tags +table that is searched before all others when find-tag is executed from this +buffer. + +If there is a file called \"TAGS\" in the same directory as the file in +question, then that tags file will always be used as well (after the +`buffer-tag-table' but before the tables specified by this list.) + +If the variable tags-file-name is set, then the tags file it names will apply +to all buffers (for backwards compatibility.) It is searched first. +" + :type '(repeat (cons (choice :value "" + (regexp :tag "Buffer regexp") + (function :tag "Expression")) + (string :tag "Tag file or directory"))) + :group 'etags) + +(defvar buffer-tag-table nil + "*The additional name of one TAGS table to be used for this buffer. +You can set this with meta-x set-buffer-tag-table. See the documentation +for the variable `tag-table-alist' for more information.") +(make-variable-buffer-local 'buffer-tag-table) + +(defcustom tags-file-name nil + "*The name of the tags-table used by all buffers. +This is for backwards compatibility, and is largely supplanted by the +variable tag-table-alist." + :type '(choice (const nil) string) + :group 'etags) + + +;; XEmacs change: added tags-auto-read-changed-tag-files +(defcustom tags-auto-read-changed-tag-files nil + "*If non-nil, always re-read changed TAGS file without prompting, if nil +then prompt if changed TAGS file should be re-read." + :type 'boolean + :group 'etags) + +(defun buffer-tag-table-list () + "Returns a list (ordered) of the tags tables which should be used for +the current buffer." + (let (result expression) + (when buffer-tag-table + (push buffer-tag-table result)) + (when (file-readable-p (concat default-directory "TAGS")) + (push (concat default-directory "TAGS") result)) + (let ((key (or buffer-file-name + (concat default-directory (buffer-name)))) + (alist tag-table-alist)) + (while alist + (setq expression (car (car alist))) + ;; If the car of the alist item is a string, apply it as a regexp + ;; to the buffer-file-name. Otherwise, evaluate it. If the + ;; regexp matches, or the expression evaluates non-nil, then this + ;; item in tag-table-alist applies to this buffer. + (when (if (stringp expression) + (string-match expression key) + (condition-case nil + (eval expression) + (error nil))) + ;; Now evaluate the cdr of the alist item to get the name of + ;; the tag table file. + (setq expression + (condition-case nil + (eval (cdr (car alist))) + (error nil))) + (if (stringp expression) + (setq result (cons expression result)) + (error "Expression in tag-table-alist evaluated to non-string"))) + (pop alist))) + (or result tags-file-name + ;; **** I don't know if this is the right place to do this, + ;; **** Maybe it would be better to do this after (delq nil result). + (call-interactively 'visit-tags-table)) + (when tags-file-name + (setq result (nconc result (list tags-file-name)))) + (setq result + (mapcar + (lambda (name) + (if (file-directory-p name) + (setq name (concat (file-name-as-directory name) "TAGS"))) + (if (file-readable-p name) + (save-current-buffer + ;; get-tag-table-buffer has side-effects + (set-buffer (get-tag-table-buffer name)) + buffer-file-name))) + result)) + (setq result (delq nil result)) + (or result (error "Buffer has no associated tag tables")) + (tags-remove-duplicates (nreverse result)))) + +;;;###autoload +(defun visit-tags-table (file) + "Tell tags commands to use tags table file FILE first. +FILE should be the name of a file created with the `etags' program. +A directory name is ok too; it means file TAGS in that directory." + (interactive (list (read-file-name "Visit tags table: (default TAGS) " + default-directory + (expand-file-name "TAGS" default-directory) + t))) + (if (string-equal file "") + (setq tags-file-name nil) + (progn + (setq file (expand-file-name file)) + (if (file-directory-p file) + (setq file (expand-file-name "TAGS" file))) + (setq tags-file-name file)))) + +(defun set-buffer-tag-table (file) + "In addition to the tags tables specified by the variable `tag-table-alist', +each buffer can have one additional table. This command sets that. +See the documentation for the variable `tag-table-alist' for more information." + (interactive + (list + (read-file-name "Visit tags table: (directory sufficient) " + nil default-directory t))) + (or file (error "No TAGS file name supplied")) + (setq file (expand-file-name file)) + (when (file-directory-p file) + (setq file (concat file "TAGS"))) + (or (file-exists-p file) (error "TAGS file missing: %s" file)) + (setq buffer-tag-table file)) + + +;; Manipulating the tag table buffer + +(defconst tag-table-completion-status nil + "Indicates whether a completion table has been built, or has explicitly not +been built. this is nil, t, or 'disabled.") +(make-variable-buffer-local 'tag-table-completion-status) + +(defcustom make-tags-files-invisible nil + "*If non-nil, TAGS-files will not show up in buffer-lists or be +selectable (or deletable.)" + :type 'boolean + :group 'etags) + +(defconst tag-table-files nil + "If the current buffer is a TAGS table, this holds a list of the files +referenced by this file, or nil if that hasn't been computed yet.") +(make-variable-buffer-local 'tag-table-files) + +(defun get-tag-table-buffer (tag-table) + "Returns a buffer visiting the given TAGS table, reverting if appropriate, +and possibly building a completion-table." + (or (stringp tag-table) + (error "Bad tags file name supplied: %s" tag-table)) + ;; add support for removing symbolic links from name + (if (fboundp 'symlink-expand-file-name) + (setq tag-table (symlink-expand-file-name tag-table))) + (let (buf build-completion check-name) + (setq buf (get-file-buffer tag-table)) + (or buf + (if (file-readable-p tag-table) + (setq buf (find-file-noselect tag-table) + check-name t) + (error "No such tags file: %s" tag-table))) + (with-current-buffer buf + ;; make the TAGS buffer invisible + (when (and check-name + make-tags-files-invisible + (string-match "\\`[^ ]" (buffer-name))) + (rename-buffer (generate-new-buffer-name + (concat " " (buffer-name))))) + (or (verify-visited-file-modtime buf) + ;; XEmacs change: added tags-auto-read-changed-tag-files + (cond ((or tags-auto-read-changed-tag-files (yes-or-no-p + (format "Tags file %s has changed, read new contents? " + tag-table))) + (when tags-auto-read-changed-tag-files + (message "Tags file %s has changed, reading new contents..." + tag-table)) + (revert-buffer t t) + (if (eq tag-table-completion-status t) + (setq tag-table-completion-status nil)) + (setq tag-table-files nil)))) + (or (eq (char-after 1) ?\f) + (error "File %s not a valid tags file" tag-table)) + (or (memq tag-table-completion-status '(t disabled)) + (setq build-completion t)) + (and build-completion + (if (cond + ((eq tags-build-completion-table nil) + nil) + ((eq tags-build-completion-table t) + t) + ((eq tags-build-completion-table 'ask) + ;; don't bother asking for small ones + (or (< (buffer-size) 20000) + (y-or-n-p + (format "Build tag completion table for %s? " + tag-table)))) + (t (error + "tags-build-completion-table is not t, nil, or ask."))) + (condition-case nil + (progn + (add-to-tag-completion-table) + (setq tag-table-completion-status t)) + ;; Allow user to C-g out correctly + (quit + (setq tag-table-completion-status nil) + (setq quit-flag t) + (eval t))) + (setq tag-table-completion-status 'disabled)))) + buf)) + +(defun file-of-tag () + "Return the file name of the file whose tags point is within. +Assumes the tag table is the current buffer. +File name returned is relative to tag table file's directory." + (let ((opoint (point)) + prev size) + (save-excursion + (goto-char (point-min)) + (while (< (point) opoint) + (forward-line 1) + (end-of-line) + (skip-chars-backward "^,\n") + (setq prev (point) + size (read (current-buffer))) + (goto-char prev) + (forward-line 1) + ;; New include syntax + ;; filename,include + ;; tacked on to the end of a tag file means use filename + ;; as a tag file before giving up. + ;; Skip it here. + (if (not (eq size 'include)) + (forward-char size))) + (goto-char (1- prev)) + (buffer-substring (point) (point-at-bol))))) + +(defun tag-table-include-files () + "Return all file names associated with `include' directives in a tag buffer." + ;; New include syntax + ;; filename,include + ;; tacked on to the end of a tag file means use filename as a + ;; tag file before giving up. + (let ((files nil)) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "\f\n\\(.*\\),include$" nil t) + (setq files (cons (match-string 1) files)))) + files )) + +(defun tag-table-files (tag-table) + "Returns a list of the files referenced by the named TAGS table." + (with-current-buffer (get-tag-table-buffer tag-table) + (or tag-table-files + (let (files prev size) + (goto-char (point-min)) + (while (not (eobp)) + (forward-line 1) + (end-of-line) + (skip-chars-backward "^,\n") + (setq prev (point) + size (read (current-buffer))) + (goto-char prev) + (push (expand-file-name (buffer-substring (1- (point)) + (point-at-bol)) + default-directory) + files) + (forward-line 1) + (forward-char size)) + (setq tag-table-files (nreverse files)))) + tag-table-files)) + +;; **** should this be on previous page? +(defun buffer-tag-table-files () + "Returns a list of all files referenced by all TAGS tables that +this buffer uses." + (apply #'nconc + (mapcar #'tag-table-files (buffer-tag-table-list)))) + + +;; Building the completion table + +;; Test cases for building completion table; must handle these properly: +;; Lisp_Int, XSETINT, current_column 60,2282 +;; Lisp_Int, XSETINT, point>NumCharacters ? 0 : CharAt(363,9935 +;; Lisp_Int, XSETINT, point<=FirstCharacter ? 0 : CharAt(366,10108 +;; point<=FirstCharacter || CharAt(378,10630 +;; point>NumCharacters || CharAt(382,10825 +;; DEFUN ("x-set-foreground-color", Fx_set_foreground_color,191,4562 +;; DEFUN ("x-set-foreground-color", Fx_set_foreground_color,191,4562 +;; DEFUN ("*", Ftimes,1172,32079 +;; DEFUN ("/=", Fneq,1035,28839 +;; defun_internal 4199,101362 +;; int pure[PURESIZE / sizeof 53,1564 +;; char staticvec1[NSTATICS * sizeof 667,17608 +;; Date: 04 May 87 23:53:11 PDT 26,1077 +;; #define anymacroname(324,4344 +;; (define-key ctl-x-map 311,11784 +;; (define-abbrev-table 'c-mode-abbrev-table 24,1016 +;; static char *skip_white(116,3443 +;; static foo 348,11643 +;; (defun texinfo-insert-@code 91,3358 +;; (defvar texinfo-kindex)29,1105 +;; (defun texinfo-format-\. 548,18376 +;; (defvar sm::menu-kludge-y 621,22726 +;; (defvar *mouse-drag-window* 103,3642 +;; (defun simula-back-level(317,11263 +;; } DPxAC,380,14024 +;; } BM_QCB;69,2990 +;; #define MTOS_DONE\t + +;; "^[^ ]+ +\\([^ ]+\\) " + +;; void *find_cactus_segment(116,2444 +;; void *find_pdb_segment(162,3688 +;; void init_dclpool(410,10739 +;; WORD insert_draw_command(342,8881 +;; void *req_pdbmem(579,15574 + +(defvar tag-completion-table (make-vector 511 0)) + +(defvar tag-symbol) +(defvar tag-table-symbol) +(defvar tag-symbol-tables) +(defvar buffer-tag-table-list) + +(defmacro intern-tag-symbol (tag) + `(progn + (setq tag-symbol (intern ,tag tag-completion-table) + tag-symbol-tables (and (boundp tag-symbol) + (symbol-value tag-symbol))) + (or (memq tag-table-symbol tag-symbol-tables) + (set tag-symbol (cons tag-table-symbol tag-symbol-tables))))) + +;; Can't use "\\s " in these patterns because that will include newline +(defconst tags-DEFUN-pattern + "DEFUN[ \t]*(\"\\([^\"]+\\)\",[ \t]*\\(\\(\\sw\\|\\s_\\)+\\),\C-?") +(defconst tags-array-pattern ".*[ \t]+\\([^ \[]+\\)\\[") +(defconst tags-def-pattern + "\\(.*[ \t]+\\)?\\**\\(\\(\\sw\\|\\s_\\)+\\)[ ();,\t]*\C-?" +;; "\\(.*[ \t]+\\)?\\(\\(\\sw\\|\\s_\\)+\\)[ ()]*\C-?" +;; "\\(\\sw\\|\\s_\\)+[ ()]*\C-?" + ) +(defconst tags-file-pattern "^\f\n\\(.+\\),[0-9]+\n") + +(defun add-to-tag-completion-table () + "Sucks the current buffer (a TAGS table) into the completion-table." + (message "Adding %s to tags completion table..." + buffer-file-name) + (goto-char (point-min)) + (let ((tag-table-symbol (intern buffer-file-name tag-completion-table)) + ;; tag-table-symbol is used by intern-tag-symbol + filename file-type name name2 tag-symbol + tag-symbol-tables + (case-fold-search nil)) + ;; loop over the files mentioned in the TAGS file + ;; for each file, try to find its major-mode, + ;; then process tags appropriately + (while (looking-at tags-file-pattern) + (goto-char (match-end 0)) + (setq filename (file-name-sans-versions + (buffer-substring (match-beginning 1) + (match-end 1))) + ;; Old code used to check auto-mode-alist for the proper + ;; file-type. This is too slow, as it breaks the + ;; compiled-regexp caching, and slows the whole thing + ;; down. We'll use the shotgun approach with only two + ;; regexps. + file-type (cond ((string-match "\\.\\([cC]\\|cc\\|cxx\\)\\'" + filename) + 'c-mode) + ((string-match "\\.\\(el\\|cl\\|lisp\\)\\'" + filename) + 'lisp-mode) + ((string-match "\\.scm\\'" filename) + 'scheme-mode) + (t nil))) + (cond ((and (eq file-type 'c-mode) + c-mode-syntax-table) + (set-syntax-table c-mode-syntax-table)) + ((eq file-type 'lisp-mode) + (set-syntax-table lisp-mode-syntax-table)) + (t + (set-syntax-table (standard-syntax-table)))) + ;; clear loop variables + (setq name nil name2 nil) + (message "%s..." filename) + ;; loop over the individual tag lines + (while (not (or (eobp) (eq (following-char) ?\f))) + (cond ((and (eq file-type 'c-mode) + (looking-at "DEFUN[ \t]")) + (or (looking-at tags-DEFUN-pattern) + (error "DEFUN doesn't fit pattern")) + (setq name (buffer-substring (match-beginning 1) + (match-end 1)) + name2 (buffer-substring (match-beginning 2) + (match-end 2)))) +;;; ((looking-at "\\s ") +;;; ;; skip probably bogus entry: +;;; ) + ((and (eq file-type 'c-mode) + (looking-at ".*\\[")) + (cond ((not (looking-at tags-array-pattern)) + (message "array definition doesn't fit pattern") + (setq name nil)) + (t + (setq name (buffer-substring (match-beginning 1) + (match-end 1)))))) + ((and (eq file-type 'scheme-mode) + (looking-at "\\s-*(\\s-*def\\sw*\\s-*(?\\s-*\\(\\(\\sw\\|\\s_\\|:\\)+\\))?\\s-*\C-?")) + (setq name (buffer-substring (match-beginning 1) + (match-end 1)))) + ((looking-at tags-def-pattern) + (setq name (buffer-substring (match-beginning 2) + (match-end 2))))) + ;; add the tags we found to the completion table + (and name (intern-tag-symbol name)) + (and name2 (intern-tag-symbol name2)) + (forward-line 1))) + (or (eobp) (error "Bad TAGS file"))) + (message "Adding %s to tags completion table...done" + buffer-file-name)) + + +;; Interactive find-tag + +(defvar find-tag-default-hook nil + "Function to call to create a default tag. +Make it buffer-local in a mode hook. The function is called with no + arguments.") + +(defvar find-tag-hook nil + "Function to call after a hook is found. +Make it buffer-local in a mode hook. The function is called with no + argsuments.") + +;; Return a default tag to search for, based on the text at point. +(defun find-tag-default () + (or (and (not (memq find-tag-default-hook '(nil find-tag-default))) + (condition-case data + (funcall find-tag-default-hook) + (error + (warn "Error in find-tag-default-hook signalled error: %s" + (error-message-string data)) + nil))) + (let ((pair (thing-symbol (point)))) + (and pair + (buffer-substring (car pair) (cdr pair)))))) + +;; This function depends on the following symbols being bound properly: +;; buffer-tag-table-list, +;; tag-symbol-tables (value irrelevant, bound outside for efficiency) +(defun tag-completion-predicate (tag-symbol) + (and (boundp tag-symbol) + (setq tag-symbol-tables (symbol-value tag-symbol)) + (catch 'found + (while tag-symbol-tables + (when (memq (car tag-symbol-tables) buffer-tag-table-list) + (throw 'found t)) + (setq tag-symbol-tables (cdr tag-symbol-tables)))))) + +(defun buffer-tag-table-symbol-list () + (mapcar (lambda (table-name) + (intern table-name tag-completion-table)) + (buffer-tag-table-list))) + +(defvar find-tag-history nil "History list for find-tag-tag") + +(defun find-tag-tag (prompt) + (let* ((default (find-tag-default)) + (buffer-tag-table-list (buffer-tag-table-symbol-list)) + tag-symbol-tables tag-name) + (setq tag-name + (completing-read + (if default + (format "%s(default %s) " prompt default) + prompt) + tag-completion-table 'tag-completion-predicate nil nil + 'find-tag-history)) + (if (string-equal tag-name "") + ;; #### - This is a really LAME way of doing it! --Stig + default ;indicate exact symbol match + tag-name))) + +(defvar last-tag-data nil + "Information for continuing a tag search. +Is of the form (TAG POINT MATCHING-EXACT TAG-TABLE TAG-TABLE ...).") + +(defvar tags-loop-operate nil + "Form for `tags-loop-continue' to eval to change one file.") + +(defvar tags-loop-scan + '(error "%s" (substitute-command-keys + "No \\[tags-search] or \\[tags-query-replace] in progress.")) + "Form for `tags-loop-continue' to eval to scan one file. +If it returns non-nil, this file needs processing by evalling +\`tags-loop-operate'. Otherwise, move on to the next file.") + +(autoload 'get-symbol-syntax-table "symbol-syntax") + +(defun find-tag-internal (tagname) + (let ((next (null tagname)) + (tmpnext (null tagname)) + ;; If tagname is a list: (TAGNAME), this indicates + ;; requiring an exact symbol match. + (exact (or tags-always-exact (consp tagname))) + (normal-syntax-table (syntax-table)) + (exact-syntax-table (get-symbol-syntax-table (syntax-table))) + tag-table-currently-matching-exact + tag-target exact-tagname + tag-tables tag-table-point file linebeg startpos buf + offset found pat syn-tab) + (if (consp tagname) (setq tagname (car tagname))) + (cond (next + (setq tagname (car last-tag-data)) + (setq tag-table-currently-matching-exact + (car (cdr (cdr last-tag-data))))) + (t + (setq tag-table-currently-matching-exact t))) + ;; \_ in the tagname is used to indicate a symbol boundary. + (setq exact-tagname (concat "\\_" tagname "\\_")) + (while (string-match "\\\\_" exact-tagname) + (aset exact-tagname (1- (match-end 0)) ?b)) + (save-excursion + (catch 'found + ;; loop searching for exact matches and then inexact matches. + (while (not (eq tag-table-currently-matching-exact 'neither)) + (cond (tmpnext + (setq tag-tables (cdr (cdr (cdr last-tag-data)))) + (setq tag-table-point (car (cdr last-tag-data))) + ;; start from the beginning of the table list + ;; on the next iteration of the loop. + (setq tmpnext nil)) + (t + (setq tag-tables (buffer-tag-table-list)) + (setq tag-table-point 1))) + (if tag-table-currently-matching-exact + (progn + (setq tag-target exact-tagname) + (setq syn-tab exact-syntax-table)) + (setq tag-target tagname) + (setq syn-tab normal-syntax-table)) + (with-caps-disable-folding tag-target + (while tag-tables + (set-buffer (get-tag-table-buffer (car tag-tables))) + (bury-buffer (current-buffer)) + (goto-char (or tag-table-point (point-min))) + (setq tag-table-point nil) + (let ((osyn (syntax-table)) + case-fold-search) + (unwind-protect + (progn + (set-syntax-table syn-tab) + ;; **** should there be support for non-regexp + ;; tag searches? + (while (re-search-forward tag-target nil t) + (if (and (save-match-data + (looking-at "[^\n\C-?]*\C-?")) + ;; if we're looking for inexact + ;; matches, skip exact matches + ;; since we've visited them + ;; already. + (or tag-table-currently-matching-exact + (unwind-protect + (save-excursion + (set-syntax-table + exact-syntax-table) + (goto-char (match-beginning 0)) + (not (looking-at exact-tagname))) + (set-syntax-table syn-tab)))) + (throw 'found t)))) + (set-syntax-table osyn))) + (setq tag-tables + (nconc (tag-table-include-files) (cdr tag-tables))))) + (if (and (not exact) (eq tag-table-currently-matching-exact t)) + (setq tag-table-currently-matching-exact nil) + (setq tag-table-currently-matching-exact 'neither))) + (error "No %sentries %s %s" + (if next "more " "") + (if exact "matching" "containing") + tagname)) + (search-forward "\C-?") + (setq file (expand-file-name (file-of-tag) + ;; XEmacs change: this needs to be + ;; relative to the + (or (file-name-directory (car tag-tables)) + "./"))) + (setq linebeg (buffer-substring (1- (point)) (point-at-bol))) + (search-forward ",") + (setq startpos (read (current-buffer))) + (setq last-tag-data + (nconc (list tagname (point) tag-table-currently-matching-exact) + tag-tables)) + (setq buf (find-file-noselect file)) + (with-current-buffer buf + (save-excursion + (save-restriction + (widen) + (setq offset 1000) + (setq pat (concat "^" (regexp-quote linebeg))) + (or startpos (setq startpos (point-min))) + (while (and (not found) + (progn + (goto-char (- startpos offset)) + (not (bobp)))) + (setq found (re-search-forward pat (+ startpos offset) t)) + (setq offset (* 3 offset))) + (or found + (re-search-forward pat nil t) + (error "%s not found in %s" pat file)) + (beginning-of-line) + (setq startpos (point))))) + (cons buf startpos)))) + +;;;###autoload +(defun find-tag (tagname &optional other-window) + "*Find tag whose name contains TAGNAME. + Selects the buffer that the tag is contained in +and puts point at its definition. + If TAGNAME is a null string, the expression in the buffer +around or before point is used as the tag name. + If called interactively with a numeric argument, searches for the next tag +in the tag table that matches the tagname used in the previous find-tag. + If second arg OTHER-WINDOW is non-nil, uses another window to display +the tag. + +This version of this function supports multiple active tags tables, +and completion. + +Variables of note: + + tag-table-alist controls which tables apply to which buffers + tags-file-name a default tags table + tags-build-completion-table controls completion behavior + buffer-tag-table another way of specifying a buffer-local table + make-tags-files-invisible whether tags tables should be very hidden + tag-mark-stack-max how many tags-based hops to remember" + (interactive (if current-prefix-arg + '(nil nil) + (list (find-tag-tag "Find tag: ") nil))) + (let* ((local-find-tag-hook find-tag-hook) + (next (null tagname)) + (result (find-tag-internal tagname)) + (tag-buf (car result)) + (tag-point (cdr result))) + ;; push old position + (if (or (not next) + (not (memq last-command + '(find-tag find-tag-other-window tags-loop-continue)))) + (push-tag-mark)) + (if other-window + (pop-to-buffer tag-buf) + (switch-to-buffer tag-buf)) + (widen) + (push-mark) + (goto-char tag-point) + (if find-tag-hook + (funcall find-tag-hook) + (if local-find-tag-hook + (funcall local-find-tag-hook)))) + (setq tags-loop-scan (list 'find-tag nil nil) + tags-loop-operate nil) + ;; Return t in case used as the tags-loop-scan. + t) + +;; This function is unchanged from lisp/tags.el: +;;;###autoload +(defun find-tag-other-window (tagname &optional next) + "*Find tag whose name contains TAGNAME. + Selects the buffer that the tag is contained in in another window +and puts point at its definition. + If TAGNAME is a null string, the expression in the buffer +around or before point is used as the tag name. + If second arg NEXT is non-nil (interactively, with prefix arg), +searches for the next tag in the tag table +that matches the tagname used in the previous find-tag. + +This version of this function supports multiple active tags tables, +and completion. + +Variables of note: + + tag-table-alist controls which tables apply to which buffers + tags-file-name a default tags table + tags-build-completion-table controls completion behavior + buffer-tag-table another way of specifying a buffer-local table + make-tags-files-invisible whether tags tables should be very hidden + tag-mark-stack-max how many tags-based hops to remember" + (interactive (if current-prefix-arg + '(nil t) + (list (find-tag-tag "Find tag other window: ")))) + (if next + (find-tag nil t) + (find-tag tagname t))) + + +;; Completion on tags in the buffer + +(defun complete-symbol (&optional table predicate prettify) + (let* ((end (point)) + (beg (save-excursion + (backward-sexp 1) + (while (= (char-syntax (following-char)) ?\') + (forward-char 1)) + (point))) + (pattern (buffer-substring beg end)) + (table (or table obarray)) + (completion (try-completion pattern table predicate))) + (cond ((eq completion t)) + ((null completion) + (message "Can't find completion for \"%s\"" pattern) + (ding)) + ((not (string-equal pattern completion)) + (delete-region beg end) + (insert completion)) + (t + (message "Making completion list...") + (let ((list (all-completions pattern table predicate))) + (if prettify + (setq list (funcall prettify list))) + (with-output-to-temp-buffer "*Help*" + (display-completion-list list))) + (message "Making completion list...%s" "done"))))) + +(defun tag-complete-symbol () + "The function used to do tags-completion (using 'tag-completion-predicate)." + (interactive) + (let* ((buffer-tag-table-list (buffer-tag-table-symbol-list)) + tag-symbol-tables) + (complete-symbol tag-completion-table 'tag-completion-predicate))) + + +;; Applying a command to files mentioned in tag tables + +(defvar next-file-list nil + "List of files for next-file to process.") + +;;;###autoload +(defun next-file (&optional initialize novisit) + "Select next file among files in current tag table(s). + +A first argument of t (prefix arg, if interactive) initializes to the +beginning of the list of files in the (first) tags table. If the argument +is neither nil nor t, it is evalled to initialize the list of files. + +Non-nil second argument NOVISIT means use a temporary buffer +to save time and avoid uninteresting warnings. + +Value is nil if the file was already visited; +if the file was newly read in, the value is the filename." + (interactive "P") + (cond ((not initialize) + ;; Not the first run. + ) + ((eq initialize t) + ;; Initialize the list from the tags table. + (setq next-file-list (buffer-tag-table-files))) + (t + ;; Initialize the list by evalling the argument. + (setq next-file-list (eval initialize)))) + (if (null next-file-list) + (progn + (and novisit + (get-buffer " *next-file*") + (kill-buffer " *next-file*")) + (error "All files processed."))) + (let* ((file (car next-file-list)) + (buf (get-file-buffer file)) + (new (not buf))) + (setq next-file-list (cdr next-file-list)) + + (if (not (and new novisit)) + (switch-to-buffer (find-file-noselect file novisit) t) + ;; Like find-file, but avoids random warning messages. + (set-buffer (get-buffer-create " *next-file*")) + (kill-all-local-variables) + (erase-buffer) + (insert-file-contents file nil)) + (widen) + (cond ((> (point) (point-min)) + (push-mark nil t) + (goto-char (point-min)))) + (and new file))) + +(defcustom tags-search-nuke-uninteresting-buffers t + "*If t (the default), tags-search and tags-query-replace will only +keep newly-visited buffers if they contain the search target." + :type 'boolean + :group 'etags) + +;;;###autoload +(defun tags-loop-continue (&optional first-time) + "Continue last \\[tags-search] or \\[tags-query-replace] command. +Used noninteractively with non-nil argument to begin such a command (the +argument is passed to `next-file', which see). +Two variables control the processing we do on each file: +the value of `tags-loop-scan' is a form to be executed on each file +to see if it is interesting (it returns non-nil if so) +and `tags-loop-operate' is a form to execute to operate on an interesting file +If the latter returns non-nil, we exit; otherwise we scan the next file." + (interactive) + (let (new + (messaged nil)) + (while + (progn + ;; Scan files quickly for the first or next interesting one. + (while (or first-time + (save-restriction + (widen) + (not (eval tags-loop-scan)))) + (setq new (next-file first-time + tags-search-nuke-uninteresting-buffers)) + ;; If NEW is non-nil, we got a temp buffer, + ;; and NEW is the file name. + (if (or messaged + (and (not first-time) + (> (device-baud-rate) search-slow-speed) + (setq messaged t))) + (message "Scanning file %s..." (or new buffer-file-name))) + (setq first-time nil) + (goto-char (point-min))) + + ;; If we visited it in a temp buffer, visit it now for real. + (if (and new tags-search-nuke-uninteresting-buffers) + (let ((pos (point))) + (erase-buffer) + (set-buffer (find-file-noselect new)) + (widen) + (goto-char pos))) + + (switch-to-buffer (current-buffer)) + + ;; Now operate on the file. + ;; If value is non-nil, continue to scan the next file. + (eval tags-loop-operate))) + (and messaged + (null tags-loop-operate) + (message "Scanning file %s...found" buffer-file-name)))) + + +;;;###autoload +(defun tags-search (regexp &optional file-list-form) + "Search through all files listed in tags table for match for REGEXP. +Stops when a match is found. +To continue searching for next match, use command \\[tags-loop-continue]. + +See documentation of variable `tag-table-alist'." + (interactive "sTags search (regexp): ") + (if (and (equal regexp "") + (eq (car tags-loop-scan) 'with-caps-disable-folding) + (null tags-loop-operate)) + ;; Continue last tags-search as if by M-,. + (tags-loop-continue nil) + (setq tags-loop-scan `(with-caps-disable-folding ,regexp + (re-search-forward ,regexp nil t)) + tags-loop-operate nil) + (tags-loop-continue (or file-list-form t)))) + +;;;###autoload +(defun tags-query-replace (from to &optional delimited file-list-form) + "Query-replace-regexp FROM with TO through all files listed in tags table. +Third arg DELIMITED (prefix arg) means replace only word-delimited matches. +If you exit (\\[keyboard-quit] or ESC), you can resume the query-replace +with the command \\[tags-loop-continue]. + +See documentation of variable `tag-table-alist'." + (interactive + "sTags query replace (regexp): \nsTags query replace %s by: \nP") + (setq tags-loop-scan `(with-caps-disable-folding ,from + (if (re-search-forward ,from nil t) + ;; When we find a match, move back + ;; to the beginning of it so perform-replace + ;; will see it. + (progn (goto-char (match-beginning 0)) t))) + tags-loop-operate (list 'perform-replace from to t t + (not (null delimited)))) + (tags-loop-continue (or file-list-form t))) + +;; Miscellaneous + +;; **** need to alter +;; This function is unchanged from lisp/tags.el: +;;;###autoload +(defun list-tags (string) + "Display list of tags in file FILE. +FILE should not contain a directory spec +unless it has one in the tag table." + (interactive "fList tags (in file): ") + (setq string (expand-file-name string)) + (with-output-to-temp-buffer "*Tags List*" + (princ "Tags in file ") + (princ string) + (terpri) + (save-excursion + (visit-tags-table-buffer) + (goto-char 1) + (search-forward (concat "\f\n" string ",")) + (forward-line 1) + (while (not (or (eobp) (looking-at "\f"))) + (princ (buffer-substring (point) + (progn (skip-chars-forward "^\C-?") + (point)))) + (terpri) + (forward-line 1))))) + +;; **** need to alter +;; This function is unchanged from lisp/tags.el: +;;;###autoload +(defun tags-apropos (string) + "Display list of all tags in tag table REGEXP matches." + (interactive "sTag apropos (regexp): ") + (with-output-to-temp-buffer "*Tags List*" + (princ "Tags matching regexp ") + (prin1 string) + (terpri) + (save-excursion + (visit-tags-table-buffer) + (goto-char 1) + (while (re-search-forward string nil t) + (beginning-of-line) + (princ (buffer-substring (point) + (progn (skip-chars-forward "^\C-?") + (point)))) + (terpri) + (forward-line 1))))) + +;; **** copied from tags.el +(defun visit-tags-table-buffer () + "Select the buffer containing the current tag table. +This is a file whose name is in the variable tags-file-name." + (or tags-file-name + (call-interactively 'visit-tags-table)) + (set-buffer (or (get-file-buffer tags-file-name) + (progn + (setq tag-table-files nil) + (find-file-noselect tags-file-name)))) + (or (verify-visited-file-modtime (get-file-buffer tags-file-name)) + (cond ((yes-or-no-p "Tags file has changed, read new contents? ") + (revert-buffer t t) + (setq tag-table-files nil)))) + (or (eq (char-after 1) ?\^L) + (error "File %s not a valid tag table" tags-file-name))) + + +;; Sample uses of find-tag-hook and find-tag-default-hook + +;; Example buffer-local tag finding + +(or (boundp 'emacs-lisp-mode-hook) + (setq emacs-lisp-mode-hook nil)) +(if (eq (car-safe emacs-lisp-mode-hook) 'lambda) + (setq emacs-lisp-mode-hook (list emacs-lisp-mode-hook))) +(or (memq 'setup-emacs-lisp-default-tag-hook emacs-lisp-mode-hook) + (setq emacs-lisp-mode-hook + (cons 'setup-emacs-lisp-default-tag-hook emacs-lisp-mode-hook))) + +(defun setup-emacs-lisp-default-tag-hook () + (cond ((eq major-mode 'emacs-lisp-mode) + (make-variable-buffer-local 'find-tag-default-hook) + (setq find-tag-default-hook 'emacs-lisp-default-tag)))) +;; Run it once immediately +(setup-emacs-lisp-default-tag-hook) +(when (get-buffer "*scratch*") + (with-current-buffer "*scratch*" + (setup-emacs-lisp-default-tag-hook))) + +(defun emacs-lisp-default-tag () + "Function to return a default tag for Emacs-Lisp mode." + (let ((tag (or (variable-at-point) + (function-at-point)))) + (if tag (symbol-name tag)))) + + +;; Display short info on tag in minibuffer + +(if (null (lookup-key esc-map "?")) + (define-key esc-map "?" 'display-tag-info)) + +(defun display-tag-info (tagname) + "Prints a description of the first tag matching TAGNAME in the echo area. +If this is an elisp function, prints something like \"(defun foo (x y z)\". +That is, is prints the first line of the definition of the form. +If this is a C-defined elisp function, it does something more clever." + (interactive (if current-prefix-arg + '(nil) + (list (find-tag-tag "Display tag info: ")))) + (let* ((results (find-tag-internal tagname)) + (tag-buf (car results)) + (tag-point (cdr results)) + info lname min max fname args) + (with-current-buffer tag-buf + (save-excursion + (save-restriction + (widen) + (goto-char tag-point) + (cond ((let ((case-fold-search nil)) + (looking-at "^DEFUN[ \t]")) + (forward-sexp 1) + (down-list 1) + (setq lname (read (current-buffer)) + fname (buffer-substring + (progn (forward-sexp 1) (point)) + (progn (backward-sexp 1) (point))) + min (buffer-substring + (progn (forward-sexp 3) (point)) + (progn (backward-sexp 1) (point))) + max (buffer-substring + (progn (forward-sexp 2) (point)) + (progn (backward-sexp 1) (point)))) + (backward-up-list 1) + (setq args (buffer-substring + (progn (forward-sexp 2) (point)) + (progn (backward-sexp 1) (point)))) + (setq info (format "Elisp: %s, C: %s %s, #args: %s" + lname + fname args + (if (string-equal min max) + min + (format "from %s to %s" min max))))) + (t + (setq info + (buffer-substring + (progn (beginning-of-line) (point)) + (progn (end-of-line) (point))))))))) + (message "%s" info)) + (setq tags-loop-scan '(display-tag-info nil) + tags-loop-operate nil) + ;; Always return non-nil + t) + + +;; Keep track of old locations before finding tags + +(defvar tag-mark-stack1 nil) +(defvar tag-mark-stack2 nil) +(defcustom tag-mark-stack-max 16 + "*The maximum number of elements kept on the mark-stack used +by tags-search. See also the commands push-tag-mark (\\[push-tag-mark]) +and pop-tag-mark. (\\[pop-tag-mark])." + :type 'integer + :group 'etags) + +(defun push-mark-on-stack (stack-symbol &optional max-size) + (let ((stack (symbol-value stack-symbol))) + (push (point-marker) stack) + (cond ((and max-size + (> (length stack) max-size)) + (set-marker (car (nthcdr max-size stack)) nil) + (setcdr (nthcdr (1- max-size) stack) nil))) + (set stack-symbol stack))) + +(defun pop-mark-from-stack (stack-symbol1 stack-symbol2 &optional max-size) + (let* ((stack (or (symbol-value stack-symbol1) + (error "No more tag marks on stack"))) + (marker (car stack)) + (m-buf (marker-buffer marker))) + (set stack-symbol1 (cdr stack)) + (or m-buf + (error "Marker has no buffer")) + (if (null (buffer-name m-buf)) + (error "Buffer has been killed")) + (push-mark-on-stack stack-symbol2 max-size) + (switch-to-buffer m-buf) + (widen) + (goto-char (marker-position marker)))) + +(defun push-tag-mark () + (push-mark-on-stack 'tag-mark-stack1 tag-mark-stack-max)) + +(if (memq (lookup-key esc-map "*") '(nil undefined)) + (define-key esc-map "*" 'pop-tag-mark)) + +(defun pop-tag-mark (arg) + "find-tag maintains a mark-stack seperate from the \\[set-mark-command] mark-stack. +This function pops (and moves to) the tag at the top of this stack." + (interactive "P") + (if (not arg) + (pop-mark-from-stack + 'tag-mark-stack1 'tag-mark-stack2 tag-mark-stack-max) + (pop-mark-from-stack + 'tag-mark-stack2 'tag-mark-stack1 tag-mark-stack-max))) + + +(provide 'etags) +(provide 'tags) diff -r 43306a74e31c -r d44af0c54775 lisp/faces.el --- a/lisp/faces.el Mon Aug 13 10:07:42 2007 +0200 +++ b/lisp/faces.el Mon Aug 13 10:08:34 2007 +0200 @@ -1671,8 +1671,6 @@ ;; on having already resourced the global face specs, which happens ;; when the first X device is created. -(set-face-background-pixmap 'modeline [nothing]) - (when (featurep 'tty) (set-face-highlight-p 'bold t 'global 'tty) (set-face-underline-p 'italic t 'global 'tty) diff -r 43306a74e31c -r d44af0c54775 lisp/finder.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/finder.el Mon Aug 13 10:08:34 2007 +0200 @@ -0,0 +1,401 @@ +;;; finder.el --- topic & keyword-based code finder + +;; Copyright (C) 1992 Free Software Foundation, Inc. + +;; Author: Eric S. Raymond +;; Created: 16 Jun 1992 +;; Version: 1.0 +;; Keywords: help +;; X-Modified-by: Bob Weiner , 4/18/95, to include Lisp +;; library directory names in finder-program-info, for fast display of +;; Lisp libraries and associated commentaries. Added {v}, finder-view, +;; and {e}, finder-edit commands for displaying libraries. +;; +;; Added user variable, 'finder-abbreviate-directory-list', used to +;; abbreviate directories before they are saved to finder-program-info. +;; Such relative directories can be portable from one Emacs installation +;; to another. Default value is based upon the value of Emacs' +;; data-directory variable. + +;; This file is part of XEmacs. + +;; XEmacs 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. + +;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: FSF 19.34. + +;;; Commentary: + +;; This mode uses the Keywords library header to provide code-finding +;; services by keyword. +;; +;; Things to do: +;; 1. Support multiple keywords per search. This could be extremely hairy; +;; there doesn't seem to be any way to get completing-read to exit on +;; an EOL with no substring pending, which is what we'd want to end the loop. +;; 2. Search by string in synopsis line? +;; 3. Function to check finder-package-info for unknown keywords. + +;;; Code: + +(require 'lisp-mnt) +(condition-case nil + (require 'finder-inf) + (t nil)) +;; XEmacs addition +(require 'picture) +(require 'mode-motion) + +(defvar finder-emacs-root-directory + (file-name-directory (directory-file-name data-directory)) + "Root directory of current emacs tree.") + +(defvar finder-abbreviate-directory-list + (list finder-emacs-root-directory) + "*List of directory roots to remove from finder-package-info directory entries. +The first element in the list is used when expanding relative package +directories to view or extract information from package source code.") + +(defvar finder-file-regexp "\\.el$" + "Regexp which matches file names but not Emacs Lisp finder keywords.") + +;; Local variable in finder buffer. +(defvar finder-headmark) + +(defvar finder-known-keywords + `( + (abbrev . "abbreviation handling, typing shortcuts, macros") + (bib . "code related to the `bib' bibliography processor") + (c . "C, C++, and Objective-C language support") + (calendar . "calendar and time management support") + (comm . "communications, networking, remote access to files") + (data . "support for editing files of data") + (docs . "support for Emacs documentation") + (dumped . "files preloaded into Emacs") + (emulations . "emulations of other editors") + (extensions . "Emacs Lisp language extensions") + (faces . "support for multiple fonts") + (frames . "support for Emacs frames and window systems") + (games . "games, jokes and amusements") + (hardware . "support for interfacing with exotic hardware") + (help . "support for on-line help systems") + (hypermedia . "support for links between text or other media types") + (i18n . "internationalization and alternate character-set support") + (internal . "code for Emacs internals, build process, defaults") + (languages . "specialized modes for editing programming languages") + (lisp . "Lisp support, including Emacs Lisp") + (local . "code local to your site") + (maint . "maintenance aids for the Emacs development group") + (mail . "modes for electronic-mail handling") + (matching . "various sorts of searching and matching") + (mouse . "mouse support") + ,(when (featurep 'mule) + (cons 'mule "multi-language extensions")) + (news . "support for netnews reading and posting") + (oop . "support for object-oriented programming") + (outlines . "support for hierarchical outlining") + (processes . "process, subshell, compilation, and job control support") + (terminals . "support for terminal types") + (tex . "code related to the TeX formatter") + (tools . "programming tools") + (unix . "front-ends/assistants for, or emulators of, UNIX features") + (vms . "support code for vms") + (wp . "word processing") + )) + +(defvar finder-mode-map nil) +(or finder-mode-map + (let ((map (make-sparse-keymap))) + (define-key map " " 'finder-select) + (define-key map "f" 'finder-select) + (define-key map "\C-m" 'finder-select) + ;; XEmacs changes + (define-key map "e" 'finder-edit) + (define-key map "v" 'finder-view) + (define-key map "?" 'finder-summary) + (define-key map "q" 'finder-exit) + (define-key map "d" 'finder-list-keywords) + ;; XEmacs change + (define-key map [button2] 'finder-mouse-select) + (setq finder-mode-map map))) + + +;;; Code for regenerating the keyword list. + +(defvar finder-package-info nil + "Assoc list mapping file names to description & keyword lists.") + +(defvar finder-compile-keywords-quiet nil + "If non-nil finder-compile-keywords will not print any messages.") + +(defun finder-compile-keywords (&rest dirs) + "Regenerate the keywords association list into the file `finder-inf.el'. +Optional arguments are a list of Emacs Lisp directories to compile from; no +arguments compiles from `load-path'." + (save-excursion + ;; XEmacs change + (find-file "finder-inf.el") + (let ((processed nil) + (directory-abbrev-alist + (append + (mapcar (function (lambda (dir) (cons dir ""))) + finder-abbreviate-directory-list) + directory-abbrev-alist)) + (using-load-path)) + (or dirs (setq dirs load-path)) + (setq using-load-path (equal dirs load-path)) + (erase-buffer) + (insert ";;; finder-inf.el --- keyword-to-package mapping\n") + (insert ";; Keywords: help\n") + (insert ";;; Commentary:\n") + (insert ";; Don't edit this file. It's generated by finder.el\n\n") + (insert ";;; Code:\n") + (insert "\n(setq finder-package-info '(\n") + (mapcar + (function + (lambda (d) + (mapcar + (function + (lambda (f) + (if (not (member f processed)) + (let (summary keystart keywords) + (setq processed (cons f processed)) + (if (not finder-compile-keywords-quiet) + (message "Processing %s ..." f)) + (save-excursion + (set-buffer (get-buffer-create "*finder-scratch*")) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (insert-file-contents (expand-file-name f d)) + (setq summary (lm-synopsis) + keywords (lm-keywords))) + (if (not summary) + nil + (insert (format " (\"%s\"\n " f)) + (prin1 summary (current-buffer)) + (insert "\n ") + (setq keystart (point)) + (insert (if keywords (format "(%s)" keywords) "nil")) + (subst-char-in-region keystart (point) ?, ? ) + (insert "\n ") + (prin1 (abbreviate-file-name d) (current-buffer)) + (insert ")\n")))))) + ;; + ;; Skip null, non-existent or relative pathnames, e.g. "./", if + ;; using load-path, so that they do not interfere with a scan of + ;; library directories only. + (if (and using-load-path + (not (and d (file-name-absolute-p d) (file-exists-p d)))) + nil + (setq d (file-name-as-directory (or d "."))) + (directory-files d nil "^[^=].*\\.el$"))))) + dirs) + (insert "))\n\n(provide 'finder-inf)\n\n;;; finder-inf.el ends here\n") + (kill-buffer "*finder-scratch*") + (eval-current-buffer) ;; So we get the new keyword list immediately + (basic-save-buffer)))) + +(defun finder-compile-keywords-make-dist () + "Regenerate `finder-inf.el' for the Emacs distribution." + (finder-compile-keywords default-directory)) + +;;; Now the retrieval code + +(defun finder-insert-at-column (column &rest strings) + "Insert list of STRINGS, at column COLUMN." + (if (>= (current-column) column) (insert "\n")) + (move-to-column column) + (let ((col (current-column))) + (if (< col column) + (indent-to column) + (if (and (/= col column) + (= (preceding-char) ?\t)) + (let (indent-tabs-mode) + (delete-char -1) + (indent-to col) + (move-to-column column))))) + (apply 'insert strings)) + +(defun finder-list-keywords () + "Display descriptions of the keywords in the Finder buffer." + (interactive) + (setq buffer-read-only nil) + (erase-buffer) + (mapcar + (lambda (assoc) + (let ((keyword (car assoc))) + (insert (symbol-name keyword)) + (finder-insert-at-column 14 (concat (cdr assoc) "\n")) + (cons (symbol-name keyword) keyword))) + finder-known-keywords) + (goto-char (point-min)) + (setq finder-headmark (point)) + (setq buffer-read-only t) + (set-buffer-modified-p nil) + ;; XEmacs change + (if (not (one-window-p)) + (balance-windows)) + (finder-summary)) + +(defun finder-list-matches (key) + (setq buffer-read-only nil) + (erase-buffer) + (let ((id (intern key))) + (insert + "The following packages match the keyword `" key "':\n\n") + (setq finder-headmark (point)) + (mapcar + (lambda (x) + (if (memq id (car (cdr (cdr x)))) + (progn + (insert (car x)) + (finder-insert-at-column 16 (concat (car (cdr x)) "\n"))))) + finder-package-info) + (goto-char (point-min)) + (forward-line) + (setq buffer-read-only t) + (set-buffer-modified-p nil) + (shrink-window-if-larger-than-buffer) + (finder-summary))) + +;; Search for a file named FILE the same way `load' would search. +(defun finder-find-library (file) + (if (file-name-absolute-p file) + file + (let ((dirs load-path) + found) + (while (and dirs (not found)) + (if (file-exists-p (expand-file-name (concat file ".el") (car dirs))) + (setq found (expand-file-name file (car dirs))) + (if (file-exists-p (expand-file-name file (car dirs))) + (setq found (expand-file-name file (car dirs))))) + (setq dirs (cdr dirs))) + found))) + +(defun finder-commentary (file) + (interactive) + (let* ((str (lm-commentary (finder-find-library file)))) + (if (null str) + (error "Can't find any Commentary section")) + (pop-to-buffer "*Finder*") + ;; XEmacs change + (setq buffer-read-only nil + mode-motion-hook 'mode-motion-highlight-line) + (erase-buffer) + (insert str) + (goto-char (point-min)) + (delete-blank-lines) + (goto-char (point-max)) + (delete-blank-lines) + (goto-char (point-min)) + (while (re-search-forward "^;+ ?" nil t) + (replace-match "" nil nil)) + (goto-char (point-min)) + (setq buffer-read-only t) + (set-buffer-modified-p nil) + (shrink-window-if-larger-than-buffer) + (finder-summary))) + +(defun finder-current-item () + (if (and finder-headmark (< (point) finder-headmark)) + (error "No keyword or filename on this line") + (save-excursion + (beginning-of-line) + (current-word)))) + +;; XEmacs change +(defun finder-edit () + (interactive) + (let ((entry (finder-current-item))) + (if (string-match finder-file-regexp entry) + (let ((path (finder-find-library entry))) + (if path + (find-file-other-window path) + (error "Can't find Emacs Lisp library: '%s'" entry))) + ;; a finder keyword + (error "Finder-edit works on Emacs Lisp libraries only")))) + +;; XEmacs change +(defun finder-view () + (interactive) + (let ((entry (finder-current-item))) + (if (string-match finder-file-regexp entry) + (let ((path (finder-find-library entry))) + (if path + (view-file-other-window path) + (error "Can't find Emacs Lisp library: '%s'" entry))) + ;; a finder keyword + (error "Finder-view works on Emacs Lisp libraries only")))) + +(defun finder-select () + (interactive) + (let ((key (finder-current-item))) + ;; XEmacs change + (if (string-match finder-file-regexp key) + (finder-commentary key) + (finder-list-matches key)))) + +;; XEmacs change +(defun finder-mouse-select (ev) + (interactive "e") + (goto-char (event-point ev)) + (finder-select)) + +(defun finder-by-keyword () + "Find packages matching a given keyword." + (interactive) + (finder-mode) + (finder-list-keywords)) + +(defun finder-mode () + "Major mode for browsing package documentation. +\\ +\\[finder-select] more help for the item on the current line +\\[finder-edit] edit Lisp library in another window +\\[finder-view] view Lisp library in another window +\\[finder-exit] exit Finder mode and kill the Finder buffer. +" + (interactive) + (pop-to-buffer "*Finder*") + ;; XEmacs change + (setq buffer-read-only nil + mode-motion-hook 'mode-motion-highlight-line) + (erase-buffer) + (use-local-map finder-mode-map) + (set-syntax-table emacs-lisp-mode-syntax-table) + (setq mode-name "Finder") + (setq major-mode 'finder-mode) + (make-local-variable 'finder-headmark) + (setq finder-headmark nil)) + +(defun finder-summary () + "Summarize basic Finder commands." + (interactive) + (message "%s" + (substitute-command-keys + ;; XEmacs change + "\\\\[finder-select] = select, \\[finder-list-keywords] = keywords, \\[finder-edit] = edit, \\[finder-view] = view, \\[finder-exit] = quit, \\[finder-summary] = help"))) + +(defun finder-exit () + "Exit Finder mode and kill the buffer" + (interactive) + ;; XEmacs change + (or (one-window-p t 0) + (delete-window)) + (kill-buffer "*Finder*")) + +(provide 'finder) + +;;; finder.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/font-lock.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/font-lock.el Mon Aug 13 10:08:34 2007 +0200 @@ -0,0 +1,2620 @@ +;;; font-lock.el --- decorating source files with fonts/colors based on syntax + +;; Copyright (C) 1992-1995, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1995 Amdahl Corporation. +;; Copyright (C) 1996 Ben Wing. + +;; Author: Jamie Zawinski , for the LISPM Preservation Society. +;; Minimally merged with FSF 19.34 by Barry Warsaw +;; Then (partially) synched with FSF 19.30, leading to: +;; Next Author: RMS +;; Next Author: Simon Marshall +;; Latest XEmacs Author: Ben Wing +;; Maintainer: XEmacs Development Team (sigh :-( ) +;; Keywords: languages, faces + +;; This file is part of XEmacs. + +;; XEmacs 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. + +;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: FSF 19.30 except for the code to initialize the faces. + +;;; Commentary: + +;; Font-lock-mode is a minor mode that causes your comments to be +;; displayed in one face, strings in another, reserved words in another, +;; documentation strings in another, and so on. +;; +;; Comments will be displayed in `font-lock-comment-face'. +;; Strings will be displayed in `font-lock-string-face'. +;; Doc strings will be displayed in `font-lock-doc-string-face'. +;; Function and variable names (in their defining forms) will be +;; displayed in `font-lock-function-name-face'. +;; Reserved words will be displayed in `font-lock-keyword-face'. +;; +;; Don't let the name fool you: you can highlight things using different +;; colors or background stipples instead of fonts, though that is not the +;; default. See the variables `font-lock-use-colors' and +;; `font-lock-use-fonts' for broad control over this, or see the +;; documentation on faces and how to change their attributes for +;; fine-grained control. +;; +;; To make the text you type be fontified, use M-x font-lock-mode. When +;; this minor mode is on, the fonts of the current line will be updated +;; with every insertion or deletion. +;; +;; By default, font-lock will automatically put newly loaded files +;; into font-lock-mode if it knows about the file's mode. See the +;; variables `font-lock-auto-fontify', `font-lock-mode-enable-list', +;; and `font-lock-mode-disable-list' for control over this. +;; +;; The `font-lock-keywords' variable defines other patterns to highlight. +;; The default font-lock-mode-hook sets it to the value of the variables +;; lisp-font-lock-keywords, c-font-lock-keywords, etc, as appropriate. +;; The easiest way to change the highlighting patterns is to change the +;; values of c-font-lock-keywords and related variables. See the doc +;; string of the variable `font-lock-keywords' for the appropriate syntax. +;; +;; The default value for `lisp-font-lock-keywords' is the value of the variable +;; `lisp-font-lock-keywords-1'. You may like `lisp-font-lock-keywords-2' +;; better; it highlights many more words, but is slower and makes your buffers +;; be very visually noisy. +;; +;; The same is true of `c-font-lock-keywords-1' and `c-font-lock-keywords-2'; +;; the former is subdued, the latter is loud. +;; +;; You can make font-lock default to the gaudier variety of keyword +;; highlighting by setting the variable `font-lock-maximum-decoration' +;; before loading font-lock, or by calling the functions +;; `font-lock-use-default-maximal-decoration' or +;; `font-lock-use-default-minimal-decoration'. +;; +;; On a Sparc10, the initial fontification takes about 6 seconds for a typical +;; 140k file of C code, using the default configuration. The actual speed +;; depends heavily on the type of code in the file, and how many non-syntactic +;; patterns match; for example, Xlib.h takes 23 seconds for 101k, because many +;; patterns match in it. You can speed this up substantially by removing some +;; of the patterns that are highlighted by default. Fontifying lisp code is +;; significantly faster, because lisp has a more regular syntax than C, so the +;; regular expressions don't have to be as complicated. +;; +;; It's called font-lock-mode here because on the Lispms it was called +;; "Electric Font Lock Mode." It was called that because there was an older +;; mode called "Electric Caps Lock Mode" which had the function of causing all +;; of your source code to be in upper case except for strings and comments, +;; without you having to blip the caps lock key by hand all the time (thus the +;; "electric", as in `electric-c-brace'.) + +;; See also the related packages `fast-lock' and `lazy-lock'. Both +;; attempt to speed up the initial fontification. `fast-lock' saves +;; the fontification info when you exit Emacs and reloads it next time +;; you load the file, so that the file doesn't have to be fontified +;; again. `lazy-lock' does "lazy" fontification -- i.e. it only +;; fontifies the text as it becomes visible rather than fontifying +;; the whole file when it's first loaded in. + +;; Further comments from the FSF: + +;; Nasty regexps of the form "bar\\(\\|lo\\)\\|f\\(oo\\|u\\(\\|bar\\)\\)\\|lo" +;; are made thusly: (regexp-opt '("foo" "fu" "fubar" "bar" "barlo" "lo")) for +;; efficiency. + +;; What is fontification for? You might say, "It's to make my code look nice." +;; I think it should be for adding information in the form of cues. These cues +;; should provide you with enough information to both (a) distinguish between +;; different items, and (b) identify the item meanings, without having to read +;; the items and think about it. Therefore, fontification allows you to think +;; less about, say, the structure of code, and more about, say, why the code +;; doesn't work. Or maybe it allows you to think less and drift off to sleep. +;; +;; So, here are my opinions/advice/guidelines: +;; +;; - Use the same face for the same conceptual object, across all modes. +;; i.e., (b) above, all modes that have items that can be thought of as, say, +;; keywords, should be highlighted with the same face, etc. +;; - Keep the faces distinct from each other as far as possible. +;; i.e., (a) above. +;; - Make the face attributes fit the concept as far as possible. +;; i.e., function names might be a bold colour such as blue, comments might +;; be a bright colour such as red, character strings might be brown, because, +;; err, strings are brown (that was not the reason, please believe me). +;; - Don't use a non-nil OVERRIDE unless you have a good reason. +;; Only use OVERRIDE for special things that are easy to define, such as the +;; way `...' quotes are treated in strings and comments in Emacs Lisp mode. +;; Don't use it to, say, highlight keywords in commented out code or strings. +;; - Err, that's it. + + +;;; Code: + +(require 'fontl-hooks) + +;;;;;;;;;;;;;;;;;;;;;; user variables ;;;;;;;;;;;;;;;;;;;;;; + +(defvar font-lock-verbose t + "*If non-nil, means show status messages when fontifying. +See also `font-lock-message-threshold'.") + +(defvar font-lock-message-threshold 6000 + "*Minimum size of region being fontified for status messages to appear. + +The size is measured in characters. This affects `font-lock-fontify-region' +but not `font-lock-fontify-buffer'. (In other words, when you first visit +a file and it gets fontified, you will see status messages no matter what +size the file is. However, if you do something else like paste a +chunk of text or revert a buffer, you will see status messages only if the +changed region is large enough.) + +Note that setting `font-lock-verbose' to nil disables the status +messages entirely.") + +;;;###autoload +(defvar font-lock-auto-fontify t + "*Whether font-lock should automatically fontify files as they're loaded. +This will only happen if font-lock has fontifying keywords for the major +mode of the file. You can get finer-grained control over auto-fontification +by using this variable in combination with `font-lock-mode-enable-list' or +`font-lock-mode-disable-list'.") + +;;;###autoload +(defvar font-lock-mode-enable-list nil + "*List of modes to auto-fontify, if `font-lock-auto-fontify' is nil.") + +;;;###autoload +(defvar font-lock-mode-disable-list nil + "*List of modes not to auto-fontify, if `font-lock-auto-fontify' is t.") + +;;;###autoload +(defvar font-lock-use-colors '(color) + "*Specification for when Font Lock will set up color defaults. +Normally this should be '(color), meaning that Font Lock will set up +color defaults that are only used on color displays. Set this to nil +if you don't want Font Lock to set up color defaults at all. This +should be one of + +-- a list of valid tags, meaning that the color defaults will be used + when all of the tags apply. (e.g. '(color x)) +-- a list whose first element is 'or and whose remaining elements are + lists of valid tags, meaning that the defaults will be used when + any of the tag lists apply. +-- nil, meaning that the defaults should not be set up at all. + +\(If you specify face values in your init file, they will override any +that Font Lock specifies, regardless of whether you specify the face +values before or after loading Font Lock.) + +See also `font-lock-use-fonts'. If you want more control over the faces +used for fontification, see the documentation of `font-lock-mode' for +how to do it.") + +;;;###autoload +(defvar font-lock-use-fonts '(or (mono) (grayscale)) + "*Specification for when Font Lock will set up non-color defaults. + +Normally this should be '(or (mono) (grayscale)), meaning that Font +Lock will set up non-color defaults that are only used on either mono +or grayscale displays. Set this to nil if you don't want Font Lock to +set up non-color defaults at all. This should be one of + +-- a list of valid tags, meaning that the non-color defaults will be used + when all of the tags apply. (e.g. '(grayscale x)) +-- a list whose first element is 'or and whose remaining elements are + lists of valid tags, meaning that the defaults will be used when + any of the tag lists apply. +-- nil, meaning that the defaults should not be set up at all. + +\(If you specify face values in your init file, they will override any +that Font Lock specifies, regardless of whether you specify the face +values before or after loading Font Lock.) + +See also `font-lock-use-colors'. If you want more control over the faces +used for fontification, see the documentation of `font-lock-mode' for +how to do it.") + +;;;###autoload +(defvar font-lock-maximum-decoration nil + "*If non-nil, the maximum decoration level for fontifying. +If nil, use the minimum decoration (equivalent to level 0). +If t, use the maximum decoration available. +If a number, use that level of decoration (or if not available the maximum). +If a list, each element should be a cons pair of the form (MAJOR-MODE . LEVEL), +where MAJOR-MODE is a symbol or t (meaning the default). For example: + ((c++-mode . 2) (c-mode . t) (t . 1)) +means use level 2 decoration for buffers in `c++-mode', the maximum decoration +available for buffers in `c-mode', and level 1 decoration otherwise.") + +;;;###autoload +(define-obsolete-variable-alias 'font-lock-use-maximal-decoration + 'font-lock-maximum-decoration) + +;;;###autoload +(defvar font-lock-maximum-size (* 250 1024) + "*If non-nil, the maximum size for buffers for fontifying. +Only buffers less than this can be fontified when Font Lock mode is turned on. +If nil, means size is irrelevant. +If a list, each element should be a cons pair of the form (MAJOR-MODE . SIZE), +where MAJOR-MODE is a symbol or t (meaning the default). For example: + ((c++-mode . 256000) (c-mode . 256000) (rmail-mode . 1048576)) +means that the maximum size is 250K for buffers in `c++-mode' or `c-mode', one +megabyte for buffers in `rmail-mode', and size is irrelevant otherwise.") + +;; Fontification variables: + +;;;###autoload +(defvar font-lock-keywords nil + "*A list of the keywords to highlight. +Each element should be of the form: + + MATCHER + (MATCHER . MATCH) + (MATCHER . FACENAME) + (MATCHER . HIGHLIGHT) + (MATCHER HIGHLIGHT ...) + (eval . FORM) + +where HIGHLIGHT should be either MATCH-HIGHLIGHT or MATCH-ANCHORED. + +FORM is an expression, whose value should be a keyword element, +evaluated when the keyword is (first) used in a buffer. This feature +can be used to provide a keyword that can only be generated when Font +Lock mode is actually turned on. + +For highlighting single items, typically only MATCH-HIGHLIGHT is required. +However, if an item or (typically) items is to be highlighted following the +instance of another item (the anchor) then MATCH-ANCHORED may be required. + +MATCH-HIGHLIGHT should be of the form: + + (MATCH FACENAME OVERRIDE LAXMATCH) + +Where MATCHER can be either the regexp to search for, a variable +containing the regexp to search for, or the function to call to make +the search (called with one argument, the limit of the search). MATCH +is the subexpression of MATCHER to be highlighted. FACENAME is either +a symbol naming a face, or an expression whose value is the face name +to use. If you want FACENAME to be a symbol that evaluates to a face, +use a form like \"(progn sym)\". + +OVERRIDE and LAXMATCH are flags. If OVERRIDE is t, existing fontification may +be overwritten. If `keep', only parts not already fontified are highlighted. +If `prepend' or `append', existing fontification is merged with the new, in +which the new or existing fontification, respectively, takes precedence. +If LAXMATCH is non-nil, no error is signalled if there is no MATCH in MATCHER. + +For example, an element of the form highlights (if not already highlighted): + + \"\\\\\\=\" Discrete occurrences of \"foo\" in the value of the + variable `font-lock-keyword-face'. + (\"fu\\\\(bar\\\\)\" . 1) Substring \"bar\" within all occurrences of \"fubar\" in + the value of `font-lock-keyword-face'. + (\"fubar\" . fubar-face) Occurrences of \"fubar\" in the value of `fubar-face'. + (\"foo\\\\|bar\" 0 foo-bar-face t) + Occurrences of either \"foo\" or \"bar\" in the value + of `foo-bar-face', even if already highlighted. + +MATCH-ANCHORED should be of the form: + + (MATCHER PRE-MATCH-FORM POST-MATCH-FORM MATCH-HIGHLIGHT ...) + +Where MATCHER is as for MATCH-HIGHLIGHT with one exception; see below. +PRE-MATCH-FORM and POST-MATCH-FORM are evaluated before the first, and after +the last, instance MATCH-ANCHORED's MATCHER is used. Therefore they can be +used to initialise before, and cleanup after, MATCHER is used. Typically, +PRE-MATCH-FORM is used to move to some position relative to the original +MATCHER, before starting with MATCH-ANCHORED's MATCHER. POST-MATCH-FORM might +be used to move, before resuming with MATCH-ANCHORED's parent's MATCHER. + +For example, an element of the form highlights (if not already highlighted): + + (\"\\\\\\=\" (0 anchor-face) (\"\\\\\\=\" nil nil (0 item-face))) + + Discrete occurrences of \"anchor\" in the value of `anchor-face', and subsequent + discrete occurrences of \"item\" (on the same line) in the value of `item-face'. + (Here PRE-MATCH-FORM and POST-MATCH-FORM are nil. Therefore \"item\" is + initially searched for starting from the end of the match of \"anchor\", and + searching for subsequent instance of \"anchor\" resumes from where searching + for \"item\" concluded.) + +The above-mentioned exception is as follows. The limit of the MATCHER search +defaults to the end of the line after PRE-MATCH-FORM is evaluated. +However, if PRE-MATCH-FORM returns a position greater than the position after +PRE-MATCH-FORM is evaluated, that position is used as the limit of the search. +It is generally a bad idea to return a position greater than the end of the +line, i.e., cause the MATCHER search to span lines. + +Note that the MATCH-ANCHORED feature is experimental; in the future, we may +replace it with other ways of providing this functionality. + +These regular expressions should not match text which spans lines. While +\\[font-lock-fontify-buffer] handles multi-line patterns correctly, updating +when you edit the buffer does not, since it considers text one line at a time. + +Be very careful composing regexps for this list; +the wrong pattern can dramatically slow things down!") +;;;###autoload +(make-variable-buffer-local 'font-lock-keywords) + +(defvar font-lock-defaults nil + "The defaults font Font Lock mode for the current buffer. +Normally, do not set this directly. If you are writing a major mode, +put a property of `font-lock-defaults' on the major-mode symbol with +the desired value. + +It should be a list + +\(KEYWORDS KEYWORDS-ONLY CASE-FOLD SYNTAX-ALIST SYNTAX-BEGIN) + +KEYWORDS may be a symbol (a variable or function whose value is the keywords +to use for fontification) or a list of symbols. If KEYWORDS-ONLY is non-nil, +syntactic fontification (strings and comments) is not performed. If CASE-FOLD +is non-nil, the case of the keywords is ignored when fontifying. If +SYNTAX-ALIST is non-nil, it should be a list of cons pairs of the form (CHAR +. STRING) used to set the local Font Lock syntax table, for keyword and +syntactic fontification (see `modify-syntax-entry'). + +If SYNTAX-BEGIN is non-nil, it should be a function with no args used to move +backwards outside any enclosing syntactic block, for syntactic fontification. +Typical values are `beginning-of-line' (i.e., the start of the line is known to +be outside a syntactic block), or `beginning-of-defun' for programming modes or +`backward-paragraph' for textual modes (i.e., the mode-dependent function is +known to move outside a syntactic block). If nil, the beginning of the buffer +is used as a position outside of a syntactic block, in the worst case. + +These item elements are used by Font Lock mode to set the variables +`font-lock-keywords', `font-lock-keywords-only', +`font-lock-keywords-case-fold-search', `font-lock-syntax-table' and +`font-lock-beginning-of-syntax-function', respectively. + +Alternatively, if the value is a symbol, it should name a major mode, +and the defaults for that mode will apply.") +(make-variable-buffer-local 'font-lock-defaults) + +;; FSF uses `font-lock-defaults-alist' and expects the major mode to +;; set a value for `font-lock-defaults', but I don't like either of +;; these -- requiring the mode to set `font-lock-defaults' makes it +;; impossible to have defaults for a minor mode, and using an alist is +;; generally a bad idea for information that really should be +;; decentralized. (Who knows what strange modes might want +;; font-locking?) + +(defvar font-lock-keywords-only nil + "Non-nil means Font Lock should not do syntactic fontification. +This is normally set via `font-lock-defaults'. + +This should be nil for all ``language'' modes, but other modes, like +dired, do not have anything useful in the syntax tables (no comment +or string delimiters, etc) and so there is no need to use them and +this variable should have a value of t. + +You should not set this variable directly; its value is computed +from `font-lock-defaults', or (if that does not specify anything) +by examining the syntax table to see whether it appears to contain +anything useful.") +(make-variable-buffer-local 'font-lock-keywords-only) + +(defvar font-lock-keywords-case-fold-search nil + "Whether the strings in `font-lock-keywords' should be case-folded. +This variable is automatically buffer-local, as the correct value depends +on the language in use.") +(make-variable-buffer-local 'font-lock-keywords-case-fold-search) + +(defvar font-lock-after-fontify-buffer-hook nil + "Function or functions to run after completion of font-lock-fontify-buffer.") + +(defvar font-lock-syntax-table nil + "Non-nil means use this syntax table for fontifying. +If this is nil, the major mode's syntax table is used. +This is normally set via `font-lock-defaults'.") +(make-variable-buffer-local 'font-lock-syntax-table) + +;; These are used in the FSF version in syntactic font-locking. +;; We do this all in C. +;;; These record the parse state at a particular position, always the +;;; start of a line. Used to make +;;; `font-lock-fontify-syntactically-region' faster. +;(defvar font-lock-cache-position nil) +;(defvar font-lock-cache-state nil) +;(make-variable-buffer-local 'font-lock-cache-position) +;(make-variable-buffer-local 'font-lock-cache-state) + +;; If this is nil, we only use the beginning of the buffer if we can't use +;; `font-lock-cache-position' and `font-lock-cache-state'. +(defvar font-lock-beginning-of-syntax-function nil + "Non-nil means use this function to move back outside of a syntactic block. +If this is nil, the beginning of the buffer is used (in the worst case). +This is normally set via `font-lock-defaults'.") +(make-variable-buffer-local 'font-lock-beginning-of-syntax-function) + +;;;###autoload +(defvar font-lock-mode nil) ; for modeline +(defvar font-lock-fontified nil) ; whether we have hacked this buffer +(put 'font-lock-fontified 'permanent-local t) + +;;;###autoload +(defvar font-lock-mode-hook nil + "Function or functions to run on entry to font-lock-mode.") + +; whether font-lock-set-defaults has already been run. +(defvar font-lock-defaults-computed nil) +(make-variable-buffer-local 'font-lock-defaults-computed) + +;; #### barf gag retch. Horrid FSF lossage that we need to +;; keep around for compatibility with font-lock-keywords that +;; forget to properly quote their faces. +(defvar font-lock-comment-face 'font-lock-comment-face + "Don't even think of using this.") +(defvar font-lock-doc-string-face 'font-lock-doc-string-face + "Don't even think of using this.") +(defvar font-lock-string-face 'font-lock-string-face + "Don't even think of using this.") +(defvar font-lock-keyword-face 'font-lock-keyword-face + "Don't even think of using this.") +(defvar font-lock-function-name-face 'font-lock-function-name-face + "Don't even think of using this.") +(defvar font-lock-variable-name-face 'font-lock-variable-name-face + "Don't even think of using this.") +(defvar font-lock-type-face 'font-lock-type-face + "Don't even think of using this.") +(defvar font-lock-reference-face 'font-lock-reference-face + "Don't even think of using this.") +(defvar font-lock-preprocessor-face 'font-lock-preprocessor-face + "Don't even think of using this.") + + +;;;;;;;;;;;;;;;;;;;;;; actual code ;;;;;;;;;;;;;;;;;;;;;; + +;;; To fontify the whole buffer by language syntax, we go through it a +;;; character at a time, creating extents on the boundary of each syntactic +;;; unit (that is, one extent for each block comment, one for each line +;;; comment, one for each string, etc.) This is done with the C function +;;; syntactically-sectionize. It's in C for speed (the speed of lisp function +;;; calls was a real bottleneck for this task since it involves examining each +;;; character in turn.) +;;; +;;; Then we make a second pass, to fontify the buffer based on other patterns +;;; specified by regexp. When we find a match for a region of text, we need +;;; to change the fonts on those characters. This is done with the +;;; put-text-property function, which knows how to efficiently share extents. +;;; Conceptually, we are attaching some particular face to each of the +;;; characters in a range, but the implementation of this involves creating +;;; extents, or resizing existing ones. +;;; +;;; Each time a modification happens to a line, we re-fontify the entire line. +;;; We do this by first removing the extents (text properties) on the line, +;;; and then doing the syntactic and keyword passes again on that line. (More +;;; generally, each modified region is extended to include the preceding and +;;; following BOL or EOL.) +;;; +;;; This means that, as the user types, we repeatedly go back to the beginning +;;; of the line, doing more work the longer the line gets. This doesn't cost +;;; much in practice, and if we don't, then we incorrectly fontify things when, +;;; for example, inserting spaces into `intfoo () {}'. +;;; + + +;; The user level functions + +;;;###autoload +(defun font-lock-mode (&optional arg) + "Toggle Font Lock Mode. +With arg, turn font-lock mode on if and only if arg is positive. + +When Font Lock mode is enabled, text is fontified as you type it: + + - Comments are displayed in `font-lock-comment-face'; + - Strings are displayed in `font-lock-string-face'; + - Documentation strings (in Lisp-like languages) are displayed in + `font-lock-doc-string-face'; + - Language keywords (\"reserved words\") are displayed in + `font-lock-keyword-face'; + - Function names in their defining form are displayed in + `font-lock-function-name-face'; + - Variable names in their defining form are displayed in + `font-lock-variable-name-face'; + - Type names are displayed in `font-lock-type-face'; + - References appearing in help files and the like are displayed + in `font-lock-reference-face'; + - Preprocessor declarations are displayed in + `font-lock-preprocessor-face'; + + and + + - Certain other expressions are displayed in other faces according + to the value of the variable `font-lock-keywords'. + +Where modes support different levels of fontification, you can use the variable +`font-lock-maximum-decoration' to specify which level you generally prefer. +When you turn Font Lock mode on/off the buffer is fontified/defontified, though +fontification occurs only if the buffer is less than `font-lock-maximum-size'. +To fontify a buffer without turning on Font Lock mode, and regardless of buffer +size, you can use \\[font-lock-fontify-buffer]. + +See the variable `font-lock-keywords' for customization." + (interactive "P") + (let ((on-p (if arg (> (prefix-numeric-value arg) 0) (not font-lock-mode))) + (maximum-size (if (not (consp font-lock-maximum-size)) + font-lock-maximum-size + (cdr (or (assq major-mode font-lock-maximum-size) + (assq t font-lock-maximum-size)))))) + ;; Font-lock mode will refuse to turn itself on if in batch mode, or if + ;; the current buffer is "invisible". The latter is because packages + ;; sometimes put their temporary buffers into some particular major mode + ;; to get syntax tables and variables and whatnot, but we don't want the + ;; fact that the user has font-lock-mode on a mode hook to slow these + ;; things down. + (if (or noninteractive (eq (aref (buffer-name) 0) ?\ )) + (setq on-p nil)) + (if (equal (buffer-name) " *Compiler Input*") ; hack for bytecomp... + (setq on-p nil)) + (cond (on-p + (make-local-hook 'after-change-functions) + (add-hook 'after-change-functions + 'font-lock-after-change-function nil t) + (add-hook 'pre-idle-hook 'font-lock-pre-idle-hook)) + (t + (remove-hook 'after-change-functions + 'font-lock-after-change-function t) + (setq font-lock-defaults-computed nil + font-lock-keywords nil) + ;; We have no business doing this here, since + ;; pre-idle-hook is global. Other buffers may + ;; still be in font-lock mode. -dkindred@cs.cmu.edu + ;; (remove-hook 'pre-idle-hook 'font-lock-pre-idle-hook) + )) + (set (make-local-variable 'font-lock-mode) on-p) + (cond (on-p + (font-lock-set-defaults-1) + (make-local-hook 'before-revert-hook) + (make-local-hook 'after-revert-hook) + ;; If buffer is reverted, must clean up the state. + (add-hook 'before-revert-hook 'font-lock-revert-setup nil t) + (add-hook 'after-revert-hook 'font-lock-revert-cleanup nil t) + (run-hooks 'font-lock-mode-hook) + (cond (font-lock-fontified + nil) + ((or (null maximum-size) (<= (buffer-size) maximum-size)) + (font-lock-fontify-buffer)) + (font-lock-verbose + (display-message + 'command + (format "Fontifying %s... buffer too big." (buffer-name)))))) + (font-lock-fontified + (setq font-lock-fontified nil) + (remove-hook 'before-revert-hook 'font-lock-revert-setup t) + (remove-hook 'after-revert-hook 'font-lock-revert-cleanup t) + (font-lock-unfontify-region (point-min) (point-max)) + (font-lock-thing-lock-cleanup)) + (t + (remove-hook 'before-revert-hook 'font-lock-revert-setup t) + (remove-hook 'after-revert-hook 'font-lock-revert-cleanup t) + (font-lock-thing-lock-cleanup))) + (redraw-modeline))) + +;; For init-file hooks +;;;###autoload +(defun turn-on-font-lock () + "Unconditionally turn on Font Lock mode." + (font-lock-mode 1)) + +;;;###autoload +(defun turn-off-font-lock () + "Unconditionally turn off Font Lock mode." + (font-lock-mode 0)) + +;;;###autoload +(defun font-lock-fontify-buffer () + "Fontify the current buffer the way `font-lock-mode' would. +See `font-lock-mode' for details. + +This can take a while for large buffers." + (interactive) + (let ((was-on font-lock-mode) + (font-lock-verbose (or font-lock-verbose (interactive-p))) + (font-lock-message-threshold 0) + (aborted nil)) + ;; Turn it on to run hooks and get the right font-lock-keywords. + (or was-on (font-lock-mode 1)) + (font-lock-unfontify-region (point-min) (point-max) t) +;; (buffer-syntactic-context-flush-cache) + + ;; If a ^G is typed during fontification, abort the fontification, but + ;; return normally (do not signal.) This is to make it easy to abort + ;; fontification if it's taking a long time, without also causing the + ;; buffer not to pop up. If a real abort is desired, the user can ^G + ;; again. + ;; + ;; Possibly this should happen down in font-lock-fontify-region instead + ;; of here, but since that happens from the after-change-hook (meaning + ;; much more frequently) I'm afraid of the bad consequences of stealing + ;; the interrupt character at inopportune times. + ;; + (condition-case nil + (save-excursion + (font-lock-fontify-region (point-min) (point-max))) + (quit + (setq aborted t))) + + (or was-on ; turn it off if it was off. + (let ((font-lock-fontified nil)) ; kludge to prevent defontification + (font-lock-mode 0))) + (set (make-local-variable 'font-lock-fontified) t) + (if (and aborted font-lock-verbose) + (display-message 'command + (format "Fontifying %s... aborted." (buffer-name)))) + ) + (run-hooks 'font-lock-after-fontify-buffer-hook)) + +;; Fontification functions. + +;; We first define some defsubsts to encapsulate the way we add +;; faces to a region of text. I am planning on modifying the +;; text-property mechanism so that multiple independent classes +;; of text properties can exist. That way, for example, ediff's +;; face text properties don't interfere with font lock's face +;; text properties. Due to the XEmacs implementation of text +;; properties in terms of extents, doing this is fairly trivial: +;; instead of using the `text-prop' property, you just use a +;; specified property. + +(defsubst font-lock-set-face (start end face) + ;; Set the face on the characters in the range. + (put-nonduplicable-text-property start end 'face face) + (put-nonduplicable-text-property start end 'font-lock t)) + +(defsubst font-lock-remove-face (start end) + ;; Remove any syntax highlighting on the characters in the range. + (put-nonduplicable-text-property start end 'face nil) + (put-nonduplicable-text-property start end 'font-lock nil)) + +(defsubst font-lock-any-faces-p (start end) + ;; Return non-nil if we've put any syntax highlighting on + ;; the characters in the range. + ;; + ;; used to look for 'text-prop property, but this has problems if + ;; you put any other text properties in the vicinity. Simon + ;; Marshall suggested looking for the 'face property (this is what + ;; FSF Emacs does) but that's equally bogus. Only reliable way is + ;; for font-lock to specially mark its extents. + ;; + ;; FSF's (equivalent) definition of this defsubst would be + ;; (text-property-not-all start end 'font-lock nil) + ;; + ;; Perhaps our `map-extents' is faster than our definition + ;; of `text-property-not-all'. #### If so, `text-property-not-all' + ;; should be fixed ... + ;; + (map-extents 'extent-property (current-buffer) start (1- end) 'font-lock)) + + +;; Fontification functions. + +;; We use this wrapper. However, `font-lock-fontify-region' used to be the +;; name used for `font-lock-fontify-syntactically-region', so a change isn't +;; back-compatible. But you shouldn't be calling these directly, should you? +(defun font-lock-fontify-region (beg end &optional loudly) + (let ((modified (buffer-modified-p)) + (buffer-undo-list t) (inhibit-read-only t) + (old-syntax-table (syntax-table)) + buffer-file-name buffer-file-truename) + (unwind-protect + (progn + ;; Use the fontification syntax table, if any. + (if font-lock-syntax-table (set-syntax-table font-lock-syntax-table)) + ;; Now do the fontification. + (if font-lock-keywords-only + (font-lock-unfontify-region beg end) + (font-lock-fontify-syntactically-region beg end loudly)) + (font-lock-fontify-keywords-region beg end loudly)) + ;; Clean up. + (set-syntax-table old-syntax-table) + (and (not modified) (buffer-modified-p) (set-buffer-modified-p nil))))) + +;; The following must be rethought, since keywords can override fontification. +; ;; Now scan for keywords, but not if we are inside a comment now. +; (or (and (not font-lock-keywords-only) +; (let ((state (parse-partial-sexp beg end nil nil +; font-lock-cache-state))) +; (or (nth 4 state) (nth 7 state)))) +; (font-lock-fontify-keywords-region beg end)) + +(defun font-lock-unfontify-region (beg end &optional maybe-loudly) + (if (and maybe-loudly font-lock-verbose + (>= (- end beg) font-lock-message-threshold)) + (display-message + 'progress + (format "Fontifying %s..." (buffer-name)))) + (let ((modified (buffer-modified-p)) + (buffer-undo-list t) (inhibit-read-only t) + buffer-file-name buffer-file-truename) + (font-lock-remove-face beg end) + (and (not modified) (buffer-modified-p) (set-buffer-modified-p nil)))) + +;; Following is the original FSF version (similar to our original +;; version, before all the crap I added below). +;; +;; Probably that crap should either be fixed up so it works better, +;; or tossed away. +;; +;; I think that lazy-lock v2 tries to do something similar. +;; Those efforts should be merged. + +;; Called when any modification is made to buffer text. +;(defun font-lock-after-change-function (beg end old-len) +; (save-excursion +; (save-match-data +; ;; Rescan between start of line from `beg' and start of line after `end'. +; (font-lock-fontify-region +; (progn (goto-char beg) (beginning-of-line) (point)) +; (progn (goto-char end) (forward-line 1) (point)))))) + +(defvar font-lock-old-extent nil) +(defvar font-lock-old-len 0) + +(defun font-lock-fontify-glumped-region () + ;; even if something goes wrong in the fontification, mark the glumped + ;; region as fontified; otherwise, the same error might get signaled + ;; after every command. + (unwind-protect + ;; buffer may be deleted. + (if (buffer-live-p (extent-object font-lock-old-extent)) + (save-excursion + (set-buffer (extent-object font-lock-old-extent)) + (font-lock-after-change-function-1 + (extent-start-position font-lock-old-extent) + (extent-end-position font-lock-old-extent) + font-lock-old-len))) + (detach-extent font-lock-old-extent) + (setq font-lock-old-extent nil))) + +(defun font-lock-pre-idle-hook () + (condition-case nil + (if font-lock-old-extent + (font-lock-fontify-glumped-region)) + (error (warn "Error caught in `font-lock-pre-idle-hook'")))) + +(defvar font-lock-always-fontify-immediately nil + "Set this to non-nil to disable font-lock deferral.") + +;;; called when any modification is made to buffer text. This function +;;; attempts to glump adjacent changes together so that excessive +;;; fontification is avoided. This function could easily be adapted +;;; to other after-change-functions. + +(defun font-lock-after-change-function (beg end old-len) + (let ((obeg (and font-lock-old-extent + (extent-start-position font-lock-old-extent))) + (oend (and font-lock-old-extent + (extent-end-position font-lock-old-extent))) + (bc-end (+ beg old-len))) + + ;; If this change can't be merged into the glumped one, + ;; we need to fontify the glumped one right now. + (if (and font-lock-old-extent + (or (not (eq (current-buffer) + (extent-object font-lock-old-extent))) + (< bc-end obeg) + (> beg oend))) + (font-lock-fontify-glumped-region)) + + (if font-lock-old-extent + ;; Update glumped region. + (progn + ;; Any characters in the before-change region that are + ;; outside the glumped region go into the glumped + ;; before-change region. + (if (> bc-end oend) + (setq font-lock-old-len (+ font-lock-old-len (- bc-end oend)))) + (if (> obeg beg) + (setq font-lock-old-len (+ font-lock-old-len (- obeg beg)))) + ;; New glumped region is the union of the glumped region + ;; and the new region. + (set-extent-endpoints font-lock-old-extent + (min obeg beg) + (max oend end))) + + ;; No glumped region, so create one. + (setq font-lock-old-extent (make-extent beg end)) + (set-extent-property font-lock-old-extent 'detachable nil) + (set-extent-property font-lock-old-extent 'end-open nil) + (setq font-lock-old-len old-len)) + + (if font-lock-always-fontify-immediately + (font-lock-fontify-glumped-region)))) + +(defun font-lock-after-change-function-1 (beg end old-len) + (if (null font-lock-mode) + nil + (save-excursion + (save-restriction + ;; if we don't widen, then fill-paragraph (and any command that + ;; operates on a narrowed region) confuses things, because the C + ;; code will fail to realize that we're inside a comment. + (widen) + (save-match-data + (let ((zmacs-region-stays zmacs-region-stays)) ; protect from change! + (goto-char beg) + ;; Maybe flush the internal cache used by syntactically-sectionize. + ;; (It'd be nice if this was more automatic.) Any deletions mean + ;; the cache is invalid, and insertions at beginning or end of line + ;; mean that the bol cache might be invalid. +;; (if (or (> old-len 0) (bobp) (= (preceding-char) ?\n)) +;; (buffer-syntactic-context-flush-cache)) + + ;; Always recompute the whole line. + (goto-char end) + (forward-line 1) + (setq end (point)) + (goto-char beg) + (beginning-of-line) + (setq beg (point)) + ;; Rescan between start of line from `beg' and start of line after + ;; `end'. + (font-lock-fontify-region beg end))))))) + + +;; Syntactic fontification functions. + +;; Note: Here is the FSF version. Our version is much faster because +;; of the C support we provide. This may be useful for reference, +;; however, and perhaps there is something useful here that should +;; be merged into our version. +;; +;(defun font-lock-fontify-syntactically-region (start end &optional loudly) +; "Put proper face on each string and comment between START and END. +;START should be at the beginning of a line." +; (let ((synstart (if comment-start-skip +; (concat "\\s\"\\|" comment-start-skip) +; "\\s\"")) +; (comstart (if comment-start-skip +; (concat "\\s<\\|" comment-start-skip) +; "\\s<")) +; state prev prevstate) +; (if loudly (message "Fontifying %s... (syntactically...)" (buffer-name))) +; (save-restriction +; (widen) +; (goto-char start) +; ;; +; ;; Find the state at the `beginning-of-line' before `start'. +; (if (eq start font-lock-cache-position) +; ;; Use the cache for the state of `start'. +; (setq state font-lock-cache-state) +; ;; Find the state of `start'. +; (if (null font-lock-beginning-of-syntax-function) +; ;; Use the state at the previous cache position, if any, or +; ;; otherwise calculate from `point-min'. +; (if (or (null font-lock-cache-position) +; (< start font-lock-cache-position)) +; (setq state (parse-partial-sexp (point-min) start)) +; (setq state (parse-partial-sexp font-lock-cache-position start +; nil nil font-lock-cache-state))) +; ;; Call the function to move outside any syntactic block. +; (funcall font-lock-beginning-of-syntax-function) +; (setq state (parse-partial-sexp (point) start))) +; ;; Cache the state and position of `start'. +; (setq font-lock-cache-state state +; font-lock-cache-position start)) +; ;; +; ;; If the region starts inside a string, show the extent of it. +; (if (nth 3 state) +; (let ((beg (point))) +; (while (and (re-search-forward "\\s\"" end 'move) +; (nth 3 (parse-partial-sexp beg (point) +; nil nil state)))) +; (put-text-property beg (point) 'face font-lock-string-face) +; (setq state (parse-partial-sexp beg (point) nil nil state)))) +; ;; +; ;; Likewise for a comment. +; (if (or (nth 4 state) (nth 7 state)) +; (let ((beg (point))) +; (save-restriction +; (narrow-to-region (point-min) end) +; (condition-case nil +; (progn +; (re-search-backward comstart (point-min) 'move) +; (forward-comment 1) +; ;; forward-comment skips all whitespace, +; ;; so go back to the real end of the comment. +; (skip-chars-backward " \t")) +; (error (goto-char end)))) +; (put-text-property beg (point) 'face font-lock-comment-face) +; (setq state (parse-partial-sexp beg (point) nil nil state)))) +; ;; +; ;; Find each interesting place between here and `end'. +; (while (and (< (point) end) +; (setq prev (point) prevstate state) +; (re-search-forward synstart end t) +; (progn +; ;; Clear out the fonts of what we skip over. +; (remove-text-properties prev (point) '(face nil)) +; ;; Verify the state at that place +; ;; so we don't get fooled by \" or \;. +; (setq state (parse-partial-sexp prev (point) +; nil nil state)))) +; (let ((here (point))) +; (if (or (nth 4 state) (nth 7 state)) +; ;; +; ;; We found a real comment start. +; (let ((beg (match-beginning 0))) +; (goto-char beg) +; (save-restriction +; (narrow-to-region (point-min) end) +; (condition-case nil +; (progn +; (forward-comment 1) +; ;; forward-comment skips all whitespace, +; ;; so go back to the real end of the comment. +; (skip-chars-backward " \t")) +; (error (goto-char end)))) +; (put-text-property beg (point) 'face +; font-lock-comment-face) +; (setq state (parse-partial-sexp here (point) nil nil state))) +; (if (nth 3 state) +; ;; +; ;; We found a real string start. +; (let ((beg (match-beginning 0))) +; (while (and (re-search-forward "\\s\"" end 'move) +; (nth 3 (parse-partial-sexp here (point) +; nil nil state)))) +; (put-text-property beg (point) 'face font-lock-string-face) +; (setq state (parse-partial-sexp here (point) +; nil nil state)))))) +; ;; +; ;; Make sure `prev' is non-nil after the loop +; ;; only if it was set on the very last iteration. +; (setq prev nil))) +; ;; +; ;; Clean up. +; (and prev (remove-text-properties prev end '(face nil))))) + +(defun font-lock-fontify-syntactically-region (start end &optional loudly) + "Put proper face on each string and comment between START and END. +START should be at the beginning of a line." + (if font-lock-keywords-only + nil + (if (and font-lock-verbose + (>= (- end start) font-lock-message-threshold)) + (display-message + 'progress + (format "Fontifying %s... (syntactically...)" (buffer-name)))) + (font-lock-unfontify-region start end loudly) + (goto-char start) + (if (> end (point-max)) (setq end (point-max))) + (syntactically-sectionize + #'(lambda (s e context depth) + (let (face) + (cond ((eq context 'string) + ;;#### Should only do this is Lisp-like modes! + (setq face + (if (= depth 1) + ;; really we should only use this if + ;; in position 3 depth 1, but that's + ;; too expensive to compute. + 'font-lock-doc-string-face + 'font-lock-string-face))) + ((or (eq context 'comment) + (eq context 'block-comment)) + (setq face 'font-lock-comment-face) +; ;; Don't fontify whitespace at the beginning of lines; +; ;; otherwise comment blocks may not line up with code. +; ;; (This is sometimes a good idea, sometimes not; in any +; ;; event it should be in C for speed --jwz) +; (save-excursion +; (goto-char s) +; (while (prog1 (search-forward "\n" (1- e) 'move) +; (setq face 'font-lock-comment-face) +; (setq e (point))) +; (skip-chars-forward " \t\n") +; (setq s (point))) + )) + (font-lock-set-face s e face))) + start end) + )) + +;;; Additional text property functions. + +;; The following three text property functions are not generally available (and +;; it's not certain that they should be) so they are inlined for speed. +;; The case for `fillin-text-property' is simple; it may or not be generally +;; useful. (Since it is used here, it is useful in at least one place.;-) +;; However, the case for `append-text-property' and `prepend-text-property' is +;; more complicated. Should they remove duplicate property values or not? If +;; so, should the first or last duplicate item remain? Or the one that was +;; added? In our implementation, the first duplicate remains. + +;; XEmacs: modified all these functions to use +;; `put-nonduplicable-text-property' instead of `put-text-property', and +;; the first one to take both SETPROP and MARKPROP, in accordance with the +;; changed definitions of `font-lock-any-faces-p' and `font-lock-set-face'. + +(defsubst font-lock-fillin-text-property (start end setprop markprop value &optional object) + "Fill in one property of the text from START to END. +Arguments PROP and VALUE specify the property and value to put where none are +already in place. Therefore existing property values are not overwritten. +Optional argument OBJECT is the string or buffer containing the text." + (let ((start (text-property-any start end markprop nil object)) next) + (while start + (setq next (next-single-property-change start markprop object end)) + (put-nonduplicable-text-property start next setprop value object) + (put-nonduplicable-text-property start next markprop value object) + (setq start (text-property-any next end markprop nil object))))) + +;; This function (from simon's unique.el) is rewritten and inlined for speed. +;(defun unique (list function) +; "Uniquify LIST, deleting elements using FUNCTION. +;Return the list with subsequent duplicate items removed by side effects. +;FUNCTION is called with an element of LIST and a list of elements from LIST, +;and should return the list of elements with occurrences of the element removed, +;i.e., a function such as `delete' or `delq'. +;This function will work even if LIST is unsorted. See also `uniq'." +; (let ((list list)) +; (while list +; (setq list (setcdr list (funcall function (car list) (cdr list)))))) +; list) + +(defsubst font-lock-unique (list) + "Uniquify LIST, deleting elements using `delq'. +Return the list with subsequent duplicate items removed by side effects." + (let ((list list)) + (while list + (setq list (setcdr list (delq (car list) (cdr list)))))) + list) + +;; A generalisation of `facemenu-add-face' for any property, but without the +;; removal of inactive faces via `facemenu-discard-redundant-faces' and special +;; treatment of `default'. Uses `unique' to remove duplicate property values. +(defsubst font-lock-prepend-text-property (start end prop value &optional object) + "Prepend to one property of the text from START to END. +Arguments PROP and VALUE specify the property and value to prepend to the value +already in place. The resulting property values are always lists, and unique. +Optional argument OBJECT is the string or buffer containing the text." + (let ((val (if (listp value) value (list value))) next prev) + (while (/= start end) + (setq next (next-single-property-change start prop object end) + prev (get-text-property start prop object)) + (put-text-property + start next prop + (font-lock-unique (append val (if (listp prev) prev (list prev)))) + object) + (setq start next)))) + +(defsubst font-lock-append-text-property (start end prop value &optional object) + "Append to one property of the text from START to END. +Arguments PROP and VALUE specify the property and value to append to the value +already in place. The resulting property values are always lists, and unique. +Optional argument OBJECT is the string or buffer containing the text." + (let ((val (if (listp value) value (list value))) next prev) + (while (/= start end) + (setq next (next-single-property-change start prop object end) + prev (get-text-property start prop object)) + (put-text-property + start next prop + (font-lock-unique (append (if (listp prev) prev (list prev)) val)) + object) + (setq start next)))) + +;;; Regexp fontification functions. + +(defsubst font-lock-apply-highlight (highlight) + "Apply HIGHLIGHT following a match. +HIGHLIGHT should be of the form MATCH-HIGHLIGHT, see `font-lock-keywords'." + (let* ((match (nth 0 highlight)) + (start (match-beginning match)) (end (match-end match)) + (override (nth 2 highlight))) + (let ((newface (nth 1 highlight))) + (or (symbolp newface) + (setq newface (eval newface))) + (cond ((not start) + ;; No match but we might not signal an error. + (or (nth 3 highlight) + (error "No match %d in highlight %S" match highlight))) + ((= start end) nil) + ((not override) + ;; Cannot override existing fontification. + (or (font-lock-any-faces-p start end) + (font-lock-set-face start end newface))) + ((eq override t) + ;; Override existing fontification. + (font-lock-set-face start end newface)) + ((eq override 'keep) + ;; Keep existing fontification. + (font-lock-fillin-text-property start end 'face 'font-lock + newface)) + ((eq override 'prepend) + ;; Prepend to existing fontification. + (font-lock-prepend-text-property start end 'face newface)) + ((eq override 'append) + ;; Append to existing fontification. + (font-lock-append-text-property start end 'face newface)))))) + +(defsubst font-lock-fontify-anchored-keywords (keywords limit) + "Fontify according to KEYWORDS until LIMIT. +KEYWORDS should be of the form MATCH-ANCHORED, see `font-lock-keywords', +LIMIT can be modified by the value of its PRE-MATCH-FORM." + (let ((matcher (nth 0 keywords)) (lowdarks (nthcdr 3 keywords)) highlights + ;; Evaluate PRE-MATCH-FORM. + (pre-match-value (eval (nth 1 keywords)))) + ;; Set LIMIT to value of PRE-MATCH-FORM or the end of line. + (if (and (numberp pre-match-value) (> pre-match-value (point))) + (setq limit pre-match-value) + (save-excursion (end-of-line) (setq limit (point)))) + (save-match-data + ;; Find an occurrence of `matcher' before `limit'. + (while (if (stringp matcher) + (re-search-forward matcher limit t) + (funcall matcher limit)) + ;; Apply each highlight to this instance of `matcher'. + (setq highlights lowdarks) + (while highlights + (font-lock-apply-highlight (car highlights)) + (setq highlights (cdr highlights))))) + ;; Evaluate POST-MATCH-FORM. + (eval (nth 2 keywords)))) + +(defun font-lock-fontify-keywords-region (start end &optional loudvar) + "Fontify according to `font-lock-keywords' between START and END. +START should be at the beginning of a line." + (let ((loudly (and font-lock-verbose + (>= (- end start) font-lock-message-threshold)))) + (let ((case-fold-search font-lock-keywords-case-fold-search) + (keywords (cdr (if (eq (car-safe font-lock-keywords) t) + font-lock-keywords + (font-lock-compile-keywords)))) + (bufname (buffer-name)) (count 0) + keyword matcher highlights) + ;; + ;; Fontify each item in `font-lock-keywords' from `start' to `end'. + (while keywords + (if loudly (display-message + 'progress + (format "Fontifying %s... (regexps..%s)" bufname + (make-string (setq count (1+ count)) ?.)))) + ;; + ;; Find an occurrence of `matcher' from `start' to `end'. + (setq keyword (car keywords) matcher (car keyword)) + (goto-char start) + (while (and (< (point) end) + (if (stringp matcher) + (re-search-forward matcher end t) + (funcall matcher end))) + ;; Apply each highlight to this instance of `matcher', which may be + ;; specific highlights or more keywords anchored to `matcher'. + (setq highlights (cdr keyword)) + (while highlights + (if (numberp (car (car highlights))) + (let ((end (match-end (car (car highlights))))) + (font-lock-apply-highlight (car highlights)) + ;; restart search just after the end of the + ;; keyword so keywords can share bracketing + ;; expressions. + (and end (goto-char end))) + (font-lock-fontify-anchored-keywords (car highlights) end)) + (setq highlights (cdr highlights)))) + (setq keywords (cdr keywords)))) + (if loudly (display-message + 'progress + (format "Fontifying %s... done." (buffer-name)))))) + + +;; Various functions. + +;; Turn off other related packages if they're on. I prefer a hook. --sm. +;; These explicit calls are easier to understand +;; because people know what they will do. +;; A hook is a mystery because it might do anything whatever. --rms. +(defun font-lock-thing-lock-cleanup () + (cond ((and (boundp 'fast-lock-mode) fast-lock-mode) + (fast-lock-mode -1)) + ((and (boundp 'lazy-lock-mode) lazy-lock-mode) + (lazy-lock-mode -1)) + ((and (boundp 'lazy-shot-mode) lazy-shot-mode) + (lazy-shot-mode -1)))) + +;; Do something special for these packages after fontifying. I prefer a hook. +(defun font-lock-after-fontify-buffer () + (cond ((and (boundp 'fast-lock-mode) fast-lock-mode) + (fast-lock-after-fontify-buffer)) + ((and (boundp 'lazy-lock-mode) lazy-lock-mode) + (lazy-lock-after-fontify-buffer)))) + +;; If the buffer is about to be reverted, it won't be fontified afterward. +(defun font-lock-revert-setup () + (setq font-lock-fontified nil)) + +;; If the buffer has just been reverted, normally that turns off +;; Font Lock mode. So turn the mode back on if necessary. +(defalias 'font-lock-revert-cleanup 'turn-on-font-lock) + + +(defun font-lock-compile-keywords (&optional keywords) + ;; Compile `font-lock-keywords' into the form (t KEYWORD ...) where KEYWORD + ;; is the (MATCHER HIGHLIGHT ...) shown in the variable's doc string. + (let ((keywords (or keywords font-lock-keywords))) + (setq font-lock-keywords + (if (eq (car-safe keywords) t) + keywords + (cons t (mapcar 'font-lock-compile-keyword keywords)))))) + +(defun font-lock-compile-keyword (keyword) + (cond ((nlistp keyword) ; Just MATCHER + (list keyword '(0 font-lock-keyword-face))) + ((eq (car keyword) 'eval) ; Specified (eval . FORM) + (font-lock-compile-keyword (eval (cdr keyword)))) + ((numberp (cdr keyword)) ; Specified (MATCHER . MATCH) + (list (car keyword) (list (cdr keyword) 'font-lock-keyword-face))) + ((symbolp (cdr keyword)) ; Specified (MATCHER . FACENAME) + (list (car keyword) (list 0 (cdr keyword)))) + ((nlistp (nth 1 keyword)) ; Specified (MATCHER . HIGHLIGHT) + (list (car keyword) (cdr keyword))) + (t ; Hopefully (MATCHER HIGHLIGHT ...) + keyword))) + +(defun font-lock-choose-keywords (keywords level) + ;; Return LEVELth element of KEYWORDS. A LEVEL of nil is equal to a + ;; LEVEL of 0, a LEVEL of t is equal to (1- (length KEYWORDS)). + (let ((level (if (not (consp level)) + level + (cdr (or (assq major-mode level) (assq t level)))))) + (cond ((symbolp keywords) + keywords) + ((numberp level) + (or (nth level keywords) (car (reverse keywords)))) + ((eq level t) + (car (reverse keywords))) + (t + (car keywords))))) + + +;;; Determining which set of font-lock keywords to use. + +(defun font-lock-find-font-lock-defaults (modesym) + ;; Get the defaults based on the major mode. + (let (raw-defaults) + ;; I want a do-while loop! + (while (progn + (setq raw-defaults (get modesym 'font-lock-defaults)) + (and raw-defaults (symbolp raw-defaults) + (setq modesym raw-defaults))) + ) + raw-defaults)) + +(defun font-lock-examine-syntax-table () + ; Computes the value of font-lock-keywords-only for this buffer. + (if (eq (syntax-table) (standard-syntax-table)) + ;; Assume that modes which haven't bothered to install their own + ;; syntax table don't do anything syntactically interesting. + ;; Really, the standard-syntax-table shouldn't have comments and + ;; strings in it, but changing that now might break things. + nil + ;; else map over the syntax table looking for strings or comments. + (let (got-one) + ;; XEmacs 20.0 ... + (if (fboundp 'map-syntax-table) + (setq got-one + (map-syntax-table + #'(lambda (key value) + (memq (char-syntax-from-code value) + '(?\" ?\< ?\> ?\$))) + (syntax-table))) + ;; older Emacsen. + (let ((i (1- (length (syntax-table))))) + (while (>= i 0) + (if (memq (char-syntax i) '(?\" ?\< ?\> ?\$)) + (setq got-one t i 0)) + (setq i (1- i))))) + (set (make-local-variable 'font-lock-keywords-only) (not got-one))))) + +;; font-lock-set-defaults is in fontl-hooks.el. + +;;;###autoload +(defun font-lock-set-defaults-1 (&optional explicit-defaults) + ;; does everything that font-lock-set-defaults does except + ;; enable font-lock-mode. This is called by `font-lock-mode'. + ;; Note that the return value is used! + + (if (and font-lock-defaults-computed (not explicit-defaults)) + ;; nothing to do. + nil + + (or font-lock-keywords + (let* ((defaults (or (and (not (eq t explicit-defaults)) + explicit-defaults) + ;; in case modes decide to set + ;; `font-lock-defaults' themselves, + ;; as in FSF Emacs. + font-lock-defaults + (font-lock-find-font-lock-defaults major-mode))) + (keywords (font-lock-choose-keywords + (nth 0 defaults) font-lock-maximum-decoration))) + + ;; Keywords? + (setq font-lock-keywords (if (fboundp keywords) + (funcall keywords) + (eval keywords))) + (or font-lock-keywords + ;; older way: + ;; try to look for a variable `foo-mode-font-lock-keywords', + ;; or similar. + (let ((major (symbol-name major-mode)) + (try #'(lambda (n) + (if (stringp n) (setq n (intern-soft n))) + (if (and n + (boundp n)) + n + nil)))) + (setq font-lock-keywords + (symbol-value + (or (funcall try (get major-mode 'font-lock-keywords)) + (funcall try (concat major "-font-lock-keywords")) + (funcall try (and (string-match "-mode\\'" major) + (concat (substring + major 0 + (match-beginning 0)) + "-font-lock-keywords"))) + 'font-lock-keywords))))) + + ;; Case fold? + (if (>= (length defaults) 3) + (setq font-lock-keywords-case-fold-search (nth 2 defaults)) + ;; older way: + ;; look for a property 'font-lock-keywords-case-fold-search on + ;; the major-mode symbol. + (let* ((nonexist (make-symbol "")) + (value (get major-mode 'font-lock-keywords-case-fold-search + nonexist))) + (if (not (eq nonexist value)) + (setq font-lock-keywords-case-fold-search value)))) + + ;; Syntactic? + (if (>= (length defaults) 2) + (setq font-lock-keywords-only (nth 1 defaults)) + ;; older way: + ;; cleverly examine the syntax table. + (font-lock-examine-syntax-table)) + + ;; Syntax table? + (if (nth 3 defaults) + (let ((slist (nth 3 defaults))) + (setq font-lock-syntax-table + (copy-syntax-table (syntax-table))) + (while slist + (modify-syntax-entry (car (car slist)) (cdr (car slist)) + font-lock-syntax-table) + (setq slist (cdr slist))))) + + ;; Syntax function? + (cond (defaults + (setq font-lock-beginning-of-syntax-function + (nth 4 defaults))) + (t + ;; older way: + ;; defaults not specified at all, so use `beginning-of-defun'. + (setq font-lock-beginning-of-syntax-function + 'beginning-of-defun))))) + + (setq font-lock-defaults-computed t))) + + +;;; Initialization of faces. + +(defconst font-lock-face-list + '(font-lock-comment-face + font-lock-doc-string-face + font-lock-string-face + font-lock-keyword-face + font-lock-function-name-face + font-lock-variable-name-face + font-lock-type-face + font-lock-reference-face + font-lock-preprocessor-face)) + +(defun font-lock-reset-face (face) + "Reset FACE its default state (from the X resource database). +Returns whether it is indistinguishable from the default face." + (reset-face face) + (init-face-from-resources face) + (face-differs-from-default-p face)) + +(defun font-lock-reset-all-faces () + (mapcar 'font-lock-reset-face font-lock-face-list)) + +(defun font-lock-add-fonts (tag-list) + ;; Underling comments looks terrible on tty's + (if (featurep 'tty) + (progn + (set-face-underline-p 'font-lock-comment-face nil 'global + (append '(tty) tag-list) 'append) + (set-face-highlight-p 'font-lock-comment-face t 'global + (append '(tty) tag-list) 'append))) + (set-face-font 'font-lock-comment-face [italic] 'global tag-list 'append) + (set-face-font 'font-lock-string-face [italic] 'global tag-list 'append) + (set-face-font 'font-lock-doc-string-face [italic] 'global tag-list 'append) + (set-face-font 'font-lock-function-name-face [bold] 'global tag-list 'append) + (set-face-font 'font-lock-variable-name-face [bold] 'global tag-list 'append) + (set-face-font 'font-lock-keyword-face [bold] 'global tag-list 'append) + (set-face-font 'font-lock-preprocessor-face [bold-italic] 'global tag-list + 'append) + (set-face-font 'font-lock-type-face [italic] 'global tag-list 'append) + (set-face-font 'font-lock-reference-face [bold] 'global tag-list 'append) + nil) + +(defun font-lock-add-colors (tag-list) + (set-face-foreground 'font-lock-comment-face "red" 'global tag-list 'append) + ;(set-face-font 'font-lock-comment-face [italic] 'global tag-list 'append) + (set-face-foreground 'font-lock-string-face "green4" 'global tag-list + 'append) + (set-face-foreground 'font-lock-string-face "green" 'global tag-list + 'append) + (set-face-foreground 'font-lock-doc-string-face "green4" 'global tag-list + 'append) + (set-face-foreground 'font-lock-doc-string-face "green" 'global tag-list + 'append) + (set-face-foreground 'font-lock-function-name-face "blue3" 'global tag-list + 'append) + (set-face-foreground 'font-lock-function-name-face "blue" 'global tag-list + 'append) + (set-face-foreground 'font-lock-variable-name-face "blue3" 'global tag-list + 'append) + (set-face-foreground 'font-lock-variable-name-face "blue" 'global tag-list + 'append) + (set-face-foreground 'font-lock-reference-face "red3" 'global + tag-list 'append) + (set-face-foreground 'font-lock-reference-face "red" 'global tag-list + 'append) + (set-face-foreground 'font-lock-keyword-face "orange" 'global tag-list + 'append) + ;(set-face-font 'font-lock-keyword-face [bold] 'global tag-list 'append) + (set-face-foreground 'font-lock-preprocessor-face "blue3" 'global tag-list + 'append) + (set-face-foreground 'font-lock-preprocessor-face "blue" 'global tag-list + 'append) + ;(set-face-font 'font-lock-preprocessor-face [bold] 'global tag-list 'append) + (set-face-foreground 'font-lock-type-face "#6920ac" 'global tag-list 'append) + nil) + +(defun font-lock-apply-defaults (function tag-list) + (if (and (listp tag-list) + (eq 'or (car tag-list))) + (mapcar #'(lambda (x) + (font-lock-apply-defaults function x)) + (cdr tag-list)) + (if tag-list + (if (not (valid-specifier-tag-set-p tag-list)) + (warn "Invalid tag set found: %s" tag-list) + (funcall function tag-list))))) + +(defun font-lock-recompute-variables () + ;; Is this a Draconian thing to do? + (mapcar #'(lambda (buffer) + (save-excursion + (set-buffer buffer) + (font-lock-mode 0) + (font-lock-set-defaults t))) + (buffer-list))) + +;; Backwards-compatible crud. + +(defun font-lock-use-default-fonts () + "Reset the font-lock faces to a default set of fonts." + (interactive) + (font-lock-reset-all-faces) + (font-lock-add-fonts nil)) + +(defun font-lock-use-default-colors () + "Reset the font-lock faces to a default set of colors." + (interactive) + (font-lock-reset-all-faces) + (font-lock-add-colors nil)) + +(defun font-lock-use-default-minimal-decoration () + "Reset the font-lock patterns to a fast, minimal set of decorations." + (and font-lock-maximum-decoration + (setq font-lock-maximum-decoration nil) + (font-lock-recompute-variables))) + +(defun font-lock-use-default-maximal-decoration () + "Reset the font-lock patterns to a larger set of decorations." + (and (not (eq t font-lock-maximum-decoration)) + (setq font-lock-maximum-decoration t) + (font-lock-recompute-variables))) + + +;;;;;;;;;;;;;;;;;;;;;; keywords ;;;;;;;;;;;;;;;;;;;;;; + +;;; Various major-mode interfaces. +;;; Probably these should go in with the source of the respective major modes. + +;; The defaults and keywords listed here should perhaps be moved into +;; mode-specific files. + +;; For C and Lisp modes we use `beginning-of-defun', rather than nil, +;; for SYNTAX-BEGIN. Thus the calculation of the cache is usually +;; faster but not infallible, so we risk mis-fontification. --sm. + +(put 'c-mode 'font-lock-defaults + '((c-font-lock-keywords + c-font-lock-keywords-1 c-font-lock-keywords-2 c-font-lock-keywords-3) + nil nil ((?_ . "w")) beginning-of-defun)) +(put 'c++-c-mode 'font-lock-defaults 'c-mode) +(put 'elec-c-mode 'font-lock-defaults 'c-mode) + +(put 'c++-mode 'font-lock-defaults + '((c++-font-lock-keywords + c++-font-lock-keywords-1 c++-font-lock-keywords-2 + c++-font-lock-keywords-3) + nil nil ((?_ . "w") (?~ . "w")) beginning-of-defun)) + +(put 'java-mode 'font-lock-defaults + '((java-font-lock-keywords + java-font-lock-keywords-1 java-font-lock-keywords-2 + java-font-lock-keywords-3) + nil nil ((?_ . "w")) beginning-of-defun + (font-lock-mark-block-function . mark-defun))) + +(put 'lisp-mode 'font-lock-defaults + '((lisp-font-lock-keywords + lisp-font-lock-keywords-1 lisp-font-lock-keywords-2) + nil nil + ((?: . "w") (?- . "w") (?* . "w") (?+ . "w") (?. . "w") (?< . "w") + (?> . "w") (?= . "w") (?! . "w") (?? . "w") (?$ . "w") (?% . "w") + (?_ . "w") (?& . "w") (?~ . "w") (?^ . "w") (?/ . "w")) + beginning-of-defun)) +(put 'emacs-lisp-mode 'font-lock-defaults 'lisp-mode) +(put 'lisp-interaction-mode 'font-lock-defaults 'lisp-mode) + +(put 'scheme-mode 'font-lock-defaults + '(scheme-font-lock-keywords + nil t + ((?: . "w") (?- . "w") (?* . "w") (?+ . "w") (?. . "w") (?< . "w") + (?> . "w") (?= . "w") (?! . "w") (?? . "w") (?$ . "w") (?% . "w") + (?_ . "w") (?& . "w") (?~ . "w") (?^ . "w") (?/ . "w")) + beginning-of-defun)) +(put 'inferior-scheme-mode 'font-lock-defaults 'scheme-mode) +(put 'scheme-interaction-mode 'font-lock-defaults 'scheme-mode) + +(put 'tex-mode 'font-lock-defaults + ;; For TeX modes we could use `backward-paragraph' for the same reason. + '(tex-font-lock-keywords nil nil ((?$ . "\"")))) +;; the nine billion names of TeX mode... +(put 'bibtex-mode 'font-lock-defaults 'tex-mode) +(put 'plain-tex-mode 'font-lock-defaults 'tex-mode) +(put 'slitex-tex-mode 'font-lock-defaults 'tex-mode) +(put 'SliTeX-mode 'font-lock-defaults 'tex-mode) +(put 'slitex-mode 'font-lock-defaults 'tex-mode) +(put 'latex-tex-mode 'font-lock-defaults 'tex-mode) +(put 'LaTex-tex-mode 'font-lock-defaults 'tex-mode) +(put 'latex-mode 'font-lock-defaults 'tex-mode) +(put 'LaTeX-mode 'font-lock-defaults 'tex-mode) +(put 'japanese-LaTeX-mode 'font-lock-defaults 'tex-mode) +(put 'japanese-SliTeX-mode 'font-lock-defaults 'tex-mode) +(put 'FoilTeX-mode 'font-lock-defaults 'tex-mode) +(put 'LATeX-MoDe 'font-lock-defaults 'tex-mode) +(put 'lATEx-mODe 'font-lock-defaults 'tex-mode) +;; ok, this is getting a bit silly ... +(put 'eDOm-xETAl 'font-lock-defaults 'tex-mode) + +;;; Various regexp information shared by several modes. +;;; Information specific to a single mode should go in its load library. + +(defconst lisp-font-lock-keywords-1 + (list + ;; Anything not a variable or type declaration is fontified as a function. + ;; It would be cleaner to allow preceding whitespace, but it would also be + ;; about five times slower. + (list (concat "^(\\(def\\(" + ;; Variable declarations. + "\\(const\\(\\|ant\\)\\|ine-key\\(\\|-after\\)\\|var\\)\\|" + ;; Structure declarations. + "\\(class\\|struct\\|type\\)\\|" + ;; Everything else is a function declaration. + "\\([^ \t\n\(\)]+\\)" + "\\)\\)\\>" + ;; Any whitespace and declared object. + "[ \t'\(]*" + "\\([^ \t\n\)]+\\)?") + '(1 font-lock-keyword-face) + '(8 (cond ((match-beginning 3) 'font-lock-variable-name-face) + ((match-beginning 6) 'font-lock-type-face) + (t 'font-lock-function-name-face)) + nil t)) + ) + "Subdued level highlighting Lisp modes.") + +(defconst lisp-font-lock-keywords-2 + (append lisp-font-lock-keywords-1 + (list + ;; + ;; Control structures. ELisp and CLisp combined. + ;; + ;;(regexp-opt + ;; '("cond" "if" "while" "let" "let*" "prog" "progn" "prog1" + ;; "prog2" "progv" "catch" "throw" "save-restriction" + ;; "save-excursion" "save-window-excursion" + ;; "save-current-buffer" "with-current-buffer" + ;; "with-temp-file" "with-temp-buffer" "with-output-to-string" + ;; "with-string-as-buffer-contents" + ;; "save-selected-window" "save-match-data" "unwind-protect" + ;; "condition-case" "track-mouse" "autoload" + ;; "eval-after-load" "eval-and-compile" "eval-when-compile" + ;; "when" "unless" "do" "dolist" "dotimes" "flet" "labels" + ;; "lambda" "return" "return-from")) + (cons + (concat + "(\\(" + "autoload\\|c\\(atch\\|ond\\(ition-case\\)?\\)\\|do\\(list\\|" + "times\\)?\\|eval-\\(a\\(fter-load\\|nd-compile\\)\\|when-compile\\)\\|" + "flet\\|if\\|l\\(a\\(bels\\|mbda\\)\\|et\\*?\\)\\|" + "prog[nv12\\*]?\\|return\\(-from\\)?\\|save-\\(current-buffer\\|" + "excursion\\|match-data\\|restriction\\|selected-window\\|" + "window-excursion\\)\\|t\\(hrow\\|rack-mouse\\)\\|un\\(less\\|" + "wind-protect\\)\\|w\\(h\\(en\\|ile\\)\\|ith-\\(current-buffer\\|" + "output-to-string\\|string-as-buffer-contents\\|temp-\\(buffer\\|" + "file\\)\\)\\)" + "\\)\\>") 1) + ;; + ;; Words inside \\[] tend to be for `substitute-command-keys'. + '("\\\\\\\\\\[\\(\\sw+\\)]" 1 font-lock-reference-face prepend) + ;; + ;; Words inside `' tend to be symbol names. + '("`\\(\\sw\\sw+\\)'" 1 font-lock-reference-face prepend) + ;; + ;; CLisp `:' keywords as references. + '("\\<:\\sw+\\>" 0 font-lock-reference-face prepend) + ;; + ;; ELisp and CLisp `&' keywords as types. + '("\\<\\&\\(optional\\|rest\\|whole\\)\\>" . font-lock-type-face) + )) + "Gaudy level highlighting for Lisp modes.") + +(defvar lisp-font-lock-keywords lisp-font-lock-keywords-1 + "Default expressions to highlight in Lisp modes.") + +;; The previous version, before replacing it with the FSF version. +;(defconst lisp-font-lock-keywords-1 (purecopy +; '(;; +; ;; highlight defining forms. This doesn't work too nicely for +; ;; (defun (setf foo) ...) but it does work for (defvar foo) which +; ;; is more important. +; ("^(def[-a-z]+\\s +\\([^ \t\n\)]+\\)" 1 font-lock-function-name-face) +; ;; +; ;; highlight CL keywords (three clauses seems faster than one) +; ("\\s :\\(\\(\\sw\\|\\s_\\)+\\)\\>" . 1) +; ("(:\\(\\(\\sw\\|\\s_\\)+\\)\\>" . 1) +; ("':\\(\\(\\sw\\|\\s_\\)+\\)\\>" . 1) +; ;; +; ;; this is highlights things like (def* (setf foo) (bar baz)), but may +; ;; be slower (I haven't really thought about it) +;; ("^(def[-a-z]+\\s +\\(\\s(\\S)*\\s)\\|\\S(\\S *\\)" +;; 1 font-lock-function-name-face) +; )) +; "For consideration as a value of `lisp-font-lock-keywords'. +;This does fairly subdued highlighting.") +; +;(defconst lisp-font-lock-keywords-2 (purecopy +; (append lisp-font-lock-keywords-1 +; '(;; +; ;; Highlight control structures +; ("(\\(cond\\|if\\|when\\|unless\\|[ec]?\\(type\\)?case\\)[ \t\n]" . 1) +; ("(\\(while\\|do\\|let\\*?\\|flet\\|labels\\|prog[nv12*]?\\)[ \t\n]" . 1) +; ("(\\(do\\*\\|dotimes\\|dolist\\|loop\\)[ \t\n]" . 1) +; ("(\\(catch\\|\\throw\\|block\\|return\\|return-from\\)[ \t\n]" . 1) +; ("(\\(save-restriction\\|save-window-restriction\\)[ \t\n]" . 1) +; ("(\\(save-excursion\\|unwind-protect\\|condition-case\\)[ \t\n]" . 1) +; ;; +; ;; highlight function names in emacs-lisp docstrings (in the syntax +; ;; that substitute-command-keys understands.) +; ("\\\\\\\\\\[\\([^]\\\n]+\\)]" 1 font-lock-keyword-face t) +; ;; +; ;; highlight words inside `' which tend to be function names +; ("`\\([-a-zA-Z0-9_][-a-zA-Z0-9_][-a-zA-Z0-9_.]+\\)'" +; 1 font-lock-keyword-face t) +; ))) +; "For consideration as a value of `lisp-font-lock-keywords'. +; +;This does a lot more highlighting.") + +(defvar scheme-font-lock-keywords + (eval-when-compile + (list + ;; + ;; Declarations. Hannes Haug says + ;; this works for SOS, STklos, SCOOPS, Meroon and Tiny CLOS. + (list (concat "(\\(define\\(" + ;; Function names. + "\\(\\|-\\(generic\\(\\|-procedure\\)\\|method\\)\\)\\|" + ;; Macro names, as variable names. A bit dubious, this. + "\\(-syntax\\)\\|" + ;; Class names. + "\\(-class\\)" + "\\)\\)\\>" + ;; Any whitespace and declared object. + "[ \t]*(?" + "\\(\\sw+\\)?") + '(1 font-lock-keyword-face) + '(8 (cond ((match-beginning 3) 'font-lock-function-name-face) + ((match-beginning 6) 'font-lock-variable-name-face) + (t 'font-lock-type-face)) + nil t)) + ;; + ;; Control structures. +;(regexp-opt '("begin" "call-with-current-continuation" "call/cc" +; "call-with-input-file" "call-with-output-file" "case" "cond" +; "do" "else" "for-each" "if" "lambda" +; "let\\*?" "let-syntax" "letrec" "letrec-syntax" +; ;; Hannes Haug wants: +; "and" "or" "delay" +; ;; Stefan Monnier says don't bother: +; ;;"quasiquote" "quote" "unquote" "unquote-splicing" +; "map" "syntax" "syntax-rules")) + (cons + (concat "(\\(" + "and\\|begin\\|c\\(a\\(ll\\(-with-\\(current-continuation\\|" + "input-file\\|output-file\\)\\|/cc\\)\\|se\\)\\|ond\\)\\|" + "d\\(elay\\|o\\)\\|else\\|for-each\\|if\\|" + "l\\(ambda\\|et\\(-syntax\\|\\*?\\|rec\\(\\|-syntax\\)\\)\\)\\|" + "map\\|or\\|syntax\\(\\|-rules\\)" + "\\)\\>") 1) + ;; + ;; David Fox for SOS/STklos class specifiers. + '("\\<<\\sw+>\\>" . font-lock-type-face) + ;; + ;; Scheme `:' keywords as references. + '("\\<:\\sw+\\>" . font-lock-reference-face) + )) +"Default expressions to highlight in Scheme modes.") + +;; The previous version, before replacing it with the FSF version. +;(defconst scheme-font-lock-keywords (purecopy +; '(("(define[ \t]+(?\\([^ \t\n\)]+\\)" 1 font-lock-function-name-face) +; ("(\\(cond\\|lambda\\|begin\\|if\\|else\\|case\\|do\\)[ \t\n]" . 1) +; ("(\\(\\|letrec\\|let\\*?\\|set!\\|and\\|or\\)[ \t\n]" . 1) +; ("(\\(quote\\|unquote\\|quasiquote\\|unquote-splicing\\)[ \t\n]" . 1) +; ("(\\(syntax\\|syntax-rules\\|define-syntax\\|let-syntax\\|letrec-syntax\\)[ \t\n]" . 1))) +; "Expressions to highlight in Scheme buffers.") + +(defconst c-font-lock-keywords-1 nil + "Subdued level highlighting for C modes.") + +(defconst c-font-lock-keywords-2 nil + "Medium level highlighting for C modes.") + +(defconst c-font-lock-keywords-3 nil + "Gaudy level highlighting for C modes.") + +(defconst c++-font-lock-keywords-1 nil + "Subdued level highlighting for C++ modes.") + +(defconst c++-font-lock-keywords-2 nil + "Medium level highlighting for C++ modes.") + +(defconst c++-font-lock-keywords-3 nil + "Gaudy level highlighting for C++ modes.") + +(defun font-lock-match-c++-style-declaration-item-and-skip-to-next (limit) + ;; Match, and move over, any declaration/definition item after point. + ;; The expect syntax of an item is "word" or "word::word", possibly ending + ;; with optional whitespace and a "(". Everything following the item (but + ;; belonging to it) is expected to by skip-able by `forward-sexp', and items + ;; are expected to be separated with a "," or ";". + (if (looking-at "[ \t*&]*\\(\\sw+\\)\\(::\\(\\sw+\\)\\)?[ \t]*\\((\\)?") + (save-match-data + (condition-case nil + (save-restriction + ;; Restrict to the end of line, currently guaranteed to be LIMIT. + (narrow-to-region (point-min) limit) + (goto-char (match-end 1)) + ;; Move over any item value, etc., to the next item. + (while (not (looking-at "[ \t]*\\([,;]\\|$\\)")) + (goto-char (or (scan-sexps (point) 1) (point-max)))) + (goto-char (match-end 0))) + (error t))))) + +(let ((c-keywords +; ("break" "continue" "do" "else" "for" "if" "return" "switch" "while") + "break\\|continue\\|do\\|else\\|for\\|if\\|return\\|switch\\|while") + (c-type-types +; ("auto" "extern" "register" "static" "typedef" "struct" "union" "enum" +; "signed" "unsigned" "short" "long" "int" "char" "float" "double" +; "void" "volatile" "const") + (concat "auto\\|c\\(har\\|onst\\)\\|double\\|e\\(num\\|xtern\\)\\|" + "float\\|int\\|long\\|register\\|" + "s\\(hort\\|igned\\|t\\(atic\\|ruct\\)\\)\\|typedef\\|" + "un\\(ion\\|signed\\)\\|vo\\(id\\|latile\\)")) ; 6 ()s deep. + (c++-keywords +; ("break" "continue" "do" "else" "for" "if" "return" "switch" "while" +; "asm" "catch" "delete" "new" "operator" "sizeof" "this" "throw" "try" +; "protected" "private" "public") + (concat "asm\\|break\\|c\\(atch\\|ontinue\\)\\|d\\(elete\\|o\\)\\|" + "else\\|for\\|if\\|new\\|" + "p\\(r\\(ivate\\|otected\\)\\|ublic\\)\\|return\\|" + "s\\(izeof\\|witch\\)\\|t\\(h\\(is\\|row\\)\\|ry\\)\\|while")) + (c++-type-types +; ("auto" "extern" "register" "static" "typedef" "struct" "union" "enum" +; "signed" "unsigned" "short" "long" "int" "char" "float" "double" +; "void" "volatile" "const" "class" "inline" "friend" "bool" +; "virtual" "complex" "template") + (concat "auto\\|bool\\|c\\(har\\|lass\\|o\\(mplex\\|nst\\)\\)\\|" + "double\\|e\\(num\\|xtern\\)\\|f\\(loat\\|riend\\)\\|" + "in\\(line\\|t\\)\\|long\\|register\\|" + "s\\(hort\\|igned\\|t\\(atic\\|ruct\\)\\)\\|" + "t\\(emplate\\|ypedef\\)\\|un\\(ion\\|signed\\)\\|" + "v\\(irtual\\|o\\(id\\|latile\\)\\)")) ; 11 ()s deep. + (ctoken "\\(\\sw\\|\\s_\\|[:~*&]\\)+") + ) + (setq c-font-lock-keywords-1 + (list + ;; + ;; These are all anchored at the beginning of line for speed. + ;; + ;; Fontify function name definitions (GNU style; without type on line). + + ;; In FSF this has the simpler definition of "\\sw+" for ctoken. + ;; I'm not sure if ours is more correct. + ;; This is a subset of the next rule, and is slower when present. --dmoore + ;; (list (concat "^\\(" ctoken "\\)[ \t]*(") 1 'font-lock-function-name-face) + ;; + ;; fontify the names of functions being defined. + ;; FSF doesn't have this but I think it should be fast for us because + ;; our regexp routines are more intelligent than FSF's about handling + ;; anchored-at-newline. (When I added this hack in regex.c, it halved + ;; the time to do the regexp phase of font-lock for a C file!) Not + ;; including this discriminates against those who don't follow the + ;; GNU coding style. --ben + ;; x?x?x?y?z should always be: (x(xx?)?)?y?z --dmoore + (list (concat + "^\\(" + "\\(" ctoken "[ \t]+\\)" ; type specs; there can be no + "\\(" + "\\(" ctoken "[ \t]+\\)" ; more than 3 tokens, right? + "\\(" ctoken "[ \t]+\\)" + "?\\)?\\)?" + "\\([*&]+[ \t]*\\)?" ; pointer + "\\(" ctoken "\\)[ \t]*(") ; name + 10 'font-lock-function-name-face) + ;; + ;; This is faster but not by much. I don't see why not. + ;(list (concat "^\\(" ctoken "\\)[ \t]*(") 1 'font-lock-function-name-face) + ;; + ;; Added next two; they're both jolly-good fastmatch candidates so + ;; should be fast. --ben + ;; + ;; Fontify structure names (in structure definition form). + (list (concat "^\\(typedef[ \t]+struct\\|struct\\|static[ \t]+struct\\)" + "[ \t]+\\(" ctoken "\\)[ \t]*\\(\{\\|$\\)") + 2 'font-lock-function-name-face) + ;; + ;; Fontify case clauses. This is fast because its anchored on the left. + '("case[ \t]+\\(\\(\\sw\\|\\s_\\)+\\)[ \t]+:". 1) + ;; + '("\\<\\(default\\):". 1) + ;; Fontify filenames in #include <...> preprocessor directives as strings. + '("^#[ \t]*include[ \t]+\\(<[^>\"\n]+>\\)" 1 font-lock-string-face) + ;; + ;; Fontify function macro names. + '("^#[ \t]*define[ \t]+\\(\\(\\sw+\\)(\\)" 2 font-lock-function-name-face) + ;; + ;; Fontify symbol names in #if ... defined preprocessor directives. + '("^#[ \t]*if\\>" + ("\\<\\(defined\\)\\>[ \t]*(?\\(\\sw+\\)?" nil nil + (1 font-lock-preprocessor-face) (2 font-lock-variable-name-face nil t))) + ;; + ;; Fontify symbol names in #elif ... defined preprocessor directives. + '("^#[ \t]*elif\\>" + ("\\<\\(defined\\)\\>[ \t]*(?\\(\\sw+\\)?" nil nil + (1 font-lock-preprocessor-face) (2 font-lock-variable-name-face nil t))) + ;; + ;; Fontify otherwise as symbol names, and the preprocessor directive names. + '("^\\(#[ \t]*[a-z]+\\)\\>[ \t]*\\(\\sw+\\)?" + (1 font-lock-preprocessor-face) (2 font-lock-variable-name-face nil t)) + )) + + (setq c-font-lock-keywords-2 + (append c-font-lock-keywords-1 + (list + ;; + ;; Simple regexps for speed. + ;; + ;; Fontify all type specifiers. + (cons (concat "\\<\\(" c-type-types "\\)\\>") 'font-lock-type-face) + ;; + ;; Fontify all builtin keywords (except case, default and goto; see below). + (cons (concat "\\<\\(" c-keywords "\\)\\>") 'font-lock-keyword-face) + ;; + ;; Fontify case/goto keywords and targets, and case default/goto tags. + '("\\<\\(case\\|goto\\)\\>[ \t]*\\([^ \t\n:;]+\\)?" + (1 font-lock-keyword-face) (2 font-lock-reference-face nil t)) + '("^[ \t]*\\(\\sw+\\)[ \t]*:" 1 font-lock-reference-face) + ))) + + (setq c-font-lock-keywords-3 + (append c-font-lock-keywords-2 + ;; + ;; More complicated regexps for more complete highlighting for types. + ;; We still have to fontify type specifiers individually, as C is so hairy. + (list + ;; + ;; Fontify all storage classes and type specifiers, plus their items. + (list (concat "\\<\\(" c-type-types "\\)\\>" + "\\([ \t*&]+\\sw+\\>\\)*") + ;; Fontify each declaration item. + '(font-lock-match-c++-style-declaration-item-and-skip-to-next + ;; Start with point after all type specifiers. + (goto-char (or (match-beginning 8) (match-end 1))) + ;; Finish with point after first type specifier. + (goto-char (match-end 1)) + ;; Fontify as a variable or function name. + (1 (if (match-beginning 4) + font-lock-function-name-face + font-lock-variable-name-face)))) + ;; + ;; Fontify structures, or typedef names, plus their items. + '("\\(}\\)[ \t*]*\\sw" + (font-lock-match-c++-style-declaration-item-and-skip-to-next + (goto-char (match-end 1)) nil + (1 (if (match-beginning 4) + font-lock-function-name-face + font-lock-variable-name-face)))) + ;; + ;; Fontify anything at beginning of line as a declaration or definition. + '("^\\(\\sw+\\)\\>\\([ \t*]+\\sw+\\>\\)*" + (1 font-lock-type-face) + (font-lock-match-c++-style-declaration-item-and-skip-to-next + (goto-char (or (match-beginning 2) (match-end 1))) nil + (1 (if (match-beginning 4) + font-lock-function-name-face + font-lock-variable-name-face)))) + ))) + + (setq c++-font-lock-keywords-1 + (append + ;; + ;; The list `c-font-lock-keywords-1' less that for function names. + ;; the simple function form regexp has been removed. --dmoore + ;;(cdr c-font-lock-keywords-1) + c-font-lock-keywords-1 + ;; + ;; Fontify function name definitions, possibly incorporating class name. + (list + '("^\\(\\sw+\\)\\(::\\(\\sw+\\)\\)?[ \t]*(" + (1 (if (match-beginning 2) + font-lock-type-face + font-lock-function-name-face)) + (3 (if (match-beginning 2) font-lock-function-name-face) nil t)) + ))) + + (setq c++-font-lock-keywords-2 + (append c++-font-lock-keywords-1 + (list + ;; + ;; The list `c-font-lock-keywords-2' for C++ plus operator overloading. + (cons (concat "\\<\\(" c++-type-types "\\)\\>") 'font-lock-type-face) + ;; + ;; Fontify operator function name overloading. + '("\\<\\(operator\\)\\>[ \t]*\\([][)(>[ \t]*\\([^ \t\n:;]+\\)?" + (1 font-lock-keyword-face) (2 font-lock-reference-face nil t)) + '("^[ \t]*\\(\\sw+\\)[ \t]*:[^:]" 1 font-lock-reference-face) + ;; + ;; Fontify other builtin keywords. + (cons (concat "\\<\\(" c++-keywords "\\)\\>") 'font-lock-keyword-face) + ))) + + (setq c++-font-lock-keywords-3 + (append c++-font-lock-keywords-2 + ;; + ;; More complicated regexps for more complete highlighting for types. + (list + ;; + ;; Fontify all storage classes and type specifiers, plus their items. + (list (concat "\\<\\(" c++-type-types "\\)\\>" + "\\([ \t*&]+\\sw+\\>\\)*") + ;; Fontify each declaration item. + '(font-lock-match-c++-style-declaration-item-and-skip-to-next + ;; Start with point after all type specifiers. + (goto-char (or (match-beginning 13) (match-end 1))) + ;; Finish with point after first type specifier. + (goto-char (match-end 1)) + ;; Fontify as a variable or function name. + (1 (cond ((match-beginning 2) 'font-lock-type-face) + ((match-beginning 4) 'font-lock-function-name-face) + (t 'font-lock-variable-name-face))) + (3 (if (match-beginning 4) + 'font-lock-function-name-face + 'font-lock-variable-name-face) nil t))) + ;; + ;; Fontify structures, or typedef names, plus their items. + '("\\(}\\)[ \t*]*\\sw" + (font-lock-match-c++-style-declaration-item-and-skip-to-next + (goto-char (match-end 1)) nil + (1 (if (match-beginning 4) + font-lock-function-name-face + font-lock-variable-name-face)))) + ;; + ;; Fontify anything at beginning of line as a declaration or definition. + '("^\\(\\sw+\\)\\>\\([ \t*]+\\sw+\\>\\)*" + (1 font-lock-type-face) + (font-lock-match-c++-style-declaration-item-and-skip-to-next + (goto-char (or (match-beginning 2) (match-end 1))) nil + (1 (cond ((match-beginning 2) 'font-lock-type-face) + ((match-beginning 4) 'font-lock-function-name-face) + (t 'font-lock-variable-name-face))) + (3 (if (match-beginning 4) + 'font-lock-function-name-face + 'font-lock-variable-name-face) nil t))) + ))) + ) + +(defvar c-font-lock-keywords c-font-lock-keywords-1 + "Default expressions to highlight in C mode.") + +(defvar c++-font-lock-keywords c++-font-lock-keywords-1 + "Default expressions to highlight in C++ mode.") + +;; The previous version, before replacing it with the FSF version. +;(defconst c-font-lock-keywords-1 nil +; "For consideration as a value of `c-font-lock-keywords'. +;This does fairly subdued highlighting.") +; +;(defconst c-font-lock-keywords-2 nil +; "For consideration as a value of `c-font-lock-keywords'. +;This does a lot more highlighting.") +; +;(let ((storage "auto\\|extern\\|register\\|static\\|volatile") +; (prefixes "unsigned\\|short\\|long\\|const") +; (types (concat "int\\|long\\|char\\|float\\|double\\|void\\|struct\\|" +; "union\\|enum\\|typedef")) +; (ctoken "\\(\\sw\\|\\s_\\|[:~*&]\\)+") +; ) +; (setq c-font-lock-keywords-1 (purecopy +; (list +; ;; fontify preprocessor directives. +; '("^#[ \t]*[a-z]+" . font-lock-preprocessor-face) +; ;; +; ;; fontify names being defined. +; '("^#[ \t]*\\(define\\|undef\\)[ \t]+\\(\\(\\sw\\|\\s_\\)+\\)" 2 +; font-lock-function-name-face) +; ;; +; ;; fontify other preprocessor lines. +; '("^#[ \t]*\\(if\\|ifn?def\\|elif\\)[ \t]+\\([^\n]+\\)" +; 2 font-lock-function-name-face t) +; ;; +; ;; fontify the filename in #include <...> +; ;; don't need to do this for #include "..." because those were +; ;; already fontified as strings by the syntactic pass. +; ;; (Changed to not include the <> in the face, since "" aren't.) +; '("^#[ \t]*include[ \t]+<\\([^>\"\n]+\\)>" 1 font-lock-string-face) +; ;; +; ;; fontify the names of functions being defined. +; ;; I think this should be fast because it's anchored at bol, but it's not. +; (list (concat +; "^\\(" ctoken "[ \t]+\\)?" ; type specs; there can be no +; "\\(" ctoken "[ \t]+\\)?" ; more than 3 tokens, right? +; "\\(" ctoken "[ \t]+\\)?" +; "\\([*&]+[ \t]*\\)?" ; pointer +; "\\(" ctoken "\\)[ \t]*(") ; name +; 8 'font-lock-function-name-face) +; ;; +; ;; This is faster but not by much. I don't see why not. +;; (list (concat "^\\(" ctoken "\\)[ \t]*(") 1 'font-lock-function-name-face) +; ;; +; ;; Fontify structure names (in structure definition form). +; (list (concat "^\\(typedef[ \t]+struct\\|struct\\|static[ \t]+struct\\)" +; "[ \t]+\\(" ctoken "\\)[ \t]*\\(\{\\|$\\)") +; 2 'font-lock-function-name-face) +; ;; +; ;; Fontify case clauses. This is fast because its anchored on the left. +; '("case[ \t]+\\(\\(\\sw\\|\\s_\\)+\\):". 1) +; '("\\<\\(default\\):". 1) +; ))) +; +; (setq c-font-lock-keywords-2 (purecopy +; (append c-font-lock-keywords-1 +; (list +; ;; +; ;; fontify all storage classes and type specifiers +; ;; types should be surrounded by non alphanumerics (Raymond Toy) +; (cons (concat "\\<\\(" storage "\\)\\>") 'font-lock-type-face) +; (list (concat "\\([^a-zA-Z0-9_]\\|^\\)\\(" +; types +; "\\)\\([^a-zA-Z0-9_]\\|$\\)") +; 2 'font-lock-type-face) +; ;; fontify the prefixes now. The types should have been fontified +; ;; previously. +; (list (concat "\\<\\(" prefixes "\\)[ \t]+\\(" types "\\)\\>") +; 1 'font-lock-type-face) +; ;; +; ;; fontify all builtin tokens +; (cons (concat +; "[ \t]\\(" +; (mapconcat 'identity +; '("for" "while" "do" "return" "goto" "case" "break" "switch" +; "if" "then" "else if" "else" "return" "continue" "default" +; ) +; "\\|") +; "\\)[ \t\n(){};,]") +; 1) +; ;; +; ;; fontify case targets and goto-tags. This is slow because the +; ;; expression is anchored on the right. +; "\\(\\(\\sw\\|\\s_\\)+\\):" +; ;; +; ;; Fontify variables declared with structures, or typedef names. +; '("}[ \t*]*\\(\\(\\sw\\|\\s_\\)+\\)[ \t]*[,;]" +; 1 font-lock-function-name-face) +; ;; +; ;; Fontify global variables without a type. +;; '("^\\([_a-zA-Z0-9:~*]+\\)[ \t]*[[;={]" 1 font-lock-function-name-face) +; +; )))) +; ) +; +; +;;; default to the gaudier variety? +;;(defconst c-font-lock-keywords c-font-lock-keywords-2 +;; "Additional expressions to highlight in C mode.") +;(defconst c-font-lock-keywords c-font-lock-keywords-1 +; "Additional expressions to highlight in C mode.") +; +;(defconst c++-font-lock-keywords-1 nil +; "For consideration as a value of `c++-font-lock-keywords'. +;This does fairly subdued highlighting.") +; +;(defconst c++-font-lock-keywords-2 nil +; "For consideration as a value of `c++-font-lock-keywords'. +;This does a lot more highlighting.") +; +;(let ((ctoken "\\(\\sw\\|\\s_\\|[:~*&]\\)+") +; (c++-types (concat "complex\\|public\\|private\\|protected\\|virtual\\|" +; "friend\\|inline")) +; c++-font-lock-keywords-internal-1 +; c++-font-lock-keywords-internal-2 +; ) +; (setq c++-font-lock-keywords-internal-1 (purecopy +; (list +; ;; +; ;; fontify friend operator functions +; '("^\\(operator[^(]*\\)(" 1 font-lock-function-name-face) +; '("^\\(operator[ \\t]*([ \\t]*)[^(]*\\)(" 1 font-lock-function-name-face) +; +; ;; fontify the class names only in the definition +; (list (concat "^class[ \t]+" ctoken "[ \t\n{: ;]") 1 +; 'font-lock-function-name-face) +; +; (list (concat +; "^\\(" ctoken "[ \t]+\\)?" ; type specs; there can be no +; "\\(" ctoken "[ \t]+\\)?" ; more than 3 tokens, right? +; "\\(" ctoken "[ \t]+\\)?" +; "\\(\\*+[ \t]*\\)?" ; pointer +; "\\(" ctoken "\\(::\\)?~?\\(\\(operator[ \t]*[^ \ta-zA-Z]+\\)\\|" +; ctoken "\\)\\)[ \t]*(") ; name +; 8 'font-lock-function-name-face t) +; ))) +; +; (setq c++-font-lock-keywords-internal-2 (purecopy +; (list +; ;; fontify extra c++ storage classes and type specifiers +; (cons (concat "\\<\\(" c++-types "\\)\\>") 'font-lock-type-face) +; +; ;;special check for class +; '("^\\(\\<\\|template[ \t]+<[ \t]*\\)\\(class\\)[ \t\n]+" 2 +; font-lock-type-face) +; +; ;; special handling of template +; "^\\(template\\)\\>" +; ;; fontify extra c++ builtin tokens +; (cons (concat +; "[ \t]\\(" +; (mapconcat 'identity +; '("asm" "catch" "throw" "try" "delete" "new" "operator" +; "sizeof" "this" +; ) +; "\\|") +; "\\)[ \t\n(){};,]") +; 1) +; ))) +; +; (setq c++-font-lock-keywords-1 (purecopy +; (append c-font-lock-keywords-1 c++-font-lock-keywords-internal-1))) +; +; (setq c++-font-lock-keywords-2 (purecopy +; (append c-font-lock-keywords-2 c++-font-lock-keywords-internal-1 +; c++-font-lock-keywords-internal-2))) +; ) +; +;(defconst c++-font-lock-keywords c++-font-lock-keywords-1 +; "Additional expressions to highlight in C++ mode.") + +;; Java support from Anders Lindgren and Bob Weiner + +(defconst java-font-lock-keywords-1 nil + "For consideration as a value of `java-font-lock-keywords'. +This does fairly subdued highlighting.") + +(defconst java-font-lock-keywords-2 nil + "For consideration as a value of `java-font-lock-keywords'. +This adds highlighting of types and identifier names.") + +(defconst java-font-lock-keywords-3 nil + "For consideration as a value of `java-font-lock-keywords'. +This adds highlighting of Java documentation tags, such as @see.") + +(defvar java-font-lock-type-regexp + (concat "\\<\\(boolean\\|byte\\|char\\|double\\|float\\|int" + "\\|long\\|short\\|void\\)\\>") + "Regexp which should match a primitive type.") + +(let ((capital-letter "A-Z\300-\326\330-\337") + (letter "a-zA-Z_$\300-\326\330-\366\370-\377") + (digit "0-9")) +(defvar java-font-lock-identifier-regexp + (concat "\\<\\([" letter "][" letter digit "]*\\)\\>") + "Regexp which should match all Java identifiers.") + +(defvar java-font-lock-class-name-regexp + (concat "\\<\\([" capital-letter "][" letter digit "]*\\)\\>") + "Regexp which should match a class or an interface name. +The name is assumed to begin with a capital letter.") +) + + +(let ((java-modifier-regexp + (concat "\\<\\(abstract\\|const\\|final\\|native\\|" + "private\\|protected\\|public\\|" + "static\\|synchronized\\|transient\\|volatile\\)\\>"))) + + ;; Basic font-lock support: + (setq java-font-lock-keywords-1 + (list + ;; Keywords: + (list + (concat + "\\<\\(" + "break\\|byvalue\\|" + "case\\|cast\\|catch\\|class\\|continue\\|" + "do\\|else\\|extends\\|" + "finally\\|for\\|future\\|" + "generic\\|goto\\|" + "if\\|implements\\|import\\|" + "instanceof\\|interface\\|" + "new\\|package\\|return\\|switch\\|" + "throws?\\|try\\|while\\)\\>") + 1 'font-lock-keyword-face) + + ;; Modifiers: + (list java-modifier-regexp 1 font-lock-type-face) + + ;; Special constants: + '("\\<\\(this\\|super\\)\\>" (1 font-lock-reference-face)) + '("\\<\\(false\\|null\\|true\\)\\>" (1 font-lock-keyword-face)) + + ;; Class names: + (list (concat "\\\\s *" java-font-lock-identifier-regexp) + 1 'font-lock-function-name-face) + + ;; Package declarations: + (list (concat "\\<\\(package\\|import\\)\\>\\s *" + java-font-lock-identifier-regexp) + '(2 font-lock-reference-face) + (list (concat + "\\=\\.\\(" java-font-lock-identifier-regexp "\\)") + nil nil '(1 (let ((c (char-after (match-end 0)))) + (if (and (characterp c) + (= c ?.)) + 'font-lock-reference-face + 'font-lock-type-face))))) + + ;; Constructors: + (list (concat + "^\\s *\\(" java-modifier-regexp "\\s +\\)*" + java-font-lock-class-name-regexp "\\s *\(") + (list 3 + '(condition-case nil + (save-excursion + (goto-char (scan-sexps (- (match-end 0) 1) 1)) + (parse-partial-sexp (point) (point-max) nil t) + (and (looking-at "\\($\\|\\\\|{\\)") + 'font-lock-function-name-face)) + (error 'font-lock-function-name-face)))) + + ;; Methods: + (list (concat "\\(" java-font-lock-type-regexp "\\|" + java-font-lock-class-name-regexp "\\)" + "\\s *\\(\\[\\s *\\]\\s *\\)*" + java-font-lock-identifier-regexp "\\s *\(") + 5 + 'font-lock-function-name-face) + + ;; Labels: + (list ":" + (list + (concat "^\\s *" java-font-lock-identifier-regexp "\\s *:") + '(beginning-of-line) '(end-of-line) + '(1 font-lock-reference-face))) + + ;; `break' and continue' destination labels: + (list (concat "\\<\\(break\\|continue\\)\\>\\s *" + java-font-lock-identifier-regexp) + 2 'font-lock-reference-face) + + ;; Case statements: + ;; In Java, any constant expression is allowed. + '("\\\\s *\\(.*\\):" 1 font-lock-reference-face))) + + ;; Types and declared variable names: + (setq java-font-lock-keywords-2 + (append + + java-font-lock-keywords-1 + (list + ;; Keywords followed by a type: + (list (concat "\\<\\(extends\\|instanceof\\|new\\)\\>\\s *" + java-font-lock-identifier-regexp) + '(2 (if (= (char-after (match-end 0)) ?.) + 'font-lock-reference-face 'font-lock-type-face)) + (list (concat "\\=\\." java-font-lock-identifier-regexp) + '(goto-char (match-end 0)) nil + '(1 (if (= (char-after (match-end 0)) ?.) + 'font-lock-reference-face 'font-lock-type-face)))) + + ;; Keywords followed by a type list: + (list (concat "\\<\\(implements\\|throws\\)\\>\\ s*" + java-font-lock-identifier-regexp) + '(2 (if (= (char-after (match-end 0)) ?.) + font-lock-reference-face font-lock-type-face)) + (list (concat "\\=\\(\\.\\|\\s *\\(,\\)\\s *\\)" + java-font-lock-identifier-regexp) + '(goto-char (match-end 0)) nil + '(3 (if (= (char-after (match-end 0)) ?.) + font-lock-reference-face font-lock-type-face)))) + + ;; primitive types, can't be confused with anything else. + (list java-font-lock-type-regexp + '(1 font-lock-type-face) + '(font-lock-match-java-declarations + (goto-char (match-end 0)) + (goto-char (match-end 0)) + (0 font-lock-variable-name-face))) + + ;; Declarations, class types and capitalized variables: + ;; + ;; Declarations are easy to recognize. Capitalized words + ;; followed by a closing parenthesis are treated as casts if they + ;; also are followed by an expression. Expressions beginning with + ;; a unary numerical operator, e.g. +, can't be cast to an object + ;; type. + ;; + ;; The path of a fully qualified type, e.g. java.lang.Foo, is + ;; fontified in the reference face. + ;; + ;; An access to a static field, e.g. System.out.println, is + ;; not fontified since it can't be distinguished from the + ;; usage of a capitalized variable, e.g. Foo.out.println. + + (list (concat java-font-lock-class-name-regexp + "\\s *\\(\\[\\s *\\]\\s *\\)*" + "\\(\\<\\|$\\|)\\s *\\([\(\"]\\|\\<\\)\\)") + '(1 (save-match-data + (save-excursion + (goto-char + (match-beginning 3)) + (if (not (looking-at "\\")) + 'font-lock-type-face)))) + (list (concat "\\=" java-font-lock-identifier-regexp "\\.") + '(progn + (goto-char (match-beginning 0)) + (while (or (= (preceding-char) ?.) + (= (char-syntax (preceding-char)) ?w)) + (backward-char))) + '(goto-char (match-end 0)) + '(1 font-lock-reference-face) + '(0 nil)) ; Workaround for bug in XEmacs. + '(font-lock-match-java-declarations + (goto-char (match-end 1)) + (goto-char (match-end 0)) + (1 font-lock-variable-name-face)))))) + + ;; Modifier keywords and Java doc tags + (setq java-font-lock-keywords-3 + (append + + '( + ;; Feature scoping: + ;; These must come first or the Modifiers from keywords-1 will + ;; catch them. We don't want to use override fontification here + ;; because then these terms will be fontified within comments. + ("\\" 0 font-lock-string-face) + ("\\" 0 font-lock-preprocessor-face) + ("\\" 0 font-lock-reference-face)) + java-font-lock-keywords-2 + + (list + + ;; Java doc tags + '("@\\(author\\|exception\\|param\\|return\\|see\\|version\\)\\s " + 0 font-lock-keyword-face t) + + ;; Doc tag - Parameter identifiers + (list (concat "@param\\s +" java-font-lock-identifier-regexp) + 1 'font-lock-variable-name-face t) + + ;; Doc tag - Exception types + (list (concat "@exception\\ s*" + java-font-lock-identifier-regexp) + '(1 (if (= (char-after (match-end 0)) ?.) + font-lock-reference-face font-lock-type-face) t) + (list (concat "\\=\\." java-font-lock-identifier-regexp) + '(goto-char (match-end 0)) nil + '(1 (if (= (char-after (match-end 0)) ?.) + 'font-lock-reference-face 'font-lock-type-face) t))) + + ;; Doc tag - Cross-references, usually to methods + '("@see\\s +\\(\\S *[^][ \t\n\r\f(){},.;:]\\)" + 1 font-lock-function-name-face t) + + ))) + ) + +(defvar java-font-lock-keywords java-font-lock-keywords-1 + "Additional expressions to highlight in Java mode.") + +;; Match and move over any declaration/definition item after +;; point. Does not match items which look like a type declaration +;; (primitive types and class names, i.e. capitalized words.) +;; Should the variable name be followed by a comma, we reposition +;; the cursor to fontify more identifiers. +(defun font-lock-match-java-declarations (limit) + "Match and skip over variable definitions." + (if (looking-at "\\s *\\(\\[\\s *\\]\\s *\\)*") + (goto-char (match-end 0))) + (and + (looking-at java-font-lock-identifier-regexp) + (save-match-data + (not (string-match java-font-lock-type-regexp + (buffer-substring (match-beginning 1) + (match-end 1))))) + (save-match-data + (save-excursion + (goto-char (match-beginning 1)) + (not (looking-at + (concat java-font-lock-class-name-regexp + "\\s *\\(\\[\\s *\\]\\s *\\)*\\<"))))) + (save-match-data + (condition-case nil + (save-restriction + (narrow-to-region (point-min) limit) + (goto-char (match-end 0)) + ;; Note: Both `scan-sexps' and the second goto-char can + ;; generate an error which is caught by the + ;; `condition-case' expression. + (while (not (looking-at "\\s *\\(\\(,\\)\\|;\\|$\\)")) + (goto-char (or (scan-sexps (point) 1) (point-max)))) + (goto-char (match-end 2))) ; non-nil + (error t))))) + + +(defvar tex-font-lock-keywords +; ;; Regexps updated with help from Ulrik Dickow . +; '(("\\\\\\(begin\\|end\\|newcommand\\){\\([a-zA-Z0-9\\*]+\\)}" +; 2 font-lock-function-name-face) +; ("\\\\\\(cite\\|label\\|pageref\\|ref\\){\\([^} \t\n]+\\)}" +; 2 font-lock-reference-face) +; ;; It seems a bit dubious to use `bold' and `italic' faces since we might +; ;; not be able to display those fonts. +; ("{\\\\bf\\([^}]+\\)}" 1 'bold keep) +; ("{\\\\\\(em\\|it\\|sl\\)\\([^}]+\\)}" 2 'italic keep) +; ("\\\\\\([a-zA-Z@]+\\|.\\)" . font-lock-keyword-face) +; ("^[ \t\n]*\\\\def[\\\\@]\\(\\w+\\)" 1 font-lock-function-name-face keep)) + ;; Rewritten and extended for LaTeX2e by Ulrik Dickow . + '(("\\\\\\(begin\\|end\\|newcommand\\){\\([a-zA-Z0-9\\*]+\\)}" + 2 font-lock-function-name-face) + ("\\\\\\(cite\\|label\\|pageref\\|ref\\){\\([^} \t\n]+\\)}" + 2 font-lock-reference-face) + ("^[ \t]*\\\\def\\\\\\(\\(\\w\\|@\\)+\\)" 1 font-lock-function-name-face) + "\\\\\\([a-zA-Z@]+\\|.\\)" + ;; It seems a bit dubious to use `bold' and `italic' faces since we might + ;; not be able to display those fonts. + ;; LaTeX2e: \emph{This is emphasized}. + ("\\\\emph{\\([^}]+\\)}" 1 'italic keep) + ;; LaTeX2e: \textbf{This is bold}, \textit{...}, \textsl{...} + ("\\\\text\\(\\(bf\\)\\|it\\|sl\\){\\([^}]+\\)}" + 3 (if (match-beginning 2) 'bold 'italic) keep) + ;; Old-style bf/em/it/sl. Stop at `\\' and un-escaped `&', for good tables. + ("\\\\\\(\\(bf\\)\\|em\\|it\\|sl\\)\\>\\(\\([^}&\\]\\|\\\\[^\\]\\)+\\)" + 3 (if (match-beginning 2) 'bold 'italic) keep)) + "Default expressions to highlight in TeX modes.") + +;; The previous version, before replacing it with the FSF version. +;(defconst tex-font-lock-keywords (purecopy +; (list +; ;; Lionel Mallet: Thu Oct 14 09:41:38 1993 +; ;; I've added an exit condition to the regexp below, and the other +; ;; regexps for the second part. +; ;; What would be useful here is something like: +; ;; ("\\(\\\\\\w+\\)\\({\\(\\w+\\)}\\)+" 1 font-lock-keyword-face t 3 +; ;; font-lock-function-name-face t) +; '("\\(\\\\\\w+\\)\\W" 1 font-lock-keyword-face t) +; '("\\(\\\\\\w+\\){\\([^}\n]+\\)}" 2 font-lock-function-name-face t) +; '("\\(\\\\\\w+\\){\\(\\w+\\)}{\\(\\w+\\)}" 3 +; font-lock-function-name-face t) +; '("\\(\\\\\\w+\\){\\(\\w+\\)}{\\(\\w+\\)}{\\(\\w+\\)}" 4 +; font-lock-function-name-face t) +; '("{\\\\\\(em\\|tt\\)\\([^}]+\\)}" 2 font-lock-comment-face t) +; '("{\\\\bf\\([^}]+\\)}" 1 font-lock-keyword-face t) +; '("^[ \t\n]*\\\\def[\\\\@]\\(\\w+\\)\\W" 1 font-lock-function-name-face t) +; ;; Lionel Mallet: Thu Oct 14 09:40:10 1993 +; ;; the regexp below is useless as it is now covered by the first 2 regexps +; ;; '("\\\\\\(begin\\|end\\){\\([a-zA-Z0-9\\*]+\\)}" +; ;; 2 font-lock-function-name-face t) +; '("[^\\\\]\\$\\([^$]*\\)\\$" 1 font-lock-string-face t) +;; '("\\$\\([^$]*\\)\\$" 1 font-lock-string-face t) +; )) +; "Additional expressions to highlight in TeX mode.") + +(defconst ksh-font-lock-keywords (purecopy + (list + '("\\(^\\|[^\$\\\]\\)#.*" . font-lock-comment-face) + '("\\<\\(if\\|then\\|else\\|elif\\|fi\\|case\\|esac\\|for\\|do\\|done\\|foreach\\|in\\|end\\|select\\|while\\|repeat\\|time\\|function\\|until\\|exec\\|command\\|coproc\\|noglob\\|nohup\\|nocorrect\\|source\\|autoload\\|alias\\|unalias\\|export\\|set\\|echo\\|eval\\|cd\\|log\\|compctl\\)\\>" . font-lock-keyword-face) + '("\\<\\[\\[.*\\]\\]\\>" . font-lock-type-face) + '("\$\(.*\)" . font-lock-type-face) + )) + "Additional expressions to highlight in ksh-mode.") + +(defconst sh-font-lock-keywords (purecopy + (list + '("\\(^\\|[^\$\\\]\\)#.*" . font-lock-comment-face) + '("\\<\\(if\\|then\\|else\\|elif\\|fi\\|case\\|esac\\|for\\|do\\|done\\|in\\|while\\|exec\\|export\\|set\\|echo\\|eval\\|cd\\)\\>" . font-lock-keyword-face) + '("\\[.*\\]" . font-lock-type-face) + '("`.*`" . font-lock-type-face) + )) + "Additional expressions to highlight in sh-mode.") + + +;; Install ourselves: + +(add-hook 'find-file-hooks 'font-lock-set-defaults t) + +(make-face 'font-lock-comment-face "Face to use for comments.") +(make-face 'font-lock-doc-string-face "Face to use for documentation strings.") +(make-face 'font-lock-string-face "Face to use for strings.") +(make-face 'font-lock-keyword-face "Face to use for keywords.") +(make-face 'font-lock-function-name-face "Face to use for function names.") +(make-face 'font-lock-variable-name-face "Face to use for variable names.") +(make-face 'font-lock-type-face "Face to use for type names.") +(make-face 'font-lock-reference-face "Face to use for reference names.") +(make-face 'font-lock-preprocessor-face + "Face to use for preprocessor commands.") + +;; Backwards compatibility? + +(if (eq t font-lock-use-colors) + (setq font-lock-use-colors '(color))) + +(if (eq t font-lock-use-fonts) + (setq font-lock-use-fonts '(or (mono) (grayscale)))) + +(font-lock-apply-defaults 'font-lock-add-fonts font-lock-use-fonts) +(font-lock-apply-defaults 'font-lock-add-colors font-lock-use-colors) + +;;;###autoload +(add-minor-mode 'font-lock-mode " Font") + +;; Provide ourselves: + +(provide 'font-lock) + +;;; font-lock.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/font.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/font.el Mon Aug 13 10:08:34 2007 +0200 @@ -0,0 +1,1242 @@ +;;; font.el --- New font model +;; Author: wmperry +;; Created: 1997/09/05 15:44:37 +;; Version: 1.52 +;; Keywords: faces + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1995, 1996 by William M. Perry (wmperry@cs.indiana.edu) +;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc. +;;; +;;; 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., 59 Temple Place - Suite 330, +;;; Boston, MA 02111-1307, USA. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; The emacsen compatibility package - load it up before anything else +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(require 'cl) + +(eval-and-compile + (condition-case () + (require 'custom) + (error nil)) + (if (and (featurep 'custom) (fboundp 'custom-declare-variable)) + nil ;; We've got what we needed + ;; We have the old custom-library, hack around it! + (defmacro defgroup (&rest args) + nil) + (defmacro defcustom (var value doc &rest args) + (` (defvar (, var) (, value) (, doc)))))) + +(if (not (fboundp 'try-font-name)) + (defun try-font-name (fontname &rest args) + (case window-system + ((x pm) (car-safe (x-list-fonts fontname))) + (mswindows (car-safe (x-list-fonts fontname))) ; XXX FIXME + (ns (car-safe (ns-list-fonts fontname))) + (otherwise nil)))) + +(if (not (fboundp 'facep)) + (defun facep (face) + "Return t if X is a face name or an internal face vector." + (if (not window-system) + nil ; FIXME if FSF ever does TTY faces + (and (or (internal-facep face) + (and (symbolp face) (assq face global-face-data))) + t)))) + +(if (not (fboundp 'set-face-property)) + (defun set-face-property (face property value &optional locale + tag-set how-to-add) + "Change a property of FACE." + (and (symbolp face) + (put face property value)))) + +(if (not (fboundp 'face-property)) + (defun face-property (face property &optional locale tag-set exact-p) + "Return FACE's value of the given PROPERTY." + (and (symbolp face) (get face property)))) + +(require 'disp-table) + +(if (not (fboundp '<<)) (fset '<< 'lsh)) +(if (not (fboundp '&)) (fset '& 'logand)) +(if (not (fboundp '|)) (fset '| 'logior)) +(if (not (fboundp '~)) (fset '~ 'lognot)) +(if (not (fboundp '>>)) (defun >> (value count) (<< value (- count)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Lots of variables / keywords for use later in the program +;;; Not much should need to be modified +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defconst font-running-xemacs (string-match "XEmacs" (emacs-version)) + "Whether we are running in XEmacs or not.") + +(defmacro define-font-keywords (&rest keys) + (` + (eval-and-compile + (let ((keywords (quote (, keys)))) + (while keywords + (or (boundp (car keywords)) + (set (car keywords) (car keywords))) + (setq keywords (cdr keywords))))))) + +(defconst font-window-system-mappings + '((x . (x-font-create-name x-font-create-object)) + (ns . (ns-font-create-name ns-font-create-object)) + (mswindows . (x-font-create-name x-font-create-object)) ; XXX FIXME + (pm . (x-font-create-name x-font-create-object)) ; Change? FIXME + (tty . (tty-font-create-plist tty-font-create-object))) + "An assoc list mapping device types to the function used to create +a font name from a font structure.") + +(defconst ns-font-weight-mappings + '((:extra-light . "extralight") + (:light . "light") + (:demi-light . "demilight") + (:medium . "medium") + (:normal . "medium") + (:demi-bold . "demibold") + (:bold . "bold") + (:extra-bold . "extrabold")) + "An assoc list mapping keywords to actual NeXTstep specific +information to use") + +(defconst x-font-weight-mappings + '((:extra-light . "extralight") + (:light . "light") + (:demi-light . "demilight") + (:demi . "demi") + (:book . "book") + (:medium . "medium") + (:normal . "medium") + (:demi-bold . "demibold") + (:bold . "bold") + (:extra-bold . "extrabold")) + "An assoc list mapping keywords to actual Xwindow specific strings +for use in the 'weight' field of an X font string.") + +(defconst font-possible-weights + (mapcar 'car x-font-weight-mappings)) + +(defvar font-rgb-file nil + "Where the RGB file was found.") + +(defvar font-maximum-slippage "1pt" + "How much a font is allowed to vary from the desired size.") + +(defvar font-family-mappings + '( + ("serif" . ("new century schoolbook" + "utopia" + "charter" + "times" + "lucidabright" + "garamond" + "palatino" + "times new roman" + "baskerville" + "bookman" + "bodoni" + "computer modern" + "rockwell" + )) + ("sans-serif" . ("lucida" + "helvetica" + "gills-sans" + "avant-garde" + "univers" + "optima")) + ("elfin" . ("tymes")) + ("monospace" . ("courier" + "courier new" + "fixed" + "lucidatypewriter" + "clean" + "terminal")) + ("cursive" . ("sirene" + "zapf chancery")) + ) + "A list of font family mappings.") + +(define-font-keywords :family :style :size :registry :encoding) + +(define-font-keywords + :weight :extra-light :light :demi-light :medium :normal :demi-bold + :bold :extra-bold) + +(defvar font-style-keywords nil) + +(defsubst set-font-family (fontobj family) + (aset fontobj 1 family)) + +(defsubst set-font-weight (fontobj weight) + (aset fontobj 3 weight)) + +(defsubst set-font-style (fontobj style) + (aset fontobj 5 style)) + +(defsubst set-font-size (fontobj size) + (aset fontobj 7 size)) + +(defsubst set-font-registry (fontobj reg) + (aset fontobj 9 reg)) + +(defsubst set-font-encoding (fontobj enc) + (aset fontobj 11 enc)) + +(defsubst font-family (fontobj) + (aref fontobj 1)) + +(defsubst font-weight (fontobj) + (aref fontobj 3)) + +(defsubst font-style (fontobj) + (aref fontobj 5)) + +(defsubst font-size (fontobj) + (aref fontobj 7)) + +(defsubst font-registry (fontobj) + (aref fontobj 9)) + +(defsubst font-encoding (fontobj) + (aref fontobj 11)) + +(eval-when-compile + (defmacro define-new-mask (attr mask) + (` + (progn + (setq font-style-keywords + (cons (cons (quote (, attr)) + (cons + (quote (, (intern (format "set-font-%s-p" attr)))) + (quote (, (intern (format "font-%s-p" attr)))))) + font-style-keywords)) + (defconst (, (intern (format "font-%s-mask" attr))) (<< 1 (, mask)) + (, (format + "Bitmask for whether a font is to be rendered in %s or not." + attr))) + (defun (, (intern (format "font-%s-p" attr))) (fontobj) + (, (format "Whether FONTOBJ will be renderd in `%s' or not." attr)) + (if (/= 0 (& (font-style fontobj) + (, (intern (format "font-%s-mask" attr))))) + t + nil)) + (defun (, (intern (format "set-font-%s-p" attr))) (fontobj val) + (, (format "Set whether FONTOBJ will be renderd in `%s' or not." + attr)) + (cond + (val + (set-font-style fontobj (| (font-style fontobj) + (, (intern + (format "font-%s-mask" attr)))))) + (((, (intern (format "font-%s-p" attr))) fontobj) + (set-font-style fontobj (- (font-style fontobj) + (, (intern + (format "font-%s-mask" attr)))))))) + )))) + +(let ((mask 0)) + (define-new-mask bold (setq mask (1+ mask))) + (define-new-mask italic (setq mask (1+ mask))) + (define-new-mask oblique (setq mask (1+ mask))) + (define-new-mask dim (setq mask (1+ mask))) + (define-new-mask underline (setq mask (1+ mask))) + (define-new-mask overline (setq mask (1+ mask))) + (define-new-mask linethrough (setq mask (1+ mask))) + (define-new-mask strikethru (setq mask (1+ mask))) + (define-new-mask reverse (setq mask (1+ mask))) + (define-new-mask blink (setq mask (1+ mask))) + (define-new-mask smallcaps (setq mask (1+ mask))) + (define-new-mask bigcaps (setq mask (1+ mask))) + (define-new-mask dropcaps (setq mask (1+ mask)))) + +(defvar font-caps-display-table + (let ((table (make-display-table)) + (i 0)) + ;; Standard ASCII characters + (while (< i 26) + (aset table (+ i ?a) (+ i ?A)) + (setq i (1+ i))) + ;; Now ISO translations + (setq i 224) + (while (< i 247) ;; Agrave - Ouml + (aset table i (- i 32)) + (setq i (1+ i))) + (setq i 248) + (while (< i 255) ;; Oslash - Thorn + (aset table i (- i 32)) + (setq i (1+ i))) + table)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Utility functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defsubst set-font-style-by-keywords (fontobj styles) + (make-local-variable 'font-func) + (declare (special font-func)) + (if (listp styles) + (while styles + (setq font-func (car-safe (cdr-safe (assq (car styles) font-style-keywords))) + styles (cdr styles)) + (and (fboundp font-func) (funcall font-func fontobj t))) + (setq font-func (car-safe (cdr-safe (assq styles font-style-keywords)))) + (and (fboundp font-func) (funcall font-func fontobj t)))) + +(defsubst font-properties-from-style (fontobj) + (let ((style (font-style fontobj)) + (todo font-style-keywords) + type func retval) + (while todo + (setq func (cdr (cdr (car todo))) + type (car (pop todo))) + (if (funcall func fontobj) + (setq retval (cons type retval)))) + retval)) + +(defun font-unique (list) + (let ((retval) + (cur)) + (while list + (setq cur (car list) + list (cdr list)) + (if (member cur retval) + nil + (setq retval (cons cur retval)))) + (nreverse retval))) + +(defun font-higher-weight (w1 w2) + (let ((index1 (length (memq w1 font-possible-weights))) + (index2 (length (memq w2 font-possible-weights)))) + (cond + ((<= index1 index2) + (or w1 w2)) + ((not w2) + w1) + (t + w2)))) + +(defun font-spatial-to-canonical (spec &optional device) + "Convert SPEC (in inches, millimeters, points, or picas) into points" + ;; 1 in = 6 pa = 25.4 mm = 72 pt + (cond + ((numberp spec) + spec) + ((null spec) + nil) + (t + (let ((num nil) + (type nil) + ;; If for any reason we get null for any of this, default + ;; to 1024x768 resolution on a 17" screen + (pix-width (float (or (device-pixel-width device) 1024))) + (mm-width (float (or (device-mm-width device) 293))) + (retval nil)) + (cond + ((string-match "^ *\\([-+*/]\\) *" spec) ; math! whee! + (let ((math-func (intern (match-string 1 spec))) + (other (font-spatial-to-canonical + (substring spec (match-end 0) nil))) + (default (font-spatial-to-canonical + (font-default-size-for-device device)))) + (if (fboundp math-func) + (setq type "px" + spec (int-to-string (funcall math-func default other))) + (setq type "px" + spec (int-to-string other))))) + ((string-match "[^0-9.]+$" spec) + (setq type (substring spec (match-beginning 0)) + spec (substring spec 0 (match-beginning 0)))) + (t + (setq type "px" + spec spec))) + (setq num (string-to-number spec)) + (cond + ((member type '("pixel" "px" "pix")) + (setq retval (* num (/ pix-width mm-width) (/ 25.4 72.0)))) + ((member type '("point" "pt")) + (setq retval num)) + ((member type '("pica" "pa")) + (setq retval (* num 12.0))) + ((member type '("inch" "in")) + (setq retval (* num 72.0))) + ((string= type "mm") + (setq retval (* num (/ 72.0 25.4)))) + ((string= type "cm") + (setq retval (* num 10 (/ 72.0 25.4)))) + (t + (setq retval num)) + ) + retval)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; The main interface routines - constructors and accessor functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun make-font (&rest args) + (vector :family + (if (stringp (plist-get args :family)) + (list (plist-get args :family)) + (plist-get args :family)) + :weight + (plist-get args :weight) + :style + (if (numberp (plist-get args :style)) + (plist-get args :style) + 0) + :size + (plist-get args :size) + :registry + (plist-get args :registry) + :encoding + (plist-get args :encoding))) + +(defun font-create-name (fontobj &optional device) + (let* ((type (device-type device)) + (func (car (cdr-safe (assq type font-window-system-mappings))))) + (and func (fboundp func) (funcall func fontobj device)))) + +;;;###autoload +(defun font-create-object (fontname &optional device) + (let* ((type (device-type device)) + (func (car (cdr (cdr-safe (assq type font-window-system-mappings)))))) + (and func (fboundp func) (funcall func fontname device)))) + +(defun font-combine-fonts-internal (fontobj-1 fontobj-2) + (let ((retval (make-font)) + (size-1 (and (font-size fontobj-1) + (font-spatial-to-canonical (font-size fontobj-1)))) + (size-2 (and (font-size fontobj-2) + (font-spatial-to-canonical (font-size fontobj-2))))) + (set-font-weight retval (font-higher-weight (font-weight fontobj-1) + (font-weight fontobj-2))) + (set-font-family retval (font-unique (append (font-family fontobj-1) + (font-family fontobj-2)))) + (set-font-style retval (| (font-style fontobj-1) (font-style fontobj-2))) + (set-font-registry retval (or (font-registry fontobj-1) + (font-registry fontobj-2))) + (set-font-encoding retval (or (font-encoding fontobj-1) + (font-encoding fontobj-2))) + (set-font-size retval (cond + ((and size-1 size-2 (>= size-2 size-1)) + (font-size fontobj-2)) + ((and size-1 size-2) + (font-size fontobj-1)) + (size-1 + (font-size fontobj-1)) + (size-2 + (font-size fontobj-2)) + (t nil))) + + retval)) + +(defun font-combine-fonts (&rest args) + (cond + ((null args) + (error "Wrong number of arguments to font-combine-fonts")) + ((= (length args) 1) + (car args)) + (t + (let ((retval (font-combine-fonts-internal (nth 0 args) (nth 1 args)))) + (setq args (cdr (cdr args))) + (while args + (setq retval (font-combine-fonts-internal retval (car args)) + args (cdr args))) + retval)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; The window-system dependent code (TTY-style) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun tty-font-create-object (fontname &optional device) + (make-font :size "12pt")) + +(defun tty-font-create-plist (fontobj &optional device) + (let ((styles (font-style fontobj)) + (weight (font-weight fontobj))) + (list + (cons 'underline (font-underline-p fontobj)) + (cons 'highlight (if (or (font-bold-p fontobj) + (memq weight '(:bold :demi-bold))) t)) + (cons 'dim (font-dim-p fontobj)) + (cons 'blinking (font-blink-p fontobj)) + (cons 'reverse (font-reverse-p fontobj))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; The window-system dependent code (X-style) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defvar font-x-font-regexp (or (and font-running-xemacs + (boundp 'x-font-regexp) + x-font-regexp) + (let + ((- "[-?]") + (foundry "[^-]*") + (family "[^-]*") + (weight "\\(bold\\|demibold\\|medium\\|black\\)") + (weight\? "\\([^-]*\\)") + (slant "\\([ior]\\)") + (slant\? "\\([^-]?\\)") + (swidth "\\([^-]*\\)") + (adstyle "\\([^-]*\\)") + (pixelsize "\\(\\*\\|[0-9]+\\)") + (pointsize "\\(\\*\\|0\\|[0-9][0-9]+\\)") + (resx "\\([*0]\\|[0-9][0-9]+\\)") + (resy "\\([*0]\\|[0-9][0-9]+\\)") + (spacing "[cmp?*]") + (avgwidth "\\(\\*\\|[0-9]+\\)") + (registry "[^-]*") + (encoding "[^-]+") + ) + (concat "\\`\\*?[-?*]" + foundry - family - weight\? - slant\? - swidth - adstyle - + pixelsize - pointsize - resx - resy - spacing - avgwidth - + registry - encoding "\\'" + )))) + +(defvar font-x-registry-and-encoding-regexp + (or (and font-running-xemacs + (boundp 'x-font-regexp-registry-and-encoding) + (symbol-value 'x-font-regexp-registry-and-encoding)) + (let ((- "[-?]") + (registry "[^-]*") + (encoding "[^-]+")) + (concat - "\\(" registry "\\)" - "\\(" encoding "\\)\\'")))) + +(defun x-font-create-object (fontname &optional device) + (let ((case-fold-search t)) + (if (or (not (stringp fontname)) + (not (string-match font-x-font-regexp fontname))) + (make-font) + (let ((family nil) + (style nil) + (size nil) + (weight (match-string 1 fontname)) + (slant (match-string 2 fontname)) + (swidth (match-string 3 fontname)) + (adstyle (match-string 4 fontname)) + (pxsize (match-string 5 fontname)) + (ptsize (match-string 6 fontname)) + (retval nil) + (case-fold-search t) + ) + (if (not (string-match x-font-regexp-foundry-and-family fontname)) + nil + (setq family (list (downcase (match-string 1 fontname))))) + (if (string= "*" weight) (setq weight nil)) + (if (string= "*" slant) (setq slant nil)) + (if (string= "*" swidth) (setq swidth nil)) + (if (string= "*" adstyle) (setq adstyle nil)) + (if (string= "*" pxsize) (setq pxsize nil)) + (if (string= "*" ptsize) (setq ptsize nil)) + (if ptsize (setq size (/ (string-to-int ptsize) 10))) + (if (and (not size) pxsize) (setq size (concat pxsize "px"))) + (if weight (setq weight (intern-soft (concat ":" (downcase weight))))) + (if (and adstyle (not (equal adstyle ""))) + (setq family (append family (list (downcase adstyle))))) + (setq retval (make-font :family family + :weight weight + :size size)) + (set-font-bold-p retval (eq :bold weight)) + (cond + ((null slant) nil) + ((member slant '("i" "I")) + (set-font-italic-p retval t)) + ((member slant '("o" "O")) + (set-font-oblique-p retval t))) + (if (string-match font-x-registry-and-encoding-regexp fontname) + (progn + (set-font-registry retval (match-string 1 fontname)) + (set-font-encoding retval (match-string 2 fontname)))) + retval)))) + +(defun x-font-families-for-device (&optional device no-resetp) + (condition-case () + (require 'x-font-menu) + (error nil)) + (or device (setq device (selected-device))) + (if (boundp 'device-fonts-cache) + (let ((menu (or (cdr-safe (assq device device-fonts-cache))))) + (if (and (not menu) (not no-resetp)) + (progn + (reset-device-font-menus device) + (x-font-families-for-device device t)) + (let ((scaled (mapcar (function (lambda (x) (if x (aref x 0)))) + (aref menu 0))) + (normal (mapcar (function (lambda (x) (if x (aref x 0)))) + (aref menu 1)))) + (sort (font-unique (nconc scaled normal)) 'string-lessp)))) + (cons "monospace" (mapcar 'car font-family-mappings)))) + +(defvar font-default-cache nil) + +;;;###autoload +(defun font-default-font-for-device (&optional device) + (or device (setq device (selected-device))) + (if font-running-xemacs + (font-truename + (make-font-specifier + (face-font-name 'default device))) + (let ((font (cdr-safe (assq 'font (frame-parameters device))))) + (if (and (fboundp 'fontsetp) (fontsetp font)) + (aref (get-font-info (aref (cdr (get-fontset-info font)) 0)) 2) + font)))) + +;;;###autoload +(defun font-default-object-for-device (&optional device) + (let ((font (font-default-font-for-device device))) + (or (cdr-safe + (assoc font font-default-cache)) + (progn + (setq font-default-cache (cons (cons font + (font-create-object font)) + font-default-cache)) + (cdr-safe (assoc font font-default-cache)))))) + +;;;###autoload +(defun font-default-family-for-device (&optional device) + (or device (setq device (selected-device))) + (font-family (font-default-object-for-device device))) + +;;;###autoload +(defun font-default-registry-for-device (&optional device) + (or device (setq device (selected-device))) + (font-registry (font-default-object-for-device device))) + +;;;###autoload +(defun font-default-encoding-for-device (&optional device) + (or device (setq device (selected-device))) + (font-encoding (font-default-object-for-device device))) + +;;;###autoload +(defun font-default-size-for-device (&optional device) + (or device (setq device (selected-device))) + ;; face-height isn't the right thing (always 1 pixel too high?) + ;; (if font-running-xemacs + ;; (format "%dpx" (face-height 'default device)) + (font-size (font-default-object-for-device device))) + +(defun x-font-create-name (fontobj &optional device) + (if (and (not (or (font-family fontobj) + (font-weight fontobj) + (font-size fontobj) + (font-registry fontobj) + (font-encoding fontobj))) + (= (font-style fontobj) 0)) + (face-font 'default) + (or device (setq device (selected-device))) + (let* ((default (font-default-object-for-device device)) + (family (or (font-family fontobj) + (font-family default) + (x-font-families-for-device device))) + (weight (or (font-weight fontobj) :medium)) + (style (font-style fontobj)) + (size (or (if font-running-xemacs + (font-size fontobj)) + (font-size default))) + (registry (or (font-registry fontobj) + (font-registry default) + "*")) + (encoding (or (font-encoding fontobj) + (font-encoding default) + "*"))) + (if (stringp family) + (setq family (list family))) + (setq weight (font-higher-weight weight + (and (font-bold-p fontobj) :bold))) + (if (stringp size) + (setq size (truncate (font-spatial-to-canonical size device)))) + (setq weight (or (cdr-safe (assq weight x-font-weight-mappings)) "*")) + (let ((done nil) ; Did we find a good font yet? + (font-name nil) ; font name we are currently checking + (cur-family nil) ; current family we are checking + ) + (while (and family (not done)) + (setq cur-family (car family) + family (cdr family)) + (if (assoc cur-family font-family-mappings) + ;; If the family name is an alias as defined by + ;; font-family-mappings, then append those families + ;; to the front of 'family' and continue in the loop. + (setq family (append + (cdr-safe (assoc cur-family + font-family-mappings)) + family)) + ;; Not an alias for a list of fonts, so we just check it. + ;; First, convert all '-' to spaces so that we don't screw up + ;; the oh-so wonderful X font model. Wheee. + (let ((x (length cur-family))) + (while (> x 0) + (if (= ?- (aref cur-family (1- x))) + (aset cur-family (1- x) ? )) + (setq x (1- x)))) + ;; We treat oblique and italic as equivalent. Don't ask. + (let ((slants '("o" "i"))) + (while (and slants (not done)) + (setq font-name (format "-*-%s-%s-%s-*-*-*-%s-*-*-*-*-%s-%s" + cur-family weight + (if (or (font-italic-p fontobj) + (font-oblique-p fontobj)) + (car slants) + "r") + (if size + (int-to-string (* 10 size)) "*") + registry + encoding + ) + slants (cdr slants) + done (try-font-name font-name device)))))) + (if done font-name))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; The window-system dependent code (NS-style) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun ns-font-families-for-device (&optional device no-resetp) + ;; For right now, assume we are going to have the same storage for + ;; device fonts for NS as we do for X. Is this a valid assumption? + (or device (setq device (selected-device))) + (if (boundp 'device-fonts-cache) + (let ((menu (or (cdr-safe (assq device device-fonts-cache))))) + (if (and (not menu) (not no-resetp)) + (progn + (reset-device-font-menus device) + (ns-font-families-for-device device t)) + (let ((scaled (mapcar (function (lambda (x) (if x (aref x 0)))) + (aref menu 0))) + (normal (mapcar (function (lambda (x) (if x (aref x 0)))) + (aref menu 1)))) + (sort (font-unique (nconc scaled normal)) 'string-lessp)))))) + +(defun ns-font-create-name (fontobj &optional device) + (let ((family (or (font-family fontobj) + (ns-font-families-for-device device))) + (weight (or (font-weight fontobj) :medium)) + (style (or (font-style fontobj) (list :normal))) + (size (font-size fontobj)) + (registry (or (font-registry fontobj) "*")) + (encoding (or (font-encoding fontobj) "*"))) + ;; Create a font, wow! + (if (stringp family) + (setq family (list family))) + (if (or (symbolp style) (numberp style)) + (setq style (list style))) + (setq weight (font-higher-weight weight (car-safe (memq :bold style)))) + (if (stringp size) + (setq size (font-spatial-to-canonical size device))) + (setq weight (or (cdr-safe (assq weight ns-font-weight-mappings)) + "medium")) + (let ((done nil) ; Did we find a good font yet? + (font-name nil) ; font name we are currently checking + (cur-family nil) ; current family we are checking + ) + (while (and family (not done)) + (setq cur-family (car family) + family (cdr family)) + (if (assoc cur-family font-family-mappings) + ;; If the family name is an alias as defined by + ;; font-family-mappings, then append those families + ;; to the front of 'family' and continue in the loop. + (setq family (append + (cdr-safe (assoc cur-family + font-family-mappings)) + family)) + ;; CARL: Need help here - I am not familiar with the NS font + ;; model + (setq font-name "UNKNOWN FORMULA GOES HERE" + done (try-font-name font-name device)))) + (if done font-name)))) + + +;;; Cache building code +;;;###autoload +(defun x-font-build-cache (&optional device) + (let ((hashtable (make-hash-table :test 'equal :size 15)) + (fonts (mapcar 'x-font-create-object + (x-list-fonts "-*-*-*-*-*-*-*-*-*-*-*-*-*-*"))) + (plist nil) + (cur nil)) + (while fonts + (setq cur (car fonts) + fonts (cdr fonts) + plist (cl-gethash (car (font-family cur)) hashtable)) + (if (not (memq (font-weight cur) (plist-get plist 'weights))) + (setq plist (plist-put plist 'weights (cons (font-weight cur) + (plist-get plist 'weights))))) + (if (not (member (font-size cur) (plist-get plist 'sizes))) + (setq plist (plist-put plist 'sizes (cons (font-size cur) + (plist-get plist 'sizes))))) + (if (and (font-oblique-p cur) + (not (memq 'oblique (plist-get plist 'styles)))) + (setq plist (plist-put plist 'styles (cons 'oblique (plist-get plist 'styles))))) + (if (and (font-italic-p cur) + (not (memq 'italic (plist-get plist 'styles)))) + (setq plist (plist-put plist 'styles (cons 'italic (plist-get plist 'styles))))) + (cl-puthash (car (font-family cur)) plist hashtable)) + hashtable)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Now overwrite the original copy of set-face-font with our own copy that +;;; can deal with either syntax. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ###autoload +(defun font-set-face-font (&optional face font &rest args) + (cond + ((and (vectorp font) (= (length font) 12)) + (let ((font-name (font-create-name font))) + (set-face-property face 'font-specification font) + (cond + ((null font-name) ; No matching font! + nil) + ((listp font-name) ; For TTYs + (let (cur) + (while font-name + (setq cur (car font-name) + font-name (cdr font-name)) + (apply 'set-face-property face (car cur) (cdr cur) args)))) + (font-running-xemacs + (apply 'set-face-font face font-name args) + (apply 'set-face-underline-p face (font-underline-p font) args) + (if (and (or (font-smallcaps-p font) (font-bigcaps-p font)) + (fboundp 'set-face-display-table)) + (apply 'set-face-display-table + face font-caps-display-table args)) + (apply 'set-face-property face 'strikethru (or + (font-linethrough-p font) + (font-strikethru-p font)) + args)) + (t + (condition-case nil + (apply 'set-face-font face font-name args) + (error + (let ((args (car-safe args))) + (and (or (font-bold-p font) + (memq (font-weight font) '(:bold :demi-bold))) + (make-face-bold face args t)) + (and (font-italic-p font) (make-face-italic face args t))))) + (apply 'set-face-underline-p face (font-underline-p font) args))))) + (t + ;; Let the original set-face-font signal any errors + (set-face-property face 'font-specification nil) + (apply 'set-face-font face font args)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Now for emacsen specific stuff +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun font-update-device-fonts (device) + ;; Update all faces that were created with the 'font' package + ;; to appear correctly on the new device. This should be in the + ;; create-device-hook. This is XEmacs 19.12+ specific + (let ((faces (face-list 2)) + (cur nil) + (font nil) + (font-spec nil)) + (while faces + (setq cur (car faces) + faces (cdr faces) + font-spec (face-property cur 'font-specification)) + (if font-spec + (set-face-font cur font-spec device))))) + +(defun font-update-one-face (face &optional device-list) + ;; Update FACE on all devices in DEVICE-LIST + ;; DEVICE_LIST defaults to a list of all active devices + (setq device-list (or device-list (device-list))) + (if (devicep device-list) + (setq device-list (list device-list))) + (let* ((cur-device nil) + (font-spec (face-property face 'font-specification)) + (font nil)) + (if (not font-spec) + ;; Hey! Don't mess with fonts we didn't create in the + ;; first place. + nil + (while device-list + (setq cur-device (car device-list) + device-list (cdr device-list)) + (if (not (device-live-p cur-device)) + ;; Whoah! + nil + (if font-spec + (set-face-font face font-spec cur-device))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Various color related things +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(cond + ((fboundp 'display-warning) + (fset 'font-warn 'display-warning)) + ((fboundp 'w3-warn) + (fset 'font-warn 'w3-warn)) + ((fboundp 'url-warn) + (fset 'font-warn 'url-warn)) + ((fboundp 'warn) + (defun font-warn (class message &optional level) + (warn "(%s/%s) %s" class (or level 'warning) message))) + (t + (defun font-warn (class message &optional level) + (save-excursion + (set-buffer (get-buffer-create "*W3-WARNINGS*")) + (goto-char (point-max)) + (save-excursion + (insert (format "(%s/%s) %s\n" class (or level 'warning) message))) + (display-buffer (current-buffer)))))) + +(defun font-lookup-rgb-components (color) + "Lookup COLOR (a color name) in rgb.txt and return a list of RGB values. +The list (R G B) is returned, or an error is signaled if the lookup fails." + (let ((lib-list (if (boundp 'x-library-search-path) + x-library-search-path + ;; This default is from XEmacs 19.13 - hope it covers + ;; everyone. + (list "/usr/X11R6/lib/X11/" + "/usr/X11R5/lib/X11/" + "/usr/lib/X11R6/X11/" + "/usr/lib/X11R5/X11/" + "/usr/local/X11R6/lib/X11/" + "/usr/local/X11R5/lib/X11/" + "/usr/local/lib/X11R6/X11/" + "/usr/local/lib/X11R5/X11/" + "/usr/X11/lib/X11/" + "/usr/lib/X11/" + "/usr/local/lib/X11/" + "/usr/X386/lib/X11/" + "/usr/x386/lib/X11/" + "/usr/XFree86/lib/X11/" + "/usr/unsupported/lib/X11/" + "/usr/athena/lib/X11/" + "/usr/local/x11r5/lib/X11/" + "/usr/lpp/Xamples/lib/X11/" + "/usr/openwin/lib/X11/" + "/usr/openwin/share/lib/X11/"))) + (file font-rgb-file) + r g b) + (if (not file) + (while lib-list + (setq file (expand-file-name "rgb.txt" (car lib-list))) + (if (file-readable-p file) + (setq lib-list nil + font-rgb-file file) + (setq lib-list (cdr lib-list) + file nil)))) + (if (null file) + (list 0 0 0) + (save-excursion + (set-buffer (find-file-noselect file)) + (if (not (= (aref (buffer-name) 0) ? )) + (rename-buffer (generate-new-buffer-name " *rgb-tmp-buffer*"))) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (if (re-search-forward (format "\t%s$" (regexp-quote color)) nil t) + (progn + (beginning-of-line) + (setq r (* (read (current-buffer)) 256) + g (* (read (current-buffer)) 256) + b (* (read (current-buffer)) 256))) + (font-warn 'color (format "No such color: %s" color)) + (setq r 0 + g 0 + b 0)) + (list r g b) )))))) + +(defun font-hex-string-to-number (string) + "Convert STRING to an integer by parsing it as a hexadecimal number." + (let ((conv-list '((?0 . 0) (?a . 10) (?A . 10) + (?1 . 1) (?b . 11) (?B . 11) + (?2 . 2) (?c . 12) (?C . 12) + (?3 . 3) (?d . 13) (?D . 13) + (?4 . 4) (?e . 14) (?E . 14) + (?5 . 5) (?f . 15) (?F . 15) + (?6 . 6) + (?7 . 7) + (?8 . 8) + (?9 . 9))) + (n 0) + (i 0) + (lim (length string))) + (while (< i lim) + (setq n (+ (* n 16) (or (cdr (assq (aref string i) conv-list)) 0)) + i (1+ i))) + n )) + +(defun font-parse-rgb-components (color) + "Parse RGB color specification and return a list of integers (R G B). +#FEFEFE and rgb:fe/fe/fe style specifications are parsed." + (let ((case-fold-search t) + r g b str) + (cond ((string-match "^#[0-9a-f]+$" color) + (cond + ((= (length color) 4) + (setq r (font-hex-string-to-number (substring color 1 2)) + g (font-hex-string-to-number (substring color 2 3)) + b (font-hex-string-to-number (substring color 3 4)) + r (* r 4096) + g (* g 4096) + b (* b 4096))) + ((= (length color) 7) + (setq r (font-hex-string-to-number (substring color 1 3)) + g (font-hex-string-to-number (substring color 3 5)) + b (font-hex-string-to-number (substring color 5 7)) + r (* r 256) + g (* g 256) + b (* b 256))) + ((= (length color) 10) + (setq r (font-hex-string-to-number (substring color 1 4)) + g (font-hex-string-to-number (substring color 4 7)) + b (font-hex-string-to-number (substring color 7 10)) + r (* r 16) + g (* g 16) + b (* b 16))) + ((= (length color) 13) + (setq r (font-hex-string-to-number (substring color 1 5)) + g (font-hex-string-to-number (substring color 5 9)) + b (font-hex-string-to-number (substring color 9 13)))) + (t + (font-warn 'color (format "Invalid RGB color specification: %s" + color)) + (setq r 0 + g 0 + b 0)))) + ((string-match "rgb:\\([0-9a-f]+\\)/\\([0-9a-f]+\\)/\\([0-9a-f]+\\)" + color) + (if (or (> (- (match-end 1) (match-beginning 1)) 4) + (> (- (match-end 2) (match-beginning 2)) 4) + (> (- (match-end 3) (match-beginning 3)) 4)) + (error "Invalid RGB color specification: %s" color) + (setq str (match-string 1 color) + r (* (font-hex-string-to-number str) + (expt 16 (- 4 (length str)))) + str (match-string 2 color) + g (* (font-hex-string-to-number str) + (expt 16 (- 4 (length str)))) + str (match-string 3 color) + b (* (font-hex-string-to-number str) + (expt 16 (- 4 (length str))))))) + (t + (font-warn 'html (format "Invalid RGB color specification: %s" + color)) + (setq r 0 + g 0 + b 0))) + (list r g b) )) + +(defsubst font-rgb-color-p (obj) + (or (and (vectorp obj) + (= (length obj) 4) + (eq (aref obj 0) 'rgb)))) + +(defsubst font-rgb-color-red (obj) (aref obj 1)) +(defsubst font-rgb-color-green (obj) (aref obj 2)) +(defsubst font-rgb-color-blue (obj) (aref obj 3)) + +(defun font-color-rgb-components (color) + "Return the RGB components of COLOR as a list of integers (R G B). +16-bit values are always returned. +#FEFEFE and rgb:fe/fe/fe style color specifications are parsed directly +into their components. +RGB values for color names are looked up in the rgb.txt file. +The variable x-library-search-path is use to locate the rgb.txt file." + (let ((case-fold-search t)) + (cond + ((and (font-rgb-color-p color) (floatp (aref color 1))) + (list (* 65535 (aref color 0)) + (* 65535 (aref color 1)) + (* 65535 (aref color 2)))) + ((font-rgb-color-p color) + (list (font-rgb-color-red color) + (font-rgb-color-green color) + (font-rgb-color-blue color))) + ((and (vectorp color) (= 3 (length color))) + (list (aref color 0) (aref color 1) (aref color 2))) + ((and (listp color) (= 3 (length color)) (floatp (car color))) + (mapcar (function (lambda (x) (* x 65535))) color)) + ((and (listp color) (= 3 (length color))) + color) + ((or (string-match "^#" color) + (string-match "^rgb:" color)) + (font-parse-rgb-components color)) + ((string-match "\\([0-9.]+\\)[ \t]\\([0-9.]+\\)[ \t]\\([0-9.]+\\)" + color) + (let ((r (string-to-number (match-string 1 color))) + (g (string-to-number (match-string 2 color))) + (b (string-to-number (match-string 3 color)))) + (if (floatp r) + (setq r (round (* 255 r)) + g (round (* 255 g)) + b (round (* 255 b)))) + (font-parse-rgb-components (format "#%02x%02x%02x" r g b)))) + (t + (font-lookup-rgb-components color))))) + +(defsubst font-tty-compute-color-delta (col1 col2) + (+ + (* (- (aref col1 0) (aref col2 0)) + (- (aref col1 0) (aref col2 0))) + (* (- (aref col1 1) (aref col2 1)) + (- (aref col1 1) (aref col2 1))) + (* (- (aref col1 2) (aref col2 2)) + (- (aref col1 2) (aref col2 2))))) + +(defun font-tty-find-closest-color (r g b) + ;; This is basically just a lisp copy of allocate_nearest_color + ;; from objects-x.c from Emacs 19 + ;; We really should just check tty-color-list, but unfortunately + ;; that does not include any RGB information at all. + ;; So for now we just hardwire in the default list and call it + ;; good for now. + (setq r (/ r 65535.0) + g (/ g 65535.0) + b (/ b 65535.0)) + (let* ((color_def (vector r g b)) + (colors [([1.0 1.0 1.0] . "white") + ([0.0 1.0 1.0] . "cyan") + ([1.0 0.0 1.0] . "magenta") + ([0.0 0.0 1.0] . "blue") + ([1.0 1.0 0.0] . "yellow") + ([0.0 1.0 0.0] . "green") + ([1.0 0.0 0.0] . "red") + ([0.0 0.0 0.0] . "black")]) + (no_cells (length colors)) + (x 1) + (nearest 0) + (nearest_delta 0) + (trial_delta 0)) + (setq nearest_delta (font-tty-compute-color-delta (car (aref colors 0)) + color_def)) + (while (/= no_cells x) + (setq trial_delta (font-tty-compute-color-delta (car (aref colors x)) + color_def)) + (if (< trial_delta nearest_delta) + (setq nearest x + nearest_delta trial_delta)) + (setq x (1+ x))) + (cdr-safe (aref colors nearest)))) + +(defun font-normalize-color (color &optional device) + "Return an RGB tuple, given any form of input. If an error occurs, black +is returned." + (case (device-type device) + ((x pm) + (apply 'format "#%02x%02x%02x" (font-color-rgb-components color))) + (mswindows + (let* ((rgb (font-color-rgb-components color)) + (color (apply 'format "#%02x%02x%02x" rgb))) + (mswindows-define-rgb-color (nth 0 rgb) (nth 1 rgb) (nth 2 rgb) color) + color)) + (tty + (apply 'font-tty-find-closest-color (font-color-rgb-components color))) + (ns + (let ((vals (mapcar (function (lambda (x) (>> x 8))) + (font-color-rgb-components color)))) + (apply 'format "RGB%02x%02x%02xff" vals))) + (otherwise + color))) + +(defun font-set-face-background (&optional face color &rest args) + (interactive) + (condition-case nil + (cond + ((or (font-rgb-color-p color) + (string-match "^#[0-9a-fA-F]+$" color)) + (apply 'set-face-background face + (font-normalize-color color) args)) + (t + (apply 'set-face-background face color args))) + (error nil))) + +(defun font-set-face-foreground (&optional face color &rest args) + (interactive) + (condition-case nil + (cond + ((or (font-rgb-color-p color) + (string-match "^#[0-9a-fA-F]+$" color)) + (apply 'set-face-foreground face (font-normalize-color color) args)) + (t + (apply 'set-face-foreground face color args))) + (error nil))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Support for 'blinking' fonts +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun font-map-windows (func &optional arg frame) + (let* ((start (selected-window)) + (cur start) + (result nil)) + (push (funcall func start arg) result) + (while (not (eq start (setq cur (next-window cur)))) + (push (funcall func cur arg) result)) + result)) + +(defun font-face-visible-in-window-p (window face) + (let ((st (window-start window)) + (nd (window-end window)) + (found nil) + (face-at nil)) + (setq face-at (get-text-property st 'face (window-buffer window))) + (if (or (eq face face-at) (and (listp face-at) (memq face face-at))) + (setq found t)) + (while (and (not found) + (/= nd + (setq st (next-single-property-change + st 'face + (window-buffer window) nd)))) + (setq face-at (get-text-property st 'face (window-buffer window))) + (if (or (eq face face-at) (and (listp face-at) (memq face face-at))) + (setq found t))) + found)) + +(defun font-blink-callback () + ;; Optimized to never invert the face unless one of the visible windows + ;; is showing it. + (let ((faces (if font-running-xemacs (face-list t) (face-list))) + (obj nil)) + (while faces + (if (and (setq obj (face-property (car faces) 'font-specification)) + (font-blink-p obj) + (memq t + (font-map-windows 'font-face-visible-in-window-p (car faces)))) + (invert-face (car faces))) + (pop faces)))) + +(defcustom font-blink-interval 0.5 + "How often to blink faces" + :type 'number + :group 'faces) + +(defun font-blink-initialize () + (cond + ((featurep 'itimer) + (if (get-itimer "font-blinker") + (delete-itimer (get-itimer "font-blinker"))) + (start-itimer "font-blinker" 'font-blink-callback + font-blink-interval + font-blink-interval)) + ((fboundp 'run-at-time) + (cancel-function-timers 'font-blink-callback) + (run-at-time font-blink-interval + font-blink-interval + 'font-blink-callback)) + (t nil))) + +(provide 'font) diff -r 43306a74e31c -r d44af0c54775 lisp/fontl-hooks.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/fontl-hooks.el Mon Aug 13 10:08:34 2007 +0200 @@ -0,0 +1,87 @@ +;;; fontl-hooks.el --- pre-loaded stuff for font-lock. + +;; Copyright (C) 1992, 1993, 1994, 1995 Free Software Foundation, Inc. +;; Copyright (C) 1995 Amdahl Corporation. +;; Copyright (C) 1996 Ben Wing. + +;; This file is part of XEmacs. + +;; XEmacs 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. + +;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: FSF 19.30. (font-lock.el) + +;;; Commentary: + +;; The reason for the existence of this file is so that modes can +;; call `font-lock-set-defaults' without worrying about whether +;; font-lock is loaded. We don't autoload this from font-lock.el +;; because loading font-lock.el automatically turns font-lock on. + +;;; Code: + +(defun font-lock-set-defaults (&optional explicit-defaults) + "Set fontification defaults appropriately for this mode. +Sets `font-lock-keywords', `font-lock-keywords-only', `font-lock-syntax-table', +`font-lock-beginning-of-syntax-function' and +`font-lock-keywords-case-fold-search'. + +If `font-lock-defaults' is currently set, it is used. Otherwise, the +symbol naming the major mode is examined for a `font-lock-defaults' +property. If that is not present, but a variable `foo-mode-font-lock-keywords' +is, the value of that variable is used as the default for +`font-lock-keywords'. Various other backward-compatible behaviors also +exist -- if you're curious, look at the source. + +The value of `font-lock-maximum-decoration' is used to determine which +set of keywords applies, if more than one exists. + +This will also put the buffer into Font Lock mode if any keywords exist +and if auto-fontification is called for, as determined by +`font-lock-auto-fontify', `font-lock-mode-enable-list', and +`font-lock-mode-disable-list'. + +Calling this function multiple times in the same buffer is safe -- this +function keeps track of whether it has already been called in this +buffer, and does nothing if so. This allows for multiple ways of getting +Font Lock properly initialized in a buffer, to deal with existing major +modes that do not call this function. (For example, Font Lock adds this +function to `find-file-hooks'.) + +Major modes that have any font-lock defaults specified should call this +function during their initialization process, after they have set +the variable `major-mode'. + +If EXPLICIT-DEFAULTS is t, this function will not check whether it +has already been run in this buffer, and will always do the full +computation. + +If EXPLICIT-DEFAULTS is not nil and not t, it should be something +that is allowable as a value for `font-lock-defaults' and will be +used to initialize the Font Lock variables." + + (when + (and + (featurep 'font-lock) + (if font-lock-auto-fontify + (not (memq major-mode font-lock-mode-disable-list)) + (memq major-mode font-lock-mode-enable-list)) + (font-lock-set-defaults-1 explicit-defaults) + font-lock-keywords) + (turn-on-font-lock))) + +(provide 'fontl-hooks) + +;;; fontl-hooks.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/gnuserv.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnuserv.el Mon Aug 13 10:08:34 2007 +0200 @@ -0,0 +1,779 @@ +;;; gnuserv.el --- Lisp interface code between Emacs and gnuserv +;; Copyright (C) 1989-1997 Free Software Foundation, Inc. + +;; Version: 3.10 +;; Author: Andy Norman (ange@hplb.hpl.hp.com), originally based on server.el +;; Hrvoje Niksic +;; Maintainer: Jan Vroonhof , +;; Hrvoje Niksic +;; Keywords: environment, processes, terminals + +;; This file is part of XEmacs. + +;; XEmacs 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. + +;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF. + +;;; Commentary: + +;; Gnuserv is run when Emacs needs to operate as a server for other +;; processes. Specifically, any number of files can be attached for +;; editing to a running XEmacs process using the `gnuclient' program. + +;; Use `M-x gnuserv-start' to start the server and `gnuclient files' +;; to load them to XEmacs. When you are done with a buffer, press +;; `C-x #' (`M-x gnuserv-edit'). You can put (gnuserv-start) to your +;; .emacs, and enable `gnuclient' as your Unix "editor". When all the +;; buffers for a client have been edited and exited with +;; `gnuserv-edit', the client "editor" will return to the program that +;; invoked it. + +;; Your editing commands and Emacs' display output go to and from the +;; terminal or X display in the usual way. If you are running under +;; X, a new X frame will be open for each gnuclient. If you are on a +;; TTY, this TTY will be attached as a new device to the running +;; XEmacs, and will be removed once you are done with the buffer. + +;; To evaluate a Lisp form in a running Emacs, use the `-eval' +;; argument of gnuclient. To simplify this, we provide the `gnudoit' +;; shell script. For example `gnudoit "(+ 2 3)"' will print `5', +;; whereas `gnudoit "(gnus)"' will fire up your favorite newsreader. +;; Like gnuclient, `gnudoit' requires the server to be started prior +;; to using it. + +;; For more information you can refer to man pages of gnuclient, +;; gnudoit and gnuserv, distributed with XEmacs. + +;; gnuserv.el was originally written by Andy Norman as an improvement +;; over William Sommerfeld's server.el. Since then, a number of +;; people have worked on it, including Bob Weiner, Darell Kindred, +;; Arup Mukherjee, Ben Wing and Jan Vroonhof. It was completely +;; rewritten (labeled as version 3) by Hrvoje Niksic in May 1997. The +;; new code will not run on GNU Emacs. + +;; Jan Vroonhof July/1996 +;; ported the server-temp-file-regexp feature from server.el +;; ported server hooks from server.el +;; ported kill-*-query functions from server.el (and made it optional) +;; synced other behaviour with server.el +;; +;; Jan Vroonhof +;; Customized. +;; +;; Hrvoje Niksic May/1997 +;; Completely rewritten. Now uses `defstruct' and other CL stuff +;; to define clients cleanly. Many thanks to Dave Gillespie! +;; +;; Mike Scheidler July, 1997 +;; Added 'Done' button to the menubar. + + +;;; Code: + +(defgroup gnuserv nil + "The gnuserv suite of programs to talk to Emacs from outside." + :group 'environment + :group 'processes + :group 'terminals) + + +;; Provide the old variables as aliases, to avoid breaking .emacs +;; files. However, they are obsolete and should be converted to the +;; new forms. This ugly crock must be before the variable +;; declaration, or the scheme fails. + +(define-obsolete-variable-alias 'server-frame 'gnuserv-frame) +(define-obsolete-variable-alias 'server-done-function + 'gnuserv-done-function) +(define-obsolete-variable-alias 'server-done-temp-file-function + 'gnuserv-done-temp-file-function) +(define-obsolete-variable-alias 'server-find-file-function + 'gnuserv-find-file-function) +(define-obsolete-variable-alias 'server-program + 'gnuserv-program) +(define-obsolete-variable-alias 'server-visit-hook + 'gnuserv-visit-hook) +(define-obsolete-variable-alias 'server-done-hook + 'gnuserv-done-hook) +(define-obsolete-variable-alias 'server-kill-quietly + 'gnuserv-kill-quietly) +(define-obsolete-variable-alias 'server-temp-file-regexp + 'gnuserv-temp-file-regexp) +(define-obsolete-variable-alias 'server-make-temp-file-backup + 'gnuserv-make-temp-file-backup) + +;;;###autoload +(defcustom gnuserv-frame nil + "*The frame to be used to display all edited files. +If nil, then a new frame is created for each file edited. +If t, then the currently selected frame will be used. +If a function, then this will be called with a symbol `x' or `tty' as the +only argument, and its return value will be interpreted as above." + :tag "Gnuserv Frame" + :type '(radio (const :tag "Create new frame each time" nil) + (const :tag "Use selected frame" t) + (function-item :tag "Use main Emacs frame" + gnuserv-main-frame-function) + (function-item :tag "Use visible frame, otherwise create new" + gnuserv-visible-frame-function) + (function-item :tag "Create special Gnuserv frame and use it" + gnuserv-special-frame-function) + (function :tag "Other")) + :group 'gnuserv + :group 'frames) + +(defcustom gnuserv-frame-plist nil + "*Plist of frame properties for creating a gnuserv frame." + :type '(repeat (group :inline t + (symbol :tag "Property") + (sexp :tag "Value"))) + :group 'gnuserv + :group 'frames) + +(defcustom gnuserv-done-function 'kill-buffer + "*Function used to remove a buffer after editing. +It is called with one BUFFER argument. Functions such as `kill-buffer' and +`bury-buffer' are good values. See also `gnuserv-done-temp-file-function'." + :type '(radio (function-item kill-buffer) + (function-item bury-buffer) + (function :tag "Other")) + :group 'gnuserv) + +(defcustom gnuserv-done-temp-file-function 'kill-buffer + "*Function used to remove a temporary buffer after editing. +It is called with one BUFFER argument. Functions such as `kill-buffer' and +`bury-buffer' are good values. See also `gnuserv-done-temp-file-function'." + :type '(radio (function-item kill-buffer) + (function-item bury-buffer) + (function :tag "Other")) + :group 'gnuserv) + +(defcustom gnuserv-find-file-function 'find-file + "*Function to visit a file with. +It takes one argument, a file name to visit." + :type 'function + :group 'gnuserv) + +(defcustom gnuserv-view-file-function 'view-file + "*Function to view a file with. +It takes one argument, a file name to view." + :type '(radio (function-item view-file) + (function-item find-file-read-only) + (function :tag "Other")) + :group 'gnuserv) + +(defcustom gnuserv-program "gnuserv" + "*Program to use as the editing server." + :type 'string + :group 'gnuserv) + +(defcustom gnuserv-visit-hook nil + "*Hook run after visiting a file." + :type 'hook + :group 'gnuserv) + +(defcustom gnuserv-done-hook nil + "*Hook run when done editing a buffer for the Emacs server. +The hook functions are called after the file has been visited, with the +current buffer set to the visiting buffer." + :type 'hook + :group 'gnuserv) + +(defcustom gnuserv-init-hook nil + "*Hook run after the server is started." + :type 'hook + :group 'gnuserv) + +(defcustom gnuserv-shutdown-hook nil + "*Hook run before the server exits." + :type 'hook + :group 'gnuserv) + +(defcustom gnuserv-kill-quietly nil + "*Non-nil means to kill buffers with clients attached without requiring confirmation." + :type 'boolean + :group 'gnuserv) + +(defcustom gnuserv-temp-file-regexp "^/tmp/Re\\|/draft$" + "*Regexp which should match filenames of temporary files deleted +and reused by the programs that invoke the Emacs server." + :type 'regexp + :group 'gnuserv) + +(defcustom gnuserv-make-temp-file-backup nil + "*Non-nil makes the server backup temporary files also." + :type 'boolean + :group 'gnuserv) + + +;;; Internal variables: + +(defstruct gnuclient + "An object that encompasses several buffers in one. +Normally, a client connecting to Emacs will be assigned an id, and +will request editing of several files. + +ID - Client id (integer). +BUFFERS - List of buffers that \"belong\" to the client. + NOTE: one buffer can belong to several clients. +DEVICE - The device this client is on. If the device was also created. + by a client, it will be placed to `gnuserv-devices' list. +FRAME - Frame created by the client, or nil if the client didn't + create a frame. + +All the slots default to nil." + (id nil) + (buffers nil) + (device nil) + (frame nil)) + +(defvar gnuserv-process nil + "The current gnuserv process.") + +(defvar gnuserv-string "" + "The last input string from the server.") + +(defvar gnuserv-current-client nil + "The client we are currently talking to.") + +(defvar gnuserv-clients nil + "List of current gnuserv clients. +Each element is a gnuclient structure that identifies a client.") + +(defvar gnuserv-devices nil + "List of devices created by clients.") + +(defvar gnuserv-special-frame nil + "Frame created specially for Server.") + +;; We want the client-infested buffers to have some modeline +;; identification, so we'll make a "minor mode". +(defvar gnuserv-minor-mode nil) +(make-variable-buffer-local 'gnuserv-mode) +(pushnew '(gnuserv-minor-mode " Server") minor-mode-alist + :test 'equal) + + +;; Sample gnuserv-frame functions + +(defun gnuserv-main-frame-function (type) + "Returns a sensible value for the main Emacs frame." + (if (eq type 'x) + (car (frame-list)) + nil)) + +(defun gnuserv-visible-frame-function (type) + "Returns a frame if there is a frame that is truly visible, nil otherwise. +This is meant in the X sense, so it will not return frames that are on another +visual screen. Totally visible frames are preferred. If none found, return nil." + (if (eq type 'x) + (cond ((car (filtered-frame-list 'frame-totally-visible-p + (selected-device)))) + ((car (filtered-frame-list (lambda (frame) + ;; eq t as in not 'hidden + (eq t (frame-visible-p frame))) + (selected-device))))) + nil)) + +(defun gnuserv-special-frame-function (type) + "Creates a special frame for Gnuserv and returns it on later invocations." + (unless (frame-live-p gnuserv-special-frame) + (setq gnuserv-special-frame (make-frame gnuserv-frame-plist))) + gnuserv-special-frame) + + +;;; Communication functions + +;; We used to restart the server here, but it's too risky -- if +;; something goes awry, it's too easy to wind up in a loop. +(defun gnuserv-sentinel (proc msg) + (let ((msgstring (concat "Gnuserv process %s; restart with `%s'")) + (keystring (substitute-command-keys "\\[gnuserv-start]"))) + (case (process-status proc) + (exit + (message msgstring "exited" keystring) + (gnuserv-prepare-shutdown)) + (signal + (message msgstring "killed" keystring) + (gnuserv-prepare-shutdown)) + (closed + (message msgstring "closed" keystring)) + (gnuserv-prepare-shutdown)))) + +;; This function reads client requests from our current server. Every +;; client is identified by a unique ID within the server +;; (incidentally, the same ID is the file descriptor the server uses +;; to communicate to client). +;; +;; The request string can arrive in several chunks. As the request +;; ends with \C-d, we check for that character at the end of string. +;; If not found, keep reading, and concatenating to former strings. +;; So, if at first read we receive "5 (gn", that text will be stored +;; to gnuserv-string. If we then receive "us)\C-d", the two will be +;; concatenated, `current-client' will be set to 5, and `(gnus)' form +;; will be evaluated. +;; +;; Server will send the following: +;; +;; "ID \C-d" (no quotes) +;; +;; ID - file descriptor of the given client; +;; - the actual contents of the request. +(defun gnuserv-process-filter (proc string) + "Process gnuserv client requests to execute Emacs commands." + (setq gnuserv-string (concat gnuserv-string string)) + ;; C-d means end of request. + (when (string-match "\C-d\\'" gnuserv-string) + (cond ((string-match "^[0-9]+" gnuserv-string) ; client request id + (let ((header (read-from-string gnuserv-string))) + ;; Set the client we are talking to. + (setq gnuserv-current-client (car header)) + ;; Evaluate the expression + (condition-case oops + (eval (car (read-from-string gnuserv-string (cdr header)))) + ;; In case of an error, write the description to the + ;; client, and then signal it. + (error (setq gnuserv-string "") + (gnuserv-write-to-client gnuserv-current-client oops) + (setq gnuserv-current-client nil) + (signal (car oops) (cdr oops))) + (quit (setq gnuserv-string "") + (gnuserv-write-to-client gnuserv-current-client oops) + (setq gnuserv-current-client nil) + (signal 'quit nil))) + (setq gnuserv-string ""))) + (t + (error "%s: invalid response from gnuserv" gnuserv-string) + (setq gnuserv-string ""))))) + +;; This function is somewhat of a misnomer. Actually, we write to the +;; server (using `process-send-string' to gnuserv-process), which +;; interprets what we say and forwards it to the client. The +;; incantation server understands is (from gnuserv.c): +;; +;; "FD/LEN:\n" (no quotes) +;; FD - file descriptor of the given client (which we obtained from +;; the server earlier); +;; LEN - length of the stuff we are about to send; +;; - the actual contents of the request. +(defun gnuserv-write-to-client (client-id form) + "Write the given form to the given client via the gnuserv process." + (when (eq (process-status gnuserv-process) 'run) + (let* ((result (format "%s" form)) + (s (format "%s/%d:%s\n" client-id + (length result) result))) + (process-send-string gnuserv-process s)))) + +;; The following two functions are helper functions, used by +;; gnuclient. + +(defun gnuserv-eval (form) + "Evaluate form and return result to client." + (gnuserv-write-to-client gnuserv-current-client (eval form)) + (setq gnuserv-current-client nil)) + +(defun gnuserv-eval-quickly (form) + "Let client know that we've received the request, and then eval the form. +This order is important as not to keep the client waiting." + (gnuserv-write-to-client gnuserv-current-client nil) + (setq gnuserv-current-client nil) + (eval form)) + + +;; "Execute" a client connection, called by gnuclient. This is the +;; backbone of gnuserv.el. +(defun gnuserv-edit-files (type list &rest flags) + "For each (line-number . file) pair in LIST, edit the file at line-number. +The visited buffers are memorized, so that when \\[gnuserv-edit] is invoked +in such a buffer, or when it is killed, or the client's device deleted, the +client will be invoked that the edit is finished. + +TYPE should either be a (tty TTY TERM PID) list, or (x DISPLAY) list. +If a flag is `quick', just edit the files in Emacs. +If a flag is `view', view the files read-only." + (let (quick view) + (mapc (lambda (flag) + (case flag + (quick (setq quick t)) + (view (setq view t)) + (t (error "Invalid flag %s" flag)))) + flags) + (let* ((old-device-num (length (device-list))) + (new-frame nil) + (dest-frame (if (functionp gnuserv-frame) + (funcall gnuserv-frame (car type)) + gnuserv-frame)) + ;; The gnuserv-frame dependencies are ugly, but it's + ;; extremely hard to make that stuff cleaner without + ;; breaking everything in sight. + (device (cond ((frame-live-p dest-frame) + (frame-device dest-frame)) + ((null dest-frame) + (case (car type) + (tty (apply 'make-tty-device (cdr type))) + (x (make-x-device (cadr type))) + (t (error "Invalid device type")))) + (t + (selected-device)))) + (frame (cond ((frame-live-p dest-frame) + dest-frame) + ((null dest-frame) + (setq new-frame (make-frame gnuserv-frame-plist + device)) + new-frame) + (t (selected-frame)))) + (client (make-gnuclient :id gnuserv-current-client + :device device + :frame new-frame))) + (setq gnuserv-current-client nil) + ;; If the device was created by this client, push it to the list. + (and (/= old-device-num (length (device-list))) + (push device gnuserv-devices)) + (and (frame-iconified-p frame) + (deiconify-frame frame)) + ;; Visit all the listed files. + (while list + (let ((line (caar list)) (path (cdar list))) + (select-frame frame) + ;; Visit the file. + (funcall (if view + gnuserv-view-file-function + gnuserv-find-file-function) + path) + (goto-line line) + ;; Don't memorize the quick and view buffers. + (unless (or quick view) + (pushnew (current-buffer) (gnuclient-buffers client)) + (setq gnuserv-minor-mode t) + ;; Add the "Done" button to the menubar, only in this buffer. + (if (and (featurep 'menubar) current-menubar) + (progn (set-buffer-menubar current-menubar) + (add-menu-button nil ["Done" gnuserv-edit t])) + )) + (run-hooks 'gnuserv-visit-hook) + (pop list))) + (cond + ((and (or quick view) + (device-on-window-system-p device)) + ;; Exit if on X device, and quick or view. NOTE: if the + ;; client is to finish now, it must absolutely /not/ be + ;; included to the list of clients. This way the client-ids + ;; should be unique. + (gnuserv-write-to-client (gnuclient-id client) nil)) + (t + ;; Else, the client gets a vote. + (push client gnuserv-clients) + ;; Explain buffer exit options. If dest-frame is nil, the + ;; user can exit via `delete-frame'. OTOH, if FLAGS are nil + ;; and there are some buffers, the user can exit via + ;; `gnuserv-edit'. + (if (and (not (or quick view)) + (gnuclient-buffers client)) + (message "%s" + (substitute-command-keys + "Type `\\[gnuserv-edit]' to finish editing")) + (or dest-frame + (message "%s" + (substitute-command-keys + "Type `\\[delete-frame]' to finish editing"))))))))) + + +;;; Functions that hook into Emacs in various way to enable operation + +;; Defined later. +(add-hook 'kill-emacs-hook 'gnuserv-kill-all-clients t) + +;; A helper function; used by others. Try avoiding it whenever +;; possible, because it is slow, and conses a list. Use +;; `gnuserv-buffer-p' when appropriate, for instance. +(defun gnuserv-buffer-clients (buffer) + "Returns a list of clients to which BUFFER belongs." + (let (res) + (dolist (client gnuserv-clients) + (when (memq buffer (gnuclient-buffers client)) + (push client res))) + res)) + +;; Like `gnuserv-buffer-clients', but returns a boolean; doesn't +;; collect a list. +(defun gnuserv-buffer-p (buffer) + (member* buffer gnuserv-clients + :test 'memq + :key 'gnuclient-buffers)) + +;; This function makes sure that a killed buffer is deleted off the +;; list for the particular client. +;; +;; This hooks into `kill-buffer-hook'. It is *not* a replacement for +;; `kill-buffer' (thanks God). +(defun gnuserv-kill-buffer-function () + "Remove the buffer from the buffer lists of all the clients it belongs to. +Any client that remains \"empty\" after the removal is informed that the +editing has ended." + (let* ((buf (current-buffer))) + (dolist (client (gnuserv-buffer-clients buf)) + (callf2 delq buf (gnuclient-buffers client)) + ;; If no more buffers, kill the client. + (when (null (gnuclient-buffers client)) + (gnuserv-kill-client client))))) + +(add-hook 'kill-buffer-hook 'gnuserv-kill-buffer-function) + +;; Ask for confirmation before killing a buffer that belongs to a +;; living client. +(defun gnuserv-kill-buffer-query-function () + (or gnuserv-kill-quietly + (not (gnuserv-buffer-p (current-buffer))) + (yes-or-no-p + (format "Buffer %s belongs to gnuserv client(s); kill anyway? " + (current-buffer))))) + +(add-hook 'kill-buffer-query-functions + 'gnuserv-kill-buffer-query-function) + +(defun gnuserv-kill-emacs-query-function () + (or gnuserv-kill-quietly + (not (some 'gnuclient-buffers gnuserv-clients)) + (yes-or-no-p "Gnuserv buffers still have clients; exit anyway? "))) + +(add-hook 'kill-emacs-query-functions + 'gnuserv-kill-emacs-query-function) + +;; If the device of a client is to be deleted, the client should die +;; as well. This is why we hook into `delete-device-hook'. +(defun gnuserv-check-device (device) + (when (memq device gnuserv-devices) + (dolist (client gnuserv-clients) + (when (eq device (gnuclient-device client)) + ;; we must make sure that the server kill doesn't result in + ;; killing the device, because it would cause a device-dead + ;; error when `delete-device' tries to do the job later. + (gnuserv-kill-client client t)))) + (callf2 delq device gnuserv-devices)) + +(add-hook 'delete-device-hook 'gnuserv-check-device) + +(defun gnuserv-temp-file-p (buffer) + "Return non-nil if BUFFER contains a file considered temporary. +These are files whose names suggest they are repeatedly +reused to pass information to another program. + +The variable `gnuserv-temp-file-regexp' controls which filenames +are considered temporary." + (and (buffer-file-name buffer) + (string-match gnuserv-temp-file-regexp (buffer-file-name buffer)))) + +(defun gnuserv-kill-client (client &optional leave-frame) + "Kill the gnuclient CLIENT. +This will do away with all the associated buffers. If LEAVE-FRAME, +the function will not remove the frames associated with the client." + ;; Order is important: first delete client from gnuserv-clients, to + ;; prevent gnuserv-buffer-done-1 calling us recursively. + (callf2 delq client gnuserv-clients) + ;; Process the buffers. + (mapc 'gnuserv-buffer-done-1 (gnuclient-buffers client)) + (unless leave-frame + (let ((device (gnuclient-device client))) + ;; kill frame created by this client (if any), unless + ;; specifically requested otherwise. + ;; + ;; note: last frame on a device will not be deleted here. + (when (and (gnuclient-frame client) + (frame-live-p (gnuclient-frame client)) + (second (device-frame-list device))) + (delete-frame (gnuclient-frame client))) + ;; If the device is live, created by a client, and no longer used + ;; by any client, delete it. + (when (and (device-live-p device) + (memq device gnuserv-devices) + (second (device-list)) + (not (member* device gnuserv-clients + :key 'gnuclient-device))) + ;; `gnuserv-check-device' will remove it from `gnuserv-devices'. + (delete-device device)))) + ;; Notify the client. + (gnuserv-write-to-client (gnuclient-id client) nil)) + +;; Do away with the buffer. +(defun gnuserv-buffer-done-1 (buffer) + (dolist (client (gnuserv-buffer-clients buffer)) + (callf2 delq buffer (gnuclient-buffers client)) + (when (null (gnuclient-buffers client)) + (gnuserv-kill-client client))) + ;; Get rid of the buffer. + (save-excursion + (set-buffer buffer) + (run-hooks 'gnuserv-done-hook) + (setq gnuserv-minor-mode nil) + ;; Delete the menu button. + (if (and (featurep 'menubar) current-menubar) + (delete-menu-item '("Done"))) + (funcall (if (gnuserv-temp-file-p buffer) + gnuserv-done-temp-file-function + gnuserv-done-function) + buffer))) + + +;;; Higher-level functions + +;; Choose a `next' server buffer, according to several criteria, and +;; return it. If none are found, return nil. +(defun gnuserv-next-buffer () + (let* ((frame (selected-frame)) + (device (selected-device)) + client) + (cond + ;; If we have a client belonging to this frame, return + ;; the first buffer from it. + ((setq client + (car (member* frame gnuserv-clients :key 'gnuclient-frame))) + (car (gnuclient-buffers client))) + ;; Else, look for a device. + ((and + (memq (selected-device) gnuserv-devices) + (setq client + (car (member* device gnuserv-clients :key 'gnuclient-device)))) + (car (gnuclient-buffers client))) + ;; Else, try to find any client with at least one buffer, and + ;; return its first buffer. + ((setq client + (car (member-if-not #'null gnuserv-clients + :key 'gnuclient-buffers))) + (car (gnuclient-buffers client))) + ;; Oh, give up. + (t nil)))) + +(defun gnuserv-buffer-done (buffer) + "Mark BUFFER as \"done\" for its client(s). +Does the save/backup queries first, and calls `gnuserv-done-function'." + ;; Check whether this is the real thing. + (unless (gnuserv-buffer-p buffer) + (error "%s does not belong to a gnuserv client" buffer)) + ;; Backup/ask query. + (if (gnuserv-temp-file-p buffer) + ;; For a temp file, save, and do NOT make a non-numeric backup + ;; Why does server.el explicitly back up temporary files? + (let ((version-control nil) + (buffer-backed-up (not gnuserv-make-temp-file-backup))) + (save-buffer)) + (if (and (buffer-modified-p) + (y-or-n-p (concat "Save file " buffer-file-name "? "))) + (save-buffer buffer))) + (gnuserv-buffer-done-1 buffer)) + +;; Called by `gnuserv-start-1' to clean everything. Hooked into +;; `kill-emacs-hook', too. +(defun gnuserv-kill-all-clients () + "Kill all the gnuserv clients. Ruthlessly." + (mapc 'gnuserv-kill-client gnuserv-clients)) + +;; This serves to run the hook and reset +;; `allow-deletion-of-last-visible-frame'. +(defun gnuserv-prepare-shutdown () + (setq allow-deletion-of-last-visible-frame nil) + (run-hooks 'gnuserv-shutdown-hook)) + +;; This is a user-callable function, too. +(defun gnuserv-shutdown () + "Shutdown the gnuserv server, if one is currently running. +All the clients will be disposed of via the normal methods." + (interactive) + (gnuserv-kill-all-clients) + (when gnuserv-process + (set-process-sentinel gnuserv-process nil) + (gnuserv-prepare-shutdown) + (condition-case () + (delete-process gnuserv-process) + (error nil)) + (setq gnuserv-process nil))) + +;; Actually start the process. Kills all the clients before-hand. +(defun gnuserv-start-1 (&optional leave-dead) + ;; Shutdown the existing server, if any. + (gnuserv-shutdown) + ;; If we already had a server, clear out associated status. + (unless leave-dead + (setq gnuserv-string "" + gnuserv-current-client nil) + (let ((process-connection-type t)) + (setq gnuserv-process + (start-process "gnuserv" nil gnuserv-program))) + (set-process-sentinel gnuserv-process 'gnuserv-sentinel) + (set-process-filter gnuserv-process 'gnuserv-process-filter) + (process-kill-without-query gnuserv-process) + (setq allow-deletion-of-last-visible-frame t) + (run-hooks 'gnuserv-init-hook))) + + +;;; User-callable functions: + +;;;###autoload +(defun gnuserv-running-p () + "Return non-nil if a gnuserv process is running from this XEmacs session." + (not (not gnuserv-process))) + +;;;###autoload +(defun gnuserv-start (&optional leave-dead) + "Allow this Emacs process to be a server for client processes. +This starts a gnuserv communications subprocess through which +client \"editors\" (gnuclient and gnudoit) can send editing commands to +this Emacs job. See the gnuserv(1) manual page for more details. + +Prefix arg means just kill any existing server communications subprocess." + (interactive "P") + (and gnuserv-process + (not leave-dead) + (message "Restarting gnuserv")) + (gnuserv-start-1 leave-dead)) + +(defun gnuserv-edit (&optional count) + "Mark the current gnuserv editing buffer as \"done\", and switch to next one. + +Run with a numeric prefix argument, repeat the operation that number +of times. If given a universal prefix argument, close all the buffers +of this buffer's clients. + +The `gnuserv-done-function' (bound to `kill-buffer' by default) is +called to dispose of the buffer after marking it as done. + +Files that match `gnuserv-temp-file-regexp' are considered temporary and +are saved unconditionally and backed up if `gnuserv-make-temp-file-backup' +is non-nil. They are disposed of using `gnuserv-done-temp-file-function' +(also bound to `kill-buffer' by default). + +When all of a client's buffers are marked as \"done\", the client is notified." + (interactive "P") + (when (null count) + (setq count 1)) + (cond ((numberp count) + (let (next) + (while (natnump (decf count)) + (gnuserv-buffer-done (current-buffer)) + (setq next (gnuserv-next-buffer)) + (when next + (switch-to-buffer next))))) + (count + (let* ((buf (current-buffer)) + (clients (gnuserv-buffer-clients buf))) + (unless clients + (error "%s does not belong to a gnuserv client" buf)) + (mapc 'gnuserv-kill-client (gnuserv-buffer-clients buf)))))) + +(global-set-key "\C-x#" 'gnuserv-edit) + +(provide 'gnuserv) + +;;; gnuserv.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/hyper-apropos.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/hyper-apropos.el Mon Aug 13 10:08:34 2007 +0200 @@ -0,0 +1,1329 @@ +;;; hyper-apropos.el --- Hypertext emacs lisp documentation interface. + +;; Copyright (C) 1994, 1995 Tinker Systems and INS Engineering Corp. +;; Copyright (C) 1995 Sun Microsystems. +;; Copyright (C) 1996 Ben Wing. + +;; Maintainer: Jonathan Stigelman +;; Keywords: lisp, tools, help, docs, matching + +;; This file is part of XEmacs. + +;; XEmacs 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 of the License, or +;; (at your option) any later version. +;; +;; XEmacs 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 XEmacs; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Synched up with: Not in FSF. + +;;; Commentary: + +;; based upon emacs-apropos.el by Frank C. Guida +;; +;; Rather than run apropos and print all the documentation at once, +;; I find it easier to view a "table of contents" first, then +;; get the details for symbols as you need them. +;; +;; This version of apropos prints two lists of symbols matching the +;; given regexp: functions/macros and variables/constants. +;; +;; The user can then do the following: +;; +;; - add an additional regexp to narrow the search +;; - display documentation for the current symbol +;; - find the tag for the current symbol +;; - show any keybindings if the current symbol is a command +;; - invoke functions +;; - set variables +;; +;; An additional feature is the ability to search the current tags +;; table, allowing you to interrogate functions not yet loaded (this +;; isn't available with the standard package). +;; +;; Mouse bindings and menus are provided for XEmacs. +;; +;; additions by Ben Wing July 1995: +;; added support for function aliases, made programmer's apropos be the +;; default, various other hacking. +;; Massive changes by Christoph Wedler +;; Some changes for XEmacs 20.3 by hniksic + +;; ### The maintainer is supposed to be stig, but I haven't seen him +;; around for ages. The real maintainer for the moment is Hrvoje +;; Niksic . + +;;; Code: + +(require 'pp) + +(defgroup hyper-apropos nil + "Hypertext emacs lisp documentation interface." + :group 'docs + :group 'lisp + :group 'tools + :group 'help + :group 'matching) + +(defcustom hyper-apropos-show-brief-docs t + "*If non-nil, display some documentation in the \"*Hyper Apropos*\" buffer. +Setting this to nil will speed up searches." + :type 'boolean + :group 'hyper-apropos) +(define-obsolete-variable-alias + 'hypropos-show-brief-docs 'hyper-apropos-show-brief-docs) +;; I changed this to true because I think it's more useful this way. --ben + +(defcustom hyper-apropos-programming-apropos t + "*If non-nil, list all the functions and variables. +This will cause more output to be generated, and take a longer time. + +Otherwise, only the interactive functions and user variables will be listed." + :type 'boolean + :group 'hyper-apropos) +(define-obsolete-variable-alias + 'hypropos-programming-apropos 'hyper-apropos-programming-apropos) + +(defcustom hyper-apropos-shrink-window nil + "*If non-nil, shrink *Hyper Help* buffer if possible." + :type 'boolean + :group 'hyper-apropos) +(define-obsolete-variable-alias + 'hypropos-shrink-window 'hyper-apropos-shrink-window) + +(defcustom hyper-apropos-prettyprint-long-values t + "*If non-nil, then try to beautify the printing of very long values." + :type 'boolean + :group 'hyper-apropos) +(define-obsolete-variable-alias + 'hypropos-prettyprint-long-values 'hyper-apropos-prettyprint-long-values) + +(defgroup hyper-apropos-faces nil + "Faces defined by hyper-apropos." + :prefix "hyper-apropos-" + :group 'faces) + +(defface hyper-apropos-documentation + '((((class color) (background light)) + (:foreground "darkred")) + (((class color) (background dark)) + (:foreground "gray90"))) + "Hyper-apropos documentation." + :group 'hyper-apropos-faces) + +(defface hyper-apropos-hyperlink + '((((class color) (background light)) + (:foreground "blue4")) + (((class color) (background dark)) + (:foreground "lightseagreen")) + (t + (:bold t))) + "Hyper-apropos hyperlinks." + :group 'hyper-apropos-faces) + +(defface hyper-apropos-major-heading '((t (:bold t))) + "Hyper-apropos major heading." + :group 'hyper-apropos-faces) + +(defface hyper-apropos-section-heading '((t (:bold t :italic t))) + "Hyper-apropos section heading." + :group 'hyper-apropos-faces) + +(defface hyper-apropos-heading '((t (:bold t))) + "Hyper-apropos heading." + :group 'hyper-apropos-faces) + +(defface hyper-apropos-warning '((t (:bold t :foreground "red"))) + "Hyper-apropos warning." + :group 'hyper-apropos-faces) + +;;; Internal variables below this point + +(defvar hyper-apropos-ref-buffer) +(defvar hyper-apropos-prev-wconfig) + +(defvar hyper-apropos-help-map + (let ((map (make-sparse-keymap))) + (suppress-keymap map) + (set-keymap-name map 'hyper-apropos-help-map) + ;; movement + (define-key map " " 'scroll-up) + (define-key map "b" 'scroll-down) + (define-key map [delete] 'scroll-down) + (define-key map [backspace] 'scroll-down) + (define-key map "/" 'isearch-forward) + (define-key map "?" 'isearch-backward) + ;; follow links + (define-key map [return] 'hyper-apropos-get-doc) + (define-key map "s" 'hyper-apropos-set-variable) + (define-key map "t" 'hyper-apropos-find-tag) + (define-key map "l" 'hyper-apropos-last-help) + (define-key map "c" 'hyper-apropos-customize-variable) + (define-key map "f" 'hyper-apropos-find-function) + (define-key map [button2] 'hyper-apropos-mouse-get-doc) + (define-key map [button3] 'hyper-apropos-popup-menu) + ;; for the totally hardcore... + (define-key map "D" 'hyper-apropos-disassemble) + ;; administrativa + (define-key map "a" 'hyper-apropos) + (define-key map "n" 'hyper-apropos) + (define-key map "q" 'hyper-apropos-quit) + map) + "Keybindings for the *Hyper Help* buffer and the *Hyper Apropos* buffer") +(define-obsolete-variable-alias + 'hypropos-help-map 'hyper-apropos-help-map) + +(defvar hyper-apropos-map + (let ((map (make-sparse-keymap))) + (set-keymap-name map 'hyper-apropos-map) + (set-keymap-parents map (list hyper-apropos-help-map)) + ;; slightly different scrolling... + (define-key map " " 'hyper-apropos-scroll-up) + (define-key map "b" 'hyper-apropos-scroll-down) + (define-key map [delete] 'hyper-apropos-scroll-down) + (define-key map [backspace] 'hyper-apropos-scroll-down) + ;; act on the current line... + (define-key map "w" 'hyper-apropos-where-is) + (define-key map "i" 'hyper-apropos-invoke-fn) +;; this is already defined in the parent-keymap above, isn't it? +;; (define-key map "s" 'hyper-apropos-set-variable) + ;; more administrativa... + (define-key map "P" 'hyper-apropos-toggle-programming-flag) + (define-key map "k" 'hyper-apropos-add-keyword) + (define-key map "e" 'hyper-apropos-eliminate-keyword) + map) + "Keybindings for the *Hyper Apropos* buffer. +This map inherits from `hyper-apropos-help-map.'") +(define-obsolete-variable-alias + 'hypropos-map 'hyper-apropos-map) + +;;(defvar hyper-apropos-mousable-keymap +;; (let ((map (make-sparse-keymap))) +;; (define-key map [button2] 'hyper-apropos-mouse-get-doc) +;; map)) + +(defvar hyper-apropos-mode-hook nil + "*User function run after hyper-apropos mode initialization. Usage: +\(setq hyper-apropos-mode-hook '(lambda () ... your init forms ...)).") + +;; ---------------------------------------------------------------------- ;; + +(defconst hyper-apropos-junk-regexp + "^Apropos\\|^Functions\\|^Variables\\|^$") + +(defvar hyper-apropos-currently-showing nil) ; symbol documented in + ; help buffer now +(defvar hyper-apropos-help-history nil) ; chain of symbols followed as links in + ; help buffer +(defvar hyper-apropos-face-history nil) +;;;(defvar hyper-apropos-variable-history nil) +;;;(defvar hyper-apropos-function-history nil) +(defvar hyper-apropos-regexp-history nil) +(defvar hyper-apropos-last-regexp nil) ; regex used for last apropos +(defconst hyper-apropos-apropos-buf "*Hyper Apropos*") +(defconst hyper-apropos-help-buf "*Hyper Help*") + +;;;###autoload +(defun hyper-apropos (regexp toggle-apropos) + "Display lists of functions and variables matching REGEXP +in buffer \"*Hyper Apropos*\". If optional prefix arg is given, then the +value of `hyper-apropos-programming-apropos' is toggled for this search. +See also `hyper-apropos-mode'." + (interactive (list (read-from-minibuffer "List symbols matching regexp: " + nil nil nil 'hyper-apropos-regexp-history) + current-prefix-arg)) + (or (memq major-mode '(hyper-apropos-mode hyper-apropos-help-mode)) + (setq hyper-apropos-prev-wconfig (current-window-configuration))) + (if (string= "" regexp) + (if (get-buffer hyper-apropos-apropos-buf) + (if toggle-apropos + (hyper-apropos-toggle-programming-flag) + (message "Using last search results")) + (error "Be more specific...")) + (set-buffer (get-buffer-create hyper-apropos-apropos-buf)) + (setq buffer-read-only nil) + (erase-buffer) + (if toggle-apropos + (set (make-local-variable 'hyper-apropos-programming-apropos) + (not (default-value 'hyper-apropos-programming-apropos)))) + (let ((flist (apropos-internal regexp + (if hyper-apropos-programming-apropos + #'fboundp + #'commandp))) + (vlist (apropos-internal regexp + (if hyper-apropos-programming-apropos + #'boundp + #'user-variable-p)))) + (insert-face (format "Apropos search for: %S\n\n" regexp) + 'hyper-apropos-major-heading) + (insert-face "* = command (M-x) or user-variable.\n" + 'hyper-apropos-documentation) + (insert-face "\ +a = autoloaded, b = byte-compiled, i = internal, l = lambda, m = macro.\n\n" + 'hyper-apropos-documentation) + (insert-face "Functions and Macros:\n\n" 'hyper-apropos-major-heading) + (hyper-apropos-grok-functions flist) + (insert-face "\n\nVariables and Constants:\n\n" + 'hyper-apropos-major-heading) + (hyper-apropos-grok-variables vlist) + (goto-char (point-min)))) + (switch-to-buffer hyper-apropos-apropos-buf) + (hyper-apropos-mode regexp)) + +(defun hyper-apropos-toggle-programming-flag () + (interactive) + (with-current-buffer hyper-apropos-apropos-buf + (set (make-local-variable 'hyper-apropos-programming-apropos) + (not hyper-apropos-programming-apropos))) + (message "Re-running apropos...") + (hyper-apropos hyper-apropos-last-regexp nil)) + +(defun hyper-apropos-grok-functions (fns) + (let (bind doc type) + (dolist (fn fns) + (setq bind (symbol-function fn) + type (cond ((subrp bind) ?i) + ((compiled-function-p bind) ?b) + ((consp bind) (or (cdr + (assq (car bind) '((autoload . ?a) + (lambda . ?l) + (macro . ?m)))) + ??)) + (t ?\ ))) + (insert type (if (commandp fn) "* " " ")) + (let ((e (insert-face (format "%S" fn) 'hyper-apropos-hyperlink))) + (set-extent-property e 'mouse-face 'highlight)) + (insert-char ?\ (let ((l (- 30 (length (format "%S" fn))))) + (if (natnump l) l 0))) + (and hyper-apropos-show-brief-docs + (setq doc + ;; A symbol's function slot can point to an unbound symbol. + ;; In that case, `documentation' will fail. + (ignore-errors + (documentation fn))) + (if (string-match + "^([^\n\t )]+[\t ]*\\([^\n)]+\\)?)\\(:[\t ]*\\|\n?\\'\\)" + doc) + (setq doc (substring doc (match-end 0) (string-match "\n" doc))) + t) + (insert-face (if doc + (concat " - " + (substring doc 0 (string-match "\n" doc))) + " Not documented.") + 'hyper-apropos-documentation)) + (insert ?\n)))) + +(defun hyper-apropos-grok-variables (vars) + (let (doc userp) + (dolist (var vars) + (setq userp (user-variable-p var)) + (insert (if userp " * " " ")) + (let ((e (insert-face (format "%S" var) 'hyper-apropos-hyperlink))) + (set-extent-property e 'mouse-face 'highlight)) + (insert-char ?\ (let ((l (- 30 (length (format "%S" var))))) + (if (natnump l) l 0))) + (and hyper-apropos-show-brief-docs + (setq doc (documentation-property var 'variable-documentation)) + (insert-face (if doc + (concat " - " (substring doc (if userp 1 0) + (string-match "\n" doc))) + " - Not documented.") + 'hyper-apropos-documentation)) + (insert ?\n)))) + +;; ---------------------------------------------------------------------- ;; + +(defun hyper-apropos-mode (regexp) + "Improved apropos mode for displaying Emacs documentation. Function and +variable names are displayed in the buffer \"*Hyper Apropos*\". + +Functions are preceded by a single character to indicates their types: + a = autoloaded, b = byte-compiled, i = internal, l = lambda, m = macro. +Interactive functions are also preceded by an asterisk. +Variables are preceded by an asterisk if they are user variables. + +General Commands: + + SPC - scroll documentation or apropos window forward + b - scroll documentation or apropos window backward + k - eliminate all hits that don't contain keyword + n - new search + / - isearch-forward + q - quit and restore previous window configuration + + Operations for Symbol on Current Line: + + RET - toggle display of symbol's documentation + (also on button2 in xemacs) + w - show the keybinding if symbol is a command + i - invoke function on current line + s - set value of variable on current line + t - display the C or lisp source (find-tag)" + (delete-other-windows) + (setq mode-name "Hyper-Apropos" + major-mode 'hyper-apropos-mode + buffer-read-only t + truncate-lines t + hyper-apropos-last-regexp regexp + modeline-buffer-identification + (list (cons modeline-buffer-id-left-extent "Hyper Apropos: ") + (cons modeline-buffer-id-right-extent (concat "\"" regexp "\"")))) + (use-local-map hyper-apropos-map) + (run-hooks 'hyper-apropos-mode-hook)) + +;; ---------------------------------------------------------------------- ;; + +;; similar to `describe-key-briefly', copied from prim/help.el by CW + +;;;###autoload +(defun hyper-describe-key (key) + (interactive "kDescribe key: ") + (hyper-describe-key-briefly key t)) + +;;;###autoload +(defun hyper-describe-key-briefly (key &optional show) + (interactive "kDescribe key briefly: \nP") + (let (menup defn interm final msg) + (setq defn (key-or-menu-binding key 'menup)) + (if (or (null defn) (integerp defn)) + (or (numberp show) (message "%s is undefined" (key-description key))) + (cond ((stringp defn) + (setq interm defn + final (key-binding defn))) + ((vectorp defn) + (setq interm (append defn nil)) + (while (and interm + (member (key-binding (vector (car interm))) + '(universal-argument digit-argument))) + (setq interm (cdr interm))) + (while (and interm + (not (setq final (key-binding (vconcat interm))))) + (setq interm (butlast interm))) + (if final + (setq interm (vconcat interm)) + (setq interm defn + final (key-binding defn))))) + (setq msg (format + "%s runs %s%s%s" + ;; This used to say 'This menu item' but it could also + ;; be a scrollbar event. We can't distinguish at the + ;; moment. + (if menup "This item" (key-description key)) + ;;(if (symbolp defn) defn (key-description defn)) + (if (symbolp defn) defn (prin1-to-string defn)) + (if final (concat ", " (key-description interm) " runs ") "") + (if final + (if (symbolp final) final (prin1-to-string final)) + ""))) + (if (numberp show) + (or (not (symbolp defn)) + (memq (symbol-function defn) + '(zkey-init-kbd-macro zkey-init-kbd-fn)) + (progn (princ msg) (princ "\n"))) + (message "%s" msg) + (if final (setq defn final)) + (if (and (or (symbolp defn) (symbolp (setq defn (car-safe defn)))) + defn + show) + (hyper-apropos-get-doc defn t)))))) + +;;;###autoload +(defun hyper-describe-face (symbol &optional this-ref-buffer) + "Describe face.. +See also `hyper-apropos' and `hyper-describe-function'." + ;; #### - perhaps a prefix arg should suppress the prompt... + (interactive + (let (v val) + (setq v (hyper-apropos-this-symbol)) ; symbol under point + (or (find-face v) + (setq v (variable-at-point))) + (setq val (let ((enable-recursive-minibuffers t)) + (completing-read + (concat (if (hyper-apropos-follow-ref-buffer current-prefix-arg) + "Follow face" + "Describe face") + (if v + (format " (default %s): " v) + ": ")) + (mapcar (function (lambda (x) (list (symbol-name x)))) + (face-list)) + nil t nil 'hyper-apropos-face-history))) + (list (if (string= val "") + (progn (push (symbol-name v) hyper-apropos-face-history) v) + (intern-soft val)) + current-prefix-arg))) + (if (null symbol) + (message "Sorry, nothing to describe.") + (or (memq major-mode '(hyper-apropos-mode hyper-apropos-help-mode)) + (setq hyper-apropos-prev-wconfig (current-window-configuration))) + (hyper-apropos-get-doc symbol t nil this-ref-buffer))) + +;;;###autoload +(defun hyper-describe-variable (symbol &optional this-ref-buffer) + "Hypertext drop-in replacement for `describe-variable'. +See also `hyper-apropos' and `hyper-describe-function'." + ;; #### - perhaps a prefix arg should suppress the prompt... + (interactive (list (hyper-apropos-read-variable-symbol + (if (hyper-apropos-follow-ref-buffer current-prefix-arg) + "Follow variable" + "Describe variable")) + current-prefix-arg)) + (if (null symbol) + (message "Sorry, nothing to describe.") + (or (memq major-mode '(hyper-apropos-mode hyper-apropos-help-mode)) + (setq hyper-apropos-prev-wconfig (current-window-configuration))) + (hyper-apropos-get-doc symbol t nil this-ref-buffer))) + +(defun hyper-where-is (symbol) + "Print message listing key sequences that invoke specified command." + (interactive (list (hyper-apropos-read-function-symbol "Where is function"))) + (if (null symbol) + (message "Sorry, nothing to describe.") + (where-is symbol))) + +;;;###autoload +(defun hyper-describe-function (symbol &optional this-ref-buffer) + "Hypertext replacement for `describe-function'. Unlike `describe-function' +in that the symbol under the cursor is the default if it is a function. +See also `hyper-apropos' and `hyper-describe-variable'." + ;; #### - perhaps a prefix arg should suppress the prompt... + (interactive (list (hyper-apropos-read-function-symbol + (if (hyper-apropos-follow-ref-buffer current-prefix-arg) + "Follow function" + "Describe function")) + current-prefix-arg)) + (if (null symbol) + (message "Sorry, nothing to describe.") + (or (memq major-mode '(hyper-apropos-mode hyper-apropos-help-mode)) + (setq hyper-apropos-prev-wconfig (current-window-configuration))) + (hyper-apropos-get-doc symbol t nil this-ref-buffer))) + +;;;###autoload +(defun hyper-apropos-read-variable-symbol (prompt &optional predicate) + "Hypertext drop-in replacement for `describe-variable'. +See also `hyper-apropos' and `hyper-describe-function'." + ;; #### - perhaps a prefix arg should suppress the prompt... + (or predicate (setq predicate 'boundp)) + (let (v val) + (setq v (hyper-apropos-this-symbol)) ; symbol under point + (or (funcall predicate v) + (setq v (variable-at-point))) + (or (funcall predicate v) + (setq v nil)) + (setq val (let ((enable-recursive-minibuffers t)) + (completing-read + (concat prompt + (if v + (format " (default %s): " v) + ": ")) + obarray predicate t nil 'variable-history))) + (if (string= val "") + (progn (push (symbol-name v) variable-history) v) + (intern-soft val)))) +;;;###autoload +(define-obsolete-function-alias + 'hypropos-read-variable-symbol 'hyper-apropos-read-variable-symbol) + +(defun hyper-apropos-read-function-symbol (prompt) + "Read function symbol from minibuffer." + (let ((fn (hyper-apropos-this-symbol)) + val) + (or (fboundp fn) + (setq fn (function-at-point))) + (setq val (let ((enable-recursive-minibuffers t)) + (completing-read (if fn + (format "%s (default %s): " prompt fn) + (format "%s: " prompt)) + obarray 'fboundp t nil + 'function-history))) + (if (equal val "") + (progn (push (symbol-name fn) function-history) fn) + (intern-soft val)))) + +(defun hyper-apropos-last-help (arg) + "Go back to the last symbol documented in the *Hyper Help* buffer." + (interactive "P") + (let ((win (get-buffer-window hyper-apropos-help-buf))) + (or arg (setq arg (if win 1 0))) + (cond ((= arg 0)) + ((<= (length hyper-apropos-help-history) arg) + ;; go back as far as we can... + (setcdr (nreverse hyper-apropos-help-history) nil)) + (t + (setq hyper-apropos-help-history + (nthcdr arg hyper-apropos-help-history)))) + (if (or win (> arg 0)) + (hyper-apropos-get-doc (car hyper-apropos-help-history) t) + (display-buffer hyper-apropos-help-buf)))) + +(defun hyper-apropos-insert-face (string &optional face) + "Insert STRING and fontify some parts with face `hyper-apropos-hyperlink'." + (let ((beg (point)) end) + (insert-face string (or face 'hyper-apropos-documentation)) + (setq end (point)) + (goto-char beg) + (while (re-search-forward + "`\\([-a-zA-Z0-9_][-a-zA-Z0-9_][-a-zA-Z0-9_.]+\\)'" + end 'limit) + (let ((e (make-extent (match-beginning 1) (match-end 1)))) + (set-extent-face e 'hyper-apropos-hyperlink) + (set-extent-property e 'mouse-face 'highlight)) + (goto-char beg) + (while (re-search-forward + "M-x \\([-a-zA-Z0-9_][-a-zA-Z0-9_][-a-zA-Z0-9_.]+\\)" + end 'limit) + (let ((e (make-extent (match-beginning 1) (match-end 1)))) + (set-extent-face e 'hyper-apropos-hyperlink) + (set-extent-property e 'mouse-face 'highlight)))))) + +(defun hyper-apropos-insert-keybinding (keys string) + (if keys + (insert " (" string " bound to \"" + (mapconcat 'key-description + (sort* keys #'< :key #'length) + "\", \"") + "\")\n"))) + +(defun hyper-apropos-insert-section-heading (alias-desc &optional desc) + (or desc (setq desc alias-desc + alias-desc nil)) + (if alias-desc + (setq desc (concat alias-desc + (if (memq (aref desc 0) + '(?a ?e ?i ?o ?u)) + ", an " ", a ") + desc))) + (aset desc 0 (upcase (aref desc 0))) ; capitalize + (goto-char (point-max)) + (newline 3) (delete-blank-lines) (newline 2) + (hyper-apropos-insert-face desc 'hyper-apropos-section-heading)) + +(defun hyper-apropos-insert-value (string symbol val) + (insert-face string 'hyper-apropos-heading) + (insert (if (symbol-value symbol) + (if (or (null val) (eq val t) (integerp val)) + (prog1 + (symbol-value symbol) + (set symbol nil)) + "see below") + "is void"))) + +(defun hyper-apropos-follow-ref-buffer (this-ref-buffer) + (and (not this-ref-buffer) + (eq major-mode 'hyper-apropos-help-mode) + hyper-apropos-ref-buffer + (buffer-live-p hyper-apropos-ref-buffer))) + +(defun hyper-apropos-get-alias (symbol alias-p next-symbol &optional use) + "Return (TERMINAL-SYMBOL . ALIAS-DESC)." + (let (aliases) + (while (funcall alias-p symbol) + (setq aliases (cons (if use (funcall use symbol) symbol) aliases)) + (setq symbol (funcall next-symbol symbol))) + (cons symbol + (and aliases + (concat "an alias for `" + (mapconcat 'symbol-name + (nreverse aliases) + "',\nwhich is an alias for `") + "'"))))) + +(defun hyper-apropos-get-doc (&optional symbol force type this-ref-buffer) + ;; #### - update this docstring + "Toggle display of documentation for the symbol on the current line." + ;; SYMBOL is the symbol to document. FORCE, if non-nil, means to + ;; regenerate the documentation even if it already seems to be there. And + ;; TYPE, if present, forces the generation of only variable documentation + ;; or only function documentation. Normally, if both are present, then + ;; both will be generated. + ;; + ;; TYPES TO IMPLEMENT: obsolete face + ;; + (interactive) + (or symbol + (setq symbol (hyper-apropos-this-symbol))) + (or type + (setq type '(function variable face))) + (if (and (eq hyper-apropos-currently-showing symbol) + (get-buffer hyper-apropos-help-buf) + (get-buffer-window hyper-apropos-help-buf) + (not force)) + ;; we're already displaying this help, so toggle its display. + (delete-windows-on hyper-apropos-help-buf) + ;; OK, we've got to refresh and display it... + (or (eq symbol (car hyper-apropos-help-history)) + (setq hyper-apropos-help-history + (if (eq major-mode 'hyper-apropos-help-mode) + ;; if we're following a link in the help buffer, then + ;; record that in the help history. + (cons symbol hyper-apropos-help-history) + ;; otherwise clear the history because it's a new search. + (list symbol)))) + (save-excursion + (if (hyper-apropos-follow-ref-buffer this-ref-buffer) + (set-buffer hyper-apropos-ref-buffer) + (setq hyper-apropos-ref-buffer (current-buffer))) + (let (standard-output + ok beg + newsym symtype doc obsolete + (local mode-name) + global local-str global-str + font fore back undl + aliases alias-desc desc) + (save-excursion + (set-buffer (get-buffer-create hyper-apropos-help-buf)) + ;;(setq standard-output (current-buffer)) + (setq buffer-read-only nil) + (erase-buffer) + (insert-face (format "`%s'" symbol) 'hyper-apropos-major-heading) + (insert (format " (buffer: %s, mode: %s)\n" + (buffer-name hyper-apropos-ref-buffer) + local))) + ;; function ---------------------------------------------------------- + (and (memq 'function type) + (fboundp symbol) + (progn + (setq ok t) + (setq aliases (hyper-apropos-get-alias (symbol-function symbol) + 'symbolp + 'symbol-function) + newsym (car aliases) + alias-desc (cdr aliases)) + (if (eq 'macro (car-safe newsym)) + (setq desc "macro" + newsym (cdr newsym)) + (setq desc "function")) + (setq symtype (cond ((subrp newsym) 'subr) + ((compiled-function-p newsym) 'bytecode) + ((eq (car-safe newsym) 'autoload) 'autoload) + ((eq (car-safe newsym) 'lambda) 'lambda)) + desc (concat (if (commandp symbol) "interactive ") + (cdr (assq symtype + '((subr . "built-in ") + (bytecode . "compiled Lisp ") + (autoload . "autoloaded Lisp ") + (lambda . "Lisp ")))) + desc + (if (eq symtype 'autoload) + (format ", (autoloaded from \"%s\")" + (nth 1 newsym)))) + local (current-local-map) + global (current-global-map) + obsolete (get symbol 'byte-obsolete-info) + doc (or (documentation symbol) "function not documented")) + (save-excursion + (set-buffer hyper-apropos-help-buf) + (goto-char (point-max)) + (setq standard-output (current-buffer)) + (hyper-apropos-insert-section-heading alias-desc desc) + (insert ":\n") + (if local + (hyper-apropos-insert-keybinding + (where-is-internal symbol (list local) nil nil nil) + "locally")) + (hyper-apropos-insert-keybinding + (where-is-internal symbol (list global) nil nil nil) + "globally") + (insert "\n") + (if obsolete + (hyper-apropos-insert-face + (format "%s is an obsolete function; %s\n\n" symbol + (if (stringp (car obsolete)) + (car obsolete) + (format "use `%s' instead." (car obsolete)))) + 'hyper-apropos-warning)) + (setq beg (point)) + (insert-face "arguments: " 'hyper-apropos-heading) + (cond ((eq symtype 'lambda) + (princ (or (nth 1 newsym) "()"))) + ((eq symtype 'bytecode) + (princ (or (compiled-function-arglist newsym) + "()"))) + ((and (eq symtype 'subr) + (string-match + "[\n\t ]*\narguments: ?\\((.*)\\)\n?\\'" + doc)) + (insert (substring doc + (match-beginning 1) + (match-end 1))) + (setq doc (substring doc 0 (match-beginning 0)))) + ((and (eq symtype 'subr) + (string-match + "\ +\[\n\t ]*([^\n\t )]+[\t ]*\\([^\n)]+\\)?)\\(:[\t ]*\\|\n?\\'\\)" + doc)) + (insert "(" + (if (match-end 1) + (substring doc + (match-beginning 1) + (match-end 1))) + ")") + (setq doc (substring doc (match-end 0)))) + (t (princ "[not available]"))) + (insert "\n\n") + (hyper-apropos-insert-face doc) + (insert "\n") + (indent-rigidly beg (point) 2)))) + ;; variable ---------------------------------------------------------- + (and (memq 'variable type) + (or (boundp symbol) (default-boundp symbol)) + (progn + (setq ok t) + (setq aliases (hyper-apropos-get-alias symbol + 'variable-alias + 'variable-alias + 'variable-alias) + newsym (car aliases) + alias-desc (cdr aliases)) + (setq symtype (or (local-variable-p newsym (current-buffer)) + (and (local-variable-p newsym + (current-buffer) t) + 'auto-local)) + desc (concat (and (get newsym 'custom-type) + "customizable ") + (if (user-variable-p newsym) + "user variable" + "variable") + (cond ((eq symtype t) ", buffer-local") + ((eq symtype 'auto-local) + ", local when set"))) + local (and (boundp newsym) + (symbol-value newsym)) + local-str (and (boundp newsym) + (prin1-to-string local)) + global (and (eq symtype t) + (default-boundp newsym) + (default-value newsym)) + global-str (and (eq symtype t) + (default-boundp newsym) + (prin1-to-string global)) + obsolete (get symbol 'byte-obsolete-variable) + doc (or (documentation-property symbol + 'variable-documentation) + "variable not documented")) + (save-excursion + (set-buffer hyper-apropos-help-buf) + (goto-char (point-max)) + (setq standard-output (current-buffer)) + (hyper-apropos-insert-section-heading alias-desc desc) + (when (and (user-variable-p newsym) + (get newsym 'custom-type)) + (let ((e (make-extent (point-at-bol) (point)))) + (set-extent-property e 'mouse-face 'highlight) + (set-extent-property e 'help-echo + (format "Customize %s" newsym)) + (set-extent-property + e 'hyper-apropos-custom + `(lambda () (customize-variable (quote ,newsym)))))) + (insert ":\n\n") + (setq beg (point)) + (if obsolete + (hyper-apropos-insert-face + (format "%s is an obsolete function; %s\n\n" symbol + (if (stringp obsolete) + obsolete + (format "use `%s' instead." obsolete))) + 'hyper-apropos-warning)) + ;; generally, the value of the variable is short and the + ;; documentation of the variable long, so it's desirable + ;; to see all of the value and the start of the + ;; documentation. Some variables, though, have huge and + ;; nearly meaningless values that force you to page + ;; forward just to find the doc string. That is + ;; undesirable. + (if (and (or (null local-str) (< (length local-str) 69)) + (or (null global-str) (< (length global-str) 69))) + ; 80 cols. docstrings assume this. + (progn (insert-face "value: " 'hyper-apropos-heading) + (insert (or local-str "is void")) + (if (eq symtype t) + (progn + (insert "\n") + (insert-face "default value: " 'hyper-apropos-heading) + (insert (or global-str "is void")))) + (insert "\n\n") + (hyper-apropos-insert-face doc)) + (hyper-apropos-insert-value "value: " 'local-str local) + (if (eq symtype t) + (progn + (insert ", ") + (hyper-apropos-insert-value "default-value: " + 'global-str global))) + (insert "\n\n") + (hyper-apropos-insert-face doc) + (if local-str + (progn + (newline 3) (delete-blank-lines) (newline 1) + (insert-face "value: " 'hyper-apropos-heading) + (if hyper-apropos-prettyprint-long-values + (condition-case nil + (let ((pp-print-readably nil)) (pprint local)) + (error (insert local-str))) + (insert local-str)))) + (if global-str + (progn + (newline 3) (delete-blank-lines) (newline 1) + (insert-face "default value: " 'hyper-apropos-heading) + (if hyper-apropos-prettyprint-long-values + (condition-case nil + (let ((pp-print-readably nil)) (pprint global)) + (error (insert global-str))) + (insert global-str))))) + (indent-rigidly beg (point) 2)))) + ;; face -------------------------------------------------------------- + (and (memq 'face type) + (find-face symbol) + (progn + (setq ok t) + (copy-face symbol 'hyper-apropos-temp-face 'global) + (mapcar (function + (lambda (property) + (setq symtype (face-property-instance symbol + property)) + (if symtype + (set-face-property 'hyper-apropos-temp-face + property + symtype)))) + built-in-face-specifiers) + (setq font (cons (face-property-instance symbol 'font nil 0 t) + (face-property-instance symbol 'font)) + fore (cons (face-foreground-instance symbol nil 0 t) + (face-foreground-instance symbol)) + back (cons (face-background-instance symbol nil 0 t) + (face-background-instance symbol)) + undl (cons (face-underline-p symbol nil 0 t) + (face-underline-p symbol)) + doc (face-doc-string symbol)) + ;; #### - add some code here + (save-excursion + (set-buffer hyper-apropos-help-buf) + (setq standard-output (current-buffer)) + (hyper-apropos-insert-section-heading + (concat "Face" + (when (get symbol 'face-defface-spec) + (let* ((str " (customizable)") + (e (make-extent 1 (length str) str))) + (set-extent-property e 'mouse-face 'highlight) + (set-extent-property e 'help-echo + (format "Customize %s" symbol)) + (set-extent-property e 'unique t) + (set-extent-property e 'duplicable t) + (set-extent-property + e 'hyper-apropos-custom + `(lambda () (customize-face (quote ,symbol)))) + str)) + ":\n\n ")) + (insert-face "\ +ABCDEFHIJKLMNOPQRSTUVWXYZ abcdefhijklmnopqrstuvwxyz 0123456789" + 'hyper-apropos-temp-face) + (newline 2) + (insert-face " Font: " 'hyper-apropos-heading) + (insert (format (if (numberp (car font)) "(%s)\n" "%s\n") + (and (cdr font) + (font-instance-name (cdr font))))) + (insert-face " Foreground: " 'hyper-apropos-heading) + (insert (format (if (numberp (car fore)) "(%s)\n" "%s\n") + (and (cdr fore) + (color-instance-name (cdr fore))))) + (insert-face " Background: " 'hyper-apropos-heading) + (insert (format (if (numberp (car back)) "(%s)\n" "%s\n") + (and (cdr back) + (color-instance-name (cdr back))))) + (insert-face " Underline: " 'hyper-apropos-heading) + (insert (format (if (numberp (car undl)) "(%s)\n" "%s\n") + (cdr undl))) + (if doc + (progn + (newline) + (setq beg (point)) + (insert doc) + (indent-rigidly beg (point) 2)))))) + ;; not bound & property list ----------------------------------------- + (or ok + (save-excursion + (set-buffer hyper-apropos-help-buf) + (hyper-apropos-insert-section-heading + "symbol is not currently bound\n"))) + (if (and (setq symtype (symbol-plist symbol)) + (or (> (length symtype) 2) + (not (memq 'variable-documentation symtype)))) + (save-excursion + (set-buffer hyper-apropos-help-buf) + (goto-char (point-max)) + (setq standard-output (current-buffer)) + (hyper-apropos-insert-section-heading "property-list:\n\n") + (while symtype + (if (memq (car symtype) + '(variable-documentation byte-obsolete-info)) + (setq symtype (cdr symtype)) + (insert-face (concat " " (symbol-name (car symtype)) + ": ") + 'hyper-apropos-heading) + (setq symtype (cdr symtype)) + (indent-to 32) + (insert (prin1-to-string (car symtype)) "\n")) + (setq symtype (cdr symtype))))))) + (save-excursion + (set-buffer hyper-apropos-help-buf) + (goto-char (point-min)) + ;; pop up window and shrink it if it's wasting space + (if hyper-apropos-shrink-window + (shrink-window-if-larger-than-buffer + (display-buffer (current-buffer))) + (display-buffer (current-buffer))) + (hyper-apropos-help-mode)) + (setq hyper-apropos-currently-showing symbol))) +;;;###autoload +(define-obsolete-function-alias + 'hypropos-get-doc 'hyper-apropos-get-doc) + +; ----------------------------------------------------------------------------- + +(defun hyper-apropos-help-mode () + "Major mode for hypertext XEmacs help. In this mode, you can quickly +follow links between back and forth between the documentation strings for +different variables and functions. Common commands: + +\\{hyper-apropos-help-map}" + (setq buffer-read-only t + major-mode 'hyper-apropos-help-mode + mode-name "Hyper-Help") + (set-syntax-table emacs-lisp-mode-syntax-table) + (hyper-apropos-highlightify) + (use-local-map hyper-apropos-help-map)) + +;; ---------------------------------------------------------------------- ;; + +(defun hyper-apropos-highlightify () + (save-excursion + (goto-char (point-min)) + (let ((st (point-min)) + sym) + (while (not (eobp)) + (if (zerop (skip-syntax-forward "w_")) + (forward-char 1) + (and (> (- (point) st) 3) + (setq sym (intern-soft (buffer-substring st (point)))) + (or (boundp sym) + (fboundp sym)) + (set-extent-property (make-extent st (point)) + 'mouse-face 'highlight))) + (setq st (point)))))) + +;; ---------------------------------------------------------------------- ;; + +(defun hyper-apropos-scroll-up () + "Scroll up the \"*Hyper Help*\" buffer if it's visible. +Otherwise, scroll the selected window up." + (interactive) + (let ((win (get-buffer-window hyper-apropos-help-buf)) + (owin (selected-window))) + (if win + (progn + (select-window win) + (condition-case nil + (scroll-up nil) + (error (goto-char (point-max)))) + (select-window owin)) + (scroll-up nil)))) + +(defun hyper-apropos-scroll-down () + "Scroll down the \"*Hyper Help*\" buffer if it's visible. +Otherwise, scroll the selected window down." + (interactive) + (let ((win (get-buffer-window hyper-apropos-help-buf)) + (owin (selected-window))) + (if win + (progn + (select-window win) + (condition-case nil + (scroll-down nil) + (error (goto-char (point-max)))) + (select-window owin)) + (scroll-down nil)))) + +;; ---------------------------------------------------------------------- ;; + +(defun hyper-apropos-mouse-get-doc (event) + "Get the documentation for the symbol the mouse is on." + (interactive "e") + (mouse-set-point event) + (let ((e (extent-at (point) nil 'hyper-apropos-custom))) + (if e + (funcall (extent-property e 'hyper-apropos-custom)) + (save-excursion + (let ((symbol (hyper-apropos-this-symbol))) + (if symbol + (hyper-apropos-get-doc symbol) + (error "Click on a symbol"))))))) + +;; ---------------------------------------------------------------------- ;; + +(defun hyper-apropos-add-keyword (pattern) + "Use additional keyword to narrow regexp match. +Deletes lines which don't match PATTERN." + (interactive "sAdditional Keyword: ") + (save-excursion + (goto-char (point-min)) + (let (buffer-read-only) + (keep-lines (concat pattern "\\|" hyper-apropos-junk-regexp)) + ))) + +(defun hyper-apropos-eliminate-keyword (pattern) + "Use additional keyword to eliminate uninteresting matches. +Deletes lines which match PATTERN." + (interactive "sKeyword to eliminate: ") + (save-excursion + (goto-char (point-min)) + (let (buffer-read-only) + (flush-lines pattern)) + )) + +;; ---------------------------------------------------------------------- ;; + +(defun hyper-apropos-this-symbol () + (save-excursion + (cond ((eq major-mode 'hyper-apropos-mode) + (beginning-of-line) + (if (looking-at hyper-apropos-junk-regexp) + nil + (forward-char 3) + (read (point-marker)))) + (t + (let* ((st (progn + (skip-syntax-backward "w_") + ;; !@(*$^%%# stupid backquote implementation!!! + (skip-chars-forward "`") + (point))) + (en (progn + (skip-syntax-forward "w_") + (skip-chars-backward ".':") ; : for Local Variables + (point)))) + (and (not (eq st en)) + (intern-soft (buffer-substring st en)))))))) + +(defun hyper-apropos-where-is (symbol) + "Find keybinding for symbol on current line." + (interactive (list (hyper-apropos-this-symbol))) + (where-is symbol)) + +(defun hyper-apropos-invoke-fn (fn) + "Interactively invoke the function on the current line." + (interactive (list (hyper-apropos-this-symbol))) + (cond ((not (fboundp fn)) + (error "%S is not a function" fn)) + (t (call-interactively fn)))) + +;;;###autoload +(defun hyper-set-variable (var val &optional this-ref-buffer) + (interactive + (let ((var (hyper-apropos-read-variable-symbol + (if (hyper-apropos-follow-ref-buffer current-prefix-arg) + "In ref buffer, set user option" + "Set user option") + 'user-variable-p))) + (list var (hyper-apropos-read-variable-value var) current-prefix-arg))) + (hyper-apropos-set-variable var val this-ref-buffer)) + +;;;###autoload +(defun hyper-apropos-set-variable (var val &optional this-ref-buffer) + "Interactively set the variable on the current line." + (interactive + (let ((var (hyper-apropos-this-symbol))) + (or (and var (boundp var)) + (and (setq var (and (eq major-mode 'hyper-apropos-help-mode) + (save-excursion + (goto-char (point-min)) + (hyper-apropos-this-symbol)))) + (boundp var)) + (setq var nil)) + (list var (hyper-apropos-read-variable-value var)))) + (and var + (boundp var) + (progn + (if (hyper-apropos-follow-ref-buffer this-ref-buffer) + (save-excursion + (set-buffer hyper-apropos-ref-buffer) + (set var val)) + (set var val)) + (hyper-apropos-get-doc var t '(variable) this-ref-buffer)))) +;;;###autoload +(define-obsolete-function-alias + 'hypropos-set-variable 'hyper-apropos-set-variable) + +(defun hyper-apropos-read-variable-value (var &optional this-ref-buffer) + (and var + (boundp var) + (let ((prop (get var 'variable-interactive)) + (print-readably t) + val str) + (hyper-apropos-get-doc var t '(variable) current-prefix-arg) + (if prop + (call-interactively (list 'lambda '(arg) + (list 'interactive prop) + 'arg)) + (setq val (if (hyper-apropos-follow-ref-buffer this-ref-buffer) + (save-excursion + (set-buffer hyper-apropos-ref-buffer) + (symbol-value var)) + (symbol-value var)) + str (prin1-to-string val)) + (eval-minibuffer + (format "Set %s `%s' to value (evaluated): " + (if (user-variable-p var) "user option" "Variable") + var) + (condition-case nil + (progn + (read str) + (format (if (or (consp val) + (and (symbolp val) + (not (memq val '(t nil))))) + "'%s" "%s") + str)) + (error nil))))))) + +(defun hyper-apropos-customize-variable () + (interactive) + (let ((var (hyper-apropos-this-symbol))) + (customize-variable var))) + +;; ---------------------------------------------------------------------- ;; + +(defun hyper-apropos-find-tag (&optional tag-name) + "Find the tag for the symbol on the current line in other window. In +order for this to work properly, the variable `tag-table-alist' or +`tags-file-name' must be set so that a TAGS file with tags for the emacs +source is found for the \"*Hyper Apropos*\" buffer." + (interactive) + ;; there ought to be a default tags file for this... + (or tag-name (setq tag-name (symbol-name (hyper-apropos-this-symbol)))) + (find-tag-other-window (list tag-name))) + +;; ---------------------------------------------------------------------- ;; + +(defun hyper-apropos-find-function (fn) + "Find the function for the symbol on the current line in other +window. (See also `find-function'.)" + (interactive + (let ((fn (hyper-apropos-this-symbol))) + (or (fboundp fn) + (and (setq fn (and (eq major-mode 'hyper-apropos-help-mode) + (save-excursion + (goto-char (point-min)) + (hyper-apropos-this-symbol)))) + (fboundp fn)) + (setq fn nil)) + (list fn))) + (if fn + (find-function-other-window fn))) + +;; ---------------------------------------------------------------------- ;; + +(defun hyper-apropos-disassemble (sym) + "Disassemble FUN if it is byte-coded. If it's a lambda, prettyprint it." + (interactive (list (hyper-apropos-this-symbol))) + (let ((fun sym) (trail nil) macrop) + (while (and (symbolp fun) (not (memq fun trail))) + (setq trail (cons fun trail) + fun (symbol-function fun))) + (and (symbolp fun) + (error "Loop detected in function binding of `%s'" fun)) + (setq macrop (and (consp fun) + (eq 'macro (car fun)))) + (cond ((compiled-function-p (if macrop (cdr fun) fun)) + (disassemble fun) + (set-buffer "*Disassemble*") + (goto-char (point-min)) + (forward-sexp 2) + (insert (format " for function `%S'" sym)) + ) + ((consp fun) + (with-output-to-temp-buffer "*Disassemble*" + (pprint (if macrop + (cons 'defmacro (cons sym (cdr (cdr fun)))) + (cons 'defun (cons sym (cdr fun)))))) + (set-buffer "*Disassemble*") + (emacs-lisp-mode)) + ((or (vectorp fun) (stringp fun)) + ;; #### - do something fancy here + (with-output-to-temp-buffer "*Disassemble*" + (princ (format "%s is a keyboard macro:\n\n\t" sym)) + (prin1 fun))) + (t + (error "Sorry, cannot disassemble `%s'" sym))))) + +;; ---------------------------------------------------------------------- ;; + +(defun hyper-apropos-quit () + (interactive) + "Quit Hyper Apropos and restore original window config." + (let ((buf (get-buffer hyper-apropos-apropos-buf))) + (and buf (bury-buffer buf))) + (set-window-configuration hyper-apropos-prev-wconfig)) + +;; ---------------------------------------------------------------------- ;; + +;;;###autoload +(defun hyper-apropos-popup-menu (event) + (interactive "e") + (mouse-set-point event) + (let* ((sym (or (hyper-apropos-this-symbol) + (and (eq major-mode 'hyper-apropos-help-mode) + (save-excursion + (goto-char (point-min)) + (hyper-apropos-this-symbol))))) + (notjunk (not (null sym))) + (command-p (if (commandp sym) t)) + (variable-p (and sym (boundp sym))) + (customizable-p (and variable-p + (get sym 'custom-type) + t)) + (function-p (fboundp sym)) + (apropos-p (eq 'hyper-apropos-mode + (save-excursion (set-buffer (event-buffer event)) + major-mode))) + (name (if sym (symbol-name sym) "")) + (hyper-apropos-menu + (delete + nil + (list (concat "Hyper-Help: " name) + (vector "Display documentation" 'hyper-apropos-get-doc notjunk) + (vector "Set variable" 'hyper-apropos-set-variable variable-p) + (vector "Customize variable" 'hyper-apropos-customize-variable + customizable-p) + (vector "Show keys for" 'hyper-apropos-where-is command-p) + (vector "Invoke command" 'hyper-apropos-invoke-fn command-p) + (vector "Find function" 'hyper-apropos-find-function function-p) + (vector "Find tag" 'hyper-apropos-find-tag notjunk) + (and apropos-p + ["Add keyword..." hyper-apropos-add-keyword t]) + (and apropos-p + ["Eliminate keyword..." hyper-apropos-eliminate-keyword t]) + (if apropos-p + ["Programmers' Apropos" hyper-apropos-toggle-programming-flag + :style toggle :selected hyper-apropos-programming-apropos] + ["Programmers' Help" hyper-apropos-toggle-programming-flag + :style toggle :selected hyper-apropos-programming-apropos]) + (and hyper-apropos-programming-apropos + (vector "Disassemble function" + 'hyper-apropos-disassemble + function-p)) + ["Help" describe-mode t] + ["Quit" hyper-apropos-quit t] + )))) + (popup-menu hyper-apropos-menu))) +;;;###autoload +(define-obsolete-function-alias + 'hypropos-popup-menu 'hyper-apropos-popup-menu) + +(provide 'hyper-apropos) + +;; end of hyper-apropos.el diff -r 43306a74e31c -r d44af0c54775 lisp/hyperbole/.hypb --- a/lisp/hyperbole/.hypb Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,16 +0,0 @@ - -"DEMO" -("Smart_Mouse_Keys" nil nil link-to-string-match ("* Smart Mouse Keys" 1 "./DEMO") "weiner" "19940530:05:17:23" nil nil) -("as_long_as_you_click_within_its_first_line" nil nil eval-elisp ((message "Hyperbole simplifies your work.")) "ex594bw" "19921024:23:08:43" nil nil) -("factorial_button" nil nil link-to-ebut ("./DEMO" "factorial") "ex594bw" "19921014:18:57:35" nil nil) -("toggle-scroll-proportional" nil nil eval-elisp ((progn (setq smart-scroll-proportional (not smart-scroll-proportional)) (message "smart-scroll-proportional = %s" smart-scroll-proportional))) "ex594bw" "19920923:05:33:32" nil nil) -("glossary" nil nil link-to-Info-node ("(hypb.info)Glossary") "rsw@cs.brown.edu" "19911210:07:11:29" nil nil) -(".login" nil nil link-to-file ("~/.login") "rsw@cs.brown.edu" "19911126:05:01:08" "rsw" "19911213:19:12:02") -("tmp_directory" nil nil link-to-directory ("/tmp") "rsw@cs.brown.edu" "19911126:04:03:37" nil nil) -("Info-directory" nil nil eval-elisp ((message "Info-directory = %s" Info-directory)) "rsw@cs.brown.edu" "19911126:03:46:54" nil nil) -("Info-directory-list" nil nil eval-elisp ((describe-variable (quote Info-directory-list))) "rsw@cs.brown.edu" "19911126:03:46:16" "rsw" "19911230:07:17:52") -("keyboard_macros" nil nil link-to-Info-node ("(emacs)Keyboard Macros") "rsw@cs.brown.edu" "19911126:01:08:12" nil nil) -("factorial_alias" nil nil link-to-ebut ("./DEMO" "factorial") "rsw@cs.brown.edu" "19911126:00:54:30" "rsw" "19911126:00:56:10") -("maximum_length" nil nil eval-elisp ((message "Max length of explicit button labels = %d characters." ebut:max-len)) "rsw@cs.brown.edu" "19911126:00:48:26" nil nil) -("shell_command" nil nil exec-shell-cmd ("ls -l DEMO" nil nil) "rsw@cs.brown.edu" "19911126:00:42:32" "rsw" "19911213:19:07:43") -("keyboard_macro" nil nil exec-kbd-macro ("(f ("factorial" nil nil eval-elisp ((message "Factorial of 5 = %d" (* 5 4 3 2))) "rsw@cs.brown.edu" "19911125:09:52:22" "rsw" "19911125:09:54:00") diff -r 43306a74e31c -r d44af0c54775 lisp/info.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/info.el Mon Aug 13 10:08:34 2007 +0200 @@ -0,0 +1,2774 @@ +;;; info.el --- info package for Emacs. +;; Keywords: help + +;; Copyright (C) 1985, 1986, 1993, 1997 Free Software Foundation, Inc. + +;; Author: Dave Gillespie +;; Richard Stallman +;; Maintainer: Dave Gillespie +;; Version: 1.07 of 7/22/93 +;; Keywords: docs, help + +;; This file is part of XEmacs. + +;; XEmacs 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. + +;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not synched with FSF. + +;; Commentary: + +;; This is based on an early Emacs 19 info.el file. +;; +;; Note that Info-directory has been replaced by Info-directory-list, +;; a search path of directories in which to find Info files. +;; Also, Info tries adding ".info" to a file name if the name itself +;; is not found. +;; +;; See the change log below for further details. + + +;; LCD Archive Entry: +;; info-dg|Dave Gillespie|daveg@synaptics.com +;; |Info reader with many enhancements; replaces standard info.el. +;; |93-07-22|1.07|~/modes/info.el + +;; Also available from anonymous FTP on csvax.cs.caltech.edu. + + +;; Change Log: + +;; Modified 3/7/1991 by Dave Gillespie: +;; (Author's address: daveg@synaptics.com or daveg@csvax.cs.caltech.edu) +;; +;; Added keys: i, t, <, >, [, ], {, }, 6, 7, 8, 9, 0. +;; Look at help for info-mode (type ? in Info) for descriptions. +;; +;; If Info-directory-list is undefined and there is no INFOPATH +;; in the environment, use value of Info-directory for compatibility +;; with Emacs 18.57. +;; +;; All files named "localdir" found in the path are appended to "dir", +;; the Info directory. For this to work, "dir" should contain only +;; one node (Top), and each "localdir" should contain no ^_ or ^L +;; characters. Generally they will contain only one or several +;; additional lines for the top-level menu. Note that "dir" is +;; modified in memory each time it is loaded, but not on disk. +;; +;; If "dir" contains a line of the form: "* Locals:" +;; then the "localdir"s are inserted there instead of at the end. + + +;; Modified 4/3/1991 by Dave Gillespie: +;; +;; Added Info-mode-hook (suggested by Sebastian Kremer). +;; Also added epoch-info-startup/select-hooks from Simon Spero's info.el. +;; +;; Added automatic decoding of compressed Info files. +;; See documentation for the variable Info-suffix-list. Default is to +;; run "uncompress" on ".Z" files and "unyabba" on ".Y" files. +;; (See comp.sources.unix v24i073-076 for yabba/unyabba, a free software +;; alternative to compress/uncompress.) +;; Note: "dir" and "localdir" files should not be compressed. +;; +;; Changed variables like Info-enable-edit to be settable by M-x set-variable. +;; +;; Added Info-auto-advance variable. If t, SPC and DEL will act like +;; } and {, i.e., they advance to the next/previous node if at the end +;; of the buffer. +;; +;; Changed `u' to restore point to most recent location in that node. +;; Added `=' to do this manually at any time. (Suggested by David Fox). +;; +;; Changed `m' and `0-9' to try interpreting menu name as a file name +;; if not found as a node name. This allows (dir) menus of the form, +;; Emacs:: Cool text editor +;; as a shorthand for +;; Emacs:(emacs). Cool text editor +;; +;; Enhanced `i' to use line-number information in the index. +;; Added `,' to move among all matches to a previous `i' command. +;; +;; Added `a' (Info-annotate) for adding personal notes to any Info node. +;; Notes are not stored in the actual Info files, but in the user's own +;; ~/.infonotes file. +;; +;; Added Info-footnote-tag, made default be "Ref" instead of "Note". +;; +;; Got mouse-click stuff to work under Emacs version 18. Check it out! +;; Left and right clicks scroll the Info window. +;; Middle click goes to clicked-on node, e.g., "Next:", a menu, or a note. + + +;; Modified 6/29/1991 by Dave Gillespie: +;; +;; Renamed epoch-info-startup/select-hooks to Info-startup/select-hook. +;; +;; Made Info-select-node into a command on the `!' key. +;; +;; Added Info-mouse-support user option. +;; +;; Cleaned up the implementation of some routines. +;; +;; Added special treatment of quoted words in annotations: The `g' +;; command for a nonexistent node name scans for an annotation +;; (in any node of any file) containing that name in quotes: g foo RET +;; looks for an annotation containing: "foo" or: <> +;; If found, it goes to that file and node. +;; +;; Added a call to set up Info-directory-list in Info-find-node to +;; work around a bug in GNUS where it calls Info-goto-node before info. +;; +;; Added completion for `g' command (inspired by Richard Kim's infox.el). +;; Completion knows all node names for the current file, and all annotation +;; tags (see above). It does not complete file names or node names in +;; other files. +;; +;; Added `k' (Info-emacs-key) and `*' (Info-elisp-ref) commands. You may +;; wish to bind these to global keys outside of Info mode. +;; +;; Allowed localdir files to be full dir-like files; only the menu part +;; of each localdir is copied. Also, redundant menu items are omitted. +;; +;; Changed Info-history to hold only one entry at a time for each node, +;; and to be circular so that multiple `l's come back again to the most +;; recent node. Note that the format of Info-history entries has changed, +;; which may interfere with external programs that try to operate on it. +;; (Also inspired by Kim's infox.el). +;; +;; Changed `n', `]', `l', etc. to accept prefix arguments to move several +;; steps at once. Most accept negative arguments to move oppositely. +;; +;; Changed `?' to bury *Help* buffer afterwards to keep it out of the way. +;; +;; Rearranged `?' key's display to be a little better for new users. +;; +;; Changed `a' to save whole window configuration and restore on C-c C-c. +;; +;; Fixed the bug reported by Bill Reynolds on gnu.emacs.bugs. +;; +;; Changed Info-last to restore window-start as well as cursor position. +;; +;; Changed middle mouse button in space after end of node to do Info-last +;; if we got here by following a cross reference, else do Info-global-next. +;; +;; Added some new mouse bindings: shift-left = Info-global-next, +;; shift-right = Info-global-prev, shift-middle = Info-last. +;; +;; Fixed Info-follow-reference not to make assumptions about length +;; of Info-footnote-tag [Linus Tolke]. +;; +;; Changed default for Info-auto-advance mode to be press-twice-for-next-node. +;; +;; Modified x-mouse-ignore to preserve last-command variable, so that +;; press-twice Info-auto-advance mode works with the mouse. + + +;; Modified 3/4/1992 by Dave Gillespie: +;; +;; Added an "autoload" command to help autoload.el. +;; +;; Changed `*' command to look for file `elisp' as well as for `lispref'. +;; +;; Fixed a bug involving footnote names containing regexp special characters. +;; +;; Fixed a bug in completion during `f' (or `r') command. +;; +;; Added TAB (Info-next-reference), M-TAB, and RET keys to Info mode. +;; +;; Added new bindings, `C-h C-k' for Info-emacs-key and `C-h C-f' for +;; Info-elisp-ref. These bindings are made when info.el is loaded, and +;; only if those key sequences were previously unbound. These bindings +;; work at any time, not just when Info is already running. + + +;; Modified 3/8/1992 by Dave Gillespie: +;; +;; Fixed some long lines that were causing trouble with mailers. + + +;; Modified 3/9/1992 by Dave Gillespie: +;; +;; Added `C-h C-i' (Info-query). +;; +;; Added Info-novice mode, warns if the user attempts to switch to +;; a different Info file. +;; +;; Fixed a bug that caused problems using compressed Info files +;; and Info-directory-list at the same time. +;; +;; Disabled Info-mouse-support by default if Epoch or Hyperbole is in use. +;; +;; Added an expand-file-name call to Info-find-node to fix a small bug. + + +;; Modified 5/22/1992 by Dave Gillespie: +;; +;; Added "standalone" operation: "emacs -f info" runs Emacs specifically +;; for use as an Info browser. In this mode, the `q' key quits Emacs +;; itself. Also, "emacs -f info arg" starts in Info file "arg" instead +;; of "dir". +;; +;; Changed to prefer "foo.info" over "foo". If both exist, "foo" is +;; probably a directory or executable program! +;; +;; Made control-mouse act like regular-mouse does in other buffers. +;; (In most systems, this will be set-cursor for left-mouse, x-cut +;; for right-mouse, and x-paste, which will be an error, for +;; middle-mouse.) +;; +;; Improved prompting and searching for `,' key. +;; +;; Fixed a bug where some "* Menu:" lines disappeared when "dir" +;; contained several nodes. + + +;; Modified 9/10/1992 by Dave Gillespie: +;; +;; Mixed in support for XEmacs. Mouse works the same as in +;; the other Emacs versions by default; added Info-lucid-mouse-style +;; variable, which enables mouse operation similar to XEmacs's default. +;; +;; Fixed a bug where RET couldn't understand "* Foo::" if "Foo" was a +;; file name instead of a node name. +;; +;; Added `x' (Info-bookmark), a simple interface to the annotation +;; tags feature. Added `j' (Info-goto-bookmark), like `g' but only +;; completes bookmarks. +;; +;; Added `<>' as alternate to `"tag"' in annotations. +;; +;; Added `v' (Info-visit-file), like Info-goto-node but specialized +;; for going to a new Info file (with file name completion). +;; +;; Added recognition of gzip'd ".z" files. + + +;; Modified 5/9/1993 by Dave Gillespie: +;; +;; Merged in various things from FSF's latest Emacs 19 info.el. +;; Notably: Added Info-default-directory-list. + + +;; Modified 6/2/1993 by Dave Gillespie: +;; +;; Changed to use new suffix ".gz" for gzip files. + + +;; Modified 7/22/1993 by Dave Gillespie: +;; +;; Changed Info-footnote-tag to "See" instead of "Ref". +;; +;; Extended Info-fontify-node to work with FSF version of Emacs 19. + +;; Modified 7/30/1993 by Jamie Zawinski: +;; +;; Commented out the tty and fsf19 mouse support, because why bother. +;; Commented out the politically incorrect version of XEmacs mouse support. +;; Commented out mouse scrolling bindings because the party line on that +;; is "scrollbars are coming soon." +;; Commented out munging of help-for-help's doc; put it in help.el. +;; Did Info-edit-map the modern XEmacs way. +;; Pruned extra cruft from fontification and mouse handling code. +;; Fixed ASCII-centric bogosity in unreading of events. + +;; Modified 8/11/95 by Chuck Thompson: +;; +;; Removed any pretense of ever referencing Info-directory since it +;; wasn't working anyhow. + +;; Modified 4/5/97 by Tomasz J. Cholewo: +;; +;; Modified Info-search to use with-caps-disable-folding + +;; Modified 6/21/97 by Hrvoje Niksic +;; +;; Fixed up Info-next-reference to work sanely when n < 0. +;; Added S-tab binding. + +;; Modified 1997-07-10 by Karl M. Hegbloom +;; +;; Added `Info-minibuffer-history' +;; (also added to defaults in "lisp/utils/savehist.el") +;; Other changes in main ChangeLog. + +;; Code: + +(defgroup info nil + "The info package for Emacs." + :group 'help + :group 'docs) + +(defgroup info-faces nil + "The faces used by info browser." + :group 'info + :group 'faces) + + +(defcustom Info-inhibit-toolbar nil + "*Non-nil means don't use the specialized Info toolbar." + :type 'boolean + :group 'info) + +(defcustom Info-novice nil + "*Non-nil means to ask for confirmation before switching Info files." + :type 'boolean + :group 'info) + +(defvar Info-history nil + "List of info nodes user has visited. +Each element of list is a list (\"(FILENAME)NODENAME\" BUFPOS WINSTART).") + +(defvar Info-keeping-history t + "Non-nil if Info-find-node should modify Info-history. +This is for use only by certain internal Info routines.") + +(defvar Info-minibuffer-history nil + "Minibuffer history for Info.") + +(defcustom Info-enable-edit nil + "*Non-nil means the \\\\[Info-edit] command in Info +can edit the current node. +This is convenient if you want to write info files by hand. +However, we recommend that you not do this. +It is better to write a Texinfo file and generate the Info file from that, +because that gives you a printed manual as well." + :type 'boolean + :group 'info) + +(defcustom Info-enable-active-nodes t + "*Non-nil allows Info to execute Lisp code associated with nodes. +The Lisp code is executed when the node is selected." + :type 'boolean + :group 'info) + +(defcustom Info-restoring-point t + "*Non-nil means to restore the cursor position when re-entering a node." + :type 'boolean + :group 'info) + +(defcustom Info-auto-advance 'twice + "*Control what SPC and DEL do when they can't scroll any further. +If nil, they beep and remain in the current node. +If t, they move to the next node (like Info-global-next/prev). +If anything else, they must be pressed twice to move to the next node." + :type '(choice (const :tag "off" nil) + (const :tag "advance" t) + (const :tag "confirm" twice)) + :group 'info) + +(defcustom Info-fontify t + "*Non-nil enables font features in XEmacs. +This variable is ignored unless running under XEmacs." + :type 'boolean + :group 'info) + +(defvar Info-default-directory-list nil + "*List of directories to search for Info documents, and `dir' or `localdir' files. +The value of `Info-default-directory-list' will be initialized to a +reasonable default by the startup code, and usually doesn't need to be +changed in your personal configuration, though you may do so if you like. + +The first directory on this list must contain a `dir' file like the one +supplied with XEmacs, which will be used as the (dir)Top node. + +For more information, see the documentation to the variable: +`Info-directory-list'.") + +(defcustom Info-additional-search-directory-list nil + "*List of additional directories to search for Info documentation +files. These directories are not searched for merging the `dir' +file. An example might be something like: +\"/usr/local/lib/xemacs/packages/lisp/calc/\"" + :type '(repeat directory) + :group 'info) + +(defvar Info-directory-list + (let ((path (getenv "INFOPATH"))) + (if path + (split-string path path-separator) + Info-default-directory-list)) + "List of directories to search for Info documentation files. +Default is to use the environment variable INFOPATH if it exists, +else to use `Info-default-directory-list'. +The first directory in this list, the \"dir\" file there will become +the (dir)Top node of the Info documentation tree.") + +(defcustom Info-localdir-heading-regexp + "^Locally installed XEmacs Packages:?" + "The menu part of localdir files will be inserted below this topic +heading." + :type 'regexp + :group 'info) + +(defface info-node '((t (:bold t :italic t))) + "Face used for node links in info." + :group 'info-faces) + +(defface info-xref '((t (:bold t))) + "Face used for cross-references in info." + :group 'info-faces) + +;; Is this right for NT? .zip, with -c for to stdout, right? +(defvar Info-suffix-list '( ("" . nil) + (".info" . nil) + (".info.gz" . "gzip -dc %s") + (".info-z" . "gzip -dc %s") + (".info.Z" . "uncompress -c %s") + (".gz" . "gzip -dc %s") + (".Z" . "uncompress -c %s") + (".zip" . "unzip -c %s") ) + "List of file name suffixes and associated decoding commands. +Each entry should be (SUFFIX . STRING); if STRING contains %s, that is +changed to name of the file to decode, otherwise the file is given to +the command as standard input. If STRING is nil, no decoding is done.") + +(defvar Info-footnote-tag "Note" + "*Symbol that identifies a footnote or cross-reference. +All \"*Note\" references will be changed to use this word instead.") + +(defvar Info-current-file nil + "Info file that Info is now looking at, or nil. +This is the name that was specified in Info, not the actual file name. +It doesn't contain directory names or file name extensions added by Info.") + +(defvar Info-current-subfile nil + "Info subfile that is actually in the *info* buffer now, +or nil if current info file is not split into subfiles.") + +(defvar Info-current-node nil + "Name of node that Info is now looking at, or nil.") + +(defvar Info-tag-table-marker (make-marker) + "Marker pointing at beginning of current Info file's tag table. +Marker points nowhere if file has no tag table.") + +(defvar Info-current-file-completions nil + "Cached completion list for current Info file.") + +(defvar Info-current-annotation-completions nil + "Cached completion list for current annotation files.") + +(defvar Info-index-alternatives nil + "List of possible matches for last Info-index command.") +(defvar Info-index-first-alternative nil) + +(defcustom Info-annotations-path '("~/.xemacs/info.notes" + "~/.infonotes" + "/usr/lib/info.notes") + "*Names of files that contain annotations for different Info nodes. +By convention, the first one should reside in your personal directory. +The last should be a world-writable \"public\" annotations file." + :type '(repeat file) + :group 'info) + +(defcustom Info-button1-follows-hyperlink nil + "*Non-nil means mouse button1 click will follow hyperlink." + :type 'boolean + :group 'info) + +(defvar Info-standalone nil + "Non-nil if Emacs was started solely as an Info browser.") + +(defvar Info-in-cross-reference nil) +(defvar Info-window-configuration nil) + +;;;###autoload +(defun info (&optional file) + "Enter Info, the documentation browser. +Optional argument FILE specifies the file to examine; +the default is the top-level directory of Info. + +In interactive use, a prefix argument directs this command +to read a file name from the minibuffer." + (interactive (if current-prefix-arg + (list (read-file-name "Info file name: " nil nil t)))) + (let ((p command-line-args)) + (while p + (and (string-match "^-[fe]" (car p)) + (equal (nth 1 p) "info") + (not Info-standalone) + (setq Info-standalone t) + (= (length p) 3) + (not (string-match "^-" (nth 2 p))) + (setq file (nth 2 p)) + (setq command-line-args-left nil)) + (setq p (cdr p)))) +; (Info-setup-x) ??? What was this going to be? Can anyone tell karlheg? + (if file + (unwind-protect + (Info-goto-node (concat "(" file ")")) + (and Info-standalone (info))) + (if (get-buffer "*info*") + (switch-to-buffer "*info*") + (Info-directory)))) + +;;;###autoload +(defun Info-query (file) + "Enter Info, the documentation browser. Prompt for name of Info file." + (interactive "sInfo topic (default = menu): ") + (info) + (if (equal file "") + (Info-goto-node "(dir)") + (Info-goto-node (concat "(" file ")")))) + +(defun Info-setup-initial () + (let ((f Info-annotations-path)) + (while f + (if (and (file-exists-p (car f)) (not (get-file-buffer (car f)))) + (bury-buffer (find-file-noselect (car f)))) + (setq f (cdr f))))) + +(defun Info-find-node (filename &optional nodename no-going-back tryfile line) + "Go to an info node specified as separate FILENAME and NODENAME. +Look for a plausible filename, or if not found then look for URL's and +dispatch to the appropriate fn. NO-GOING-BACK is non-nil if +recovering from an error in this function; it says do not attempt +further (recursive) error recovery. TRYFILE is ??" + + (Info-setup-initial) + + (cond + ;; empty filename is simple case + ((null filename) + (Info-find-file-node nil nodename no-going-back tryfile line)) + ;; Convert filename to lower case if not found as specified. + ;; Expand it, look harder... + ((let (temp temp-downcase found + (fname (substitute-in-file-name filename))) + (let ((dirs (cond + ((string-match "^\\./" fname) ; If specified name starts with `./' + (list default-directory)) ; then just try current directory. + ((file-name-absolute-p fname) + '(nil)) ; No point in searching for an absolute file name + (Info-additional-search-directory-list + (append Info-directory-list + Info-additional-search-directory-list)) + (t Info-directory-list)))) + ;; Search the directory list for file FNAME. + (while (and dirs (not found)) + (setq temp (expand-file-name fname (car dirs))) + (setq temp-downcase + (expand-file-name (downcase fname) (car dirs))) + (if (equal temp-downcase temp) (setq temp-downcase nil)) + ;; Try several variants of specified name. + ;; Try downcasing, appending a suffix, or both. + (setq found (Info-suffixed-file temp temp-downcase)) + (setq dirs (cdr dirs))) + (if found + (progn (setq filename (expand-file-name found)) + t)))) + (Info-find-file-node filename nodename no-going-back tryfile line)) + ;; Look for a URL. This pattern is stolen from w3.el to prevent + ;; loading it if we won't need it. + ((string-match (concat "^\\(wais\\|solo\\|x-exec\\|newspost\\|www\\|" + "mailto\\|news\\|tn3270\\|ftp\\|http\\|file\\|" + "telnet\\|gopher\\):") + filename) + (browse-url filename)) + (t + (error "Info file %s does not exist" filename)))) + +(defun Info-find-file-node (filename nodename + &optional no-going-back tryfile line) + ;; This is the guts of what was Info-find-node. Whoever wrote this + ;; should be locked up where they can't do any more harm. + + ;; Go into info buffer. + (switch-to-buffer "*info*") + (buffer-disable-undo (current-buffer)) + (run-hooks 'Info-startup-hook) + (or (eq major-mode 'Info-mode) + (Info-mode)) + (or (null filename) + (equal Info-current-file filename) + (not Info-novice) + (string= "dir" (file-name-nondirectory Info-current-file)) + (if (y-or-n-p-maybe-dialog-box + (format "Leave Info file `%s'? " + (file-name-nondirectory Info-current-file))) + (message "") + (keyboard-quit))) + ;; Record the node we are leaving. + (if (and Info-current-file (not no-going-back)) + (Info-history-add Info-current-file Info-current-node (point))) + (widen) + (setq Info-current-node nil + Info-in-cross-reference nil) + (unwind-protect + (progn + ;; Switch files if necessary + (or (null filename) + (equal Info-current-file filename) + (let ((buffer-read-only nil)) + (setq Info-current-file nil + Info-current-subfile nil + Info-current-file-completions nil + Info-index-alternatives nil + buffer-file-name nil) + (erase-buffer) + (if (string= "dir" (file-name-nondirectory filename)) + (Info-insert-dir) + (Info-insert-file-contents filename t) + (setq default-directory (file-name-directory filename))) + (set-buffer-modified-p nil) + ;; See whether file has a tag table. Record the location if yes. + (set-marker Info-tag-table-marker nil) + (goto-char (point-max)) + (forward-line -8) + (or (equal nodename "*") + (not (search-forward "\^_\nEnd tag table\n" nil t)) + (let (pos) + ;; We have a tag table. Find its beginning. + ;; Is this an indirect file? + (search-backward "\nTag table:\n") + (setq pos (point)) + (if (save-excursion + (forward-line 2) + (looking-at "(Indirect)\n")) + ;; It is indirect. Copy it to another buffer + ;; and record that the tag table is in that buffer. + (save-excursion + (let ((buf (current-buffer))) + (set-buffer + (get-buffer-create " *info tag table*")) + (buffer-disable-undo (current-buffer)) + (setq case-fold-search t) + (erase-buffer) + (insert-buffer-substring buf) + (set-marker Info-tag-table-marker + (match-end 0)))) + (set-marker Info-tag-table-marker pos)))) + (setq Info-current-file + (file-name-sans-versions buffer-file-name)))) + (if (equal nodename "*") + (progn (setq Info-current-node nodename) + (Info-set-mode-line) + (goto-char (point-min))) + ;; Search file for a suitable node. + (let* ((qnode (regexp-quote nodename)) + (regexp (concat "Node: *" qnode " *[,\t\n\177]")) + (guesspos (point-min)) + (found t)) + ;; First get advice from tag table if file has one. + ;; Also, if this is an indirect info file, + ;; read the proper subfile into this buffer. + (if (marker-position Info-tag-table-marker) + (save-excursion + (set-buffer (marker-buffer Info-tag-table-marker)) + (goto-char Info-tag-table-marker) + (if (re-search-forward regexp nil t) + (progn + (setq guesspos (read (current-buffer))) + ;; If this is an indirect file, + ;; determine which file really holds this node + ;; and read it in. + (if (not (eq (current-buffer) (get-buffer "*info*"))) + (setq guesspos + (Info-read-subfile guesspos))))))) + (goto-char (max (point-min) (- guesspos 1000))) + ;; Now search from our advised position (or from beg of buffer) + ;; to find the actual node. + (catch 'foo + (while (search-forward "\n\^_" nil t) + (forward-line 1) + (let ((beg (point))) + (forward-line 1) + (if (re-search-backward regexp beg t) + (throw 'foo t)))) + (setq found nil) + (let ((bufs (delq nil (mapcar 'get-file-buffer + Info-annotations-path))) + (pattern (if (string-match "\\`<<.*>>\\'" qnode) qnode + (format "\"%s\"\\|<<%s>>" qnode qnode))) + (pat2 (concat "------ *File: *\\([^ ].*[^ ]\\) *Node: " + "*\\([^ ].*[^ ]\\) *Line: *\\([0-9]+\\)")) + (afile nil) anode aline) + (while (and bufs (not anode)) + (save-excursion + (set-buffer (car bufs)) + (goto-char (point-min)) + (if (re-search-forward pattern nil t) + (if (re-search-backward pat2 nil t) + (setq afile (buffer-substring (match-beginning 1) + (match-end 1)) + anode (buffer-substring (match-beginning 2) + (match-end 2)) + aline (string-to-int + (buffer-substring (match-beginning 3) + (match-end 3))))))) + (setq bufs (cdr bufs))) + (if anode + (Info-find-node afile anode t nil aline) + (if tryfile + (condition-case nil + (Info-find-node nodename "Top" t) + (error nil))))) + (or Info-current-node + (error "No such node: %s" nodename))) + (if found + (progn + (Info-select-node) + (goto-char (point-min)) + (if line (forward-line line))))))) + ;; If we did not finish finding the specified node, + ;; go back to the previous one. + (or Info-current-node no-going-back + (let ((hist (car Info-history))) + ;; The following is no longer safe with new Info-history system + ;; (setq Info-history (cdr Info-history)) + (Info-goto-node (car hist) t) + (goto-char (+ (point-min) (nth 1 hist))))))) + +;; Cache the contents of the (virtual) dir file, once we have merged +;; it for the first time, so we can save time subsequently. +(defvar Info-dir-contents nil) + +;; Cache for the directory we decided to use for the default-directory +;; of the merged dir text. +(defvar Info-dir-contents-directory nil) + +;; Record the file attributes of all the files from which we +;; constructed Info-dir-contents. +(defvar Info-dir-file-attributes nil) + +(defun Info-insert-dir () + "Construct the Info directory node by merging the files named +\"dir\" or \"localdir\" from the directories in `Info-directory-list' +The \"dir\" files will take precedence in cases where both exist. It +sets the *info* buffer's `default-directory' to the first directory we +actually get any text from." + (if (and Info-dir-contents Info-dir-file-attributes + ;; Verify that none of the files we used has changed + ;; since we used it. + (eval (cons 'and + (mapcar '(lambda (elt) + (let ((curr (file-attributes (car elt)))) + ;; Don't compare the access time. + (if curr (setcar (nthcdr 4 curr) 0)) + (setcar (nthcdr 4 (cdr elt)) 0) + (equal (cdr elt) curr))) + Info-dir-file-attributes)))) + (insert Info-dir-contents) + (let ((dirs (reverse Info-directory-list)) + buffers lbuffers buffer others nodes dirs-done) + + (setq Info-dir-file-attributes nil) + + ;; Search the directory list for the directory file. + (while dirs + (let ((truename (file-truename (expand-file-name (car dirs))))) + (or (member truename dirs-done) + (member (directory-file-name truename) dirs-done) + ;; Try several variants of specified name. + ;; Try upcasing, appending `.info', or both. + (let* (file + (attrs + (or + (progn (setq file (expand-file-name "dir" truename)) + (file-attributes file)) + (progn (setq file (expand-file-name "DIR" truename)) + (file-attributes file)) + (progn (setq file (expand-file-name "dir.info" truename)) + (file-attributes file)) + (progn (setq file (expand-file-name "DIR.INFO" truename)) + (file-attributes file)) + (progn (setq file (expand-file-name "localdir" truename)) + (file-attributes file)) + ))) + (setq dirs-done + (cons truename + (cons (directory-file-name truename) + dirs-done))) + (if attrs + (save-excursion + (or buffers + (message "Composing main Info directory...")) + (set-buffer (generate-new-buffer + (if (string-match "localdir" file) + "localdir" + "info dir"))) + (insert-file-contents file) + (if (string-match "localdir" (buffer-name)) + (setq lbuffers (cons (current-buffer) lbuffers)) + (setq buffers (cons (current-buffer) buffers))) + (setq Info-dir-file-attributes + (cons (cons file attrs) + Info-dir-file-attributes)))))) + (or (cdr dirs) (setq Info-dir-contents-directory (car dirs))) + (setq dirs (cdr dirs)))) + + ;; ensure that the localdir files are inserted last, and reverse + ;; the list of them so that when they get pushed in, they appear + ;; in the same order they got specified in the path, from top to + ;; bottom. + (nconc buffers (nreverse lbuffers)) + + (or buffers + (error "Can't find the Info directory node")) + ;; Distinguish the dir file that comes with Emacs from all the + ;; others. Yes, that is really what this is supposed to do. + ;; If it doesn't work, fix it. + (setq buffer (car buffers) + ;; reverse it since they are pushed down from the top. the + ;; `Info-default-directory-list'/INFOPATH can be specified + ;; in natural order this way. + others (nreverse (cdr buffers))) + + ;; Insert the entire original dir file as a start; note that we've + ;; already saved its default directory to use as the default + ;; directory for the whole concatenation. + (insert-buffer buffer) + + ;; Look at each of the other buffers one by one. + (while others + (let ((other (car others)) + (info-buffer (current-buffer))) + (if (string-match "localdir" (buffer-name other)) + (save-excursion + (set-buffer info-buffer) + (goto-char (point-max)) + (cond + ((re-search-backward "^ *\\* *Locals *: *$" nil t) + (delete-region (match-beginning 0) (match-end 0))) + ;; look for a line like |Local XEmacs packages: + ;; or mismatch on some text ... + ((re-search-backward Info-localdir-heading-regexp nil t) + ;; This is for people who underline topic headings with + ;; equal signs or dashes. + (when (save-excursion + (forward-line 1) + (beginning-of-line) + (looking-at "^[ \t]*[-=*]+")) + (forward-line 1)) + (forward-line 1) + (beginning-of-line)) + (t (search-backward "\^L" nil t))) + ;; Insert menu part of the file + (let* ((pt (point)) + (len (length (buffer-string nil nil other)))) + (insert (buffer-string nil nil other)) + (goto-char (+ pt len)) + (save-excursion + (goto-char pt) + (if (search-forward "* Menu:" (+ pt len) t) + (progn + (forward-line 1) + (delete-region pt (point))))))) + ;; In each, find all the menus. + (save-excursion + (set-buffer other) + (goto-char (point-min)) + ;; Find each menu, and add an elt to NODES for it. + (while (re-search-forward "^\\* Menu:" nil t) + (let (beg nodename end) + (forward-line 1) + (setq beg (point)) + (search-backward "\n\^_") + (search-forward "Node: ") + (setq nodename (Info-following-node-name)) + (search-forward "\n\^_" nil 'move) + (beginning-of-line) + (setq end (point)) + (setq nodes (cons (list nodename other beg end) nodes)))))) + (setq others (cdr others)))) + + ;; Add to the main menu a menu item for each other node. + (re-search-forward "^\\* Menu:" nil t) + (forward-line 1) + (let ((menu-items '("top")) + (nodes nodes) + (case-fold-search t) + (end (save-excursion (search-forward "\^_" nil t) (point)))) + (while nodes + (let ((nodename (car (car nodes)))) + (save-excursion + (or (member (downcase nodename) menu-items) + (re-search-forward (concat "^\\* " + (regexp-quote nodename) + "::") + end t) + (progn + (insert "* " nodename "::" "\n") + (setq menu-items (cons nodename menu-items)))))) + (setq nodes (cdr nodes)))) + ;; Now take each node of each of the other buffers + ;; and merge it into the main buffer. + (while nodes + (let ((nodename (car (car nodes)))) + (goto-char (point-min)) + ;; Find the like-named node in the main buffer. + (if (re-search-forward (concat "\n\^_.*\n.*Node: " + (regexp-quote nodename) + "[,\n\t]") + nil t) + (progn + (search-forward "\n\^_" nil 'move) + (beginning-of-line) + (insert "\n")) + ;; If none exists, add one. + (goto-char (point-max)) + (insert "\^_\nFile: dir\tNode: " nodename "\n\n* Menu:\n\n")) + ;; Merge the text from the other buffer's menu + ;; into the menu in the like-named node in the main buffer. + (apply 'insert-buffer-substring (cdr (car nodes)))) + (setq nodes (cdr nodes))) + ;; Kill all the buffers we just made. + (while buffers + (kill-buffer (car buffers)) + (setq buffers (cdr buffers))) + (while lbuffers + (kill-buffer (car lbuffers)) + (setq lbuffers (cdr lbuffers))) + (message "Composing main Info directory...done")) + (setq Info-dir-contents (buffer-string))) + (setq default-directory Info-dir-contents-directory) + (setq buffer-file-name (caar Info-dir-file-attributes))) + +(defun Info-history-add (file node point) + (if Info-keeping-history + (let* ((name (format "(%s)%s" (Info-file-name-only file) node)) + (found (assoc name Info-history))) + (if found + (setq Info-history (delq found Info-history))) + (setq Info-history (cons (list name (- point (point-min)) + (and (eq (window-buffer) + (current-buffer)) + (- (window-start) (point-min)))) + Info-history))))) + +(defun Info-file-name-only (file) + (let ((dir (file-name-directory file)) + (p Info-directory-list)) + (while (and p (not (equal (car p) dir))) + (setq p (cdr p))) + (if p (file-name-nondirectory file) file))) + +(defun Info-read-subfile (nodepos) + (set-buffer (marker-buffer Info-tag-table-marker)) + (goto-char (point-min)) + (search-forward "\n\^_") + (let (lastfilepos + lastfilename) + (forward-line 2) + (catch 'foo + (while (not (looking-at "\^_")) + (if (not (eolp)) + (let ((beg (point)) + thisfilepos thisfilename) + (search-forward ": ") + (setq thisfilename (buffer-substring beg (- (point) 2))) + (setq thisfilepos (read (current-buffer))) + ;; read in version 19 stops at the end of number. + ;; Advance to the next line. + (if (eolp) + (forward-line 1)) + (if (> thisfilepos nodepos) + (throw 'foo t)) + (setq lastfilename thisfilename) + (setq lastfilepos thisfilepos)) + (throw 'foo t)))) + (set-buffer (get-buffer "*info*")) + (or (equal Info-current-subfile lastfilename) + (let ((buffer-read-only nil)) + (setq buffer-file-name nil) + (widen) + (erase-buffer) + (Info-insert-file-contents (Info-suffixed-file + (expand-file-name lastfilename + (file-name-directory + Info-current-file))) + t) + (set-buffer-modified-p nil) + (setq Info-current-subfile lastfilename))) + (goto-char (point-min)) + (search-forward "\n\^_") + (+ (- nodepos lastfilepos) (point)))) + +(defun Info-suffixed-file (name &optional name2) + "Look for NAME with each of the `Info-suffix-list' extensions in +turn. Optional NAME2 is the name of a fallback info file to check +for; usually a downcased version of NAME." + (let ((suff Info-suffix-list) + (found nil) + file file2) + (while (and suff (not found)) + (setq file (concat name (caar suff)) + file2 (and name2 (concat name2 (caar suff)))) + (cond + ((file-exists-p file) + (setq found file)) + ((and file2 (file-exists-p file2)) + (setq found file2)) + (t + (setq suff (cdr suff))))) + (or found + (and name (when (file-exists-p name) + name)) + (and name2 (when (file-exists-p name2) + name2))))) + +(defun Info-insert-file-contents (file &optional visit) + (setq file (expand-file-name file default-directory)) + (let ((suff Info-suffix-list)) + (while (and suff (or (<= (length file) (length (car (car suff)))) + (not (equal (substring file + (- (length (car (car suff))))) + (car (car suff)))))) + (setq suff (cdr suff))) + (if (stringp (cdr (car suff))) + (let ((command (if (string-match "%s" (cdr (car suff))) + (format (cdr (car suff)) file) + (concat (cdr (car suff)) " < " file)))) + (message "%s..." command) + (if (eq system-type 'vax-vms) + (call-process command nil t nil) + (call-process shell-file-name nil t nil "-c" command)) + (message "") + (if visit + (progn + (setq buffer-file-name file) + (set-buffer-modified-p nil) + (clear-visited-file-modtime)))) + (insert-file-contents file visit)))) + +(defun Info-select-node () + "Select the node that point is in, after using `g *' to select whole file." + (interactive) + (widen) + (save-excursion + ;; Find beginning of node. + (search-backward "\n\^_") + (forward-line 2) + ;; Get nodename spelled as it is in the node. + (re-search-forward "Node:[ \t]*") + (setq Info-current-node + (buffer-substring (point) + (progn + (skip-chars-forward "^,\t\n") + (point)))) + (Info-set-mode-line) + ;; Find the end of it, and narrow. + (beginning-of-line) + (let (active-expression) + (narrow-to-region (point) + (if (re-search-forward "\n[\^_\f]" nil t) + (prog1 + (1- (point)) + (if (looking-at "[\n\^_\f]*execute: ") + (progn + (goto-char (match-end 0)) + (setq active-expression + (read (current-buffer)))))) + (point-max))) + (or (equal Info-footnote-tag "Note") + (progn + (goto-char (point-min)) + (let ((buffer-read-only nil) + (bufmod (buffer-modified-p)) + (case-fold-search t)) + (while (re-search-forward "\\*[Nn]ote\\([ \n]\\)" nil t) + (replace-match (concat "*" Info-footnote-tag "\ "))) + (set-buffer-modified-p bufmod)))) + (Info-reannotate-node) + ;; XEmacs: remove v19 test + (and Info-fontify + (Info-fontify-node)) + (run-hooks 'Info-select-hook) + (if Info-enable-active-nodes (eval active-expression))))) + +(defun Info-set-mode-line () + (setq modeline-buffer-identification + (list (cons modeline-buffer-id-left-extent "Info: ") + (cons modeline-buffer-id-right-extent + (concat + "(" + (if Info-current-file + (let ((name (file-name-nondirectory Info-current-file))) + (if (string-match "\\.info$" name) + (substring name 0 -5) + name)) + "") + ")" + (or Info-current-node "")))))) + +;; Go to an info node specified with a filename-and-nodename string +;; of the sort that is found in pointers in nodes. + +;;;###autoload +(defun Info-goto-node (nodename &optional no-going-back tryfile) + "Go to info node named NAME. Give just NODENAME or (FILENAME)NODENAME. +Actually, the following interpretations of NAME are tried in order: + (FILENAME)NODENAME + (FILENAME) (using Top node) + NODENAME (in current file) + TAGNAME (see below) + FILENAME (using Top node) +where TAGNAME is a string that appears in quotes: \"TAGNAME\", in an +annotation for any node of any file. (See `a' and `x' commands.)" + (interactive (list (Info-read-node-name "Goto node, file or tag: ") + nil t)) + (let (filename) + (string-match "\\s *\\((\\s *\\([^\t)]*\\)\\s *)\\s *\\|\\)\\(.*\\)" + nodename) + (setq filename (if (= (match-beginning 1) (match-end 1)) + "" + (substring nodename (match-beginning 2) (match-end 2))) + nodename (substring nodename (match-beginning 3) (match-end 3))) + (let ((trim (string-match "\\s *\\'" filename))) + (if trim (setq filename (substring filename 0 trim)))) + (let ((trim (string-match "\\s *\\'" nodename))) + (if trim (setq nodename (substring nodename 0 trim)))) + (Info-find-node (if (equal filename "") nil filename) + (if (equal nodename "") "Top" nodename) + no-going-back (and tryfile (equal filename ""))))) + +(defun Info-goto-bookmark () + (interactive) + (let ((completion-ignore-case nil) + (tag (completing-read "Goto tag: " + (Info-build-annotation-completions) + nil t nil + 'Info-minibuffer-history))) + (or (equal tag "") (Info-find-node nil (format "<<%s>>" tag))))) + +;;;###autoload +(defun Info-visit-file () + "Directly visit an info file." + (interactive) + (let* ((insert-default-directory nil) + (file (read-file-name "Goto Info file: " "" ""))) + (or (equal file "") (Info-find-node (expand-file-name file) "Top")))) + +(defun Info-restore-point (&optional always) + "Restore point to same location it had last time we were in this node." + (interactive "p") + (if (or Info-restoring-point always) + (let* ((name (format "(%s)%s" + (Info-file-name-only Info-current-file) + Info-current-node)) + (p (assoc name Info-history))) + (if p (Info-restore-history-entry p))))) + +(defun Info-restore-history-entry (entry) + (goto-char (+ (nth 1 entry) (point-min))) + (and (nth 2 entry) + (get-buffer-window (current-buffer)) + (set-window-start (get-buffer-window (current-buffer)) + (+ (nth 2 entry) (point-min))))) + +(defun Info-read-node-name (prompt &optional default) + (Info-setup-initial) + (let* ((completion-ignore-case t) + (nodename (completing-read prompt + (Info-build-node-completions) + nil nil nil + 'Info-minibuffer-history))) + (if (equal nodename "") + (or default + (Info-read-node-name prompt)) + nodename))) + +(defun Info-build-annotation-completions () + (or Info-current-annotation-completions + (save-excursion + (let ((bufs (delq nil (mapcar 'get-file-buffer + Info-annotations-path))) + (compl nil)) + (while bufs + (set-buffer (car bufs)) + (goto-char (point-min)) + (while (re-search-forward "<<\\(.*\\)>>" nil t) + (setq compl (cons (list (buffer-substring (match-beginning 1) + (match-end 1))) + compl))) + (setq bufs (cdr bufs))) + (setq Info-current-annotation-completions compl))))) + +(defun Info-build-node-completions () + (or Info-current-file-completions + (let ((compl (Info-build-annotation-completions))) + (save-excursion + (save-restriction + (if (marker-buffer Info-tag-table-marker) + (progn + (set-buffer (marker-buffer Info-tag-table-marker)) + (goto-char Info-tag-table-marker) + (while (re-search-forward "\nNode: \\(.*\\)\177" nil t) + (setq compl + (cons (list (buffer-substring (match-beginning 1) + (match-end 1))) + compl)))) + (widen) + (goto-char (point-min)) + (while (search-forward "\n\^_" nil t) + (forward-line 1) + (let ((beg (point))) + (forward-line 1) + (if (re-search-backward "Node: *\\([^,\n]*\\) *[,\n\t]" + beg t) + (setq compl + (cons (list (buffer-substring (match-beginning 1) + (match-end 1))) + compl)))))))) + (setq Info-current-file-completions compl)))) + +(defvar Info-last-search nil + "Default regexp for \\\\[Info-search] command to search for.") + + +;;;###autoload +(defun Info-search (regexp) + "Search for REGEXP, starting from point, and select node it's found in." + (interactive "sSearch (regexp): ") + (if (equal regexp "") + (setq regexp Info-last-search) + (setq Info-last-search regexp)) + (with-caps-disable-folding regexp + (let ((found ()) + (onode Info-current-node) + (ofile Info-current-file) + (opoint (point)) + (osubfile Info-current-subfile)) + (save-excursion + (save-restriction + (widen) + (if (null Info-current-subfile) + (progn (re-search-forward regexp) (setq found (point))) + (condition-case nil + (progn (re-search-forward regexp) (setq found (point))) + (search-failed nil))))) + (if (not found) ;can only happen in subfile case -- else would have erred + (unwind-protect + (let ((list ())) + (set-buffer (marker-buffer Info-tag-table-marker)) + (goto-char (point-min)) + (search-forward "\n\^_\nIndirect:") + (save-restriction + (narrow-to-region (point) + (progn (search-forward "\n\^_") + (1- (point)))) + (goto-char (point-min)) + (search-forward (concat "\n" osubfile ": ")) + (beginning-of-line) + (while (not (eobp)) + (re-search-forward "\\(^.*\\): [0-9]+$") + (goto-char (+ (match-end 1) 2)) + (setq list (cons (cons (read (current-buffer)) + (buffer-substring (match-beginning 1) + (match-end 1))) + list)) + (goto-char (1+ (match-end 0)))) + (setq list (nreverse list) + list (cdr list))) + (while list + (message "Searching subfile %s..." (cdr (car list))) + (Info-read-subfile (car (car list))) + (setq list (cdr list)) + (goto-char (point-min)) + (if (re-search-forward regexp nil t) + (setq found (point) list ()))) + (if found + (message "") + (signal 'search-failed (list regexp)))) + (if (not found) + (progn (Info-read-subfile opoint) + (goto-char opoint) + (Info-select-node))))) + (widen) + (goto-char found) + (Info-select-node) + (or (and (equal onode Info-current-node) + (equal ofile Info-current-file)) + (Info-history-add ofile onode opoint))))) + +;; Extract the value of the node-pointer named NAME. +;; If there is none, use ERRORNAME in the error message; +;; if ERRORNAME is nil, just return nil. +(defun Info-extract-pointer (name &optional errorname) + (save-excursion + (goto-char (point-min)) + (forward-line 4) + (let ((case-fold-search t)) + (if (re-search-backward (concat name ":") nil t) + (progn + (goto-char (match-end 0)) + (Info-following-node-name)) + (if (eq errorname t) + nil + (error (concat "Node has no " (capitalize (or errorname name))))))))) + +;; Return the node name in the buffer following point. +;; ALLOWEDCHARS, if non-nil, goes within [...] to make a regexp +;; saying which chas may appear in the node name. +(defun Info-following-node-name (&optional allowedchars) + (skip-chars-forward " \t") + (buffer-substring + (point) + (progn + (while (looking-at (concat "[" (or allowedchars "^,\t\n") "]")) + (skip-chars-forward (concat (or allowedchars "^,\t\n") "(")) + (if (looking-at "(") + (skip-chars-forward "^)"))) + (skip-chars-backward " ") + (point)))) + +(defun Info-next (&optional n) + "Go to the next node of this node. +A positive or negative prefix argument moves by multiple nodes." + (interactive "p") + (or n (setq n 1)) + (if (< n 0) + (Info-prev (- n)) + (while (>= (setq n (1- n)) 0) + (Info-goto-node (Info-extract-pointer "next"))))) + +(defun Info-prev (&optional n) + "Go to the previous node of this node. +A positive or negative prefix argument moves by multiple nodes." + (interactive "p") + (or n (setq n 1)) + (if (< n 0) + (Info-next (- n)) + (while (>= (setq n (1- n)) 0) + (Info-goto-node (Info-extract-pointer "prev[ious]*" "previous"))))) + +(defun Info-up (&optional n) + "Go to the superior node of this node. +A positive prefix argument moves up several times." + (interactive "p") + (or n (setq n 1)) + (while (>= (setq n (1- n)) 0) + (Info-goto-node (Info-extract-pointer "up"))) + (if (interactive-p) (Info-restore-point))) + +(defun Info-last (&optional n) + "Go back to the last node visited. +With a prefix argument, go to Nth most recently visited node. History is +circular; after oldest node, history comes back around to most recent one. +Argument can be negative to go through the circle in the other direction. +\(In other words, `l' is like \"undo\" and `C-u - l' is like \"redo\".)" + (interactive "p") + (or n (setq n 1)) + (or Info-history + (error "This is the first Info node you looked at")) + (let ((len (1+ (length Info-history)))) + (setq n (% (+ n (* len 100)) len))) + (if (> n 0) + (let ((entry (nth (1- n) Info-history))) + (Info-history-add Info-current-file Info-current-node (point)) + (while (>= (setq n (1- n)) 0) + (setq Info-history (nconc (cdr Info-history) + (list (car Info-history))))) + (setq Info-history (cdr Info-history)) + (let ((Info-keeping-history nil)) + (Info-goto-node (car entry))) + (Info-restore-history-entry entry)))) + +(defun Info-directory () + "Go to the Info directory node." + (interactive) + (Info-find-node "dir" "top")) + +(defun Info-follow-reference (footnotename) + "Follow cross reference named NAME to the node it refers to. +NAME may be an abbreviation of the reference name." + (interactive + (let ((completion-ignore-case t) + completions default (start-point (point)) str i) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward (format "\\*%s[ \n\t]*\\([^:]*\\):" + Info-footnote-tag) + nil t) + (setq str (buffer-substring + (match-beginning 1) + (1- (point)))) + ;; See if this one should be the default. + (and (null default) + (< (match-beginning 0) start-point) + (<= start-point (point)) + (setq default t)) + (setq i 0) + (while (setq i (string-match "[ \n\t]+" str i)) + (setq str (concat (substring str 0 i) " " + (substring str (match-end 0)))) + (setq i (1+ i))) + ;; Record as a completion and perhaps as default. + (if (eq default t) (setq default str)) + (setq completions + (cons (cons str nil) + completions)))) + (if completions + (let ((item (completing-read (if default + (concat "Follow reference named: (" + default ") ") + "Follow reference named: ") + completions nil t nil + 'Info-minibuffer-history))) + (if (and (string= item "") default) + (list default) + (list item))) + (error "No cross-references in this node")))) + (let (target i (str (concat "\\*" Info-footnote-tag " " + (regexp-quote footnotename)))) + (while (setq i (string-match " " str i)) + (setq str (concat (substring str 0 i) "\\([ \t\n]+\\)" + (substring str (1+ i)))) + (setq i (+ i 10))) + (save-excursion + (goto-char (point-min)) + (or (re-search-forward str nil t) + (error "No cross-reference named %s" footnotename)) + (goto-char (match-end 1)) + (setq target + (Info-extract-menu-node-name "Bad format cross reference" t))) + (while (setq i (string-match "[ \t\n]+" target i)) + (setq target (concat (substring target 0 i) " " + (substring target (match-end 0)))) + (setq i (+ i 1))) + (Info-goto-node target) + (setq Info-in-cross-reference t))) + +(defun Info-next-reference (n) + (interactive "p") + (let ((pat (format "\\*%s[ \n\t]*\\([^:]*\\):\\|^\\* .*:\\|<<.*>>" + Info-footnote-tag)) + (old-pt (point)) + wrapped found-nomenu) + (while (< n 0) + (unless (re-search-backward pat nil t) + ;; Don't wrap more than once in a buffer where only the + ;; menu references are found. + (when (and wrapped (not found-nomenu)) + (goto-char old-pt) + (error "No cross references in this node")) + (setq wrapped t) + (goto-char (point-max)) + (unless (re-search-backward pat nil t) + (goto-char old-pt) + (error "No cross references in this node"))) + (unless (save-excursion + (goto-char (match-beginning 0)) + (when (looking-at "\\* Menu:") + (decf n))) + (setq found-nomenu t)) + (incf n)) + (while (> n 0) + (or (eobp) (forward-char 1)) + (unless (re-search-forward pat nil t) + (when (and wrapped (not found-nomenu)) + (goto-char old-pt) + (error "No cross references in this node")) + (setq wrapped t) + (goto-char (point-min)) + (unless (re-search-forward pat nil t) + (goto-char old-pt) + (error "No cross references in this node"))) + (unless (save-excursion + (goto-char (match-beginning 0)) + (when (looking-at "\\* Menu:") + (incf n))) + (setq found-nomenu t)) + (decf n)) + (when (looking-at "\\* Menu:") + (error "No cross references in this node")) + (goto-char (match-beginning 0)))) + +(defun Info-prev-reference (n) + (interactive "p") + (Info-next-reference (- n))) + +(defun Info-extract-menu-node-name (&optional errmessage multi-line) + (skip-chars-forward " \t\n") + (let ((beg (point)) + str i) + (skip-chars-forward "^:") + (forward-char 1) + (setq str + (if (looking-at ":") + (buffer-substring beg (1- (point))) + (skip-chars-forward " \t\n") + (Info-following-node-name (if multi-line "^.,\t" "^.,\t\n")))) + (while (setq i (string-match "\n" str i)) + (aset str i ?\ )) + str)) + +(defun Info-menu (menu-item) + "Go to node for menu item named (or abbreviated) NAME. +Completion is allowed, and the menu item point is on is the default." + (interactive + (let ((completions '()) + ;; If point is within a menu item, use that item as the default + (default nil) + (p (point)) + (last nil)) + (save-excursion + (goto-char (point-min)) + (let ((case-fold-search t)) + (if (not (search-forward "\n* menu:" nil t)) + (error "No menu in this node"))) + (while (re-search-forward + "\n\\* \\([^:\t\n]*\\):" nil t) + (if (and (null default) + (prog1 (if last (< last p) nil) + (setq last (match-beginning 0))) + (<= p last)) + (setq default (car (car completions)))) + (setq completions (cons (cons (buffer-substring + (match-beginning 1) + (match-end 1)) + (match-beginning 1)) + completions))) + (if (and (null default) last + (< last p) + (<= p (progn (end-of-line) (point)))) + (setq default (car (car completions))))) + (let ((item nil)) + (while (null item) + (setq item (let ((completion-ignore-case t)) + (completing-read (if default + (format "Menu item (default %s): " + default) + "Menu item: ") + completions nil t nil + 'Info-minibuffer-history))) + ;; we rely on the fact that completing-read accepts an input + ;; of "" even when the require-match argument is true and "" + ;; is not a valid possibility + (if (string= item "") + (if default + (setq item default) + ;; ask again + (setq item nil)))) + (list item)))) + ;; there is a problem here in that if several menu items have the same + ;; name you can only go to the node of the first with this command. + (Info-goto-node (Info-extract-menu-item menu-item) nil t)) + +(defun Info-extract-menu-item (menu-item &optional noerror) + (save-excursion + (goto-char (point-min)) + (if (let ((case-fold-search t)) + (search-forward "\n* menu:" nil t)) + (if (or (search-forward (concat "\n* " menu-item ":") nil t) + (search-forward (concat "\n* " menu-item) nil t)) + (progn + (beginning-of-line) + (forward-char 2) + (Info-extract-menu-node-name)) + (and (not noerror) (error "No such item in menu"))) + (and (not noerror) (error "No menu in this node"))))) + +;; If COUNT is nil, use the last item in the menu. +(defun Info-extract-menu-counting (count &optional noerror noindex) + (save-excursion + (goto-char (point-min)) + (if (let ((case-fold-search t)) + (and (search-forward "\n* menu:" nil t) + (or (not noindex) + (not (string-match "\\" Info-current-node))))) + (if (search-forward "\n* " nil t count) + (progn + (or count + (while (search-forward "\n* " nil t))) + (Info-extract-menu-node-name)) + (and (not noerror) (error "Too few items in menu"))) + (and (not noerror) (error "No menu in this node"))))) + +(defun Info-nth-menu-item (n) + "Go to the node of the Nth menu item." + (interactive "P") + (or n (setq n (- last-command-char ?0))) + (if (< n 1) (error "Index must be at least 1")) + (Info-goto-node (Info-extract-menu-counting n) nil t)) + +(defun Info-last-menu-item () + "Go to the node of the tenth menu item." + (interactive) + (Info-goto-node (Info-extract-menu-counting nil) nil t)) + +(defun Info-top () + "Go to the Top node of this file." + (interactive) + (Info-goto-node "Top")) + +(defun Info-end () + "Go to the final node in this file." + (interactive) + (Info-top) + (let ((Info-keeping-history nil) + node) + (Info-last-menu-item) + (while (setq node (or (Info-extract-pointer "next" t) + (Info-extract-menu-counting nil t t))) + (Info-goto-node node)) + (or (equal (Info-extract-pointer "up" t) "Top") + (let ((executing-kbd-macro "")) ; suppress messages + (condition-case nil + (Info-global-next 10000) + (error nil)))))) + +(defun Info-global-next (&optional n) + "Go to the next node in this file, traversing node structure as necessary. +This works only if the Info file is structured as a hierarchy of nodes. +A positive or negative prefix argument moves by multiple nodes." + (interactive "p") + (or n (setq n 1)) + (if (< n 0) + (Info-global-prev (- n)) + (while (>= (setq n (1- n)) 0) + (let (node) + (cond ((and (string-match "^Top$" Info-current-node) + (setq node (Info-extract-pointer "next" t)) + (Info-extract-menu-item node t)) + (Info-goto-node node)) + ((setq node (Info-extract-menu-counting 1 t t)) + (message "Going down...") + (Info-goto-node node)) + (t + (let ((Info-keeping-history Info-keeping-history) + (orignode Info-current-node) + (ups "")) + (while (not (Info-extract-pointer "next" t)) + (if (and (setq node (Info-extract-pointer "up" t)) + (not (equal node "Top"))) + (progn + (message "Going%s..." (setq ups (concat ups " up"))) + (Info-goto-node node) + (setq Info-keeping-history nil)) + (if orignode + (let ((Info-keeping-history nil)) + (Info-goto-node orignode))) + (error "Last node in file"))) + (Info-next)))))))) + +(defun Info-page-next (&optional n) + "Scroll forward one screenful, or go to next global node. +A positive or negative prefix argument moves by multiple screenfuls." + (interactive "p") + (or n (setq n 1)) + (if (< n 0) + (Info-page-prev (- n)) + (while (>= (setq n (1- n)) 0) + (if (pos-visible-in-window-p (point-max)) + (progn + (Info-global-next) + (message "Node: %s" Info-current-node)) + (scroll-up))))) + +(defun Info-scroll-next (arg) + (interactive "P") + (if Info-auto-advance + (if (and (pos-visible-in-window-p (point-max)) + (not (eq Info-auto-advance t)) + (not (eq last-command this-command))) + (message "Hit %s again to go to next node" + (if (= last-command-char 0) + "mouse button" + (key-description (char-to-string last-command-char)))) + (Info-page-next) + (setq this-command 'Info)) + (scroll-up arg))) + +(defun Info-global-prev (&optional n) + "Go to the previous node in this file, traversing structure as necessary. +This works only if the Info file is structured as a hierarchy of nodes. +A positive or negative prefix argument moves by multiple nodes." + (interactive "p") + (or n (setq n 1)) + (if (< n 0) + (Info-global-next (- n)) + (while (>= (setq n (1- n)) 0) + (let ((upnode (Info-extract-pointer "up" t)) + (prevnode (Info-extract-pointer "prev[ious]*" t))) + (if (or (not prevnode) + (equal prevnode upnode)) + (if (string-match "^Top$" Info-current-node) + (error "First node in file") + (message "Going up...") + (Info-up)) + (Info-goto-node prevnode) + (let ((downs "") + (Info-keeping-history nil) + node) + (while (setq node (Info-extract-menu-counting nil t t)) + (message "Going%s..." (setq downs (concat downs " down"))) + (Info-goto-node node)))))))) + +(defun Info-page-prev (&optional n) + "Scroll backward one screenful, or go to previous global node. +A positive or negative prefix argument moves by multiple screenfuls." + (interactive "p") + (or n (setq n 1)) + (if (< n 0) + (Info-page-next (- n)) + (while (>= (setq n (1- n)) 0) + (if (pos-visible-in-window-p (point-min)) + (progn + (Info-global-prev) + (message "Node: %s" Info-current-node) + (sit-for 0) + ;;(scroll-up 1) ; work around bug in pos-visible-in-window-p + ;;(scroll-down 1) + (while (not (pos-visible-in-window-p (point-max))) + (scroll-up))) + (scroll-down))))) + +(defun Info-scroll-prev (arg) + (interactive "P") + (if Info-auto-advance + (if (and (pos-visible-in-window-p (point-min)) + (not (eq Info-auto-advance t)) + (not (eq last-command this-command))) + (message "Hit %s again to go to previous node" + (if (= last-command-char 0) + "mouse button" + (key-description (char-to-string last-command-char)))) + (Info-page-prev) + (setq this-command 'Info)) + (scroll-down arg))) + +(defun Info-index (topic) + "Look up a string in the index for this file. +The index is defined as the first node in the top-level menu whose +name contains the word \"Index\", plus any immediately following +nodes whose names also contain the word \"Index\". +If there are no exact matches to the specified topic, this chooses +the first match which is a case-insensitive substring of a topic. +Use the `,' command to see the other matches. +Give a blank topic name to go to the Index node itself." + (interactive "sIndex topic: ") + (let ((pattern (format "\n\\* \\([^\n:]*%s[^\n:]*\\):[ \t]*%s" + (regexp-quote topic) + "\\([^.\n]*\\)\\.[ t]*\\([0-9]*\\)")) + node) + (message "Searching index for `%s'..." topic) + (Info-goto-node "Top") + (let ((case-fold-search t)) + (or (search-forward "\n* menu:" nil t) + (error "No index")) + (or (re-search-forward "\n\\* \\(.*\\\\)" nil t) + (error "No index"))) + (goto-char (match-beginning 1)) + (let ((Info-keeping-history nil) + (Info-fontify (and Info-fontify (equal topic "")))) + (Info-goto-node (Info-extract-menu-node-name))) + (or (equal topic "") + (let ((matches nil) + (exact nil) + (Info-keeping-history nil) + found) + (while + (progn + (goto-char (point-min)) + (while (re-search-forward pattern nil t) + (setq matches + (cons (list (buffer-substring (match-beginning 1) + (match-end 1)) + (buffer-substring (match-beginning 2) + (match-end 2)) + Info-current-node + (string-to-int (concat "0" + (buffer-substring + (match-beginning 3) + (match-end 3))))) + matches))) + (and (setq node (Info-extract-pointer "next" t)) + (string-match "\\" node))) + (let ((Info-fontify nil)) + (Info-goto-node node))) + (or matches + (progn + (Info-last) + (error "No \"%s\" in index" topic))) + ;; Here it is a feature that assoc is case-sensitive. + (while (setq found (assoc topic matches)) + (setq exact (cons found exact) + matches (delq found matches))) + (setq Info-index-alternatives (nconc exact (nreverse matches)) + Info-index-first-alternative (car Info-index-alternatives)) + (Info-index-next 0))))) + +(defun Info-index-next (num) + "Go to the next matching index item from the last `i' command." + (interactive "p") + (or Info-index-alternatives + (error "No previous `i' command in this file")) + (while (< num 0) + (setq num (+ num (length Info-index-alternatives)))) + (while (> num 0) + (setq Info-index-alternatives + (nconc (cdr Info-index-alternatives) + (list (car Info-index-alternatives))) + num (1- num))) + (Info-goto-node (nth 1 (car Info-index-alternatives))) + (if (> (nth 3 (car Info-index-alternatives)) 0) + (forward-line (nth 3 (car Info-index-alternatives))) + (forward-line 3) ; don't search in headers + (let ((name (car (car Info-index-alternatives)))) + (if (or (re-search-forward (format + "\\(Function\\|Command\\): %s\\( \\|$\\)" + (regexp-quote name)) nil t) + (re-search-forward (format "^`%s[ ']" (regexp-quote name)) nil t) + (search-forward (format "`%s'" name) nil t) + (and (string-match "\\`.*\\( (.*)\\)\\'" name) + (search-forward + (format "`%s'" (substring name 0 (match-beginning 1))) + nil t)) + (search-forward name nil t)) + (beginning-of-line) + (goto-char (point-min))))) + (message "Found \"%s\" in %s. %s" + (car (car Info-index-alternatives)) + (nth 2 (car Info-index-alternatives)) + (if (cdr Info-index-alternatives) + (if (eq (car (cdr Info-index-alternatives)) + Info-index-first-alternative) + "(Press `,' to repeat)" + (format "(Press `,' for %d more)" + (- (1- (length Info-index-alternatives)) + (length (memq Info-index-first-alternative + (cdr Info-index-alternatives)))))) + "(Only match)"))) + + +;;;###autoload +(defun Info-emacs-command (command) + "Look up an Emacs command in the Emacs manual in the Info system. +This command is designed to be used whether you are already in Info or not." + (interactive "CLook up command in Emacs manual: ") + (save-window-excursion + (info) + (Info-find-node Info-emacs-info-file-name "Top") + (Info-index (symbol-name command))) + (pop-to-buffer "*info*")) + + +;;;###autoload +(defun Info-goto-emacs-command-node (key) + "Look up an Emacs command in the Emacs manual in the Info system. +This command is designed to be used whether you are already in Info or not." + (interactive "CLook up command in Emacs manual: ") + (Info-emacs-command key)) + +;;;###autoload +(defun Info-goto-emacs-key-command-node (key) + "Look up an Emacs key sequence in the Emacs manual in the Info system. +This command is designed to be used whether you are already in Info or not." + (interactive "kLook up key in Emacs manual: ") + (let ((command (key-binding key))) + (cond ((eq command 'keyboard-quit) + (keyboard-quit)) + ((null command) + (error "%s is undefined" (key-description key))) + ((and (interactive-p) (eq command 'execute-extended-command)) + (call-interactively 'Info-goto-emacs-command-node)) + (t + (Info-goto-emacs-command-node command))))) + +;;;###autoload +(defun Info-emacs-key (key) + "Look up an Emacs key sequence in the Emacs manual in the Info system. +This command is designed to be used whether you are already in Info or not." + (interactive "kLook up key in Emacs manual: ") + (cond ((eq (key-binding key) 'keyboard-quit) + (keyboard-quit)) + ((and (interactive-p) (eq (key-binding key) 'execute-extended-command)) + (call-interactively 'Info-goto-emacs-command-node)) + (t + (save-window-excursion + (info) + (Info-find-node Info-emacs-info-file-name "Top") + (setq key (key-description key)) + (let (p) + (if (setq p (string-match "[@{}]" key)) + (setq key (concat (substring key 0 p) "@" (substring key p)))) + (if (string-match "^ESC " key) + (setq key (concat "M-" (substring key 4)))) + (if (string-match "^M-C-" key) + (setq key (concat "C-M-" (substring key 4))))) + (Info-index key)) + (pop-to-buffer "*info*")))) + +;;;###autoload +(defun Info-elisp-ref (func) + "Look up an Emacs Lisp function in the Elisp manual in the Info system. +This command is designed to be used whether you are already in Info or not." + (interactive (let ((fn (function-at-point)) + (enable-recursive-minibuffers t) + val) + (setq val (completing-read + (format "Look up Emacs Lisp function%s: " + (if fn + (format " (default %s)" fn) + "")) + obarray 'fboundp t)) + (list (if (equal val "") + fn (intern val))))) + (save-window-excursion + (info) + (condition-case nil + (Info-find-node "lispref" "Top") + (error (Info-find-node "elisp" "Top"))) + (Info-index (symbol-name func))) + (pop-to-buffer "*info*")) + +(defun Info-reannotate-node () + (let ((bufs (delq nil (mapcar 'get-file-buffer Info-annotations-path)))) + (if bufs + (let ((ibuf (current-buffer)) + (file (concat "\\(" (regexp-quote + (file-name-nondirectory Info-current-file)) + "\\|" (regexp-quote Info-current-file) "\\)")) + (node (regexp-quote Info-current-node)) + (savept (point))) + (goto-char (point-min)) + (if (search-forward "\n------ NOTE:\n" nil t) + (let ((buffer-read-only nil) + (bufmod (buffer-modified-p)) + top) + (setq savept (copy-marker savept)) + (goto-char (point-min)) + (while (search-forward "\n------ NOTE:" nil t) + (setq top (1+ (match-beginning 0))) + (if (search-forward "\n------\n" nil t) + (delete-region top (point))) + (backward-char 1)) + (set-buffer-modified-p bufmod))) + (save-excursion + (while bufs + (set-buffer (car bufs)) + (goto-char (point-min)) + (while (re-search-forward + (format + "------ *File: *%s *Node: *%s *Line: *\\([0-9]+\\) *\n" + file node) + nil t) + (let ((line (string-to-int + (buffer-substring (match-beginning 2) + (match-end 2)))) + (top (point)) + bot) + (search-forward "\n------\n" nil t) + (setq bot (point)) + (save-excursion + (set-buffer ibuf) + (if (integerp savept) (setq savept (copy-marker savept))) + (if (= line 0) + (goto-char (point-max)) + (goto-char (point-min)) + (forward-line line)) + (let ((buffer-read-only nil) + (bufmod (buffer-modified-p))) + (insert "------ NOTE:\n") + (insert-buffer-substring (car bufs) top bot) + (set-buffer-modified-p bufmod))))) + (setq bufs (cdr bufs)))) + (goto-char savept))))) + +(defvar Info-annotate-map nil + "Local keymap used within `a' command of Info.") +(if Info-annotate-map + nil + ;; (setq Info-annotate-map (nconc (make-sparse-keymap) text-mode-map)) + (setq Info-annotate-map (copy-keymap text-mode-map)) + (define-key Info-annotate-map "\C-c\C-c" 'Info-cease-annotate)) + +(defun Info-annotate-mode () + "Major mode for adding an annotation to an Info node. +Like text mode with the addition of Info-cease-annotate +which returns to Info mode for browsing. +\\{Info-annotate-map}") + +(defun Info-annotate (arg) + "Add a personal annotation to the current Info node. + Only you will be able to see this annotation. Annotations are stored +in the file \"~/.xemacs/info.notes\" by default. If point is inside +an existing annotation, edit that annotation. A prefix argument +specifies which annotations file (from `Info-annotations-path') is to +be edited; default is 1." + (interactive "p") + (setq arg (1- arg)) + (if (or (< arg 0) (not (nth arg Info-annotations-path))) + (if (= arg 0) + (setq Info-annotations-path + (list (read-file-name + "Annotations file: " "~/" "~/.infonotes"))) + (error "File number must be in the range from 1 to %d" + (length Info-annotations-path)))) + (let ((which nil) + (file (file-name-nondirectory Info-current-file)) + (d Info-directory-list) + where pt) + (while (and d (not (equal (expand-file-name file (car d)) + Info-current-file))) + (setq d (cdr d))) + (or d (setq file Info-current-file)) + (if (and (save-excursion + (goto-char (min (point-max) (+ (point) 13))) + (and (search-backward "------ NOTE:\n" nil t) + (setq pt (match-end 0)) + (search-forward "\n------\n" nil t))) + (< (point) (match-end 0))) + (setq which (format "File: *%s *Node: *%s *Line:.*\n%s" + (regexp-quote file) + (regexp-quote Info-current-node) + (regexp-quote + (buffer-substring pt (match-beginning 0)))) + where (max (- (point) pt) 0))) + (let ((node Info-current-node) + (line (if (looking-at "[ \n]*\\'") 0 + (count-lines (point-min) (point))))) + (or which + (let ((buffer-read-only nil) + (bufmod (buffer-modified-p))) + (beginning-of-line) + (if (bobp) (goto-char (point-max))) + (insert "------ NOTE:\n------\n") + (backward-char 20) + (set-buffer-modified-p bufmod))) + ;; (setq Info-window-start (window-start)) + (setq Info-window-configuration (current-window-configuration)) + (pop-to-buffer (find-file-noselect (nth arg Info-annotations-path))) + (use-local-map Info-annotate-map) + (setq major-mode 'Info-annotate-mode) + (setq mode-name "Info Annotate") + (if which + (if (save-excursion + (goto-char (point-min)) + (re-search-forward which nil t)) + (progn + (goto-char (match-beginning 0)) + (forward-line 1) + (forward-char where))) + (let ((bufmod (buffer-modified-p))) + (goto-char (point-max)) + (insert (format "\n------ File: %s Node: %s Line: %d\n" + file node line)) + (setq pt (point)) + (insert "\n------\n" + "\nPress C-c C-c to save and return to Info.\n") + (goto-char pt) + (set-buffer-modified-p bufmod)))))) + +(defun Info-cease-annotate () + (interactive) + (let ((bufmod (buffer-modified-p))) + (while (save-excursion + (goto-char (point-min)) + (re-search-forward "\n\n?Press .* to save and return to Info.\n" + nil t)) + (delete-region (1+ (match-beginning 0)) (match-end 0))) + (while (save-excursion + (goto-char (point-min)) + (re-search-forward "\n------ File:.*Node:.*Line:.*\n+------\n" + nil t)) + (delete-region (match-beginning 0) (match-end 0))) + (set-buffer-modified-p bufmod)) + (save-buffer) + (fundamental-mode) + (bury-buffer) + (or (one-window-p) (delete-window)) + (info) + (setq Info-current-annotation-completions nil) + (set-window-configuration Info-window-configuration) + (Info-reannotate-node)) + +(defun Info-bookmark (arg tag) + (interactive "p\nsBookmark name: ") + (Info-annotate arg) + (if (or (string-match "^\"\\(.*\\)\"$" tag) + (string-match "^<<\\(.*\\)>>$" tag)) + (setq tag (substring tag (match-beginning 1) (match-end 1)))) + (let ((pt (point))) + (search-forward "\n------\n") + (let ((end (- (point) 8))) + (goto-char pt) + (if (re-search-forward "<<[^>\n]*>>" nil t) + (delete-region (match-beginning 0) (match-end 0)) + (goto-char end)) + (or (equal tag "") + (insert "<<" tag ">>")))) + (Info-cease-annotate)) + +(defun Info-exit () + "Exit Info by selecting some other buffer." + (interactive) + (if Info-standalone + (save-buffers-kill-emacs) + (bury-buffer (current-buffer)) + (if (and (featurep 'toolbar) + (eq toolbar-info-frame (selected-frame))) + (condition-case () + (delete-frame toolbar-info-frame) + (error (bury-buffer))) + (switch-to-buffer (other-buffer (current-buffer)))))) + +(defun Info-undefined () + "Make command be undefined in Info." + (interactive) + (ding)) + +(defun Info-help () + "Enter the Info tutorial." + (interactive) + (delete-other-windows) + (Info-find-node "info" + (if (< (window-height) 23) + "Help-Small-Screen" + "Help"))) + +(defun Info-summary () + "Display a brief summary of all Info commands." + (interactive) + (save-window-excursion + (switch-to-buffer "*Help*") + (erase-buffer) + (insert (documentation 'Info-mode)) + (goto-char (point-min)) + (let (flag) + (while (progn (setq flag (not (pos-visible-in-window-p (point-max)))) + (message (if flag "Type Space to see more" + "Type Space to return to Info")) + (let ((e (next-command-event))) + (if (/= ?\ (event-to-character e)) + (progn (setq unread-command-event e) nil) + flag))) + (scroll-up))) + (message "") + (bury-buffer "*Help*"))) + +(defun Info-get-token (pos start all &optional errorstring) + "Return the token around POS, +POS must be somewhere inside the token +START is a regular expression which will match the + beginning of the tokens delimited string +ALL is a regular expression with a single + parenthized subpattern which is the token to be + returned. E.g. '{\(.*\)}' would return any string + enclosed in braces around POS. +SIG optional fourth argument, controls action on no match + nil: return nil + t: beep + a string: signal an error, using that string." + (save-excursion + (goto-char (point-min)) + (re-search-backward "\\`") ; Bug fix due to Nicholas J. Foskett. + (goto-char pos) + (re-search-backward start (max (point-min) (- pos 200)) 'yes) + (let (found) + (while (and (re-search-forward all (min (point-max) (+ pos 200)) 'yes) + (not (setq found (and (<= (match-beginning 0) pos) + (> (match-end 0) pos)))))) + (if (and found (<= (match-beginning 0) pos) + (> (match-end 0) pos)) + (buffer-substring (match-beginning 1) (match-end 1)) + (cond ((null errorstring) + nil) + ((eq errorstring t) + (beep) + nil) + (t + (error "No %s around position %d" errorstring pos))))))) + +(defun Info-follow-clicked-node (event) + "Follow a node reference near clicked point. Like M, F, N, P or U command. +At end of the node's text, moves to the next node." + (interactive "@e") + (or (and (event-point event) + (Info-follow-nearest-node + (max (progn + (select-window (event-window event)) + (event-point event)) + (1+ (point-min))))) + (error "click on a cross-reference to follow"))) + +(defun Info-maybe-follow-clicked-node (event &optional click-count) + "Follow a node reference (if any) near clicked point. +Like M, F, N, P or U command. At end of the node's text, moves to the +next node. No error is given if there is no node to follow." + (interactive "@e") + (and Info-button1-follows-hyperlink + (event-point event) + (Info-follow-nearest-node + (max (progn + (select-window (event-window event)) + (event-point event)) + (1+ (point-min)))))) + +(defun Info-find-nearest-node (point) + (let (node) + (cond + ((= point (point-min)) nil) ; don't trigger on accidental RET. + ((setq node (Info-get-token point + (format "\\*%s[ \n]" Info-footnote-tag) + (format "\\*%s[ \n]\\([^:]*\\):" + Info-footnote-tag))) + (list "Following cross-reference %s..." + (list 'Info-follow-reference node))) + ((setq node (Info-get-token point "\\* " "\\* \\([^:]*\\)::")) + (list "Selecting menu item %s..." + (list 'Info-goto-node node nil t))) + ((setq node (Info-get-token point "\\* " "\\* \\([^:]*\\):")) + (list "Selecting menu item %s..." + (list 'Info-menu node))) + ((setq node (Info-get-token point "Up: " "Up: \\([^,\n\t]*\\)")) + (list "Going up..." + (list 'Info-goto-node node))) + ((setq node (Info-get-token point "Next: " "Next: \\([^,\n\t]*\\)")) + (list "Next node..." + (list 'Info-goto-node node))) + ((setq node (Info-get-token point "File: " "File: \\([^,\n\t]*\\)")) + (list "Top node..." + (list 'Info-goto-node "Top"))) + ((setq node (Info-get-token point "Prev[ious]*: " + "Prev[ious]*: \\([^,\n\t]*\\)")) + (list "Previous node..." + (list 'Info-goto-node node))) + ((setq node (Info-get-token point "Node: " "Node: \\([^,\n\t]*\\)")) + (list "Reselecting %s..." + (list 'Info-goto-node node))) + ((save-excursion (goto-char point) (looking-at "[ \n]*\\'")) + (if Info-in-cross-reference + (list "Back to last node..." + '(Info-last)) + (list "Next node..." + '(Info-global-next))))) + )) + +(defun Info-follow-nearest-node (point) + "Follow a node reference near point. Like M, F, N, P or U command. +At end of the node's text, moves to the next node." + (interactive "d") + (let ((data (Info-find-nearest-node point))) + (if (null data) + nil + (let ((msg (format (car data) (nth 1 (nth 1 data))))) + (message "%s" msg) + (eval (nth 1 data)) + (message "%sdone" msg)) + t))) + +(defun Info-indicated-node (event) + (condition-case () + (save-excursion + (cond ((eventp event) + (set-buffer (event-buffer event)) + (setq event (event-point event)))) + (let* ((data (Info-find-nearest-node event)) + (name (nth 1 (nth 1 data)))) + (and name (nth 1 data)))) + (error nil))) + +(defun Info-mouse-track-double-click-hook (event click-count) + "Handle double-clicks by turning pages, like the `gv' ghostscript viewer" + (if (/= click-count 2) + ;; Return nil so any other hooks are performed. + nil + (let* ((x (event-x-pixel event)) + (y (event-y-pixel event)) + (w (window-pixel-width (event-window event))) + (h (window-pixel-height (event-window event))) + (w/3 (/ w 3)) + (w/2 (/ w 2)) + (h/4 (/ h 4))) + (cond + ;; In the top 1/4 and inside the middle 1/3 + ((and (<= y h/4) + (and (>= x w/3) (<= x (+ w/3 w/3)))) + (Info-up) + t) + ;; In the bottom 1/4 and inside the middle 1/3 + ((and (>= y (+ h/4 h/4 h/4)) + (and (>= x w/3) (<= x (+ w/3 w/3)))) + (Info-nth-menu-item 1) + t) + ;; In the lower 3/4 and the right 1/2 + ;; OR in the upper 1/4 and the right 1/3 + ((or (and (>= y h/4) (>= x w/2)) + (and (< y h/4) (>= x (+ w/3 w/3)))) + (Info-next) + t) + ;; In the lower 3/4 and the left 1/2 + ;; OR in the upper 1/4 and the left 1/3 + ((or (and (>= y h/4) (< x w/2)) + (and (< y h/4) (<= x w/3))) + (Info-prev) + t) + ;; This shouldn't happen. + (t + (error "event out of bounds: %s %s" x y)))))) + +(defvar Info-mode-map nil + "Keymap containing Info commands.") +(if Info-mode-map + nil + (setq Info-mode-map (make-sparse-keymap)) + (suppress-keymap Info-mode-map) + (define-key Info-mode-map "." 'beginning-of-buffer) + (define-key Info-mode-map " " 'Info-scroll-next) + (define-key Info-mode-map "1" 'Info-nth-menu-item) + (define-key Info-mode-map "2" 'Info-nth-menu-item) + (define-key Info-mode-map "3" 'Info-nth-menu-item) + (define-key Info-mode-map "4" 'Info-nth-menu-item) + (define-key Info-mode-map "5" 'Info-nth-menu-item) + (define-key Info-mode-map "6" 'Info-nth-menu-item) + (define-key Info-mode-map "7" 'Info-nth-menu-item) + (define-key Info-mode-map "8" 'Info-nth-menu-item) + (define-key Info-mode-map "9" 'Info-nth-menu-item) + (define-key Info-mode-map "0" 'Info-last-menu-item) + (define-key Info-mode-map "?" 'Info-summary) + (define-key Info-mode-map "a" 'Info-annotate) + (define-key Info-mode-map "b" 'beginning-of-buffer) + (define-key Info-mode-map "d" 'Info-directory) + (define-key Info-mode-map "e" 'Info-edit) + (define-key Info-mode-map "f" 'Info-follow-reference) + (define-key Info-mode-map "g" 'Info-goto-node) + (define-key Info-mode-map "h" 'Info-help) + (define-key Info-mode-map "i" 'Info-index) + (define-key Info-mode-map "j" 'Info-goto-bookmark) + (define-key Info-mode-map "k" 'Info-emacs-key) + (define-key Info-mode-map "l" 'Info-last) + (define-key Info-mode-map "m" 'Info-menu) + (define-key Info-mode-map "n" 'Info-next) + (define-key Info-mode-map "p" 'Info-prev) + (define-key Info-mode-map "q" 'Info-exit) + (define-key Info-mode-map "r" 'Info-follow-reference) + (define-key Info-mode-map "s" 'Info-search) + (define-key Info-mode-map "t" 'Info-top) + (define-key Info-mode-map "u" 'Info-up) + (define-key Info-mode-map "v" 'Info-visit-file) + (define-key Info-mode-map "x" 'Info-bookmark) + (define-key Info-mode-map "<" 'Info-top) + (define-key Info-mode-map ">" 'Info-end) + (define-key Info-mode-map "[" 'Info-global-prev) + (define-key Info-mode-map "]" 'Info-global-next) + (define-key Info-mode-map "{" 'Info-page-prev) + (define-key Info-mode-map "}" 'Info-page-next) + (define-key Info-mode-map "=" 'Info-restore-point) + (define-key Info-mode-map "!" 'Info-select-node) + (define-key Info-mode-map "@" 'Info-follow-nearest-node) + (define-key Info-mode-map "," 'Info-index-next) + (define-key Info-mode-map "*" 'Info-elisp-ref) + (define-key Info-mode-map [tab] 'Info-next-reference) + (define-key Info-mode-map [(meta tab)] 'Info-prev-reference) + (define-key Info-mode-map [(shift tab)] 'Info-prev-reference) + (define-key Info-mode-map "\r" 'Info-follow-nearest-node) + ;; XEmacs addition + (define-key Info-mode-map 'backspace 'Info-scroll-prev) + (define-key Info-mode-map 'delete 'Info-scroll-prev) + (define-key Info-mode-map 'button2 'Info-follow-clicked-node) + (define-key Info-mode-map 'button3 'Info-select-node-menu)) + + +;; Info mode is suitable only for specially formatted data. +(put 'info-mode 'mode-class 'special) + +(defun Info-mode () + "Info mode is for browsing through the Info documentation tree. +Documentation in Info is divided into \"nodes\", each of which +discusses one topic and contains references to other nodes +which discuss related topics. Info has commands to follow +the references and show you other nodes. + +h Invoke the Info tutorial. +q Quit Info: return to the previously selected file or buffer. + +Selecting other nodes: +n Move to the \"next\" node of this node. +p Move to the \"previous\" node of this node. +m Pick menu item specified by name (or abbreviation). +1-9, 0 Pick first..ninth, last item in node's menu. + Menu items select nodes that are \"subsections\" of this node. +u Move \"up\" from this node (i.e., from a subsection to a section). +f or r Follow a cross reference by name (or abbrev). Type `l' to get back. +RET Follow cross reference or menu item indicated by cursor. +i Look up a topic in this file's Index and move to that node. +, (comma) Move to the next match from a previous `i' command. +l (letter L) Move back to the last node you were in. + +Moving within a node: +Space Scroll forward a full screen. DEL Scroll backward. +b Go to beginning of node. Meta-> Go to end of node. +TAB Go to next cross-reference. Meta-TAB Go to previous ref. + +Mouse commands: +Left Button Set point. +Middle Button Click on a highlighted node reference to go to it. +Right Button Pop up a menu of applicable Info commands. + +Advanced commands: +g Move to node, file, or annotation tag specified by name. + Examples: `g Rectangles' `g (Emacs)Rectangles' `g Emacs'. +v Move to file, with filename completion. +k Look up a key sequence in Emacs manual (also C-h C-k at any time). +* Look up a function name in Emacs Lisp manual (also C-h C-f). +d Go to the main directory of Info files. +< or t Go to Top (first) node of this file. +> Go to last node in this file. +\[ Go to previous node, treating file as one linear document. +\] Go to next node, treating file as one linear document. +{ Scroll backward, or go to previous node if at top. +} Scroll forward, or go to next node if at bottom. += Restore cursor position from last time in this node. +a Add a private note (annotation) to the current node. +x, j Add, jump to a bookmark (annotation tag). +s Search this Info file for a node containing the specified regexp. +e Edit the contents of the current node." + (kill-all-local-variables) + (setq major-mode 'Info-mode) + (setq mode-name "Info") + (use-local-map Info-mode-map) + (set-syntax-table text-mode-syntax-table) + (setq local-abbrev-table text-mode-abbrev-table) + (setq case-fold-search t) + (setq buffer-read-only t) +; (setq buffer-mouse-map Info-mode-mouse-map) + (make-local-variable 'Info-current-file) + (make-local-variable 'Info-current-subfile) + (make-local-variable 'Info-current-node) + (make-local-variable 'Info-tag-table-marker) + (make-local-variable 'Info-current-file-completions) + (make-local-variable 'Info-current-annotation-completions) + (make-local-variable 'Info-index-alternatives) + (make-local-variable 'Info-history) + ;; Faces are now defined by `defface'... + (make-local-variable 'mouse-track-click-hook) + (add-hook 'mouse-track-click-hook 'Info-maybe-follow-clicked-node) + (add-hook 'mouse-track-click-hook 'Info-mouse-track-double-click-hook) + ;; #### The console-on-window-system-p check is to allow this to + ;; work on tty's. The real problem here is that featurep really + ;; needs to have some device/console domain knowledge added to it. + (if (and (featurep 'toolbar) + (console-on-window-system-p) + (not Info-inhibit-toolbar)) + (set-specifier default-toolbar (cons (current-buffer) info::toolbar))) + (if (featurep 'menubar) + (progn + ;; make a local copy of the menubar, so our modes don't + ;; change the global menubar + (set-buffer-menubar current-menubar) + (add-submenu nil '("Info" + :filter Info-menu-filter)))) + (run-hooks 'Info-mode-hook) + (Info-set-mode-line)) + +(defvar Info-edit-map nil + "Local keymap used within `e' command of Info.") +(if Info-edit-map + nil + ;; XEmacs: remove FSF stuff + (setq Info-edit-map (make-sparse-keymap)) + (set-keymap-name Info-edit-map 'Info-edit-map) + (set-keymap-parents Info-edit-map (list text-mode-map)) + (define-key Info-edit-map "\C-c\C-c" 'Info-cease-edit)) + +;; Info-edit mode is suitable only for specially formatted data. +(put 'info-edit-mode 'mode-class 'special) + +(defun Info-edit-mode () + "Major mode for editing the contents of an Info node. +Like text mode with the addition of `Info-cease-edit' +which returns to Info mode for browsing. +\\{Info-edit-map}" + ) + +(defun Info-edit () + "Edit the contents of this Info node. +Allowed only if variable `Info-enable-edit' is non-nil." + (interactive) + (or Info-enable-edit + (error "Editing info nodes is not enabled")) + (use-local-map Info-edit-map) + (setq major-mode 'Info-edit-mode) + (setq mode-name "Info Edit") + (kill-local-variable 'modeline-buffer-identification) + (setq buffer-read-only nil) + ;; Make mode line update. + (set-buffer-modified-p (buffer-modified-p)) + (message (substitute-command-keys + "Editing: Type \\[Info-cease-edit] to return to info"))) + +(defun Info-cease-edit () + "Finish editing Info node; switch back to Info proper." + (interactive) + ;; Do this first, so nothing has changed if user C-g's at query. + (and (buffer-modified-p) + (y-or-n-p-maybe-dialog-box "Save the file? ") + (save-buffer)) + (use-local-map Info-mode-map) + (setq major-mode 'Info-mode) + (setq mode-name "Info") + (Info-set-mode-line) + (setq buffer-read-only t) + ;; Make mode line update. + (set-buffer-modified-p (buffer-modified-p)) + (and (marker-position Info-tag-table-marker) + (buffer-modified-p) + (message "Tags may have changed. Use Info-tagify if necessary"))) + +(defun Info-find-emacs-command-nodes (command) + "Return a list of locations documenting COMMAND in the XEmacs Info manual. +The locations are of the format used in Info-history, i.e. +\(FILENAME NODENAME BUFFERPOS\)." + (let ((where '()) + (cmd-desc (concat "^\\* " (regexp-quote (symbol-name command)) + ":\\s *\\(.*\\)\\.$"))) + (save-excursion + (Info-find-node "XEmacs" "Command Index") + ;; Take the index node off the Info history. + ;; ??? says this isn't safe someplace else... hmmm. + (setq Info-history (cdr Info-history)) + (goto-char (point-max)) + (while (re-search-backward cmd-desc nil t) + (setq where (cons (list Info-current-file + (buffer-substring + (match-beginning 1) + (match-end 1)) + 0) + where))) + where))) + +;;; fontification and mousability for info + +(defun Info-highlight-region (start end face) + (let ((extent nil) + (splitp (string-match "\n[ \t]+" (buffer-substring start end)))) + (if splitp + (save-excursion + (setq extent (make-extent start (progn (goto-char start) + (end-of-line) + (point)))) + (set-extent-face extent face) + (set-extent-property extent 'info t) + (set-extent-property extent 'highlight t) + (skip-chars-forward "\n\t ") + (setq extent (make-extent (point) end))) + (setq extent (make-extent start end))) + (set-extent-face extent face) + (set-extent-property extent 'info t) + (set-extent-property extent 'highlight t))) + +(defun Info-fontify-node () + (save-excursion + (let ((case-fold-search t) + (xref-regexp (concat "\\*" + (regexp-quote Info-footnote-tag) + "[ \n\t]*\\([^:]*\\):"))) + ;; Clear the old extents + (map-extents #'(lambda (x y) (delete-extent x)) + (current-buffer) (point-min) (point-max) nil) + ;; Break the top line iff it is > 79 characters. Some info nodes + ;; have top lines that span 3 lines because of long node titles. + ;; eg: (Info-find-node "lispref.info" "Window-Level Event Position Info") + (toggle-read-only -1) + (let ((extent nil) + (len 0) + (done nil) + (p (point-min))) + (goto-char (point-min)) + (re-search-forward "Node: *[^,]+, " nil t) + (setq len (- (point) (point-min)) + extent (make-extent (point-min) (point))) + (set-extent-property extent 'invisible t) + (while (not done) + (goto-char p) + (end-of-line) + (if (< (current-column) (+ 78 len)) + (setq done t) + (goto-char p) + (forward-char (+ 79 len)) + (re-search-backward "," nil t) + (forward-char 1) + (insert "\n") + (just-one-space) + (backward-delete-char 1) + (setq p (point) + len 0)))) + (toggle-read-only 1) + ;; Highlight xrefs in the top few lines of the node + (goto-char (point-min)) + (if (looking-at "^File: [^,: \t]+,?[ \t]+") + (progn + (goto-char (match-end 0)) + (while + (looking-at "[ \t]*[^:, \t\n]+:[ \t]+\\([^:,\t\n]+\\),?\n?") + (goto-char (match-end 0)) + (Info-highlight-region (match-beginning 1) (match-end 1) 'info-xref)))) + ;; Now get the xrefs in the body + (goto-char (point-min)) + (while (re-search-forward xref-regexp nil t) + (if (= (char-after (1- (match-beginning 0))) ?\") ; hack + nil + (Info-highlight-region (match-beginning 1) (match-end 1) 'info-xref))) + ;; then highlight the nodes in the menu. + (goto-char (point-min)) + (if (and (search-forward "\n* menu:" nil t)) + (while (re-search-forward + "^\\* \\([^:\t\n]*\\):?:[ \t\n]" nil t) + (Info-highlight-region (match-beginning 1) (match-end 1) 'info-node))) + (set-buffer-modified-p nil)))) + +(defun Info-construct-menu (&optional event) + "Construct a menu of Info commands. +Adds an entry for the node at EVENT, or under point if EVENT is omitted. +Used to construct the menubar submenu and popup menu." + (or event (setq event (point))) + (let ((case-fold-search t) + (xref-regexp (concat "\\*" + (regexp-quote Info-footnote-tag) + "[ \n\t]*\\([^:]*\\):")) + up-p prev-p next-p menu xrefs subnodes in) + (save-excursion + ;; `one-space' fixes "Notes:" xrefs that are split across lines. + (flet + ((one-space (text) + (let (i) + (while (setq i (string-match "[ \n\t]+" text i)) + (setq text (concat (substring text 0 i) " " + (substring text (match-end 0)))) + (setq i (1+ i))) + text))) + (goto-char (point-min)) + (if (looking-at ".*\\bNext:") (setq next-p t)) + (if (looking-at ".*\\bPrev:") (setq prev-p t)) + (if (looking-at ".*Up:") (setq up-p t)) + (setq menu (nconc + (if (setq in (Info-indicated-node event)) + (list (vector (one-space (cadr in)) in t) + "--:shadowEtchedIn")) + (list + ["Goto Info Top-level" Info-directory t] + (vector "Next Node" 'Info-next next-p) + (vector "Previous Node" 'Info-prev prev-p) + (vector "Parent Node (Up)" 'Info-up up-p) + ["Goto Node..." Info-goto-node t] + ["Goto Last Visited Node " Info-last t]))) + ;; Find the xrefs and make a list + (while (re-search-forward xref-regexp nil t) + (setq xrefs (cons (one-space (buffer-substring (match-beginning 1) + (match-end 1))) + xrefs)))) + (setq xrefs (nreverse xrefs)) + (if (> (length xrefs) 21) (setcdr (nthcdr 20 xrefs) '(more))) + ;; Find the subnodes and make a list + (goto-char (point-min)) + (if (search-forward "\n* menu:" nil t) + (while (re-search-forward "^\\* \\([^:\t\n]*\\):" nil t) + (setq subnodes (cons (buffer-substring (match-beginning 1) + (match-end 1)) + subnodes)))) + (setq subnodes (nreverse subnodes)) + (if (> (length subnodes) 21) (setcdr (nthcdr 20 subnodes) '(more)))) + (if xrefs + (nconc menu (list "--:shadowDoubleEtchedIn" + " Cross-References" + "--:singleLine") + (mapcar #'(lambda (xref) + (if (eq xref 'more) + "...more..." + (vector xref + (list 'Info-follow-reference xref) + t))) + xrefs))) + (if subnodes + (nconc menu (list "--:shadowDoubleEtchedIn" + " Sub-Nodes" + "--:singleLine") + (mapcar #'(lambda (node) + (if (eq node 'more) + "...more..." + (vector node (list 'Info-menu node) + t))) + subnodes))) + menu)) + +(defun Info-menu-filter (menu) + "This is the menu filter for the \"Info\" submenu." + (Info-construct-menu)) + +(defun Info-select-node-menu (event) + "Pops up a menu of applicable Info commands." + (interactive "e") + (select-window (event-window event)) + (let ((menu (Info-construct-menu event))) + (setq menu (nconc (list "Info" ; title: not displayed + " Info Commands" + "--:shadowDoubleEtchedOut") + menu)) + (let ((popup-menu-titles nil)) + (popup-menu menu)))) + +;;; Info toolbar support + +;; exit icon taken from GNUS +(defvar info::toolbar-exit-icon + (if (featurep 'toolbar) + (toolbar-make-button-list + (expand-file-name (if (featurep 'xpm) "info-exit.xpm" "info-exit.xbm") + toolbar-icon-directory))) + "Exit Info icon") + +(defvar info::toolbar-up-icon + (if (featurep 'toolbar) + (toolbar-make-button-list + (expand-file-name (if (featurep 'xpm) "info-up.xpm" "info-up.xbm") + toolbar-icon-directory))) + "Up icon") + +(defvar info::toolbar-next-icon + (if (featurep 'toolbar) + (toolbar-make-button-list + (expand-file-name (if (featurep 'xpm) "info-next.xpm" "info-next.xbm") + toolbar-icon-directory))) + "Next icon") + +(defvar info::toolbar-prev-icon + (if (featurep 'toolbar) + (toolbar-make-button-list + (expand-file-name (if (featurep 'xpm) "info-prev.xpm" "info-prev.xbm") + toolbar-icon-directory))) + "Prev icon") + +(defvar info::toolbar + (if (featurep 'toolbar) +; disabled until we get the next/prev-win icons working again. +; (cons (first initial-toolbar-spec) +; (cons (second initial-toolbar-spec) + '([info::toolbar-exit-icon + Info-exit + t + "Exit info"] + [info::toolbar-next-icon + Info-next + t + "Next entry in same section"] + [info::toolbar-prev-icon + Info-prev + t + "Prev entry in same section"] + [info::toolbar-up-icon + Info-up + t + "Up entry to enclosing section"] + ))) +;)) + +(provide 'info) + +(run-hooks 'Info-load-hook) + +;;; info.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/make-docfile.el --- a/lisp/make-docfile.el Mon Aug 13 10:07:42 2007 +0200 +++ b/lisp/make-docfile.el Mon Aug 13 10:08:34 2007 +0200 @@ -103,7 +103,7 @@ ;; (load "featurep") (let (preloaded-file-list) - (load (concat default-directory "../lisp/prim/dumped-lisp.el")) + (load (concat default-directory "../lisp/dumped-lisp.el")) (setq preloaded-file-list (append preloaded-file-list packages-hardcoded-lisp)) (while preloaded-file-list diff -r 43306a74e31c -r d44af0c54775 lisp/minibuf.el --- a/lisp/minibuf.el Mon Aug 13 10:07:42 2007 +0200 +++ b/lisp/minibuf.el Mon Aug 13 10:08:34 2007 +0200 @@ -209,13 +209,21 @@ (eq ?/ (char-before (point))) (not (save-excursion (goto-char (point-min)) - (and (looking-at "^/.+:~?") + (and (looking-at "^/.+:~?[^/]*/.+") (re-search-forward "^/.+:~?[^/]*" nil t) (progn (delete-region (point) (point-max)) t)))) + (not (save-excursion + (goto-char (point-min)) + (and (looking-at "^.+://[^/]*/.+") + (re-search-forward "^.+:/" nil t) + (progn + (delete-region (point) (point-max)) + t)))) (not (eq (point) (1+ (point-min)))) ; permit `//hostname/path/to/file' - (not (eq ?: (char-after (- (point) 2)))) ; permit `http://url/goes/here' + (or (not (eq ?: (char-after (- (point) 2)))) ; permit `http://url/goes/here' + (eq ?/ (char-after (point-min)))) (delete-region (point-min) (point))) (insert ?/)) diff -r 43306a74e31c -r d44af0c54775 lisp/modes/auto-autoloads.el --- a/lisp/modes/auto-autoloads.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1524 +0,0 @@ -;;; DO NOT MODIFY THIS FILE -(if (featurep 'modes-autoloads) (error "Already loaded")) - -;;;### (autoloads (autoconf-mode) "autoconf-mode" "modes/autoconf-mode.el") - -(autoload 'autoconf-mode "autoconf-mode" "\ -A major-mode to edit autoconf input files like configure.in -\\{autoconf-mode-map} -" t nil) - -;;;*** - -;;;### (autoloads (awk-mode) "awk-mode" "modes/awk-mode.el") - -(autoload 'awk-mode "awk-mode" "\ -Major mode for editing AWK code. -This is much like C mode except for the syntax of comments. It uses -the same keymap as C mode and has the same variables for customizing -indentation. It has its own abbrev table and its own syntax table. - -Turning on AWK mode calls the value of the variable `awk-mode-hook' -with no args, if that value is non-nil." t nil) - -;;;*** - -;;;### (autoloads (bibtex-mode) "bibtex" "modes/bibtex.el") - -(autoload 'bibtex-mode "bibtex" "\ -Major mode for editing bibtex files. - -\\{bibtex-mode-map} - -A command such as \\[bibtex-Book] will outline the fields for a BibTeX book entry. - -The optional fields start with the string OPT, and thus ignored by BibTeX. -The OPT string may be removed from a field with \\[bibtex-remove-OPT]. -\\[bibtex-kill-optional-field] kills the current optional field entirely. -\\[bibtex-remove-double-quotes] removes the double-quotes around the text of -the current field. \\[bibtex-empty-field] replaces the text of the current -field with the default \"\". - -The command \\[bibtex-clean-entry] cleans the current entry, i.e. (i) removes -double-quotes from entirely numerical fields, (ii) removes OPT from all -non-empty optional fields, (iii) removes all empty optional fields, and (iv) -checks that no non-optional fields are empty. - -Use \\[bibtex-find-text] to position the dot at the end of the current field. -Use \\[bibtex-next-field] to move to end of the next field. - -The following may be of interest as well: - - Functions: - find-bibtex-duplicates - find-bibtex-entry-location - hide-bibtex-entry-bodies - sort-bibtex-entries - validate-bibtex-buffer - - Variables: - bibtex-clean-entry-zap-empty-opts - bibtex-entry-field-alist - bibtex-include-OPTannote - bibtex-include-OPTcrossref - bibtex-include-OPTkey - bibtex-maintain-sorted-entries - bibtex-mode-user-optional-fields - -Fields: - address - Publisher's address - annote - Long annotation used for annotated bibliographies (begins sentence) - author - Name(s) of author(s), in BibTeX name format - booktitle - Book title when the thing being referenced isn't the whole book. - For book entries, the title field should be used instead. - chapter - Chapter number - crossref - The database key of the entry being cross referenced. - edition - Edition of a book (e.g., \"second\") - editor - Name(s) of editor(s), in BibTeX name format. - If there is also an author field, then the editor field should be - for the book or collection that the work appears in - howpublished - How something strange has been published (begins sentence) - institution - Sponsoring institution - journal - Journal name (macros are provided for many) - key - Alphabetizing and labeling key (needed when no author or editor) - month - Month (macros are provided) - note - To help the reader find a reference (begins sentence) - number - Number of a journal or technical report - organization - Organization (sponsoring a conference) - pages - Page number or numbers (use `--' to separate a range) - publisher - Publisher name - school - School name (for theses) - series - The name of a series or set of books. - An individual book will also have its own title - title - The title of the thing being referenced - type - Type of a technical report (e.g., \"Research Note\") to be used - instead of the default \"Technical Report\" - volume - Volume of a journal or multivolume work - year - Year---should contain only numerals ---------------------------------------------------------- -Entry to this mode calls the value of bibtex-mode-hook if that value is -non-nil." t nil) - -;;;*** - -;;;### (autoloads (c-comment-edit) "c-comment" "modes/c-comment.el") - -(autoload 'c-comment-edit "c-comment" "\ -Edit multi-line C comments. -This command allows the easy editing of a multi-line C comment like this: - /* - * ... - * ... - */ -The comment may be indented or flush with the left margin. - -If point is within a comment, that comment is used. Otherwise the -comment to be edited is found by searching forward from point. - -With one \\[universal-argument] searching starts after moving back one - paragraph. -With two \\[universal-argument]'s searching starts at the beginning of the - current or proceeding C function. -With three \\[universal-argument]'s searching starts at the beginning of the - current page. -With four \\[universal-argument]'s searching starts at the beginning of the - current buffer (clipping restrictions apply). - -Once located, the comment is copied into a temporary buffer, the comment -leaders and delimiters are stripped away and the resulting buffer is -selected for editing. The major mode of this buffer is controlled by -the variable `c-comment-edit-mode'.\\ - -Use \\[c-comment-edit-end] when you have finished editing the comment. The -comment will be inserted into the original buffer with the appropriate -delimiters and indention, replacing the old version of the comment. If -you don't want your edited version of the comment to replace the -original, use \\[c-comment-edit-abort]." t nil) - -;;;*** - -;;;### (autoloads (common-lisp-indent-function) "cl-indent" "modes/cl-indent.el") - -(autoload 'common-lisp-indent-function "cl-indent" nil nil nil) - -;;;*** - -;;;### (autoloads (c-macro-expand) "cmacexp" "modes/cmacexp.el") - -(autoload 'c-macro-expand "cmacexp" "\ -Expand C macros in the region, using the C preprocessor. -Normally display output in temp buffer, but -prefix arg means replace the region with it. - -`c-macro-preprocessor' specifies the preprocessor to use. -Prompt for arguments to the preprocessor (e.g. `-DDEBUG -I ./include') -if the user option `c-macro-prompt-flag' is non-nil. - -Noninteractive args are START, END, SUBST. -For use inside Lisp programs, see also `c-macro-expansion'." t nil) - -;;;*** - -;;;### (autoloads (cperl-mode) "cperl-mode" "modes/cperl-mode.el") - -(defalias 'perl-mode 'cperl-mode) - -(autoload 'cperl-mode "cperl-mode" "\ -Major mode for editing Perl code. -Expression and list commands understand all C brackets. -Tab indents for Perl code. -Paragraphs are separated by blank lines only. -Delete converts tabs to spaces as it moves back. - -Various characters in Perl almost always come in pairs: {}, (), [], -sometimes <>. When the user types the first, she gets the second as -well, with optional special formatting done on {}. (Disabled by -default.) You can always quote (with \\[quoted-insert]) the left -\"paren\" to avoid the expansion. The processing of < is special, -since most the time you mean \"less\". Cperl mode tries to guess -whether you want to type pair <>, and inserts is if it -appropriate. You can set `cperl-electric-parens-string' to the string that -contains the parenths from the above list you want to be electrical. -Electricity of parenths is controlled by `cperl-electric-parens'. -You may also set `cperl-electric-parens-mark' to have electric parens -look for active mark and \"embrace\" a region if possible.' - -CPerl mode provides expansion of the Perl control constructs: - if, else, elsif, unless, while, until, for, and foreach. -=========(Disabled by default, see `cperl-electric-keywords'.) -The user types the keyword immediately followed by a space, which causes -the construct to be expanded, and the user is positioned where she is most -likely to want to be. -eg. when the user types a space following \"if\" the following appears in -the buffer: - if () { or if () - } { - } -and the cursor is between the parentheses. The user can then type some -boolean expression within the parens. Having done that, typing -\\[cperl-linefeed] places you, appropriately indented on a new line -between the braces. If CPerl decides that you want to insert -\"English\" style construct like - bite if angry; -it will not do any expansion. See also help on variable -`cperl-extra-newline-before-brace'. - -\\[cperl-linefeed] is a convenience replacement for typing carriage -return. It places you in the next line with proper indentation, or if -you type it inside the inline block of control construct, like - foreach (@lines) {print; print} -and you are on a boundary of a statement inside braces, it will -transform the construct into a multiline and will place you into an -appropriately indented blank line. If you need a usual -`newline-and-indent' behaviour, it is on \\[newline-and-indent], -see documentation on `cperl-electric-linefeed'. - -\\{cperl-mode-map} - -Setting the variable `cperl-font-lock' to t switches on -font-lock-mode, `cperl-electric-lbrace-space' to t switches on -electric space between $ and {, `cperl-electric-parens-string' is the -string that contains parentheses that should be electric in CPerl (see -also `cperl-electric-parens-mark' and `cperl-electric-parens'), -setting `cperl-electric-keywords' enables electric expansion of -control structures in CPerl. `cperl-electric-linefeed' governs which -one of two linefeed behavior is preferable. You can enable all these -options simultaneously (recommended mode of use) by setting -`cperl-hairy' to t. In this case you can switch separate options off -by setting them to `null'. Note that one may undo the extra whitespace -inserted by semis and braces in `auto-newline'-mode by consequent -\\[cperl-electric-backspace]. - -If your site has perl5 documentation in info format, you can use commands -\\[cperl-info-on-current-command] and \\[cperl-info-on-command] to access it. -These keys run commands `cperl-info-on-current-command' and -`cperl-info-on-command', which one is which is controlled by variable -`cperl-info-on-command-no-prompt' (in turn affected by `cperl-hairy'). - -Even if you have no info-format documentation, short one-liner-style -help is available on \\[cperl-get-help]. - -It is possible to show this help automatically after some idle -time. This is regulated by variable `cperl-lazy-help-time'. Default -with `cperl-hairy' is 5 secs idle time if the value of this variable -is nil. It is also possible to switch this on/off from the -menu. Requires `run-with-idle-timer'. - -Use \\[cperl-lineup] to vertically lineup some construction - put the -beginning of the region at the start of construction, and make region -span the needed amount of lines. - -Variables `cperl-pod-here-scan', `cperl-pod-here-fontify', -`cperl-pod-face', `cperl-pod-head-face' control processing of pod and -here-docs sections. In a future version results of scan may be used -for indentation too, currently they are used for highlighting only. - -Variables controlling indentation style: - `cperl-tab-always-indent' - Non-nil means TAB in CPerl mode should always reindent the current line, - regardless of where in the line point is when the TAB command is used. - `cperl-auto-newline' - Non-nil means automatically newline before and after braces, - and after colons and semicolons, inserted in Perl code. The following - \\[cperl-electric-backspace] will remove the inserted whitespace. - Insertion after colons requires both this variable and - `cperl-auto-newline-after-colon' set. - `cperl-auto-newline-after-colon' - Non-nil means automatically newline even after colons. - Subject to `cperl-auto-newline' setting. - `cperl-indent-level' - Indentation of Perl statements within surrounding block. - The surrounding block's indentation is the indentation - of the line on which the open-brace appears. - `cperl-continued-statement-offset' - Extra indentation given to a substatement, such as the - then-clause of an if, or body of a while, or just a statement continuation. - `cperl-continued-brace-offset' - Extra indentation given to a brace that starts a substatement. - This is in addition to `cperl-continued-statement-offset'. - `cperl-brace-offset' - Extra indentation for line if it starts with an open brace. - `cperl-brace-imaginary-offset' - An open brace following other text is treated as if it the line started - this far to the right of the actual line indentation. - `cperl-label-offset' - Extra indentation for line that is a label. - `cperl-min-label-indent' - Minimal indentation for line that is a label. - -Settings for K&R and BSD indentation styles are - `cperl-indent-level' 5 8 - `cperl-continued-statement-offset' 5 8 - `cperl-brace-offset' -5 -8 - `cperl-label-offset' -5 -8 - -If `cperl-indent-level' is 0, the statement after opening brace in column 0 is indented on `cperl-brace-offset'+`cperl-continued-statement-offset'. - -Turning on CPerl mode calls the hooks in the variable `cperl-mode-hook' -with no args." t nil) - -;;;*** - -;;;### (autoloads (eiffel-mode) "eiffel3" "modes/eiffel3.el") - -(autoload 'eiffel-mode "eiffel3" "\ -Major mode for editing Eiffel programs." t nil) - -;;;*** - -;;;### (autoloads (enriched-decode enriched-encode enriched-mode) "enriched" "modes/enriched.el") - -(autoload 'enriched-mode "enriched" "\ -Minor mode for editing text/enriched files. -These are files with embedded formatting information in the MIME standard -text/enriched format. -Turning the mode on runs `enriched-mode-hook'. - -More information about Enriched mode is available in the file -etc/enriched.doc in the Emacs distribution directory. - -Commands: - -\\\\{enriched-mode-map}" t nil) - -(autoload 'enriched-encode "enriched" nil nil nil) - -(autoload 'enriched-decode "enriched" nil nil nil) - -;;;*** - -;;;### (autoloads (executable-self-display executable-set-magic) "executable" "modes/executable.el") - -(autoload 'executable-set-magic "executable" "\ -Set this buffer's interpreter to INTERPRETER with optional ARGUMENT. -The variables `executable-magicless-file-regexp', `executable-prefix', -`executable-insert', `executable-query' and `executable-chmod' control -when and how magic numbers are inserted or replaced and scripts made -executable." t nil) - -(autoload 'executable-self-display "executable" "\ -Turn a text file into a self-displaying Un*x command. -The magic number of such a command displays all lines but itself." t nil) - -;;;*** - -;;;### (autoloads (hide-ifdef-mode) "hideif" "modes/hideif.el") - -(add-minor-mode 'hide-ifdef-mode " Ifdef" 'hide-ifdef-mode-map) - -(autoload 'hide-ifdef-mode "hideif" "\ -Toggle Hide-Ifdef mode. This is a minor mode, albeit a large one. -With ARG, turn Hide-Ifdef mode on if arg is positive, off otherwise. -In Hide-Ifdef mode, code within #ifdef constructs that the C preprocessor -would eliminate may be hidden from view. Several variables affect -how the hiding is done: - -hide-ifdef-env - An association list of defined and undefined symbols for the - current buffer. Initially, the global value of `hide-ifdef-env' - is used. - -hide-ifdef-define-alist - An association list of defined symbol lists. - Use `hide-ifdef-set-define-alist' to save the current `hide-ifdef-env' - and `hide-ifdef-use-define-alist' to set the current `hide-ifdef-env' - from one of the lists in `hide-ifdef-define-alist'. - -hide-ifdef-lines - Set to non-nil to not show #if, #ifdef, #ifndef, #else, and - #endif lines when hiding. - -hide-ifdef-initially - Indicates whether `hide-ifdefs' should be called when Hide-Ifdef mode - is activated. - -hide-ifdef-read-only - Set to non-nil if you want to make buffers read only while hiding. - After `show-ifdefs', read-only status is restored to previous value. - -\\{hide-ifdef-mode-map}" t nil) - -(defvar hide-ifdef-initially nil "\ -*Non-nil means call `hide-ifdefs' when Hide-Ifdef mode is first activated.") - -(defvar hide-ifdef-read-only nil "\ -*Set to non-nil if you want buffer to be read-only while hiding text.") - -(defvar hide-ifdef-lines nil "\ -*Non-nil means hide the #ifX, #else, and #endif lines.") - -;;;*** - -;;;### (autoloads (hs-minor-mode hs-hide-block hs-hide-all) "hideshow" "modes/hideshow.el") - -(defcustom hs-minor-mode nil "Non-nil if using hideshow mode as a minor mode of some other mode.\nUse the command `hs-minor-mode' to toggle this variable." :type 'boolean :set (lambda (symbol value) (hs-minor-mode (or value 0))) :initialize 'custom-initialize-default :require 'hideshow :group 'hideshow) - -(autoload 'hs-hide-all "hideshow" "\ -Hides all top-level blocks, displaying only first and last lines. -It moves point to the beginning of the line, and it runs the normal hook -`hs-hide-hook'. See documentation for `run-hooks'." t nil) - -(autoload 'hs-hide-block "hideshow" "\ -Selects a block and hides it. With prefix arg, reposition at end. -Block is defined as a sexp for lispish modes, mode-specific otherwise. -Comments are blocks, too. Upon completion, point is at repositioned and -the normal hook `hs-hide-hook' is run. See documentation for `run-hooks'." t nil) - -(autoload 'hs-minor-mode "hideshow" "\ -Toggle hideshow minor mode. -With ARG, turn hideshow minor mode on if ARG is positive, off otherwise. -When hideshow minor mode is on, the menu bar is augmented with hideshow -commands and the hideshow commands are enabled. The variables -`selective-display' and `selective-display-ellipses' are set to t. -Last, the normal hook `hs-minor-mode-hook' is run; see the doc for `run-hooks'. - -Turning hideshow minor mode off reverts the menu bar and the -variables to default values and disables the hideshow commands." t nil) - -;;;*** - -;;;### (autoloads (icon-mode) "icon" "modes/icon.el") - -(autoload 'icon-mode "icon" "\ -Major mode for editing Icon code. -Expression and list commands understand all Icon brackets. -Tab indents for Icon code. -Paragraphs are separated by blank lines only. -Delete converts tabs to spaces as it moves back. -\\{icon-mode-map} -Variables controlling indentation style: - icon-tab-always-indent - Non-nil means TAB in Icon mode should always reindent the current line, - regardless of where in the line point is when the TAB command is used. - icon-auto-newline - Non-nil means automatically newline before and after braces - inserted in Icon code. - icon-indent-level - Indentation of Icon statements within surrounding block. - The surrounding block's indentation is the indentation - of the line on which the open-brace appears. - icon-continued-statement-offset - Extra indentation given to a substatement, such as the - then-clause of an if or body of a while. - icon-continued-brace-offset - Extra indentation given to a brace that starts a substatement. - This is in addition to `icon-continued-statement-offset'. - icon-brace-offset - Extra indentation for line if it starts with an open brace. - icon-brace-imaginary-offset - An open brace following other text is treated as if it were - this far to the right of the start of its line. - -Turning on Icon mode calls the value of the variable `icon-mode-hook' -with no args, if that value is non-nil." t nil) - -;;;*** - -;;;### (autoloads (image-decode-xpm image-decode-png image-decode-gif image-decode-jpeg image-mode) "image-mode" "modes/image-mode.el") - -(autoload 'image-mode "image-mode" "\ -\\{image-mode-map}" t nil) - -(autoload 'image-decode-jpeg "image-mode" "\ -Decode JPEG image between START and END." nil nil) - -(autoload 'image-decode-gif "image-mode" "\ -Decode GIF image between START and END." nil nil) - -(autoload 'image-decode-png "image-mode" "\ -Decode PNG image between START and END." nil nil) - -(autoload 'image-decode-xpm "image-mode" "\ -Decode XPM image between START and END." nil nil) - -;;;*** - -;;;### (autoloads (turn-on-lazy-shot lazy-shot-mode) "lazy-shot" "modes/lazy-shot.el") - -(autoload 'lazy-shot-mode "lazy-shot" "\ -Toggle Lazy Lock mode. -With arg, turn Lazy Lock mode on if and only if arg is positive." t nil) - -(autoload 'turn-on-lazy-shot "lazy-shot" "\ -Unconditionally turn on Lazy Lock mode." nil nil) - -;;;*** - -;;;### (autoloads (linuxdoc-sgml-mode) "linuxdoc-sgml" "modes/linuxdoc-sgml.el") - -(autoload 'linuxdoc-sgml-mode "linuxdoc-sgml" "\ -Major mode based on SGML mode for editing linuxdoc-sgml documents. -See the documentation on sgml-mode for more info. This mode -understands the linuxdoc-sgml tags." t nil) - -;;;*** - -;;;### (autoloads (define-mail-alias build-mail-aliases mail-aliases-setup) "mail-abbrevs" "modes/mail-abbrevs.el") - -(defcustom mail-abbrev-mailrc-file nil "Name of file with mail aliases. If nil, ~/.mailrc is used." :type '(choice (const :tag "Default" nil) file) :group 'mail-abbrevs) - -(defvar mail-aliases nil "\ -Word-abbrev table of mail address aliases. -If this is nil, it means the aliases have not yet been initialized and -should be read from the .mailrc file. (This is distinct from there being -no aliases, which is represented by this being a table with no entries.)") - -(autoload 'mail-aliases-setup "mail-abbrevs" nil nil nil) - -(autoload 'build-mail-aliases "mail-abbrevs" "\ -Read mail aliases from .mailrc and set mail-aliases." nil nil) - -(autoload 'define-mail-alias "mail-abbrevs" "\ -Define NAME as a mail-alias that translates to DEFINITION. -If DEFINITION contains multiple addresses, separate them with commas." t nil) - -;;;*** - -;;;### (autoloads (makefile-mode) "make-mode" "modes/make-mode.el") - -(autoload 'makefile-mode "make-mode" "\ -Major mode for editing Makefiles. -This function ends by invoking the function(s) `makefile-mode-hook'. - -\\{makefile-mode-map} - -In the browser, use the following keys: - -\\{makefile-browser-map} - -Makefile mode can be configured by modifying the following variables: - -makefile-browser-buffer-name: - Name of the macro- and target browser buffer. - -makefile-target-colon: - The string that gets appended to all target names - inserted by `makefile-insert-target'. - \":\" or \"::\" are quite common values. - -makefile-macro-assign: - The string that gets appended to all macro names - inserted by `makefile-insert-macro'. - The normal value should be \" = \", since this is what - standard make expects. However, newer makes such as dmake - allow a larger variety of different macro assignments, so you - might prefer to use \" += \" or \" := \" . - -makefile-tab-after-target-colon: - If you want a TAB (instead of a space) to be appended after the - target colon, then set this to a non-nil value. - -makefile-browser-leftmost-column: - Number of blanks to the left of the browser selection mark. - -makefile-browser-cursor-column: - Column in which the cursor is positioned when it moves - up or down in the browser. - -makefile-browser-selected-mark: - String used to mark selected entries in the browser. - -makefile-browser-unselected-mark: - String used to mark unselected entries in the browser. - -makefile-browser-auto-advance-after-selection-p: - If this variable is set to a non-nil value the cursor - will automagically advance to the next line after an item - has been selected in the browser. - -makefile-pickup-everything-picks-up-filenames-p: - If this variable is set to a non-nil value then - `makefile-pickup-everything' also picks up filenames as targets - (i.e. it calls `makefile-find-filenames-as-targets'), otherwise - filenames are omitted. - -makefile-cleanup-continuations-p: - If this variable is set to a non-nil value then makefile-mode - will assure that no line in the file ends with a backslash - (the continuation character) followed by any whitespace. - This is done by silently removing the trailing whitespace, leaving - the backslash itself intact. - IMPORTANT: Please note that enabling this option causes makefile-mode - to MODIFY A FILE WITHOUT YOUR CONFIRMATION when \"it seems necessary\". - -makefile-browser-hook: - A function or list of functions to be called just before the - browser is entered. This is executed in the makefile buffer. - -makefile-special-targets-list: - List of special targets. You will be offered to complete - on one of those in the minibuffer whenever you enter a `.'. - at the beginning of a line in Makefile mode." t nil) - -;;;*** - -;;;### (autoloads (modula-2-mode) "modula2" "modes/modula2.el") - -(autoload 'modula-2-mode "modula2" "\ -This is a mode intended to support program development in Modula-2. -All control constructs of Modula-2 can be reached by typing C-c -followed by the first character of the construct. -\\ - \\[m2-begin] begin \\[m2-case] case - \\[m2-definition] definition \\[m2-else] else - \\[m2-for] for \\[m2-header] header - \\[m2-if] if \\[m2-module] module - \\[m2-loop] loop \\[m2-or] or - \\[m2-procedure] procedure Control-c Control-w with - \\[m2-record] record \\[m2-stdio] stdio - \\[m2-type] type \\[m2-until] until - \\[m2-var] var \\[m2-while] while - \\[m2-export] export \\[m2-import] import - \\[m2-begin-comment] begin-comment \\[m2-end-comment] end-comment - \\[suspend-emacs] suspend Emacs \\[m2-toggle] toggle - \\[m2-compile] compile \\[m2-next-error] next-error - \\[m2-link] link - - `m2-indent' controls the number of spaces for each indentation. - `m2-compile-command' holds the command to compile a Modula-2 program. - `m2-link-command' holds the command to link a Modula-2 program." t nil) - -;;;*** - -;;;### (autoloads (electric-nroff-mode nroff-mode) "nroff-mode" "modes/nroff-mode.el") - -(autoload 'nroff-mode "nroff-mode" "\ -Major mode for editing text intended for nroff to format. -\\{nroff-mode-map} -Turning on Nroff mode runs `text-mode-hook', then `nroff-mode-hook'. -Also, try `nroff-electric-mode', for automatically inserting -closing requests for requests that are used in matched pairs." t nil) - -(autoload 'electric-nroff-mode "nroff-mode" "\ -Toggle `nroff-electric-newline' minor mode. -`nroff-electric-newline' forces Emacs to check for an nroff request at the -beginning of the line, and insert the matching closing request if necessary. -This command toggles that mode (off->on, on->off), with an argument, -turns it on iff arg is positive, otherwise off." t nil) - -(defvar nroff-electric-mode nil "\ -Non-nil if in electric-nroff minor mode.") - -(add-minor-mode 'nroff-electric-mode " Electric" nil nil 'electric-nroff-mode) - -;;;*** - -;;;### (autoloads (outl-mouse-minor-mode outl-mouse-mode) "outl-mouse" "modes/outl-mouse.el") - -(autoload 'outl-mouse-mode "outl-mouse" "\ -Calls outline-mode, with outl-mouse extensions" t nil) - -(autoload 'outl-mouse-minor-mode "outl-mouse" "\ -Toggles outline-minor-mode, with outl-mouse extensions" t nil) - -;;;*** - -;;;### (autoloads (outline-minor-mode outline-mode) "outline" "modes/outline.el") - -(defvar outline-minor-mode nil "\ -Non-nil if using Outline mode as a minor mode of some other mode.") - -(make-variable-buffer-local 'outline-minor-mode) - -(put 'outline-minor-mode 'permanent-local t) - -(add-minor-mode 'outline-minor-mode " Outl") - -(autoload 'outline-mode "outline" "\ -Set major mode for editing outlines with selective display. -Headings are lines which start with asterisks: one for major headings, -two for subheadings, etc. Lines not starting with asterisks are body lines. - -Body text or subheadings under a heading can be made temporarily -invisible, or visible again. Invisible lines are attached to the end -of the heading, so they move with it, if the line is killed and yanked -back. A heading with text hidden under it is marked with an ellipsis (...). - -Commands:\\ -\\[outline-next-visible-heading] outline-next-visible-heading move by visible headings -\\[outline-previous-visible-heading] outline-previous-visible-heading -\\[outline-forward-same-level] outline-forward-same-level similar but skip subheadings -\\[outline-backward-same-level] outline-backward-same-level -\\[outline-up-heading] outline-up-heading move from subheading to heading - -\\[hide-body] make all text invisible (not headings). -\\[show-all] make everything in buffer visible. - -The remaining commands are used when point is on a heading line. -They apply to some of the body or subheadings of that heading. -\\[hide-subtree] hide-subtree make body and subheadings invisible. -\\[show-subtree] show-subtree make body and subheadings visible. -\\[show-children] show-children make direct subheadings visible. - No effect on body, or subheadings 2 or more levels down. - With arg N, affects subheadings N levels down. -\\[hide-entry] make immediately following body invisible. -\\[show-entry] make it visible. -\\[hide-leaves] make body under heading and under its subheadings invisible. - The subheadings remain visible. -\\[show-branches] make all subheadings at all levels visible. - -The variable `outline-regexp' can be changed to control what is a heading. -A line is a heading if `outline-regexp' matches something at the -beginning of the line. The longer the match, the deeper the level. - -Turning on outline mode calls the value of `text-mode-hook' and then of -`outline-mode-hook', if they are non-nil." t nil) - -(autoload 'outline-minor-mode "outline" "\ -Toggle Outline minor mode. -With arg, turn Outline minor mode on if arg is positive, off otherwise. -See the command `outline-mode' for more information on this mode." t nil) - -;;;*** - -;;;### (autoloads (pascal-mode) "pascal" "modes/pascal.el") - -(autoload 'pascal-mode "pascal" "\ -Major mode for editing Pascal code. \\ -TAB indents for Pascal code. Delete converts tabs to spaces as it moves back. - -\\[pascal-complete-word] completes the word around current point with respect to position in code -\\[pascal-show-completions] shows all possible completions at this point. - -Other useful functions are: - -\\[pascal-mark-defun] - Mark function. -\\[pascal-insert-block] - insert begin ... end; -\\[pascal-star-comment] - insert (* ... *) -\\[pascal-comment-area] - Put marked area in a comment, fixing nested comments. -\\[pascal-uncomment-area] - Uncomment an area commented with \\[pascal-comment-area]. -\\[pascal-beg-of-defun] - Move to beginning of current function. -\\[pascal-end-of-defun] - Move to end of current function. -\\[pascal-goto-defun] - Goto function prompted for in the minibuffer. -\\[pascal-outline] - Enter pascal-outline-mode (see also pascal-outline). - -Variables controlling indentation/edit style: - - pascal-indent-level (default 3) - Indentation of Pascal statements with respect to containing block. - pascal-case-indent (default 2) - Indentation for case statements. - pascal-auto-newline (default nil) - Non-nil means automatically newline after semicolons and the punctuation - mark after an end. - pascal-tab-always-indent (default t) - Non-nil means TAB in Pascal mode should always reindent the current line, - regardless of where in the line point is when the TAB command is used. - pascal-auto-endcomments (default t) - Non-nil means a comment { ... } is set after the ends which ends cases and - functions. The name of the function or case will be set between the braces. - pascal-auto-lineup (default t) - List of contexts where auto lineup of :'s or ='s should be done. - -See also the user variables pascal-type-keywords, pascal-start-keywords and -pascal-separator-keywords. - -Turning on Pascal mode calls the value of the variable pascal-mode-hook with -no args, if that value is non-nil." t nil) - -;;;*** - -;;;### (autoloads nil "perl-mode" "modes/perl-mode.el") - -;;;*** - -;;;### (autoloads (picture-mode) "picture" "modes/picture.el") - -(autoload 'picture-mode "picture" "\ -Switch to Picture mode, in which a quarter-plane screen model is used. -Printing characters replace instead of inserting themselves with motion -afterwards settable by these commands: - C-c < Move left after insertion. - C-c > Move right after insertion. - C-c ^ Move up after insertion. - C-c . Move down after insertion. - C-c ` Move northwest (nw) after insertion. - C-c ' Move northeast (ne) after insertion. - C-c / Move southwest (sw) after insertion. - C-c \\ Move southeast (se) after insertion. -The current direction is displayed in the modeline. The initial -direction is right. Whitespace is inserted and tabs are changed to -spaces when required by movement. You can move around in the buffer -with these commands: - \\[picture-move-down] Move vertically to SAME column in previous line. - \\[picture-move-up] Move vertically to SAME column in next line. - \\[picture-end-of-line] Move to column following last non-whitespace character. - \\[picture-forward-column] Move right inserting spaces if required. - \\[picture-backward-column] Move left changing tabs to spaces if required. - C-c C-f Move in direction of current picture motion. - C-c C-b Move in opposite direction of current picture motion. - Return Move to beginning of next line. -You can edit tabular text with these commands: - M-Tab Move to column beneath (or at) next interesting character. - `Indents' relative to a previous line. - Tab Move to next stop in tab stop list. - C-c Tab Set tab stops according to context of this line. - With ARG resets tab stops to default (global) value. - See also documentation of variable picture-tab-chars - which defines \"interesting character\". You can manually - change the tab stop list with command \\[edit-tab-stops]. -You can manipulate text with these commands: - C-d Clear (replace) ARG columns after point without moving. - C-c C-d Delete char at point - the command normally assigned to C-d. - \\[picture-backward-clear-column] Clear (replace) ARG columns before point, moving back over them. - \\[picture-clear-line] Clear ARG lines, advancing over them. The cleared - text is saved in the kill ring. - \\[picture-open-line] Open blank line(s) beneath current line. -You can manipulate rectangles with these commands: - C-c C-k Clear (or kill) a rectangle and save it. - C-c C-w Like C-c C-k except rectangle is saved in named register. - C-c C-y Overlay (or insert) currently saved rectangle at point. - C-c C-x Like C-c C-y except rectangle is taken from named register. - \\[copy-rectangle-to-register] Copies a rectangle to a register. - \\[advertised-undo] Can undo effects of rectangle overlay commands - commands if invoked soon enough. -You can return to the previous mode with: - C-c C-c Which also strips trailing whitespace from every line. - Stripping is suppressed by supplying an argument. - -Entry to this mode calls the value of picture-mode-hook if non-nil. - -Note that Picture mode commands will work outside of Picture mode, but -they are not defaultly assigned to keys." t nil) - -(defalias 'edit-picture 'picture-mode) - -;;;*** - -;;;### (autoloads (postscript-mode) "postscript" "modes/postscript.el") - -(autoload 'postscript-mode "postscript" "\ -Major mode for editing PostScript files. - -\\[ps-execute-buffer] will send the contents of the buffer to the NeWS -server using psh(1). \\[ps-execute-region] sends the current region. -\\[ps-shell] starts an interactive psh(1) window which will be used for -subsequent \\[ps-execute-buffer] or \\[ps-execute-region] commands. - -In this mode, TAB and \\[indent-region] attempt to indent code -based on the position of {}, [], and begin/end pairs. The variable -ps-indent-level controls the amount of indentation used inside -arrays and begin/end pairs. - -\\{ps-mode-map} - -\\[postscript-mode] calls the value of the variable postscript-mode-hook -with no args, if that value is non-nil." t nil) - -;;;*** - -;;;### (autoloads (run-prolog inferior-prolog-mode prolog-mode) "prolog" "modes/prolog.el") - -(autoload 'prolog-mode "prolog" "\ -Major mode for editing Prolog code for Prologs. -Blank lines and `%%...' separate paragraphs. `%'s start comments. -Commands: -\\{prolog-mode-map} -Entry to this mode calls the value of `prolog-mode-hook' -if that value is non-nil." t nil) - -(autoload 'inferior-prolog-mode "prolog" "\ -Major mode for interacting with an inferior Prolog process. - -The following commands are available: -\\{inferior-prolog-mode-map} - -Entry to this mode calls the value of `prolog-mode-hook' with no arguments, -if that value is non-nil. Likewise with the value of `comint-mode-hook'. -`prolog-mode-hook' is called after `comint-mode-hook'. - -You can send text to the inferior Prolog from other buffers -using the commands `send-region', `send-string' and \\[prolog-consult-region]. - -Commands: -Tab indents for Prolog; with argument, shifts rest - of expression rigidly with the current line. -Paragraphs are separated only by blank lines and '%%'. -'%'s start comments. - -Return at end of buffer sends line as input. -Return not at end copies rest of line to end and sends it. -\\[comint-kill-input] and \\[backward-kill-word] are kill commands, imitating normal Unix input editing. -\\[comint-interrupt-subjob] interrupts the shell or its current subjob if any. -\\[comint-stop-subjob] stops. \\[comint-quit-subjob] sends quit signal." t nil) - -(autoload 'run-prolog "prolog" "\ -Run an inferior Prolog process, input and output via buffer *prolog*." t nil) - -;;;*** - -;;;### (autoloads (py-shell python-mode) "python-mode" "modes/python-mode.el") - -(eval-when-compile (condition-case nil (progn (require 'cl) (require 'imenu)) (error nil))) - -(autoload 'python-mode "python-mode" "\ -Major mode for editing Python files. -To submit a problem report, enter `\\[py-submit-bug-report]' from a -`python-mode' buffer. Do `\\[py-describe-mode]' for detailed -documentation. To see what version of `python-mode' you are running, -enter `\\[py-version]'. - -This mode knows about Python indentation, tokens, comments and -continuation lines. Paragraphs are separated by blank lines only. - -COMMANDS -\\{py-mode-map} -VARIABLES - -py-indent-offset indentation increment -py-block-comment-prefix comment string used by comment-region -py-python-command shell command to invoke Python interpreter -py-scroll-process-buffer always scroll Python process buffer -py-temp-directory directory used for temp files (if needed) -py-beep-if-tab-change ring the bell if tab-width is changed" t nil) - -(autoload 'py-shell "python-mode" "\ -Start an interactive Python interpreter in another window. -This is like Shell mode, except that Python is running in the window -instead of a shell. See the `Interactive Shell' and `Shell Mode' -sections of the Emacs manual for details, especially for the key -bindings active in the `*Python*' buffer. - -See the docs for variable `py-scroll-buffer' for info on scrolling -behavior in the process window. - -Warning: Don't use an interactive Python if you change sys.ps1 or -sys.ps2 from their default values, or if you're running code that -prints `>>> ' or `... ' at the start of a line. `python-mode' can't -distinguish your output from Python's output, and assumes that `>>> ' -at the start of a line is a prompt from Python. Similarly, the Emacs -Shell mode code assumes that both `>>> ' and `... ' at the start of a -line are Python prompts. Bad things can happen if you fool either -mode. - -Warning: If you do any editing *in* the process buffer *while* the -buffer is accepting output from Python, do NOT attempt to `undo' the -changes. Some of the output (nowhere near the parts you changed!) may -be lost if you do. This appears to be an Emacs bug, an unfortunate -interaction between undo and process filters; the same problem exists in -non-Python process buffers using the default (Emacs-supplied) process -filter." t nil) - -;;;*** - -;;;### (autoloads (reftex-mode turn-on-reftex) "reftex" "modes/reftex.el") - -(autoload 'turn-on-reftex "reftex" "\ -Turn on RefTeX minor mode." nil nil) - -(autoload 'reftex-mode "reftex" "\ -Minor mode with distinct support for \\label, \\ref and \\cite in LaTeX. - -Labels can be created with `\\[reftex-label]' and referenced with `\\[reftex-reference]'. -When referencing, you get a menu with all labels of a given type and -context of the label definition. The selected label is inserted as a -\\ref macro. - -Citations can be made with `\\[reftex-citation]' which will use a regular expression -to pull out a *formatted* list of articles from your BibTeX -database. The selected citation is inserted as a \\cite macro. - -A Table of Contents of the entire (multifile) document with browsing -capabilities is available with `\\[reftex-toc]'. - -Most command have help available on the fly. This help is accessed by -pressing `?' to any prompt mentioning this feature. - -Extensive documentation about RefTeX is in the file header of `reftex.el'. -You can view this information with `\\[reftex-show-commentary]'. - -\\{reftex-mode-map} -Under X, these and other functions will also be available as `Ref' menu -on the menu bar. - -------------------------------------------------------------------------------" t nil) - -;;;*** - -;;;### (autoloads (rexx-mode) "rexx-mode" "modes/rexx-mode.el") - -(autoload 'rexx-mode "rexx-mode" "\ -Major mode for editing REXX code. -\\{rexx-mode-map} - -Variables controlling indentation style: - rexx-indent - The basic indentation for do-blocks. - rexx-end-indent - The relative offset of the \"end\" statement. 0 places it in the - same column as the statements of the block. Setting it to the same - value as rexx-indent places the \"end\" under the do-line. - rexx-cont-indent - The indention for lines following \"then\", \"else\" and \",\" - (continued) lines. - rexx-tab-always-indent - Non-nil means TAB in REXX mode should always reindent the current - line, regardless of where in the line the point is when the TAB - command is used. - -If you have set rexx-end-indent to a nonzero value, you probably want to -remap RETURN to rexx-indent-newline-indent. It makes sure that lines -indents correctly when you press RETURN. - -An extensive abbreviation table consisting of all the keywords of REXX are -supplied. Expanded keywords are converted into upper case making it -easier to distinguish them. To use this feature the buffer must be in -abbrev-mode. (See example below.) - -Turning on REXX mode calls the value of the variable rexx-mode-hook with -no args, if that value is non-nil. - -For example: -\(setq rexx-mode-hook '(lambda () - (setq rexx-indent 4) - (setq rexx-end-indent 4) - (setq rexx-cont-indent 4) - (local-set-key \"\\C-m\" 'rexx-indent-newline-indent) - (abbrev-mode 1) - )) - -will make the END aligned with the DO/SELECT. It will indent blocks and -IF-statements four steps and make sure that the END jumps into the -correct position when RETURN is pressed. Finally it will use the abbrev -table to convert all REXX keywords into upper case." t nil) - -;;;*** - -;;;### (autoloads (resize-minibuffer-mode) "rsz-minibuf" "modes/rsz-minibuf.el") - -(autoload 'resize-minibuffer-mode "rsz-minibuf" "\ -Enable or disable resize-minibuffer mode. -A negative prefix argument disables this mode. A positive argument or -argument of 0 enables it. - -When this minor mode is enabled, the minibuffer is dynamically resized to -contain the entire region of text put in it as you type. - -The variable `resize-minibuffer-mode' is set to t or nil depending on -whether this mode is active or not. - -The maximum height to which the minibuffer can grow is controlled by the -variable `resize-minibuffer-window-max-height'. - -The variable `resize-minibuffer-window-exactly' determines whether the -minibuffer window should ever be shrunk to make it no larger than needed to -display its contents. - -When using a window system, it is possible for a minibuffer to be the sole -window in a frame. Since that window is already its maximum size, the only -way to make more text visible at once is to increase the size of the frame. -The variable `resize-minibuffer-frame' controls whether this should be -done. The variables `resize-minibuffer-frame-max-height' and -`resize-minibuffer-frame-exactly' are analogous to their window -counterparts." t nil) - -;;;*** - -;;;### (autoloads (scheme-mode) "scheme" "modes/scheme.el") - -(autoload 'scheme-mode "scheme" "\ -Major mode for editing Scheme code. -Editing commands are similar to those of lisp-mode. - -In addition, if an inferior Scheme process is running, some additional -commands will be defined, for evaluating expressions and controlling -the interpreter, and the state of the process will be displayed in the -modeline of all Scheme buffers. The names of commands that interact -with the Scheme process start with \"xscheme-\". For more information -see the documentation for xscheme-interaction-mode. - -Commands: -Delete converts tabs to spaces as it moves back. -Blank lines separate paragraphs. Semicolons start comments. -\\{scheme-mode-map} -Entry to this mode calls the value of scheme-mode-hook -if that value is non-nil." t nil) - -;;;*** - -;;;### (autoloads (scribe-mode) "scribe" "modes/scribe.el") - -(autoload 'scribe-mode "scribe" "\ -Major mode for editing files of Scribe (a text formatter) source. -Scribe-mode is similar text-mode, with a few extra commands added. -\\{scribe-mode-map} - -Interesting variables: - -scribe-fancy-paragraphs - Non-nil makes Scribe mode use a different style of paragraph separation. - -scribe-electric-quote - Non-nil makes insert of double quote use `` or '' depending on context. - -scribe-electric-parenthesis - Non-nil makes an open-parenthesis char (one of `([<{') - automatically insert its close if typed after an @Command form." t nil) - -;;;*** - -;;;### (autoloads (mail-other-frame mail-other-window mail mail-mode user-mail-address) "sendmail" "modes/sendmail.el") - -(defvar mail-from-style 'angles "\ -*Specifies how \"From:\" fields look. - -If `nil', they contain just the return address like: - king@grassland.com -If `parens', they look like: - king@grassland.com (Elvis Parsley) -If `angles', they look like: - Elvis Parsley ") - -(defvar mail-self-blind nil "\ -Non-nil means insert BCC to self in messages to be sent. -This is done when the message is initialized, -so you can remove or alter the BCC field to override the default.") - -(defvar mail-interactive nil "\ -Non-nil means when sending a message wait for and display errors. -nil means let mailer mail back a message to report errors.") - -(defvar mail-dir nil "\ -*Default directory for saving messages.") - -(defvar rmail-ignored-headers (purecopy (concat "^\\(" (mapconcat 'identity '("Sender:" "References:" "Return-Path:" "Received:" "[^: \n]*Message-ID:" "Errors-To:" "Path:" "Expires:" "Xref:" "Lines:" "Approved:" "Distribution:" "Content-Length:" "Mime-Version:" "Content-Type:" "Content-Transfer-Encoding:" "X400-Received:" "X400-Originator:" "X400-Mts-Identifier:" "X400-Content-Type:" "Content-Identifier:" "Status:" "Summary-Line:" "X-Attribution:" "Via:" "Sent-Via:" "Mail-From:" "Origin:" "Comments:" "Originator:" "NF-ID:" "NF-From:" "Posting-Version:" "Posted:" "Posted-Date:" "Date-Received:" "Relay-Version:" "Article-I\\.D\\.:" "NNTP-Version:" "NNTP-Posting-Host:" "X-Mailer:" "X-Newsreader:" "News-Software:" "X-Received:" "X-References:" "X-Envelope-To:" "X-VMS-" "Remailed-" "X-Plantation:" "X-Windows:" "X-Pgp-") "\\|") "\\)")) "\ -*Gubbish header fields one would rather not see.") - -(defvar mail-yank-ignored-headers (purecopy (concat rmail-ignored-headers "\\|" "^\\(" (mapconcat 'identity '("Resent-To:" "Resent-By:" "Resent-CC:" "To:" "Subject:" "In-Reply-To:") "\\|") "\\)")) "\ -Delete these headers from old message when it's inserted in a reply.") - -(defvar send-mail-function 'sendmail-send-it "\ -Function to call to send the current buffer as mail. -The headers should be delimited by a line whose contents -match the variable `mail-header-separator'.") - -(defvar mail-header-separator (purecopy "--text follows this line--") "\ -*Line used to separate headers from text in messages being composed.") - -(defvar mail-archive-file-name nil "\ -*Name of file to write all outgoing messages in, or nil for none. -This can be an inbox file or an Rmail file.") - -(defvar mail-default-reply-to nil "\ -*Address to insert as default Reply-to field of outgoing messages. -If nil, it will be initialized from the REPLYTO environment variable -when you first send mail.") - -(defvar mail-alias-file nil "\ -*If non-nil, the name of a file to use instead of `/usr/lib/aliases'. -This file defines aliases to be expanded by the mailer; this is a different -feature from that of defining aliases in `.mailrc' to be expanded in Emacs. -This variable has no effect unless your system uses sendmail as its mailer.") - -(defvar mail-yank-prefix "> " "\ -*Prefix insert on lines of yanked message being replied to. -nil means use indentation.") - -(defvar mail-signature nil "\ -*Text inserted at end of mail buffer when a message is initialized. -If t, it means to insert the contents of the file `mail-signature-file'.") - -(autoload 'user-mail-address "sendmail" "\ -Query the user for his mail address, unless it is already known." t nil) - -(autoload 'mail-mode "sendmail" "\ -Major mode for editing mail to be sent. -Like Text Mode but with these additional commands: -C-c C-s mail-send (send the message) C-c C-c mail-send-and-exit -C-c C-f move to a header field (and create it if there isn't): - C-c C-f C-t move to To: C-c C-f C-s move to Subj: - C-c C-f C-b move to BCC: C-c C-f C-c move to CC: - C-c C-f C-f move to FCC: C-c C-f C-r move to Reply-To: -C-c C-t mail-text (move to beginning of message text). -C-c C-w mail-signature (insert `mail-signature-file' file). -C-c C-y mail-yank-original (insert current message, in Rmail). -C-c C-q mail-fill-yanked-message (fill what was yanked). -C-c C-v mail-sent-via (add a sent-via field for each To or CC)." t nil) - -(autoload 'mail "sendmail" "\ -Edit a message to be sent. Prefix arg means resume editing (don't erase). -When this function returns, the buffer `*mail*' is selected. -The value is t if the message was newly initialized; otherwise, nil. - -Optionally, the signature file `mail-signature-file' can be inserted at the -end; see the variable `mail-signature'. - -\\ -While editing message, type \\[mail-send-and-exit] to send the message and exit. - -Various special commands starting with C-c are available in sendmail mode -to move to message header fields: -\\{mail-mode-map} - -The variable `mail-signature' controls whether the signature file -`mail-signature-file' is inserted immediately. - -If `mail-signature' is nil, use \\[mail-signature] to insert the -signature in `mail-signature-file'. - -If `mail-self-blind' is non-nil, a BCC to yourself is inserted -when the message is initialized. - -If `mail-default-reply-to' is non-nil, it should be an address (a string); -a Reply-to: field with that address is inserted. - -If `mail-archive-file-name' is non-nil, an FCC field with that file name -is inserted. - -The normal hook `mail-setup-hook' is run after the message is -initialized. It can add more default fields to the message. - -When calling from a program, the first argument if non-nil says -not to erase the existing contents of the `*mail*' buffer. - -The second through fifth arguments, - TO, SUBJECT, IN-REPLY-TO and CC, specify if non-nil - the initial contents of those header fields. - These arguments should not have final newlines. -The sixth argument REPLYBUFFER is a buffer whose contents - should be yanked if the user types C-c C-y. -The seventh argument ACTIONS is a list of actions to take - if/when the message is sent. Each action looks like (FUNCTION . ARGS); - when the message is sent, we apply FUNCTION to ARGS. - This is how Rmail arranges to mark messages `answered'." t nil) - -(autoload 'mail-other-window "sendmail" "\ -Like `mail' command, but display mail buffer in another window." t nil) - -(autoload 'mail-other-frame "sendmail" "\ -Like `mail' command, but display mail buffer in another frame." t nil) - -(add-hook 'same-window-buffer-names "*mail*") - -;;;*** - -;;;### (autoloads nil "sgml-mode" "modes/sgml-mode.el") - -;;;*** - -;;;### (autoloads (latex-mode plain-tex-mode tex-mode) "tex-mode" "modes/tex-mode.el") - -(autoload 'tex-mode "tex-mode" "\ -Major mode for editing files of input for TeX, LaTeX, or SliTeX. -Tries to determine (by looking at the beginning of the file) whether -this file is for plain TeX, LaTeX, or SliTeX and calls plain-tex-mode, -latex-mode, or slitex-mode, respectively. If it cannot be determined, -such as if there are no commands in the file, the value of tex-default-mode -is used." t nil) - -(fset 'TeX-mode 'tex-mode) - -(fset 'LaTeX-mode 'latex-mode) - -(autoload 'plain-tex-mode "tex-mode" "\ -Major mode for editing files of input for plain TeX. -Makes $ and } display the characters they match. -Makes \" insert `` when it seems to be the beginning of a quotation, -and '' when it appears to be the end; it inserts \" only after a \\. - -Use \\[tex-region] to run TeX on the current region, plus a \"header\" -copied from the top of the file (containing macro definitions, etc.), -running TeX under a special subshell. \\[tex-buffer] does the whole buffer. -\\[tex-file] saves the buffer and then processes the file. -\\[tex-print] prints the .dvi file made by any of these. -\\[tex-view] previews the .dvi file made by any of these. -\\[tex-bibtex-file] runs bibtex on the file of the current buffer. - -Use \\[validate-tex-buffer] to check buffer for paragraphs containing -mismatched $'s or braces. - -Special commands: -\\{tex-mode-map} - -Mode variables: -tex-run-command - Command string used by \\[tex-region] or \\[tex-buffer]. -tex-directory - Directory in which to create temporary files for TeX jobs - run by \\[tex-region] or \\[tex-buffer]. -tex-dvi-print-command - Command string used by \\[tex-print] to print a .dvi file. -tex-alt-dvi-print-command - Alternative command string used by \\[tex-print] (when given a prefix - argument) to print a .dvi file. -tex-dvi-view-command - Command string used by \\[tex-view] to preview a .dvi file. -tex-show-queue-command - Command string used by \\[tex-show-print-queue] to show the print - queue that \\[tex-print] put your job on. - -Entering Plain-tex mode calls the value of text-mode-hook, then the value of -tex-mode-hook, and then the value of plain-tex-mode-hook. When the special -subshell is initiated, the value of tex-shell-hook is called." t nil) - -(fset 'plain-TeX-mode 'plain-tex-mode) - -(autoload 'latex-mode "tex-mode" "\ -Major mode for editing files of input for LaTeX. -Makes $ and } display the characters they match. -Makes \" insert `` when it seems to be the beginning of a quotation, -and '' when it appears to be the end; it inserts \" only after a \\. - -Use \\[tex-region] to run LaTeX on the current region, plus the preamble -copied from the top of the file (containing \\documentstyle, etc.), -running LaTeX under a special subshell. \\[tex-buffer] does the whole buffer. -\\[tex-file] saves the buffer and then processes the file. -\\[tex-print] prints the .dvi file made by any of these. -\\[tex-view] previews the .dvi file made by any of these. -\\[tex-bibtex-file] runs bibtex on the file of the current buffer. - -Use \\[validate-tex-buffer] to check buffer for paragraphs containing -mismatched $'s or braces. - -Special commands: -\\{tex-mode-map} - -Mode variables: -latex-run-command - Command string used by \\[tex-region] or \\[tex-buffer]. -tex-directory - Directory in which to create temporary files for LaTeX jobs - run by \\[tex-region] or \\[tex-buffer]. -tex-dvi-print-command - Command string used by \\[tex-print] to print a .dvi file. -tex-alt-dvi-print-command - Alternative command string used by \\[tex-print] (when given a prefix - argument) to print a .dvi file. -tex-dvi-view-command - Command string used by \\[tex-view] to preview a .dvi file. -tex-show-queue-command - Command string used by \\[tex-show-print-queue] to show the print - queue that \\[tex-print] put your job on. - -Entering Latex mode calls the value of text-mode-hook, then the value of -tex-mode-hook, and then the value of latex-mode-hook. When the special -subshell is initiated, the value of tex-shell-hook is called." t nil) - -;;;*** - -;;;### (autoloads (texinfo-mode) "texinfo" "modes/texinfo.el") - -(autoload 'texinfo-mode "texinfo" "\ -Major mode for editing Texinfo files. - - It has these extra commands: -\\{texinfo-mode-map} - - These are files that are used as input for TeX to make printed manuals -and also to be turned into Info files with \\[makeinfo-buffer] or -the `makeinfo' program. These files must be written in a very restricted and -modified version of TeX input format. - - Editing commands are like text-mode except that the syntax table is -set up so expression commands skip Texinfo bracket groups. To see -what the Info version of a region of the Texinfo file will look like, -use \\[makeinfo-region], which runs `makeinfo' on the current region. - - You can show the structure of a Texinfo file with \\[texinfo-show-structure]. -This command shows the structure of a Texinfo file by listing the -lines with the @-sign commands for @chapter, @section, and the like. -These lines are displayed in another window called the *Occur* window. -In that window, you can position the cursor over one of the lines and -use \\[occur-mode-goto-occurrence], to jump to the corresponding spot -in the Texinfo file. - - In addition, Texinfo mode provides commands that insert various -frequently used @-sign commands into the buffer. You can use these -commands to save keystrokes. And you can insert balanced braces with -\\[texinfo-insert-braces] and later use the command \\[up-list] to -move forward past the closing brace. - -Also, Texinfo mode provides functions for automatically creating or -updating menus and node pointers. These functions - - * insert the `Next', `Previous' and `Up' pointers of a node, - * insert or update the menu for a section, and - * create a master menu for a Texinfo source file. - -Here are the functions: - - texinfo-update-node \\[texinfo-update-node] - texinfo-every-node-update \\[texinfo-every-node-update] - texinfo-sequential-node-update - - texinfo-make-menu \\[texinfo-make-menu] - texinfo-all-menus-update \\[texinfo-all-menus-update] - texinfo-master-menu - - texinfo-indent-menu-description (column &optional region-p) - -The `texinfo-column-for-description' variable specifies the column to -which menu descriptions are indented. - -Passed an argument (a prefix argument, if interactive), the -`texinfo-update-node' and `texinfo-make-menu' functions do their jobs -in the region. - -To use the updating commands, you must structure your Texinfo file -hierarchically, such that each `@node' line, with the exception of the -Top node, is accompanied by some kind of section line, such as an -`@chapter' or `@section' line. - -If the file has a `top' node, it must be called `top' or `Top' and -be the first node in the file. - -Entering Texinfo mode calls the value of text-mode-hook, and then the -value of texinfo-mode-hook." t nil) - -;;;*** - -;;;### (autoloads (vhdl-mode) "vhdl-mode" "modes/vhdl-mode.el") - -(autoload 'vhdl-mode "vhdl-mode" "\ -Major mode for editing VHDL code. -vhdl-mode $Revision: 1.14 $ -To submit a problem report, enter `\\[vhdl-submit-bug-report]' from a -vhdl-mode buffer. This automatically sets up a mail buffer with version -information already added. You just need to add a description of the -problem, including a reproducable test case and send the message. - -Note that the details of configuring vhdl-mode will soon be moved to the -accompanying texinfo manual. Until then, please read the README file -that came with the vhdl-mode distribution. - -The hook variable `vhdl-mode-hook' is run with no args, if that value is -bound and has a non-nil value. - -Key bindings: -\\{vhdl-mode-map}" t nil) - -;;;*** - -;;;### (autoloads (auto-view-mode view-major-mode view-mode view-minor-mode view-buffer-other-window view-file-other-window view-buffer view-file) "view-less" "modes/view-less.el") - -(defvar view-minor-mode-map (let ((map (make-keymap))) (set-keymap-name map 'view-minor-mode-map) (suppress-keymap map) (define-key map "-" 'negative-argument) (define-key map " " 'scroll-up) (define-key map "f" 'scroll-up) (define-key map "b" 'scroll-down) (define-key map 'backspace 'scroll-down) (define-key map 'delete 'scroll-down) (define-key map " " 'view-scroll-lines-up) (define-key map "\n" 'view-scroll-lines-up) (define-key map "e" 'view-scroll-lines-up) (define-key map "j" 'view-scroll-lines-up) (define-key map "y" 'view-scroll-lines-down) (define-key map "k" 'view-scroll-lines-down) (define-key map "d" 'view-scroll-some-lines-up) (define-key map "u" 'view-scroll-some-lines-down) (define-key map "r" 'recenter) (define-key map "t" 'toggle-truncate-lines) (define-key map "N" 'view-buffer) (define-key map "E" 'view-file) (define-key map "P" 'view-buffer) (define-key map "!" 'shell-command) (define-key map "|" 'shell-command-on-region) (define-key map "=" 'what-line) (define-key map "?" 'view-search-backward) (define-key map "h" 'view-mode-describe) (define-key map "s" 'view-repeat-search) (define-key map "n" 'view-repeat-search) (define-key map "/" 'view-search-forward) (define-key map "\\" 'view-search-backward) (define-key map "g" 'view-goto-line) (define-key map "G" 'view-last-windowful) (define-key map "%" 'view-goto-percent) (define-key map "p" 'view-goto-percent) (define-key map "m" 'point-to-register) (define-key map "'" 'register-to-point) (define-key map "C" 'view-cleanup-backspaces) (define-key map "" 'view-quit) (define-key map "" 'view-quit-toggle-ro) (define-key map "q" 'view-quit) map)) - -(defvar view-mode-map (let ((map (copy-keymap view-minor-mode-map))) (set-keymap-name map 'view-mode-map) map)) - -(autoload 'view-file "view-less" "\ -Find FILE, enter view mode. With prefix arg OTHER-P, use other window." t nil) - -(autoload 'view-buffer "view-less" "\ -Switch to BUF, enter view mode. With prefix arg use other window." t nil) - -(autoload 'view-file-other-window "view-less" "\ -Find FILE in other window, and enter view mode." t nil) - -(autoload 'view-buffer-other-window "view-less" "\ -Switch to BUFFER in another window, and enter view mode." t nil) - -(autoload 'view-minor-mode "view-less" "\ -Minor mode for viewing text, with bindings like `less'. -Commands are: -\\ -0..9 prefix args -- prefix minus -\\[scroll-up] page forward -\\[scroll-down] page back -\\[view-scroll-lines-up] scroll prefix-arg lines forward, default 1. -\\[view-scroll-lines-down] scroll prefix-arg lines backward, default 1. -\\[view-scroll-some-lines-down] scroll prefix-arg lines backward, default 10. -\\[view-scroll-some-lines-up] scroll prefix-arg lines forward, default 10. -\\[what-line] print line number -\\[view-mode-describe] print this help message -\\[view-search-forward] regexp search, uses previous string if you just hit RET -\\[view-search-backward] as above but searches backward -\\[view-repeat-search] repeat last search -\\[view-goto-line] goto line prefix-arg, default 1 -\\[view-last-windowful] goto line prefix-arg, default last line -\\[view-goto-percent] goto a position by percentage -\\[toggle-truncate-lines] toggle truncate-lines -\\[view-file] view another file -\\[view-buffer] view another buffer -\\[view-cleanup-backspaces] cleanup backspace constructions -\\[shell-command] execute a shell command -\\[shell-command-on-region] execute a shell command with the region as input -\\[view-quit] exit view-mode, and bury the current buffer. - -If invoked with the optional (prefix) arg non-nil, view-mode cleans up -backspace constructions. - -More precisely: -\\{view-minor-mode-map}" t nil) - -(autoload 'view-mode "view-less" "\ -View the current buffer using view-minor-mode. This exists to be 99.9% -compatible with the implementations of `view-mode' in view.el and older -versions of view-less.el." t nil) - -(autoload 'view-major-mode "view-less" "\ -View the current buffer using view-mode, as a major mode. -This function has a nonstandard name because `view-mode' is wrongly -named but is like this for compatibility reasons." t nil) - -(autoload 'auto-view-mode "view-less" "\ -If the file of the current buffer is not writable, call view-mode. -This is meant to be added to `find-file-hooks'." nil nil) - -;;;*** - -(provide 'modes-autoloads) diff -r 43306a74e31c -r d44af0c54775 lisp/modes/autoconf-mode.el --- a/lisp/modes/autoconf-mode.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,83 +0,0 @@ -;;; autoconf-mode.el --- autoconf code editing commands for Emacs - -;; Author: Martin Buchholz (mrb@eng.sun.com) -;; Maintainer: Martin Buchholz -;; Keywords: languages, faces, m4, configure - -;; This file is part of XEmacs - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: not in FSF. - -;;; Commentary: - -;; A major mode for editing autoconf input (like configure.in). -;; Derived from m4-mode.el by Andrew Csillag (drew@staff.prodigy.com) - -;;; Code: - -;;thank god for make-regexp.el! -(defvar autoconf-font-lock-keywords - `(("\\bdnl \\(.*\\)" 1 font-lock-comment-face t) - ("\\$[0-9*#@]" . font-lock-variable-name-face) - ("\\b\\(m4_\\)?\\(builtin\\|change\\(com\\|quote\\|word\\)\\|d\\(e\\(bug\\(file\\|mode\\)\\|cr\\|f\\(ine\\|n\\)\\)\\|iv\\(ert\\|num\\)\\|nl\\|umpdef\\)\\|e\\(rrprint\\|syscmd\\|val\\)\\|f\\(ile\\|ormat\\)\\|gnu\\|i\\(f\\(def\\|else\\)\\|n\\(c\\(lude\\|r\\)\\|d\\(ex\\|ir\\)\\)\\)\\|l\\(en\\|ine\\)\\|m\\(4\\(exit\\|wrap\\)\\|aketemp\\)\\|p\\(atsubst\\|opdef\\|ushdef\\)\\|regexp\\|s\\(hift\\|include\\|ubstr\\|ys\\(cmd\\|val\\)\\)\\|tra\\(ceo\\(ff\\|n\\)\\|nslit\\)\\|un\\(d\\(efine\\|ivert\\)\\|ix\\)\\)\\b" . font-lock-keyword-face) - "default font-lock-keywords") -) - -(defvar autoconf-mode-syntax-table nil - "syntax table used in autoconf mode") -(setq autoconf-mode-syntax-table (make-syntax-table)) -(modify-syntax-entry ?\" "\"" autoconf-mode-syntax-table) -;;(modify-syntax-entry ?\' "\"" autoconf-mode-syntax-table) -(modify-syntax-entry ?# "<\n" autoconf-mode-syntax-table) -(modify-syntax-entry ?\n ">#" autoconf-mode-syntax-table) -(modify-syntax-entry ?\( "." autoconf-mode-syntax-table) -(modify-syntax-entry ?\) "." autoconf-mode-syntax-table) -(modify-syntax-entry ?\[ "(]" autoconf-mode-syntax-table) -(modify-syntax-entry ?\] ")[" autoconf-mode-syntax-table) -(modify-syntax-entry ?* "." autoconf-mode-syntax-table) -(modify-syntax-entry ?_ "_" autoconf-mode-syntax-table) - -(defvar autoconf-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-c" 'comment-region) - map)) - -;;;###autoload -(defun autoconf-mode () - "A major-mode to edit autoconf input files like configure.in -\\{autoconf-mode-map} -" - (interactive) - (kill-all-local-variables) - (use-local-map autoconf-mode-map) - - (make-local-variable 'comment-start) - (setq comment-start "dnl") - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - - (make-local-variable 'font-lock-defaults) - (setq major-mode 'autoconf-mode) - (setq mode-name "Autoconf") - (setq font-lock-defaults `(autoconf-font-lock-keywords nil)) - (set-syntax-table autoconf-mode-syntax-table) - (run-hooks 'autoconf-mode-hook)) - -(provide 'autoconf-mode) - -;;; autoconf-mode.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/awk-mode.el --- a/lisp/modes/awk-mode.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,99 +0,0 @@ -;;; awk-mode.el --- AWK code editing commands for Emacs - -;; Copyright (C) 1988, 1994 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: unix, languages - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34. - -;;; Commentary: - -;; Sets up C-mode with support for awk-style #-comments and a lightly -;; hacked syntax table. - -;;; Code: - -(defvar awk-mode-syntax-table nil - "Syntax table in use in Awk-mode buffers.") - -(if awk-mode-syntax-table - () - (setq awk-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\\ "\\" awk-mode-syntax-table) - (modify-syntax-entry ?\n "> " awk-mode-syntax-table) - (modify-syntax-entry ?\f "> " awk-mode-syntax-table) - (modify-syntax-entry ?\# "< " awk-mode-syntax-table) - (modify-syntax-entry ?/ "." awk-mode-syntax-table) - (modify-syntax-entry ?* "." awk-mode-syntax-table) - (modify-syntax-entry ?+ "." awk-mode-syntax-table) - (modify-syntax-entry ?- "." awk-mode-syntax-table) - (modify-syntax-entry ?= "." awk-mode-syntax-table) - (modify-syntax-entry ?% "." awk-mode-syntax-table) - (modify-syntax-entry ?< "." awk-mode-syntax-table) - (modify-syntax-entry ?> "." awk-mode-syntax-table) - (modify-syntax-entry ?& "." awk-mode-syntax-table) - (modify-syntax-entry ?| "." awk-mode-syntax-table) - (modify-syntax-entry ?\' "\"" awk-mode-syntax-table)) - -(defvar awk-mode-abbrev-table nil - "Abbrev table in use in Awk-mode buffers.") -(define-abbrev-table 'awk-mode-abbrev-table ()) - -;;;###autoload -(defun awk-mode () - "Major mode for editing AWK code. -This is much like C mode except for the syntax of comments. It uses -the same keymap as C mode and has the same variables for customizing -indentation. It has its own abbrev table and its own syntax table. - -Turning on AWK mode calls the value of the variable `awk-mode-hook' -with no args, if that value is non-nil." - (interactive) - (kill-all-local-variables) - (require 'cc-mode) - (use-local-map c-mode-map) - (setq major-mode 'awk-mode) - (setq mode-name "AWK") - (setq local-abbrev-table awk-mode-abbrev-table) - (set-syntax-table awk-mode-syntax-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'c-indent-line) - (make-local-variable 'require-final-newline) - (setq require-final-newline t) - (make-local-variable 'comment-start) - (setq comment-start "# ") - (make-local-variable 'comment-end) - (setq comment-end "") - (make-local-variable 'comment-column) - (setq comment-column 32) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "#+ *") - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'c-comment-indent) - (run-hooks 'awk-mode-hook)) - -;;; awk-mode.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/bib-mode.el --- a/lisp/modes/bib-mode.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,244 +0,0 @@ -;;; bib-mode.el --- bib-mode, major mode for editing bib files. - -;; Copyright (C) 1989 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: bib - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34. - -;;; Commentary: - -;; GNU Emacs code to help maintain databases compatible with (troff) -;; refer and lookbib. The file bib-file should be set to your -;; bibliography file. Keys are automagically inserted as you type, -;; and appropriate keys are presented for various kinds of entries. - -;;; Code: - -(defvar bib-file "~/my-bibliography.bib" - "Default name of file used by `addbib'.") - -(defvar unread-bib-file "~/to-be-read.bib" - "Default name of file used by `unread-bib' in Bib mode.") - -(defvar bib-mode-map (copy-keymap text-mode-map)) -(define-key bib-mode-map "\C-M" 'return-key-bib) -(define-key bib-mode-map "\C-c\C-u" 'unread-bib) -(define-key bib-mode-map "\C-c\C-@" 'mark-bib) -(define-key bib-mode-map "\e`" 'abbrev-mode) -(defvar bib-mode-abbrev-table nil - "Abbrev table used in Bib mode") - -(defun addbib () - "Set up editor to add to troff bibliography file specified -by global variable `bib-file'. See description of `bib-mode'." - (interactive) - (find-file bib-file) - (goto-char (point-max)) - (bib-mode) - ) - -(defun bib-mode () - "Mode for editing `lookbib' style bibliographies. -Hit RETURN to get next % field key. -If you want to ignore this field, just hit RETURN again. -Use `text-mode' to turn this feature off. - - journal papers: A* T D J V N P K W X - articles in books & proceedings: A* T D B E* I C P K W X - tech reports: A* T D R I C K W X - books: A* T D I C K W X - -Fields: - -A uthor T itle D ate J ournal -V olume N umber P age K eywords -B in book or proceedings E ditor C ity & state -I nstitution, school, or publisher -R eport number or 'phd thesis' or 'masters thesis' or 'draft' or - 'unnumbered' or 'unpublished' -W here can be found locally (login name, or ailib, etc.) -X comments (not used in indexing) - -\\[unread-bib] appends current entry to a different file (for example, -a file of papers to be read in the future), given by the value of the -variable `unread-bib-file'. -\\[mark-bib] marks current or previous entry. -Abbreviations are saved in `bib-mode-abbrev-table'. -Hook can be stored in `bib-mode-hook'. -Field keys given by variable `bib-assoc'. - -Commands: -\\{bib-mode-map} -" - (interactive) - (text-mode) - (use-local-map bib-mode-map) - (setq mode-name "Bib") - (setq major-mode 'bib-mode) - (define-abbrev-table 'bib-mode-abbrev-table ()) - (setq local-abbrev-table bib-mode-abbrev-table) - (abbrev-mode 1) - (run-hooks 'bib-mode-hook) - ) - -(defconst bib-assoc '( - (" *$" . "%A ") - ("%A ." . "%A ") - ("%A $" . "%T ") - ("%T " . "%D ") - ("%D " . "%J ") - ("%J ." . "%V ") - ("%V " . "%N ") - ("%N " . "%P ") - ("%P " . "%K ") - ("%K " . "%W ") - ("%W " . "%X ") - ("%X " . "") - ("%J $" . "%B ") - ("%B ." . "%E ") - ("%E ." . "%E ") - ("%E $" . "%I ") - ("%I " . "%C ") - ("%C " . "%P ") - ("%B $" . "%R ") - ("%R " . "%I ") - ) - -"Describes bibliographic database format. A line beginning with -the car of an entry is followed by one beginning with the cdr. -") - -(defun bib-find-key (slots) - (cond - ((null slots) - (if (bobp) - "" - (progn (previous-line 1) (bib-find-key bib-assoc)))) - ((looking-at (car (car slots))) - (cdr (car slots))) - (t (bib-find-key (cdr slots))) - )) - - -(defvar bib-auto-capitalize t -"*True to automatically capitalize appropriate fields in Bib mode.") - -(defconst bib-capitalized-fields "%[AETCBIJR]") - -(defun return-key-bib () - "Magic when user hits return, used by `bib-mode'." - (interactive) - (if (eolp) - (let (empty new-key beg-current end-current) - (beginning-of-line) - (setq empty (looking-at "%. $")) - (if (not empty) - (progn - (end-of-line) - (newline) - (forward-line -1) - )) - (end-of-line) - (setq end-current (point)) - (beginning-of-line) - (setq beg-current (point)) - (setq new-key (bib-find-key bib-assoc)) - (if (and (not empty) bib-auto-capitalize - (looking-at bib-capitalized-fields)) - (save-excursion - (capitalize-title-region (+ (point) 3) end-current))) - (goto-char beg-current) - (if empty - (kill-line nil) - (forward-line 1) - ) - (insert-string new-key)) - (newline))) - -(defun mark-bib () - "Set mark at beginning of current or previous bib entry, point at end." - (interactive) - (beginning-of-line nil) - (if (looking-at "^ *$") (re-search-backward "[^ \n]" nil 2)) - (re-search-backward "^ *$" nil 2) - (re-search-forward "^%") - (beginning-of-line nil) - (push-mark (point)) - (re-search-forward "^ *$" nil 2) - (next-line 1) - (beginning-of-line nil)) - -(defun unread-bib () - "Append current or previous entry to file of unread papers -named by variable `unread-bib-file'." - (interactive) - (mark-bib) - (if (get-file-buffer unread-bib-file) - (append-to-buffer (get-file-buffer unread-bib-file) (mark) (point)) - (append-to-file (mark) (point) unread-bib-file))) - - -(defvar capitalize-title-stop-words - (concat - "the\\|and\\|of\\|is\\|a\\|an\\|of\\|for\\|in\\|to\\|in\\|on\\|at\\|" - "by\\|with\\|that\\|its") - "Words not to be capitalized in a title (unless they're the first word -in the title).") - -(defvar capitalize-title-stop-regexp - (concat "\\(" capitalize-title-stop-words "\\)\\(\\b\\|'\\)")) - -(defun capitalize-title-region (begin end) - "Like `capitalize-region', but don't capitalize stop words, except the first." - (interactive "r") - (let ((case-fold-search nil) (orig-syntax-table (syntax-table))) - (unwind-protect - (save-restriction - (set-syntax-table text-mode-syntax-table) - (narrow-to-region begin end) - (goto-char (point-min)) - (if (looking-at "[A-Z][a-z]*[A-Z]") - (forward-word 1) - (capitalize-word 1)) - (while (re-search-forward "\\<" nil t) - (if (looking-at "[A-Z][a-z]*[A-Z]") - (forward-word 1) - (if (let ((case-fold-search t)) - (looking-at capitalize-title-stop-regexp)) - (downcase-word 1) - (capitalize-word 1))) - )) - (set-syntax-table orig-syntax-table)))) - - -(defun capitalize-title (s) - "Like `capitalize', but don't capitalize stop words, except the first." - (save-excursion - (set-buffer (get-buffer-create "$$$Scratch$$$")) - (erase-buffer) - (insert s) - (capitalize-title-region (point-min) (point-max)) - (buffer-string))) - -(provide 'bib-mode) - -;;; bib-mode.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/bibtex.el --- a/lisp/modes/bibtex.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1531 +0,0 @@ -;;; bibtex.el --- BibTeX mode for GNU Emacs - -;; Copyright (C) 1992 Free Software Foundation, Inc. - -;; Author: Bengt Martensson -;; Mark Shapiro -;; Mike Newton -;; Aaron Larson -;; Version: 1.3.1 -;; Maintainer:Aaron Larson -;; Adapted-By: ESR -;; Keywords: tex, bib - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; TODO distribute texinfo file. - -;;; LCD Archive Entry: -;;; bibtex-mode|Bengt Martensson, Marc Shapiro, Aaron Larson| -;;; alarson@src.honeywell.com| -;;; Support for maintaining BibTeX format bibliography databases| -;;; 93-03-29|version 1.3|~/modes/bibtex-mode.el.Z| - -;;; Commentary: - -;;; BUGS: -;;; 1. using regular expressions to match the entire bibtex entry dies -;;; on long bibtex entires (e.g. those containing abstracts) since -;;; the length of regular expression matches is fairly limited. -;;; 2. When inserting a string (with \C-C\C-E\s) hitting a TAB results -;;; in the error message "Can't find enclosing Bibtex field" instead -;;; of moving to the empty string. [reported by gernot@cs.unsw.oz.au] -;;; 3. Function string-equalp should be in a library file, not in this -;;; file. - -;;; (current keeper: alarson@src.honeywell.com -;;; previous: shapiro@corto.inria.fr) - -;;; Change Log: - -;; Mon Mar 29 14:06:06 1993 Aaron Larson (alarson at gendibal) -;; -;; * bibtex.el: V1.3 released Mar 30, 1993 -;; (bibtex-field-name): Fix to match definition if latex manual, -;; specifically letters, digits, and punctuation other than comma. -;; Underscore is retained for historical reasons. -;; (bibtex-make-field): Fix to work around bug in Lucid prin1-to-string -;; function as reported by Martin Sjolin . -;; (bibtex-entry): minor code cleanup. -;; (bibtex-mode-map): Remove key binding (C-c n) for -;; narrow-to-bibtex-entry, previous binding violated emacs policy of -;; reserving C-c followed by a letter for user customization. -;; revise modification history to better conform to FSF changelog -;; standards. -;; (bibtex-refile-entry): Removed. Would need disclaimer papers to -;; incorporate it into official sources, and unable to contact author. -;; Fix minor "syntax" errors in documentation strings and such found -;; by new byte compiler. Funs bibtex-mode, bibtex-remove-double-quotes -;; -;; -;; Fri Jan 15 14:06:06 1993 Aaron Larson (alarson at gendibal) -;; -;; * bibtex.el: V1.2 released Feb 15 1993 -;; (find-bibtex-entry-location bibtex-make-field): Fixed placement of -;; "interactive specification". [Bug report from -;; mernst@theory.lcs.mit.edu] -;; Fixed problem where bibtex-entry would fail if user typed entry -;; name in wrong case. -;; (bibtex-inside-field) Position the cursor _before_ the last comma -;; on a line (the comma is not necessarily "inside" the field); this -;; does not seem to break any existing code. ref sct@dcs.edinburgh.ac.uk -;; (bibtex-enclosing-field, bibtex-enclosing-reference): leave -;; point unmoved if no enclosing field/reference is found. As a -;; result of changes (3) and (4) bibtex-next-field works properly, -;; even when called from the entry key position. -;; (bibtex-remove-OPT): realign the '=' after removing the 'opt'. -;; (bibtex-clean-entry): always remove any trailing comma from the -;; end of a bibtex entry (these commas get stripped automatically when -;; optional fields are killed by bibtex-kill-optional-field, but can be -;; left if optional fields are removed by other means). -;; (bibtex-x-help) Replace tab with spaces in X menu as noted by -;; khera@cs.duke.edu -;; (bibtex-refile-entry): Added (from brannon@jove.cs.caltech.edu) -;; (bibtex-sort-ignore-string-entries sort-bibtex-entries, -;; map-bibtex-entries): Added variable as requested by -;; gernot@cs.unsw.oz.au, required changes to funs. -;; (bibtex-current-entry-label): Added at request of -;; yasuro@maekawa.is.uec.ac.jp -;; (bibtex-DEAthesis:) Deleted along with corresponding entry from -;; bibtex-x-help per shapiro@corto.inria.fr -;; Moved narrow-to-bibtex-entry from C-c C-n to C-c n (the previous -;; binding was in conflict with the binding for bibtex-pop-next. -;; bug report from [shapiro@corto.inria.fr] -;; - -;;; -;;; alarson@src.honeywell.com 92-Feb-13 -;;; 1. Made bibtex-entry user callable, now prompts for entry type (e.g. -;;; Article), with completion, and bound it to a key. This is now my -;;; preferred way to add most entries. -;;; 2. Made fields of a bibtex entry derived from the alist bibtex-entry- -;;; field-alist. -;;; 3. Fixed handling of escaped double quotes, e.g. "Schr{\"o}dinger". -;;; 4. Fixed bug where unhiding bibtex entries moved point. -;;; 5. Made "field name" specs permit (name . value) for defaulting. E.g. -;;; (setq bibtex-mode-user-optional-fields '(("library" . "alarson"))) -;;; will generate the field: -;;; library = "alarson", -;;; 6. Added binding for narrow-to-bibtex-entry -;;; 7. Adding a bibtex entry now runs hook: bibtex-add-entry-hook -;;; 8. Made bibtex-clean-entry fixup text alignment, and eliminated the -;;; dependency on bibtex-enclosing-reference which has a problem with -;;; long entries (e.g. those containing abstracts). -;;; -;;; alarson@src.honeywell.com 92-Jan-31 -;;; Added support for: ispell, beginning/end of entry movement, a simple -;;; outline like mode (hide the bodies of bibtex entries), support for -;;; sorting bibtex entries, and maintaining them in sorted order, and -;;; simple buffer validation. -;;; User visible functions added: -;;; ispell-{abstract,bibtex-entry}, {beginning,end}-of-bibtex-entry -;;; hide-bibtex-entry-bodies, sort-bibtex-entries, validate-bibtex- -;;; buffer, find-bibtex-duplicates -;;; user visible variables added: -;;; bibtex-maintain-sorted-entries -;;; new local keybindings: -;;; " tex-insert-quote -;;; C-c$ ispell-bibtex-entry -;;; M-C-a beginning-of-bibtex-entry -;;; M-C-e end-of-bibtex-entry -;;; Mike Newton (newton@gumby.cs.caltech.edu) 90.11.17 -;;; * Handle items like -;;; title = poft # "Fifth Tri-quarterly" # random-conf, -;;; and title = {This title is inside curlies} -;;; * added user settable, always present, optional fields -;;; * fixed 'bibtex-find-it's doc string's location -;;; * bibtex-field-text made more general (it wouldn't handle the # construct) -;;; and it now handles a small subset of the {} cases - -;;; Bengt Martensson, March 6 -;;; Adapted to Bibtex 0.99 by updating the optional fields according -;;; to the document BibTeXing, Oren Patashnik, dated January 31, 1988. -;;; Updated documentation strings accordingly. Added (provide 'bibtex). -;;; If bibtex-include-OPT-crossref is non-nil, every entry will have -;;; an OPTcrossref field, analogously for bibtex-include-OPTkey and -;;; bibtex-include-OPTannote. Added bibtex-preamble, bound to ^C^EP, -;;; and also found in X- and sun-menus. Cleaned up the sun-menu -;;; stuff, and made it more uniform with the X-menu stuff. Marc: I -;;; strongly suspect that I broke your parsing... (Or, more -;;; correctly, BibTeX 0.99 broke it.) -;;; Added bibtex-clean-entry-zap-empty-opts, defvar'd to t. If it -;;; is nil, bibtex-clean-entry will leave empty optional fields alone. - -;;; Marc Shapiro 1-feb-89: integrated changes by Bengt Martensson 88-05-06: -;;; Added Sun menu support. Locally bound to right mouse button in -;;; bibtex-mode. Emacs 18.49 allows local mouse bindings!! -;;; Commented out DEAthesis. - -;;; Marc Shapiro 6-oct-88 -;;; * skip-whitespace replaced by skip-chars-forward -;;; * use indent-to-column instead of inserting tabs (changes to -;;; bibtex-entry, bibtex-make-entry, bibtex-make-OPT-entry, renamed to -;;; bibtex-make-optional-entry) -;;; * C-c C-k deletes the current OPT entry entirely -;;; * C-c C-d replaces text of field with "" -;;; * renamed bibtex-find-it to bibtex-find-text. With arg, now goes to -;;; start of text. Fixed bugs in it. - -;;; Marc Shapiro 23-sep-88 -;;; * bibtex-clean-entry moves past end of entry. -;;; * bibtex-clean-entry signals mandatory fields left empty. - -;;; Marc Shapiro 18-jul-88 -;;; * Fixed bug in bibtex-flash-entry -;;; * Moved all the entry type keystrokes to "C-c C-e something" (instead of -;;; "C-c something" previously) to make room for more. C-c C-e is -;;; supposed to stand for "entry" [idea taken from mail-mode]. Moved -;;; bibtex-pop-previous to C-c C-p and bibtex-pop-next to C-c C-n. -;;; * removed binding for "\e[25~" -;;; * replaced bibtex-clean-optionals by bibtex-clean-entry, bound to -;;; C-c C-c - -;;; Marc Shapiro 13-jul-88 [based on ideas by Sacha Krakowiak of IMAG] -;;; * bibtex-pop-previous replaces current field with value of -;;; similar field in previous entry. May be called n times in a row -;;; (or with arg n) to pop similar field of n'th previous entry. -;;; There is also a bibtex-pop-next to get similar field of next -;;; entry. -;;; * C-c C-k now kills all empty optional fields of current entry, and -;;; removes "OPT" for those optional fields which have text. - -;;; Marc Shapiro 14-dec-87 -;;; Cosmetic fixes. Fixed small bug in bibtex-move-outside-of-entry. -;;; Skip Montanaro 7-dec-87, Shapiro 10-dec-87 -;;; before inserting an entry, make sure we are outside of a bib entry -;;; Marc Shapiro 3-nov-87 -;;; addition for France: DEAthesis -;;; Marc Shapiro 19-oct-1987 -;;; add X window menu option; bug fixes. TAB, LFD, C-c " and C-c C-o now -;;; behave consistently; deletion never occurs blindly. -;;; Marc Shapiro 15-oct-1986 -;;; align long lines nicely; C-c C-o checks for the "OPT" string; -;;; TAB goes to the end of the string; use lower case; use -;;; run-hooks - -;;; Bengt Martensson 87-06-28 -;;; Bengt Martensson 87-06-28 -;;; Original version - -;;; Code: - -;;; NOTE by Marc Shapiro, 14-dec-87: -;;; (bibtex-x-environment) binds an X menu for bibtex mode to x-button-c-right. -;;; Trouble is, in Emacs 18.44 you can't have a mode-specific mouse binding, -;;; so it will remain active in all windows. Yuck! - -(provide 'bibtex) - -;;; these guys typically don't have autoloads...[alarson:19920131.1548CST] -;;; Check for fboundp first so that if user autoloads them from non standard -;;; places, the users bindings will take precedence. -(if (not (fboundp 'tex-insert-quote)) - (autoload 'tex-insert-quote "tex-mode")) -(if (not (fboundp 'sort-subr)) - (autoload 'sort-subr "sort")) - -;;; These should be in a more generally accessible location. - -(defun string-equalp (s1 s2) - "Like string= except differences in case are ignored." - (let ((ss1 (if (symbolp s1) (symbol-name s1) s1)) - (ss2 (if (symbolp s2) (symbol-name s2) s2))) - (and (= (length ss1) (length ss2)) - (string-equal (upcase ss1) (upcase ss2))))) - -;;; This should be moved into simple.el, and the functions there modified -;;; to call it rather than doing it themselves. -(defun put-string-on-kill-ring (string) - "Make STRING be the first element of the kill ring." - (setq kill-ring (cons string kill-ring)) - (if (> (length kill-ring) kill-ring-max) - (setcdr (nthcdr (1- kill-ring-max) kill-ring) nil)) - (setq kill-ring-yank-pointer kill-ring)) - - - - -(defvar bibtex-clean-entry-zap-empty-opts t - "*If non-nil, bibtex-clean-entry will delete all empty optional fields.") - -(defvar bibtex-include-OPTcrossref t - "*If non-nil, all entries will have an OPTcrossref field.") -(defvar bibtex-include-OPTkey t - "*If non-nil, all entries will have an OPTkey field.") -(defvar bibtex-include-OPTannote t - "*If non-nil, all entries will have an OPTannote field.") - -;; note: the user should be allowed to have their own list of always -;; available optional fields. exs: "keywords" "categories" - -(defvar bibtex-mode-user-optional-fields nil ;no default value - "*List of optional fields that user want to have as always present -when making a bibtex entry. One possibility is for ``keywords''. -Entries can be either strings or conses, in which case the car should be -string and the cdr the value to be inserted.") - -(defvar bibtex-mode-syntax-table - (let ((st (make-syntax-table))) - ;; [alarson:19920214.1004CST] make double quote a string quote - (modify-syntax-entry ?\" "\"" st) - (modify-syntax-entry ?$ "$$ " st) - (modify-syntax-entry ?% "< " st) - (modify-syntax-entry ?' "w " st) - (modify-syntax-entry ?@ "w " st) - (modify-syntax-entry ?\\ "\\" st) - (modify-syntax-entry ?\f "> " st) - (modify-syntax-entry ?\n "> " st) - (modify-syntax-entry ?~ " " st) - st)) - -(defvar bibtex-mode-abbrev-table nil "") -(define-abbrev-table 'bibtex-mode-abbrev-table ()) -(defvar bibtex-mode-map - (let ((km (make-sparse-keymap))) - - (define-key km "\t" 'bibtex-find-text) - (define-key km "\n" 'bibtex-next-field) - (define-key km "\C-c\"" 'bibtex-remove-double-quotes) - (define-key km "\C-c\C-c" 'bibtex-clean-entry) - (define-key km "\C-c?" 'describe-mode) - (define-key km "\C-c\C-p" 'bibtex-pop-previous) - (define-key km "\C-c\C-n" 'bibtex-pop-next) - (define-key km "\C-c\C-k" 'bibtex-kill-optional-field) - (define-key km "\C-c\C-d" 'bibtex-empty-field) - - ;; [alarson:19920131.1543CST] - (define-key km "\"" 'tex-insert-quote) - (define-key km "\C-c$" 'ispell-bibtex-entry) - (define-key km "\M-\C-a" 'beginning-of-bibtex-entry) - (define-key km "\M-\C-e" 'end-of-bibtex-entry) - (define-key km "\C-c\C-b" 'bibtex-entry) -; (define-key km "\C-cn" 'narrow-to-bibtex-entry) - - (define-key km "\C-c\C-e\C-a" 'bibtex-Article) - (define-key km "\C-c\C-e\C-b" 'bibtex-Book) -; (define-key km "\C-c\C-e\C-d" 'bibtex-DEAthesis) - (define-key km "\C-c\C-e\C-c" 'bibtex-InProceedings) - (define-key km "\C-c\C-e\C-i" 'bibtex-InBook) - (define-key km "\C-c\C-ei" 'bibtex-InCollection) - (define-key km "\C-c\C-eI" 'bibtex-InProceedings) - (define-key km "\C-c\C-e\C-m" 'bibtex-Manual) - (define-key km "\C-c\C-em" 'bibtex-MastersThesis) - (define-key km "\C-c\C-eM" 'bibtex-Misc) - (define-key km "\C-c\C-o" 'bibtex-remove-OPT) - (define-key km "\C-c\C-e\C-p" 'bibtex-PhdThesis) - (define-key km "\C-c\C-ep" 'bibtex-Proceedings) - (define-key km "\C-c\C-eP" 'bibtex-preamble) - (define-key km "\C-c\C-e\C-t" 'bibtex-TechReport) - (define-key km "\C-c\C-e\C-s" 'bibtex-string) - (define-key km "\C-c\C-e\C-u" 'bibtex-Unpublished) - - (define-key km 'button3 'bibtex-menu) - km)) - -(defvar bibtex-pop-previous-search-point nil - "Next point where bibtex-pop-previous should start looking for a similar -entry.") - -(defvar bibtex-pop-next-search-point nil - "Next point where bibtex-pop-next should start looking for a similar -entry.") - -(defvar bibtex-entry-field-alist - '( - ("Article" . ((("author" "title" "journal" "year") - ("volume" "number" "pages" "month" "note")) - (("author" "title") - ("journal" "year" "volume" "number" "pages" - "month" "note")))) - ("Book" . ((("author" "title" "publisher" "year") - ("editor" "volume" "number" "series" "address" - "edition" "month" "note")))) - ("Booklet" . ((("title") - ("author" "howpublished" "address" "month" "year" "note")))) - - ;; France: Dipl\^{o}me d'Etudes Approfondies (similar to Master's) -; ("DEAthesis" . ((("author" "title" "school" "year") -; ("address" "month" "note")))) - - ("InBook" . ((("author" "title" "chapter" "publisher" "year") - ("editor" "pages" "volume" "number" "series" "address" - "edition" "month" "type" "note")) - (("author" "title" "chapter") - ("publisher" "year" "editor" "pages" "volume" "number" - "series" "address" "edition" "month" "type" "note")))) - - - ("InCollection" . ((("author" "title" - "booktitle" "publisher" "year") - ("editor" "volume" "number" "series" "type" "chapter" - "pages" "address" "edition" "month" "note")) - (("author" "title") - ("booktitle" "publisher" "year" - "editor" "volume" "number" "series" "type" "chapter" - "pages" "address" "edition" "month" "note")))) - - - ("InProceedings" . ((("author" "title" "booktitle" "year") - ("editor" "volume" "number" "series" "pages" - "organization" "publisher" "address" "month" "note")) - (("author" "title") - ("editor" "volume" "number" "series" "pages" - "booktitle" "year" - "organization" "publisher" "address" "month" "note")))) - - - ("Manual" . ((("title") - ("author" "organization" "address" "edition" "year" - "month" "note")))) - - ("MastersThesis" . ((("author" "title" "school" "year") - ("address" "month" "note" "type")))) - - ("Misc" . ((() - ("author" "title" "howpublished" "year" "month" "note")))) - - ("PhdThesis" . ((("author" "title" "school" "year") - ("address" "month" "type" "note")))) - - ("Proceedings" . ((("title" "year") - ("editor" "volume" "number" "series" "publisher" - "organization" "address" "month" "note")))) - - ("TechReport" . ((("author" "title" "institution" "year") - ("type" "number" "address" "month" "note")))) - - ("Unpublished" . ((("author" "title" "note") - ("year" "month")))) - ) - - "List of (entry-name (required optional) (crossref-required crossref-optional)) -tripples. If the third element is nil, then the first pair can be used. Required -and optional are lists of strings. All entry creation functions use this variable -to generate entries, and bibtex-entry ensures the entry type is valid. This -variable can be used for example to make bibtex manipulate a different set of entry -types, e.g. a crossreference document of organization types.") - - -;;; A bibtex file is a sequence of entries, either string definitions -;;; or reference entries. A reference entry has a type part, a -;;; key part, and a comma-separated sequence of fields. A string -;;; entry has a single field. A field has a left and right part, -;;; separated by a '='. The left part is the name, the right part is -;;; the text. Here come the definitions allowing to create and/or parse -;;; entries and fields: - -;;; fields -(defun bibtex-cfield (name text) - "Create a regexp for a bibtex field of name NAME and text TEXT" - (concat ",[ \t\n]*\\(" - name - "\\)[ \t\n]*=[ \t\n]*\\(" - text - "\\)")) -(defconst bibtex-name-in-cfield 1 - "The regexp subexpression number of the name part in bibtex-cfield.") -(defconst bibtex-text-in-cfield 2 - "The regexp subexpression number of the text part in bibtex-cfield.") - -;;; KAWATA Yasuro reported bug that "/" -;;; was not premitted in field names. The old value of this var was: -;;; "[A-Za-z][---A-Za-z0-9:_+]*" -;;; According to the LaTeX manual, page 71, the legal values are letters, -;;; digits, and punctuation other than comma. Section 2.1 defines -;;; punctuation as: -;;; .:;,?!`'()[]-/*@ -;;; and says that += can be used in normal text. Specifically #$%&~_^\{} -;;; are called out as special chars. Some experimentation with LaTeX -;;; indicates that # and ~ definitely don't work, but that the following -;;; citation does! \cite{a0.:;?!`'()[]-/*@_&$^+=|<>}. I chose here to -;;; permit _ since it was previously allowed, but otherwise to only handle -;;; punc and += -;;; Amendment: I couldn't get a regexp with both "[]"'s and hyphen to -;;; work. It looks like you need them both to be the first entries in a -;;; regexp pattern. [alarson:19930315.0900CST] - -(defconst bibtex-field-name "[A-Za-z][---A-Za-z0-9.:;?!`'()/*@_+=]*" - "Regexp defining the name part of a bibtex field.") - -;; bibtex-field-text must be able to handle -;; title = "Proc. Fifteenth Annual" # STOC, -;; month = "10~" # jan, -;; year = "{\noopsort{1973c}}1981", -;; month = apr # "-" # may, -;; key = {Volume-2}, -;; note = "Volume~2 is listed under Knuth \cite{book-full}" -;; i have added a few of these, but not all! -- MON - -(defconst bibtex-field-const - "[0-9A-Za-z][---A-Za-z0-9:_+]*" - "Format of a bibtex field constant.") - -(defconst bibtex-field-string - (concat - "\"[^\"]*[^\\\\]\"\\|\"\"") - "Match either a string or an empty string.") - -(defconst bibtex-field-string-or-const - (concat bibtex-field-const "\\|" bibtex-field-string) - "Match either bibtex-field-string or bibtex-field-const.") - -(defconst bibtex-field-text - (concat - "\\(" bibtex-field-string-or-const "\\)" - "\\([ \t\n]+#[ \t\n]+\\(" bibtex-field-string-or-const "\\)\\)*\\|" - "{[^{}]*[^\\\\]}") - "Regexp defining the text part of a bibtex field: either a string, or -an empty string, or a constant followed by one or more # / constant pairs. -Also matches simple {...} patterns.") - -;(defconst bibtex-field-text -; "\"[^\"]*[^\\\\]\"\\|\"\"\\|[0-9A-Za-z][---A-Za-z0-9:_+]*" -; "Regexp defining the text part of a bibtex field: either a string, or an empty string, or a constant.") - -(defconst bibtex-field - (bibtex-cfield bibtex-field-name bibtex-field-text) - "Regexp defining the format of a bibtex field") - -(defconst bibtex-name-in-field bibtex-name-in-cfield - "The regexp subexpression number of the name part in bibtex-field") -(defconst bibtex-text-in-field bibtex-text-in-cfield - "The regexp subexpression number of the text part in bibtex-field") - -;;; references -(defconst bibtex-reference-type - "@[A-Za-z]+" - "Regexp defining the type part of a bibtex reference entry") -(defconst bibtex-reference-head - (concat "^[ \t]*\\(" - bibtex-reference-type - "\\)[ \t]*[({]\\(" - bibtex-field-name - "\\)") - "Regexp defining format of the header line of a bibtex reference entry") -(defconst bibtex-type-in-head 1 - "The regexp subexpression number of the type part in bibtex-reference-head") -(defconst bibtex-key-in-head 2 - "The regexp subexpression number of the key part in -bibtex-reference-head") - -(defconst bibtex-reference - (concat bibtex-reference-head - "\\([ \t\n]*" bibtex-field "\\)*" - "[ \t\n]*[})]") - "Regexp defining the format of a bibtex reference entry") -(defconst bibtex-type-in-reference bibtex-type-in-head - "The regexp subexpression number of the type part in bibtex-reference") -(defconst bibtex-key-in-reference bibtex-key-in-head - "The regexp subexpression number of the key part in -bibtex-reference") - -;;; strings -(defconst bibtex-string - (concat "^[ \t]*@[sS][tT][rR][iI][nN][gG][ \t\n]*[({][ \t\n]*\\(" - bibtex-field-name - "\\)[ \t\n]*=[ \t\n]*\\(" - bibtex-field-text - "\\)[ \t\n]*[})]") - "Regexp defining the format of a bibtex string entry") -(defconst bibtex-name-in-string 1 - "The regexp subexpression of the name part in bibtex-string") -(defconst bibtex-text-in-string 2 - "The regexp subexpression of the text part in bibtex-string") - -(defconst bibtex-name-alignment 2 - "Alignment for the name part in BibTeX fields. -Chosen on aesthetic grounds only.") - -(defconst bibtex-text-alignment (length " organization = ") - "Alignment for the text part in BibTeX fields. -Equal to the space needed for the longest name part.") - -(defun bibtex-current-entry-label (&optional include-cite kill) - "Return the label of the bibtex entry containing, or preceding point. -Optional argument INCLUDE-CITE, if true means put a '\\cite{}' around the -returned value. Second optional argument KILL, if true, means place the -returned value in the kill buffer. Interactively; providing prefix -argument makes INCLUDE-CITE true, and kill is true by default. - -Rationale: -The intention is that someone will write a function that can be bound to -a mouse key so that people entering TeX can just mouse on the bibtex entry -and have the citation key inserted at the current point (which will almost -certainly be in some other buffer). In the interim this function is -marginally useful for keyboard binding and is not bound by default. -Suggested binding is ^C-k." - (interactive (list current-prefix-arg t)) - (save-excursion - (beginning-of-bibtex-entry) - (re-search-forward bibtex-reference-head (save-excursion (end-of-bibtex-entry) (point))) - (let* ((key (buffer-substring (match-beginning bibtex-key-in-head) - (match-end bibtex-key-in-head))) - (val (if include-cite - (format "\\cite{%s}" key) - key))) - (if kill - (put-string-on-kill-ring val)) - val))) - -;;; bibtex mode: - -;;;###autoload -(defun bibtex-mode () - "Major mode for editing bibtex files. - -\\{bibtex-mode-map} - -A command such as \\[bibtex-Book] will outline the fields for a BibTeX book entry. - -The optional fields start with the string OPT, and thus ignored by BibTeX. -The OPT string may be removed from a field with \\[bibtex-remove-OPT]. -\\[bibtex-kill-optional-field] kills the current optional field entirely. -\\[bibtex-remove-double-quotes] removes the double-quotes around the text of -the current field. \\[bibtex-empty-field] replaces the text of the current -field with the default \"\". - -The command \\[bibtex-clean-entry] cleans the current entry, i.e. (i) removes -double-quotes from entirely numerical fields, (ii) removes OPT from all -non-empty optional fields, (iii) removes all empty optional fields, and (iv) -checks that no non-optional fields are empty. - -Use \\[bibtex-find-text] to position the dot at the end of the current field. -Use \\[bibtex-next-field] to move to end of the next field. - -The following may be of interest as well: - - Functions: - find-bibtex-duplicates - find-bibtex-entry-location - hide-bibtex-entry-bodies - sort-bibtex-entries - validate-bibtex-buffer - - Variables: - bibtex-clean-entry-zap-empty-opts - bibtex-entry-field-alist - bibtex-include-OPTannote - bibtex-include-OPTcrossref - bibtex-include-OPTkey - bibtex-maintain-sorted-entries - bibtex-mode-user-optional-fields - -Fields: - address - Publisher's address - annote - Long annotation used for annotated bibliographies (begins sentence) - author - Name(s) of author(s), in BibTeX name format - booktitle - Book title when the thing being referenced isn't the whole book. - For book entries, the title field should be used instead. - chapter - Chapter number - crossref - The database key of the entry being cross referenced. - edition - Edition of a book (e.g., \"second\") - editor - Name(s) of editor(s), in BibTeX name format. - If there is also an author field, then the editor field should be - for the book or collection that the work appears in - howpublished - How something strange has been published (begins sentence) - institution - Sponsoring institution - journal - Journal name (macros are provided for many) - key - Alphabetizing and labeling key (needed when no author or editor) - month - Month (macros are provided) - note - To help the reader find a reference (begins sentence) - number - Number of a journal or technical report - organization - Organization (sponsoring a conference) - pages - Page number or numbers (use `--' to separate a range) - publisher - Publisher name - school - School name (for theses) - series - The name of a series or set of books. - An individual book will also have its own title - title - The title of the thing being referenced - type - Type of a technical report (e.g., \"Research Note\") to be used - instead of the default \"Technical Report\" - volume - Volume of a journal or multivolume work - year - Year---should contain only numerals ---------------------------------------------------------- -Entry to this mode calls the value of bibtex-mode-hook if that value is -non-nil." - (interactive) - (kill-all-local-variables) - (set-syntax-table bibtex-mode-syntax-table) - (use-local-map bibtex-mode-map) - (setq major-mode 'bibtex-mode) - (setq mode-name "BibTeX") - (set-syntax-table bibtex-mode-syntax-table) - (setq local-abbrev-table bibtex-mode-abbrev-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start "^[ \f\n\t]*$") - (auto-fill-mode 1) ; nice alignments - (setq left-margin (+ bibtex-text-alignment 1)) - - (run-hooks 'bibtex-mode-hook)) - -(defun bibtex-move-outside-of-entry () - "Make sure we are outside of a bib entry" - (cond ((or - (= (point) (point-max)) - (= (point) (point-min)) - (looking-at "[ \n]*@") - ) - t) - (t - (backward-paragraph) - (forward-paragraph))) - (re-search-forward "[ \t\n]*" (point-max) t)) - -(defun ispell-abstract () - (interactive) - (beginning-of-bibtex-entry) - (re-search-forward "^[ \t]*[OPT]*abstract[ \t]*=") - (ispell-region (point) - (save-excursion (forward-sexp) (point)))) - -(defun beginning-of-bibtex-entry () - (interactive) - (re-search-backward "^@" nil 'move)) - -(defun skip-whitespace-and-comments () - ;; It might be a good idea to have forward-sexp with argument 0 do what - ;; this function tries to do, namely skip whitespace and comments. - ;; Maybe a better name for this would be skip-to-next-sexp. - ;; alternative implementation: - ;; (let ((parse-sexp-ignore-comments t)) - ;; (forward-sexp 1) - ;; (forward-sexp -1)) - ;; but I've had problems with this not getting the parse of comments - ;; right going backward if they contain unbalanced expressions or string - ;; quotes. [alarson:19920217.1021CST] - (let ((md (match-data))) - (unwind-protect - (while (cond ((looking-at "\\s>+\\|\\s +") - ;; was whitespace - ;; NOTE: also checked end-comment. In latex and - ;; lisp modes, newline is an end comment, but it - ;; should also be a whitespace char. - (goto-char (match-end 0))) - ;; If looking at beginning of comment, skip to end. - ((looking-at "\\s<") - (re-search-forward "\\s>")))) - (store-match-data md)))) - -;;; [alarson:19920214.1007CST] -(defun end-of-bibtex-entry () - "If inside an entry, move to the end of it, otherwise move to the end -of the next entry." - (interactive) - ;; if point was previously at the end of an entry, this puts us - ;; inside the next entry, otherwise we remain in the current one. - (progn - (skip-whitespace-and-comments) -;;; (skip-chars-forward " \t\n") - (end-of-line)) - (beginning-of-bibtex-entry) - (let ((parse-sexp-ignore-comments t)) - (forward-sexp) ; skip entry type - (forward-sexp) ; skip entry body - )) -;(defun end-of-bibtex-entry () -; (interactive) -; (re-search-forward "}$" nil 'move)) - -(defun ispell-bibtex-entry () - (interactive) - (ispell-region (progn (beginning-of-bibtex-entry) (point)) - (progn (end-of-bibtex-entry) (point)))) - -(defun narrow-to-bibtex-entry () - (interactive) - (save-excursion - (narrow-to-region (progn (beginning-of-bibtex-entry) (point)) - (progn (end-of-bibtex-entry) (point))))) - - -(defun beginning-of-first-bibtex-entry () - (goto-char (point-min)) - (cond - ((re-search-forward "^@" nil 'move) - (beginning-of-line)) - ((and (bobp) (eobp)) - nil) - (t - (message "Warning: No bibtex entries found!")))) - -(defun hide-bibtex-entry-bodies (&optional arg) - "Hide all lines between first and last bibtex entries not beginning with @. -With argument, show all text." - (interactive "P") - (save-excursion - (beginning-of-first-bibtex-entry) - ;; subst-char-in-region modifies the buffer, despite what the - ;; documentation says... - (let ((modifiedp (buffer-modified-p)) - (buffer-read-only nil)) - (if arg - (subst-char-in-region (point) (point-max) ?\r ?\n t) - (while (save-excursion (re-search-forward "\n[^@]" (point-max) t)) - (save-excursion (replace-regexp "\n\\([^@]\\)" "\r\\1")))) - (setq selective-display (not arg)) - (set-buffer-modified-p modifiedp)))) - -(defvar bibtex-sort-ignore-string-entries nil - "*If true, bibtex @STRING entries are ignored when determining ordering -of the buffer (e.g. sorting, locating alphabetical position for new entries, -etc.)") - -(defun sort-bibtex-entries () - "Sort bibtex entries alphabetically by key. -Text before the first bibtex entry, and following the last is not affected. -If bibtex-sort-ignore-string-entries is true, @string entries will be ignored. - -Bugs: - 1. Text between the closing brace ending one bibtex entry, and the @ starting - the next, is considered part of the PRECEDING entry. Perhaps it should be - part of the following entry." - (interactive) - (save-restriction - (beginning-of-first-bibtex-entry) - (narrow-to-region (point) - (save-excursion - (goto-char (point-max)) - (beginning-of-bibtex-entry) - (end-of-bibtex-entry) - (point))) - (sort-subr nil ; reversep - ;; beginning of record function - 'forward-line - ;; end of record function - (function (lambda () (and (re-search-forward "}\\s-*\n[\n \t]*@" nil 'move) - (forward-char -2)))) - ;; start of key function - (if bibtex-sort-ignore-string-entries - (function (lambda () - (while (and (re-search-forward "^\\s-*\\([@a-zA-Z]*\\)\\s-*{\\s-*") - (string-equalp "@string" - (buffer-substring (match-beginning 1) - (match-end 1))))) - nil)) - (function (lambda () (re-search-forward "{\\s-*") nil))) - ;; end of key function - (function (lambda () (search-forward ","))) - ))) - -(defun map-bibtex-entries (fun) - "Call FUN for each bibtex entry starting with the current, to the end of the file. -FUN is called with one argument, the key of the entry, and with point inside the entry. -If bibtex-sort-ignore-string-entries is true, FUN will not be called for @string entries." - (beginning-of-bibtex-entry) - (while (re-search-forward "^@[^{]*{[ \t]*\\([^, ]*\\)" nil t) - (if (and bibtex-sort-ignore-string-entries - (string-equalp "@string{" - (buffer-substring (match-beginning 0) - (match-beginning 1)))) - nil ; ignore the @string entry. - (funcall fun (buffer-substring (match-beginning 1) (match-end 1)))))) - -(defun find-bibtex-entry-location (entry-name) - "Searches from beginning of current buffer looking for place to put the -bibtex entry named ENTRY-NAME. Buffer is assumed to be in sorted order, -without duplicates (see \\[sort-bibtex-entries]), if it is not, an error will -be signalled." - (interactive "sBibtex entry key: ") - (let ((previous nil) - point) - (beginning-of-first-bibtex-entry) - (or (catch 'done - (map-bibtex-entries (function (lambda (current) - (cond - ((string-equal entry-name current) - (error "Entry duplicates existing!")) - ((or (null previous) - (string< previous current)) - (setq previous current - point (point)) - (if (string< entry-name current) - (progn - (beginning-of-bibtex-entry) - ;; Many schemes append strings to - ;; existing entries to resolve them, - ;; so initial substring matches may - ;; indicate a duplicate entry. - (let ((idx (string-match (regexp-quote entry-name) current))) - (if (and (integerp idx) - (zerop idx)) - (progn - (message "Warning: Entry %s may be a duplicate of %s!" - entry-name current) - (ding t)))) - (throw 'done t)))) - ((string-equal previous current) - (error "Duplicate here with previous!")) - (t (error "Entries out of order here!"))))))) - (end-of-bibtex-entry)))) - -(defun validate-bibtex-buffer () - "Find some typical errors in bibtex files. - 1. At signs (@) not as first char of a line. - 2. Double quotes (\") inside strings. - 3. Closing braces (}) not the last character of a line." - (interactive) - (let ((point (point))) - (while (re-search-forward ".@" nil t) - (let* ((foo (parse-partial-sexp (save-excursion (beginning-of-bibtex-entry) - (point)) - (point))) - (in-a-string (nth 3 foo))) - (if (not in-a-string) - (error "At sign (@) out of place!")))) - (goto-char point) - (while (search-forward "\"" nil t) - (or (looking-at "[,}][ \t]*$") - (char-equal (preceding-char) ?\") - ;; some versions put closing brace on separate line. - (looking-at "[ \t]*\n}") - (save-excursion - (save-restriction - (narrow-to-region (point) - (progn (beginning-of-line) (point))) - (looking-at "^[ \t]*[a-zA-Z]+[ \t]*=[ \t]*\"$"))) - (error "Quote out of place, or missing \",\" or \"}\"!"))) - (goto-char point) - ;; This is only approximate, should actually search for close braces, - ;; then see if they are inside a string, or at the end of a line. - ;; This just gets the typical case of whitespace after a closing brace. - (while (search-forward "}[ \t]+$" nil t) - (error "Brace not last char of line!")) - (goto-char point) - (message "Bibtex buffer appears o.k."))) - -(defun find-bibtex-duplicates () - "Searches forward in current buffer looking for duplicate bibtex entries. -Buffer is assumed to be sorted, see \\[sort-bibtex-entries]" - (interactive) - (let ((point (point))) - ;; errors if things are not right... - (find-bibtex-entry-location (make-string 10 255)) - (goto-char point) - (message "No duplicates found!"))) - - -;;; assoc doesn't ignore case, so we need an assoc that does... -(defun assoc-string-equalp (thing alist) - (or (assoc thing alist) - (while (and alist - (not (string-equalp thing (car (car alist))))) - (setq alist (cdr alist))) - (car alist))) - -(defvar bibtex-maintain-sorted-entries nil - "*If true, bibtex-mode will attempt to maintain all bibtex entries in -sorted order. - -Note that this is more a property of a file than a personal preference and -as such should normally be set via a file local variable entry.") - -(defun bibtex-entry (entry-type &optional required optional) - (interactive (let* ((completion-ignore-case t) - (e-t (completing-read "Entry Type: " bibtex-entry-field-alist - nil t))) - (list e-t))) - (if (and (null required) (null optional)) - (let* ((e (assoc-string-equalp entry-type bibtex-entry-field-alist)) - (r-n-o (elt e 1)) - (c-ref (elt e 2))) - (if (null e) - (error "Bibtex entry type %s not defined!")) - (if (and bibtex-include-OPTcrossref c-ref) - (setq required (elt c-ref 0) - optional (elt c-ref 1)) - (setq required (elt r-n-o 0) - optional (elt r-n-o 1))))) - (let ((key (if bibtex-maintain-sorted-entries - (read-string (format "%s key: " entry-type))))) - (if key - (find-bibtex-entry-location key)) - (bibtex-move-outside-of-entry) - (insert "@" entry-type "{") - (if key - (insert key)) - (save-excursion - (mapcar 'bibtex-make-field required) - (if bibtex-include-OPTcrossref - (bibtex-make-optional-field "crossref")) - (if bibtex-include-OPTkey - (bibtex-make-optional-field "key")) - (mapcar 'bibtex-make-optional-field optional) - (mapcar 'bibtex-make-optional-field - bibtex-mode-user-optional-fields) - (if bibtex-include-OPTannote - (bibtex-make-optional-field "annote")) - (insert "\n}\n\n")) - (if key - (bibtex-next-field t)) - (run-hooks 'bibtex-add-entry-hook))) - -;; (defun bibtex-entry (entry-type required optional) -;; (bibtex-move-outside-of-entry) -;; (insert (concat "@" entry-type "{,\n\n}\n\n")) -;; (previous-line 3) -;; (insert (mapconcat 'bibtex-make-entry required ",\n")) -;; (if required -;; (if optional -;; (insert ",\n"))) -;; (insert (mapconcat 'bibtex-make-OPT-entry optional ",\n")) -;; (if bibtex-mode-user-optional-fields ;MON... -;; (progn -;; (if optional -;; (insert ",\n")) -;; (insert (mapconcat 'bibtex-make-OPT-entry -;; bibtex-mode-user-optional-fields -;; ",\n")))) ;MON -;; (up-list -1) -;; (forward-char 1)) - - -(defun bibtex-make-field (e-t) - (interactive "sBibTeX entry type: ") - (let ((name (if (consp e-t) (car e-t) e-t)) - (value (if (consp e-t) (cdr e-t) ""))) - (insert ",\n") - (indent-to-column bibtex-name-alignment) - (insert name " = ") - (indent-to-column bibtex-text-alignment) - ;; lucid emacs prin1-to-string breaks the undo chain. When they fix - ;; that, the hack can be removed. [alarson:19930316.0805CST] -; (insert (prin1-to-string value)) - ;; begin hack - (insert (format (if (stringp value) "\"%s\"" "%s") - value)) - ;; end hack - nil)) - -(defun bibtex-make-optional-field (e-t) - (interactive "sOptional BibTeX entry type: ") - (if (consp e-t) - (setq e-t (cons (concat "OPT" (car e-t)) (cdr e-t))) - (setq e-t (concat "OPT" e-t))) - (bibtex-make-field e-t)) - -;; What to do about crossref? if present, journal and year are -;; both optional. Due to this, i move all of them into optional. -- MON - -(defun bibtex-Article () - (interactive) - (bibtex-entry "Article")) - -(defun bibtex-Book () - (interactive) - (bibtex-entry "Book")) - -(defun bibtex-Booklet () - (interactive) - (bibtex-entry "Booklet")) - -;(defun bibtex-DEAthesis () -; (interactive) -; (bibtex-entry "DEAthesis")) - -(defun bibtex-InBook () - (interactive) - (bibtex-entry "InBook")) - -(defun bibtex-InCollection () - (interactive) - (bibtex-entry "InCollection")) - -(defun bibtex-InProceedings () - (interactive) - (bibtex-entry "InProceedings")) - -(defun bibtex-Manual () - (interactive) - (bibtex-entry "Manual")) - -(defun bibtex-MastersThesis () - (interactive) - (bibtex-entry "MastersThesis")) - -(defun bibtex-Misc () - (interactive) - (bibtex-entry "Misc")) - -(defun bibtex-PhdThesis () - (interactive) - (bibtex-entry "PhdThesis")) - -(defun bibtex-Proceedings () - (interactive) - (bibtex-entry "Proceedings")) - -(defun bibtex-TechReport () - (interactive) - (bibtex-entry "TechReport")) - -(defun bibtex-Unpublished () - (interactive) - (bibtex-entry "Unpublished")) - -(defun bibtex-string () - (interactive) - (bibtex-move-outside-of-entry) - (insert "@string{ = \"\"}\n") - (previous-line 1) - (forward-char 8)) - -(defun bibtex-preamble () - (interactive) - (bibtex-move-outside-of-entry) - (insert "@Preamble{}\n") - (previous-line 1) - (forward-char 10)) - -(defun bibtex-next-field (arg) - "Finds end of text of next BibTeX field; with arg, to its beginning" - (interactive "P") - (bibtex-inside-field) - (let ((start (point))) - (condition-case () - (progn - (bibtex-enclosing-field) - (goto-char (match-end 0)) - (forward-char 2)) - (error - (goto-char start) - (end-of-line) - (forward-char 1)))) - (bibtex-find-text arg)) - -;; (defun bibtex-next-field () -;; "Finds end of text of next field." -;; (interactive) -;; (condition-case () -;; (progn -;; (bibtex-inside-field) -;; (re-search-forward ",[ \t\n]*" (point-max) 1) -;; (bibtex-enclosing-field) -;; (bibtex-inside-field)) -;; (error nil))) - -(defun bibtex-find-text (arg) - "Go to end of text of current field; with arg, go to beginning." - (interactive "P") - (bibtex-inside-field) - (bibtex-enclosing-field) - (if arg - (progn - (goto-char (match-beginning bibtex-text-in-field)) - (if (looking-at "\"") - (forward-char 1))) - (goto-char (match-end bibtex-text-in-field)) - (if (= (preceding-char) ?\") - (forward-char -1)))) - -;; (defun bibtex-find-text () -;; "Go to end of text of current field." -;; (interactive) -;; (condition-case () -;; (progn -;; (bibtex-inside-field) -;; (bibtex-enclosing-field) -;; (goto-char (match-end bibtex-text-in-field)) -;; (bibtex-inside-field)) -;; (error nil))) - -(defun bibtex-remove-OPT () - "Removes the 'OPT' starting optional arguments and goes to end of text" - (interactive) - (bibtex-inside-field) - (bibtex-enclosing-field) - (save-excursion - (goto-char (match-beginning bibtex-name-in-field)) - (if (looking-at "OPT") - ;; sct@dcs.edinburgh.ac.uk - (progn - (delete-char (length "OPT")) - (search-forward "=") - (delete-horizontal-space) - (indent-to-column bibtex-text-alignment)))) - (bibtex-inside-field)) - -(defun bibtex-inside-field () - "Try to avoid point being at end of a bibtex field." - (interactive) - (end-of-line) - (skip-chars-backward " \t") ;MON - maybe delete these chars? - (cond ((= (preceding-char) ?,) - (forward-char -2))) ; -1 --> -2 sct@dcs.edinburgh.ac.uk - (cond ((= (preceding-char) ?\") - (forward-char -1)))) ;MON - only go back if quote - -(defun bibtex-remove-double-quotes () - "Removes \"\" around string." - (interactive) - (save-excursion - (bibtex-inside-field) - (bibtex-enclosing-field) - (let ((start (match-beginning bibtex-text-in-field)) - (stop (match-end bibtex-text-in-field))) - (goto-char stop) - (forward-char -1) - (if (looking-at "\"") - (delete-char 1)) - (goto-char start) - (if (looking-at "\"") - (delete-char 1))))) - -(defun bibtex-kill-optional-field () - "Kill the entire enclosing optional BibTeX field" - (interactive) - (bibtex-inside-field) - (bibtex-enclosing-field) - (goto-char (match-beginning bibtex-name-in-field)) - (let ((the-end (match-end 0)) - (the-beginning (match-beginning 0))) - (if (looking-at "OPT") - (progn - (goto-char the-end) - (skip-chars-forward " \t\n,") - (kill-region the-beginning the-end)) - (error "Mandatory fields can't be killed")))) - -(defun bibtex-empty-field () - "Delete the text part of the current field, replace with empty text" - (interactive) - (bibtex-inside-field) - (bibtex-enclosing-field) - (goto-char (match-beginning bibtex-text-in-field)) - (kill-region (point) (match-end bibtex-text-in-field)) - (insert "\"\"") - (bibtex-find-text t)) - - -(defun bibtex-pop-previous (arg) - "Replace text of current field with the text of similar field in previous entry. -With arg, go up ARG entries. Repeated, goes up so many times. May be -intermixed with \\[bibtex-pop-next] (bibtex-pop-next)." - (interactive "p") - (bibtex-inside-field) - (save-excursion - ; parse current field - (bibtex-enclosing-field) - (let ((start-old-text (match-beginning bibtex-text-in-field)) - (stop-old-text (match-end bibtex-text-in-field)) - (start-name (match-beginning bibtex-name-in-field)) - (stop-name (match-end bibtex-name-in-field)) - (new-text)) - (goto-char start-name) - ; construct regexp for previous field with same name as this one - (let ((matching-entry - (bibtex-cfield - (buffer-substring (if (looking-at "OPT") - (+ (point) (length "OPT")) - (point)) - stop-name) - bibtex-field-text))) - - ; if executed several times in a row, start each search where the - ; last one finished - (cond ((or (eq last-command 'bibtex-pop-previous) - (eq last-command 'bibtex-pop-next)) - t - ) - (t - (bibtex-enclosing-reference) - (setq bibtex-pop-previous-search-point (match-beginning 0)) - (setq bibtex-pop-next-search-point (match-end 0)))) - (goto-char bibtex-pop-previous-search-point) - - ; Now search for arg'th previous similar field - (cond - ((re-search-backward matching-entry (point-min) t arg) - (setq new-text - (buffer-substring (match-beginning bibtex-text-in-cfield) - (match-end bibtex-text-in-cfield))) - ; Found a matching field. Remember boundaries. - (setq bibtex-pop-next-search-point (match-end 0)) - (setq bibtex-pop-previous-search-point (match-beginning 0)) - (bibtex-flash-head) - ; Go back to where we started, delete old text, and pop new. - (goto-char stop-old-text) - (delete-region start-old-text stop-old-text) - (insert new-text)) - (t ; search failed - (error "No previous matching BibTeX field.")))))) - (setq this-command 'bibtex-pop-previous)) - -(defun bibtex-pop-next (arg) - "Replace text of current field with the text of similar field in next entry. -With arg, go up ARG entries. Repeated, goes up so many times. May be -intermixed with \\[bibtex-pop-previous] (bibtex-pop-previous)." - (interactive "p") - (bibtex-inside-field) - (save-excursion - ; parse current field - (bibtex-enclosing-field) - (let ((start-old-text (match-beginning bibtex-text-in-field)) - (stop-old-text (match-end bibtex-text-in-field)) - (start-name (match-beginning bibtex-name-in-field)) - (stop-name (match-end bibtex-name-in-field)) - (new-text)) - (goto-char start-name) - ; construct regexp for next field with same name as this one, - ; ignoring possible OPT's - (let ((matching-entry - (bibtex-cfield - (buffer-substring (if (looking-at "OPT") - (+ (point) (length "OPT")) - (point)) - stop-name) - bibtex-field-text))) - - ; if executed several times in a row, start each search where the - ; last one finished - (cond ((or (eq last-command 'bibtex-pop-next) - (eq last-command 'bibtex-pop-previous)) - t - ) - (t - (bibtex-enclosing-reference) - (setq bibtex-pop-previous-search-point (match-beginning 0)) - (setq bibtex-pop-next-search-point (match-end 0)))) - (goto-char bibtex-pop-next-search-point) - - ; Now search for arg'th next similar field - (cond - ((re-search-forward matching-entry (point-max) t arg) - (setq new-text - (buffer-substring (match-beginning bibtex-text-in-cfield) - (match-end bibtex-text-in-cfield))) - ; Found a matching field. Remember boundaries. - (setq bibtex-pop-next-search-point (match-end 0)) - (setq bibtex-pop-previous-search-point (match-beginning 0)) - (bibtex-flash-head) - ; Go back to where we started, delete old text, and pop new. - (goto-char stop-old-text) - (delete-region start-old-text stop-old-text) - (insert new-text)) - (t ; search failed - (error "No next matching BibTeX field.")))))) - (setq this-command 'bibtex-pop-next)) - -(defun bibtex-flash-head () - "Flash at BibTeX reference head before point, if exists. (Moves point)." - (let ((flash)) - (cond ((re-search-backward bibtex-reference-head (point-min) t) - (goto-char (match-beginning bibtex-type-in-head)) - (setq flash (match-end bibtex-key-in-reference))) - (t - (end-of-line) - (skip-chars-backward " \t") - (setq flash (point)) - (beginning-of-line) - (skip-chars-forward " \t"))) - (if (pos-visible-in-window-p (point)) - (sit-for 1) - (message "From: %s" - (buffer-substring (point) flash))))) - - - -(defun bibtex-enclosing-field () - "Search for BibTeX field enclosing point. -Point moves to end of field; also, use match-beginning and match-end -to parse the field." - ;; sct@dcs.edinburgh.ac.uk - (let ((old-point (point))) - (condition-case errname - (bibtex-enclosing-regexp bibtex-field) - (search-failed - (goto-char old-point) - (error "Can't find enclosing BibTeX field."))))) - -(defun bibtex-enclosing-reference () - "Search for BibTeX reference enclosing point. -Point moves to end of reference; also, use match-beginning and match-end -to parse the reference." - ;; sct@dcs.edinburgh.ac.uk - (let ((old-point (point))) - (condition-case errname - (bibtex-enclosing-regexp bibtex-reference) - (search-failed - (goto-char old-point) - (error "Can't find enclosing BibTeX reference."))))) - -(defun bibtex-enclosing-regexp (regexp) - "Search for REGEXP enclosing point. -Point moves to end of REGEXP. See also match-beginning and match-end. -If an enclosing REGEXP is not found, signals search-failed; point is left in -an undefined location. - -[Doesn't something like this exist already?]" - - (interactive "sRegexp: ") - ; compute reasonable limits for the loop - (let* ((initial (point)) - (right (if (re-search-forward regexp (point-max) t) - (match-end 0) - (point-max))) - (left - (progn - (goto-char initial) - (if (re-search-backward regexp (point-min) t) - (match-beginning 0) - (point-min))))) - ; within the prescribed limits, loop until a match is found - (goto-char left) - (re-search-forward regexp right nil 1) - (if (> (match-beginning 0) initial) - (signal 'search-failed (list regexp))) - (while (<= (match-end 0) initial) - (re-search-forward regexp right nil 1) - (if (> (match-beginning 0) initial) - (signal 'search-failed (list regexp)))) - )) - -(defun bibtex-clean-entry () - "For all optional fields of current BibTeX entry: if empty, kill the whole field; otherwise, remove the \"OPT\" string in the name; if text numerical, remove double-quotes. For all mandatory fields: if empty, signal error." - (interactive) - (beginning-of-bibtex-entry) - (let ((start (point))) - (save-restriction - (narrow-to-region start (save-excursion (end-of-bibtex-entry) (point))) - (while (re-search-forward bibtex-field (point-max) t 1) - (let ((begin-field (match-beginning 0)) - (end-field (match-end 0)) - (begin-name (match-beginning bibtex-name-in-field)) - (end-name (match-end bibtex-name-in-field)) - (begin-text (match-beginning bibtex-text-in-field)) - (end-text (match-end bibtex-text-in-field)) - ) - (goto-char begin-name) - (cond ((and - (looking-at "OPT") - bibtex-clean-entry-zap-empty-opts) - (goto-char begin-text) - (if (looking-at "\"\"") ; empty: delete whole field - (delete-region begin-field end-field) - ; otherwise: not empty, delete "OPT" - (goto-char begin-name) - (delete-char (length "OPT")) - (progn - ;; fixup alignment. [alarson:19920309.2047CST] - (search-forward "=") - (delete-horizontal-space) - (indent-to-column bibtex-text-alignment)) - (goto-char begin-field) ; and loop to go through next test - )) - (t - (goto-char begin-text) - (cond ((looking-at "\"[0-9]+\"") ; if numerical, - (goto-char end-text) - (delete-char -1) ; delete enclosing double-quotes - (goto-char begin-text) - (delete-char 1) - (goto-char end-field) ; go to end for next search - (forward-char -2) ; to compensate for the 2 quotes deleted - ) - ((looking-at "\"\"") ; if empty quotes, complain - (forward-char 1) - (if (not (or (equal (buffer-substring - begin-name - (+ begin-name 3)) - "OPT") - (equal (buffer-substring - begin-name - (+ begin-name 3)) - "opt"))) - (error "Mandatory field ``%s'' is empty" - (buffer-substring begin-name end-name)))) - (t - (goto-char end-field)))))))) - (goto-char start) - (end-of-bibtex-entry) - ;; sct@dcs.edinburgh.ac.uk - (save-excursion - (previous-line 1) - (end-of-line) - (if (eq (preceding-char) ?,) - (backward-delete-char 1))) - (skip-whitespace-and-comments))) - - -;;; Menus for bibtex mode - -(defconst bibtex-menu - '("BibTeX Commands" - "Entry Types" - "---" - ["Article in Conference Proceedings" bibtex-InProceedings t] - ["Article in Journal" bibtex-Article t] - ["Book" bibtex-Book t] - ["Booklet" bibtex-Booklet t] - ["Conference" bibtex-InProceedings t] - ["Master's Thesis" bibtex-MastersThesis t] - ["DEA Thesis" bibtex-DEAthesis t] - ["Phd. Thesis" bibtex-PhdThesis t] - ["Technical Report" bibtex-TechReport t] - ["Technical Manual" bibtex-Manual t] - ["Conference Proceedings" bibtex-Proceedings t] - ["A Chapter in a Book" bibtex-InBook t] - ["An Article in a Collection" bibtex-InCollection t] - ["Miscellaneous" bibtex-Misc t] - ["Unpublished" bibtex-Unpublished t] - ["String" bibtex-string t] - ["Preamble" bibtex-preamble t] - "---" - "Bibtex Edit" - "---" - ["Next Field" bibtex-next-field t] - ["To End of Field" bibtex-find-text t] - ["Snatch From Similar Preceding Field" bibtex-pop-previous t] - ["Snatch From Similar Following Field" bibtex-pop-next t] - ["Remove OPT" bibtex-remove-OPT t] - ["Remove Quotes" bibtex-remove-double-quotes t] - ["Clean Up Entry" bibtex-clean-entry t] - ["Find Duplicates" find-bibtex-duplicates t] - ["Sort Entries" sort-bibtex-entries t] - ["Validate Entries" validate-bibtex-buffer t] - )) - -(defun bibtex-menu () - (interactive) - (let ((popup-menu-titles nil)) - (popup-menu bibtex-menu))) - -;;; bibtex.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/c-comment.el --- a/lisp/modes/c-comment.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,332 +0,0 @@ -;;; c-comment.el --- edit C comments - -;; Copyright (C) 1987, 1988, 1989 Kyle E. Jones -;; Copyright (C) 1997 Free Software Foundation, Inc. - -;; Author: Kyle Jones -;; Maintainer: XEmacs Development Team -;; Keywords: languages - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Not in FSF. - -;;; Commentary: - -;; -;; Verbatim copies of this file may be freely redistributed. -;; -;; Modified versions of this file may be redistributed provided that this -;; notice remains unchanged, the file contains prominent notice of -;; author and time of modifications, and redistribution of the file -;; is not further restricted in any way. -;; -;; This file is distributed `as is', without warranties of any kind. - -;; sb [23-Oct-1997] Put into standard format, fixed an autoload cookie. - -;;; Code: - -(provide 'c-comment-edit) - -(defvar c-comment-leader " *" - "*Leader used when rebuilding edited C comments. The value of this variable -should be a two-character string. Values of \" \", \" *\" and \"**\" produce the -comment styles: - /* /* /* - ... * ... ** ... - ... * ... ** ... - */ */ */ -respectively.") - -(defconst c-comment-leader-regexp "^[ ]*\\(\\*\\*\\|\\*\\)?[ ]?" - "Regexp used to match C comment leaders.") - -(defvar c-comment-edit-mode 'text-mode - "*Major mode used by `c-comment-edit' when editing C comments.") - -(defvar c-comment-edit-hook nil - "*Function to call whenever `c-comment-edit' is used. -The function is called just before the `c-comment-edit' function allows you to -begin editing the comment.") - -(defvar c-comment-edit-buffer-alist nil - "Assoc list of C buffers and their associated comment buffers. -Elements are of the form (C-BUFFER COMMENT-BUFFER COMMENT-START COMMENT-END) -COMMENT-START and COMMENT-END are markers in the C-BUFFER.") - -(defmacro save-point (&rest body) - "Save value of point, evalutes FORMS and restore value of point. -If the saved value of point is no longer valid go to (point-max). -The variable `save-point' is lambda-bound to the value of point for -the duration of this call." - (list 'let '((save-point (point))) - (list 'unwind-protect - (cons 'progn body) - '(goto-char (min (point-max) save-point))))) - -(defmacro marker (pos &optional buffer) - (list 'set-marker '(make-marker) pos buffer)) - -(defvar c-comment-edit-map nil "Key map for c-comment-edit buffers") -(if c-comment-edit-map - nil - (setq c-comment-edit-map (make-sparse-keymap)) - (define-key c-comment-edit-map [(meta control c)] 'c-comment-edit-end) - (define-key c-comment-edit-map [(control c) (control c)] 'c-comment-edit-end) - (define-key c-comment-edit-map [(control c) (control ?\])] 'c-comment-edit-abort)) - -;;;###autoload -(defun c-comment-edit (search-prefix) - "Edit multi-line C comments. -This command allows the easy editing of a multi-line C comment like this: - /* - * ... - * ... - */ -The comment may be indented or flush with the left margin. - -If point is within a comment, that comment is used. Otherwise the -comment to be edited is found by searching forward from point. - -With one \\[universal-argument] searching starts after moving back one - paragraph. -With two \\[universal-argument]'s searching starts at the beginning of the - current or proceeding C function. -With three \\[universal-argument]'s searching starts at the beginning of the - current page. -With four \\[universal-argument]'s searching starts at the beginning of the - current buffer (clipping restrictions apply). - -Once located, the comment is copied into a temporary buffer, the comment -leaders and delimiters are stripped away and the resulting buffer is -selected for editing. The major mode of this buffer is controlled by -the variable `c-comment-edit-mode'.\\ - -Use \\[c-comment-edit-end] when you have finished editing the comment. The -comment will be inserted into the original buffer with the appropriate -delimiters and indention, replacing the old version of the comment. If -you don't want your edited version of the comment to replace the -original, use \\[c-comment-edit-abort]." - (interactive "*P") - (let ((c-buffer (current-buffer)) - marker tem c-comment-fill-column c-comment-buffer - c-comment-start c-comment-end - (inhibit-quit t)) - ;; honor search-prefix - (cond ((equal search-prefix '(4)) - (backward-paragraph)) - ((equal search-prefix '(16)) - (end-of-defun) - (beginning-of-defun) - (backward-paragraph)) - ((equal search-prefix '(64)) - (backward-page)) - ((equal search-prefix '(256)) - (goto-char (point-min)))) - (if (and (null search-prefix) (setq tem (within-c-comment-p))) - (setq c-comment-start (marker (car tem)) - c-comment-end (marker (cdr tem))) - (let (start end) - (condition-case error-data - (save-point - (search-forward "/*") - (setq start (- (point) 2)) - (search-forward "*/") - (setq end (point))) - (search-failed (error "No C comment found."))) - (setq c-comment-start (marker start)) - (setq c-comment-end (marker end)))) - ;; calculate the correct fill-column for the comment - (setq c-comment-fill-column (- fill-column - (save-excursion - (goto-char c-comment-start) - (current-column)))) - ;; create the comment buffer - (setq c-comment-buffer - (generate-new-buffer (concat (buffer-name) " *C Comment Edit*"))) - ;; link into the c-comment-edit-buffer-alist - (setq c-comment-edit-buffer-alist - (cons (list (current-buffer) c-comment-buffer - c-comment-start c-comment-end) - c-comment-edit-buffer-alist)) - ;; copy to the comment to the comment-edit buffer - (copy-to-buffer c-comment-buffer (+ c-comment-start 2) (- c-comment-end 2)) - ;; mark the position of point, relative to the beginning of the - ;; comment, in the comment buffer. (iff point is within a comment.) - (or search-prefix (< (point) c-comment-start) - (setq marker (marker (+ (- (point) c-comment-start 2) 1) - c-comment-buffer))) - ;; select the comment buffer for editing - (switch-to-buffer c-comment-buffer) - ;; remove the comment leaders and delimiters - (goto-char (point-min)) - (while (not (eobp)) - (and (re-search-forward c-comment-leader-regexp nil t) - (replace-match "" nil t)) - (forward-line)) - ;; run appropriate major mode - (funcall (or c-comment-edit-mode 'fundamental-mode)) - ;; override user's default fill-column here since it will lose if - ;; the comment is indented in the C buffer. - (setq fill-column c-comment-fill-column) - ;; delete one leading whitespace char - (goto-char (point-min)) - (if (looking-at "[ \n\t]") - (delete-char 1)) - ;; restore cursor if possible - (goto-char (or marker (point-min))) - (set-buffer-modified-p nil) - (use-local-map c-comment-edit-map c-comment-buffer)) - ;; run user hook, if present. - (if c-comment-edit-hook - (funcall c-comment-edit-hook)) - ;; final admonition - (message - (substitute-command-keys - "Type \\[c-comment-edit-end] to end edit, \\[c-comment-edit-abort] to abort with no change."))) - -(defun c-comment-edit-end () - "End c-comment-edit. -C comment is replaced by its edited counterpart in the appropriate C buffer. -Indentation will be the same as the original." - (interactive) - (let ((tuple (find-c-comment-buffer))) - (if (null tuple) - (error "Not a c-comment-edit buffer.")) - (let ((inhibit-quit t) - (c-comment-c-buffer (car tuple)) - (c-comment-buffer (nth 1 tuple)) - (c-comment-start (nth 2 tuple)) - (c-comment-end (nth 3 tuple))) - (cond - ((buffer-modified-p) - ;; rebuild the comment - (goto-char (point-min)) - (insert "/*\n") - (if (string= c-comment-leader " ") - (while (not (eobp)) - (if (not (eolp)) - (insert c-comment-leader " ")) - (forward-line)) - (while (not (eobp)) - (insert c-comment-leader (if (eolp) "" " ")) - (forward-line))) - (if (not (char-equal (preceding-char) ?\n)) - (insert "\n")) - (insert (if (string= c-comment-leader " *") " */" "*/")) - ;; indent if necessary - (let ((indention - (save-excursion - (set-buffer c-comment-c-buffer) - (goto-char c-comment-start) - (current-column)))) - (goto-char (point-min)) - (cond ((not (zerop indention)) - ;; first line is already indented - ;; in the C buffer - (forward-line) - (while (not (eobp)) - (indent-to indention) - (forward-line))))) - ;; replace the old comment with the new - (save-excursion - (set-buffer c-comment-c-buffer) - (save-point - (save-excursion - (delete-region c-comment-start c-comment-end) - (goto-char c-comment-start) - (set-buffer c-comment-buffer) - (append-to-buffer c-comment-c-buffer - (point-min) (point-max)))))) - (t (message "No change."))) - ;; switch to the C buffer - (if (get-buffer-window c-comment-c-buffer) - (select-window (get-buffer-window c-comment-c-buffer)) - (switch-to-buffer c-comment-c-buffer)) - ;; delete the window viewing the comment buffer - (and (get-buffer-window c-comment-buffer) - (delete-window (get-buffer-window c-comment-buffer))) - ;; unlink the tuple from c-comment-edit-buffer-alist - (setq c-comment-edit-buffer-alist - (delq tuple c-comment-edit-buffer-alist)) - ;; let Emacs reclaim various resources - (save-excursion - (set-buffer c-comment-buffer) - (set-buffer-modified-p nil) - (kill-buffer c-comment-buffer)) - (set-marker c-comment-start nil) - (set-marker c-comment-end nil)))) - -(defun c-comment-edit-abort () - "Abort a c-comment-edit with no change." - (interactive) - (let* ((tuple (find-c-comment-buffer)) - (c-comment-c-buffer (car tuple)) - (c-comment-buffer (nth 1 tuple)) - (c-comment-start (nth 2 tuple)) - (c-comment-end (nth 3 tuple))) - (if (null tuple) - (error "Not a c-comment-edit buffer.")) - ;; switch to the C buffer - (if (get-buffer-window c-comment-c-buffer) - (select-window (get-buffer-window c-comment-c-buffer)) - (switch-to-buffer c-comment-c-buffer)) - (let ((inhibit-quit t)) - (save-excursion - (set-buffer c-comment-buffer) - (set-buffer-modified-p nil) - (kill-buffer c-comment-buffer)) - ;; unlink the tuple from c-comment-edit-buffer-alist - (setq c-comment-edit-buffer-alist - (delq tuple c-comment-edit-buffer-alist)) - (set-marker c-comment-start nil) - (set-marker c-comment-end nil) - (message "Aborted with no change.")))) - -;; this loses on /* /* */ but doing it right would be grim. -(defun within-c-comment-p () - (condition-case error-data - (let (start end) - (save-point - (search-backward "/*") - (setq start (point)) - (search-forward "*/") - (setq end (point))) - (if (< (point) end) (cons start end) nil)) - (search-failed nil))) - -(defun find-c-comment-buffer (&optional buffer) - (or buffer (setq buffer (current-buffer))) - (let ((list c-comment-edit-buffer-alist)) - (catch 'return-value - (while list - (if (eq (nth 1 (car list)) buffer) - (throw 'return-value (car list)) - (setq list (cdr list))))))) - -(defun find-c-comment-c-buffer (&optional buffer) - (or buffer (setq buffer (current-buffer))) - (let ((list c-comment-edit-buffer-alist)) - (catch 'return-value - (while list - (if (eq (car (car list)) buffer) - (throw 'return-value (car list)) - (setq list (cdr list))))))) - -;;; c-comment.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/c-fill.el --- a/lisp/modes/c-fill.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,272 +0,0 @@ -;;; C comment mode - An auto-filled comment mode for gnu c-mode. -;;; -;;; Author: Robert Mecklenburg -;;; Computer Science Dept. -;;; University of Utah -;;; From: mecklen@utah-gr.UUCP (Robert Mecklenburg) -;;; Also hartzell@Boulder.Colorado.EDU -;;; (c) 1986, University of Utah -;;; -;;; Everyone is granted permission to copy, modify and redistribute -;;; this file, provided the people they give it to can. - -;;; Synched up with: Not in FSF. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; I have written a "global comment" minor-mode which performs auto-fill, -;;; fill-paragraph, and auto-indentation functions. This function only -;;; works for comments which occupy an entire line (not comments to the -;;; right of code). The mode has several options set through variables. -;;; If the variable c-comment-starting-blank is non-nil multi-line -;;; comments come out like this: -;;; -;;; /* -;;; * Your favorite -;;; * multi-line comment. -;;; */ -;;; -;;; otherwise they look like this: -;;; -;;; /* Your Favorite -;;; * multi-line comment. -;;; */ -;;; -;;; If the variable c-comment-hanging-indent is non-nil K&R style comments -;;; are indented automatically like this: -;;; -;;; /* my_func - For multi-line comments with hanging indent -;;; * the text is lined up after the dash. -;;; */ -;;; -;;; otherwise the text "the text" (!) is lined up under my_func. If a -;;; comment fits (as typed) on a single line it remains a single line -;;; comment even if c-comment-starting-blank is set. If -;;; c-comment-indenting is non-nil hitting carriage return resets the -;;; indentation for the next line to the current line's indentation -;;; (within the comment) like this: -;;; -;;; /* Typing along merrily.... -;;; * Now I indent with spaces, when I hit return -;;; * the indentation is automatically set to -;;; * ^ here. -;;; */ -;;; -;;; Due to my lack of understanding of keymaps this permanently resets M-q -;;; to my own fill function. I would like to have the comment mode -;;; bindings only in comment mode but I can't seem to get that to work. -;;; If some gnu guru can clue me in, I'd appreciate it. -;;; -(defvar c-comment-starting-blank t - "*Controls whether global comments have an initial blank line.") -(defvar c-comment-indenting t - "*If set global comments are indented to the level of the previous line.") -(defvar c-comment-hanging-indent t - "*If true, comments will be automatically indented to the dash.") -(defvar c-hang-already-done t - "If true we have performed the haning indent already for this comment.") - - -;;; -;;; c-comment-map - This is a sparse keymap for comment mode which -;;; gets inserted when c-comment is called. -;;; -(defvar c-comment-mode-map () - "Keymap used in C comment mode.") -(if c-comment-mode-map - () - (setq c-comment-mode-map (copy-keymap c-mode-map)) - (define-key c-comment-mode-map "\e\r" 'newline) - (define-key c-comment-mode-map "\eq" 'set-fill-and-fill) - (define-key c-comment-mode-map "\r" 'set-fill-and-return)) - -;;; -;;; c-comment - This is a filled comment mode which can format -;;; indented text, do hanging indents, and symetric -;;; placement of comment delimiters. -;;; -(defun c-comment () - "Edit a C comment with filling and indentation. -This performs hanging indentation, symmetric placement of delimiters, - and Indented-Text mode style indentation. Type 'M-x apropos -c-comment' for information on options." - (interactive) - (let - ;; Save old state. - ((auto-fill-function (if c-comment-indenting - 'do-indented-auto-fill 'do-auto-fill)) -; (comment-start nil) - (comment-multi-line t) - (comment-start-skip "/*\\*+[ ]*") - (paragraph-start-ref paragraph-start) - fill-prefix paragraph-start paragraph-separate opoint) - - ;; Determine if we are inside a comment. - (setq in-comment - (save-excursion - (and (re-search-backward "/\\*\\|\\*/" 0 t) - (string= "/*" (buffer-substring (point) (+ (point) 2)))))) - - ;; Indent the comment and set the fill prefix to comment continuation - ;; string. If we are already in a comment get the indentation on - ;; the current line. - (setq c-hang-already-done nil) - - ;; Set the beginning of the comment and insert the blank line if needed. - (use-local-map c-comment-mode-map) - (if (not in-comment) - (progn (c-indent-line) - (insert "/* ") - (setq fill-prefix (get-current-fill (point))) - (recursive-edit) - - ;; If the comment fits on one line, place the close - ;; comment at the end of the line. Otherwise, newline. - (setq opoint (point)) - (if (and (save-excursion (beginning-of-line) - (search-forward "/*" opoint t)) - (<= (+ (current-column) 3) 79)) - (insert " */") - (insert "\n*/")) - - (c-indent-line)) - (progn (setq fill-prefix (get-current-fill (point))) - (recursive-edit) - (search-forward "*/" (buffer-size) t) - (forward-line 1))) - - ;; If starting blank enabled, insert a newline, etc., but only if - ;; this comment requires multiple lines. - (if c-comment-starting-blank - (save-excursion - (setq opoint (point)) - (forward-line -1) - (if (or (null (search-forward "/*" opoint t)) - (null (search-forward "*/" opoint t))) - (progn - (search-backward "/*") - (re-search-forward comment-start-skip opoint t) - (setq fill-prefix (get-current-fill (point))) - (if (not (looking-at "\n")) - (insert ?\n fill-prefix)))))) -; (indent-new-comment-line)))))) - - ;; Move cursor to indentation. - (c-indent-line) - (use-local-map c-mode-map) - ) - ) - - -;;; -;;; set-fill-and-fill - Get the current fill for this line and fill -;;; the paragraph. -;;; -(defun set-fill-and-fill (arg) - "Get the fill-prefix and fill the current paragraph." - - (interactive "P") - (setq fill-prefix (get-current-fill (point))) - (fill-paragraph arg)) - -;;; -;;; set-fill-and-return - Set the current fill prefix and -;;; indent-new-comment-line. -;;; -(defun set-fill-and-return () - "Set the current fill prefix and move to the next line." - - (interactive) - (if c-comment-indenting - (setq fill-prefix (get-current-fill (point)))) - (insert ?\n fill-prefix)) - -;;; -;;; do-indented-auto-fill - Perform the auto-fill function, but get -;;; the fill-prefix first. -;;; -(defun do-indented-auto-fill () - "Perform auto-fill, but get fill-prefix first." - - (let ((opoint (point))) - (save-excursion - (move-to-column (1+ fill-column)) - (skip-chars-backward "^ \t\n") - (if (bolp) - (re-search-forward "[ \t]" opoint t)) - ;; If there is a space on the line before fill-point, - ;; and nonspaces precede it, break the line there. - (if (save-excursion - (skip-chars-backward " \t") - (not (bolp))) - - ;; If we are wrapping to a new line, figure out the indentation on - ;; the current line first. - (progn - (setq fill-prefix (get-current-fill opoint)) - (insert ?\n fill-prefix))))) -; (indent-new-comment-line))))) - ) - - -;;; -;;; get-current-fill - Get the fill-prefix for the current line. This -;;; assumes that the valid fill prefix is between -;;; (beginning-of-line) and (point). -;;; -(defun get-current-fill (pnt) - "Get the current fill prefix. -A valid fill prefix must be between the beginning of the line and point." - - (let ((opoint pnt) fill last-char) - (save-excursion - (beginning-of-line) - (setq fill - (buffer-substring (point) - (progn - (re-search-forward comment-start-skip opoint t) - (point)))) - - ;; Be sure there is trailing white space. - (setq last-char (substring fill (1- (length fill)) (length fill))) - (if (and (not (string= " " last-char)) - (not (string= " " last-char))) - (setq fill (concat fill " "))) - - (setq fill (replace-letter fill "/" " ")) - - ;; Get the hanging indentation if we haven't already. - (if (and c-comment-hanging-indent (not c-hang-already-done)) - (let ((curr (point)) - (opnt (progn (end-of-line) (point)))) - (beginning-of-line) - (if (search-forward " - " opnt t) - (progn - (setq fill (concat fill (make-string (- (point) curr) 32))) - (setq c-hang-already-done t))))) - - ;; Set the paragraph delimiters. - (setq paragraph-start (concat paragraph-start-ref - "\\|^" - (regexp-quote - (substring fill - 0 (1- (length fill)))) - "$")) - (setq paragraph-separate paragraph-start)) - fill) - ) - - -;;; -;;; replace-letter - Given a string, an old letter and a new letter, -;;; perform the substitution. -;;; -(defun replace-letter (str old-letter new-letter) - (let (new-str c - (sp 0) - (size (length str))) - (while (< sp size) - (setq c (substring str sp (1+ sp))) - (setq new-str (concat new-str (if (string= c old-letter) new-letter c))) - (setq sp (1+ sp))) - new-str)) diff -r 43306a74e31c -r d44af0c54775 lisp/modes/c-style.el --- a/lisp/modes/c-style.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,199 +0,0 @@ -;; c-style.el --- sets c-style control variables. -;; Copyright (C) 1992-1993 Free Software Foundation, Inc. - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. -;; -;; LCD Archive Entry: -;; c-style|Daniel LaLiberte|liberte@cs.uiuc.edu -;; |sets c-style control variables -;; |Thu Feb 27 13:42:57 CST 1992|Version: 2.1|~/as-is/c-src-doc.el.Z -;; -;;; Synched up with: Not in FSF. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; There are several ways to call set-c-style described below. -;;; None of these methods reindent your program - they only affect -;;; new indentation. -;;; -;;; - Just call set-c-style in your c-mode-hook. -;;; Without style argument, default-c-style will be used. -;;; With style argument, this will set the style for every -;;; c-mode buffer the same. -;;; -;;; - Call set-c-style from the Local Variables list. -;;; e.g. "eval:(set-c-style 'C++)" -;;; -;;; - Call set-c-style interactively. It prompts for the style name -;;; with completion using default-c-style. -;;; -;;; For convenience, put one of the following in your .emacs: -;;; (autoload 'set-c-style "c-style" nil t) -;;; or (load "c-style") -;;; ===================================================== - -(defvar default-c-style 'GNU - "*The default value of c-style. Set this in your .emacs.") - -;; The following predefined styles are all I know about. -;; If you learn of another style that has a "big" following, please -;; send me the parameters. - -(defvar c-style-alist - '((GNU - (c-indent-level 2) - (c-continued-statement-offset 2) - (c-brace-offset 0) - (c-argdecl-indent 5) - (c-label-offset -2)) - - (BSD - (c-indent-level 8) - (c-continued-statement-offset 8) - (c-brace-offset -8) - (c-argdecl-indent 8) - (c-label-offset -8)) - - (K&R - (c-indent-level 5) - (c-continued-statement-offset 5) - (c-brace-offset -5) - (c-argdecl-indent 0) - (c-label-offset -5)) - - (BS ; was C++ - (c-indent-level 4) - (c-continued-statement-offset 4) - (c-brace-offset -4) - (c-argdecl-indent 4) - (c-label-offset -4)) - - ;; From Lynn Slater - (LRS - (c-indent-level 4) - (c-continued-statement-offset 4) - (c-brace-offset 0) - (c-argdecl-indent 4) - (c-label-offset -2) - (c-auto-newline nil)) - - (Plauger - (c-indent-level 0) - (c-continued-statement-offset 8) - (c-continued-brace-offset -8) - (c-brace-offset 8) - (c-brace-imaginary-offset 0) - (c-argdecl-indent 0) - (c-label-offset -8) - (c-auto-newline t) - (c-tab-always-indent t)) - - ;; From Jozsef A Toth - ;; Is this really the Whitesmith style? - (Alman - (c-argdecl-indent 0) - (c-brace-imaginary-offset 2) ;;; ???? - (c-brace-offset 0) - (c-continued-statement-offset 2) - (c-indent-level 0) - (c-label-offset -2) - (c-auto-newline t) - (comment-column 40) - (tab-width 2) - (fill-column '79)) - - (Gould - (c-indent-level 4) - (c-continued-statement-offset 4) - (c-brace-offset -4) - (c-argdecl-indent 8) - (c-label-offset -2) - (c-brace-imaginary-offset 0)) - - ;; From Joan Eslinger - (WRS - (c-indent-level 0) - (c-continued-statement-offset 4) - (c-brace-offset 0) - (c-argdecl-indent 4) - (c-label-offset -2) - (c-brace-imaginary-offset 4) - (c-continued-brace-offset -4)) - )) - -(defvar c-style nil - "The buffer local c-mode indentation style.") - -;; Add style name to mode line. Assumes minor-mode-alist is not buffer local. -;; Thanks to Joan Eslinger. - -(defvar c-style-name nil - "The style name for a c-mode indentation style. -This is to be set by set-c-style, and used by the mode line.") - -(or (assq 'c-style-name minor-mode-alist) - (setq minor-mode-alist - (purecopy - (append minor-mode-alist - ;; use undocumented feature - '((c-style-name c-style-name)))))) - -(defun set-c-style (&optional style) - "Set up the c-mode style variables from STYLE if it is given, or -default-c-style otherwise. It makes the c indentation style variables -buffer local." - - (interactive) - - (let ((c-styles (mapcar 'car c-style-alist))) ; for completion - (if (interactive-p) - (setq style - (let ((style-string ; Get style name with completion. - (completing-read - (format "Set c-mode indentation style to (default %s): " - default-c-style) - (vconcat c-styles) - (function (lambda (arg) (memq arg c-styles))) - ))) - (if (string-equal "" style-string) - default-c-style - (intern style-string)) - ))) - - ;; If style is nil, use default-c-style. - (setq style (or style default-c-style)) - - (make-local-variable 'c-style) - (if (memq style c-styles) - (setq c-style style) - (error "Undefined c style: %s" style) - ) - (message "c-style: %s" c-style) - - ;; Set the c-style-name - (make-local-variable 'c-style-name) - (setq c-style-name (format " %s" c-style)) - - ;; Finally, set the indentation style variables making each one local. - (mapcar (function (lambda (c-style-pair) - (make-local-variable (car c-style-pair)) - (set (car c-style-pair) - (car (cdr c-style-pair))))) - (cdr (assq c-style c-style-alist))) - c-style - )) diff -r 43306a74e31c -r d44af0c54775 lisp/modes/cl-indent.el --- a/lisp/modes/cl-indent.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,513 +0,0 @@ -;;; cl-indent.el --- enhanced lisp-indent mode - -;; Copyright (C) 1987 Free Software Foundation, Inc. - -;; Author: Richard Mlynarik -;; Created: July 1987 -;; Maintainer: FSF -;; Keywords: lisp, tools - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34 - -;;; Commentary: - -;; This package supplies a single entry point, common-lisp-indent-function, -;; which performs indentation in the preferred style for Common Lisp code. -;; To enable it: -;; -;; (setq lisp-indent-function 'common-lisp-indent-function) - -;;>> TODO -;; :foo -;; bar -;; :baz -;; zap -;; &key (like &body)?? - -;; &rest 1 in lambda-lists doesn't work -;; -- really want (foo bar -;; baz) -;; not (foo bar -;; baz) -;; Need something better than &rest for such cases - -;;; Code: - -(defgroup lisp-indent nil - "Enhanced lisp-indent mode." - :group 'lisp) - - -(defcustom lisp-indent-maximum-backtracking 3 - "*Maximum depth to backtrack out from a sublist for structured indentation. -If this variable is 0, no backtracking will occur and forms such as flet -may not be correctly indented." - :type 'integer - :group 'lisp-indent) - -(defcustom lisp-tag-indentation 1 - "*Indentation of tags relative to containing list. -This variable is used by the function `lisp-indent-tagbody'." - :type 'integer - :group 'lisp-indent) - -(defcustom lisp-tag-body-indentation 3 - "*Indentation of non-tagged lines relative to containing list. -This variable is used by the function `lisp-indent-tagbody' to indent normal -lines (lines without tags). -The indentation is relative to the indentation of the parenthesis enclosing -the special form. If the value is t, the body of tags will be indented -as a block at the same indentation as the first s-expression following -the tag. In this case, any forms before the first tag are indented -by `lisp-body-indent'." - :type 'integer - :group 'lisp-indent) - - -;;;###autoload -(defun common-lisp-indent-function (indent-point state) - (let ((normal-indent (current-column))) - ;; Walk up list levels until we see something - ;; which does special things with subforms. - (let ((depth 0) - ;; Path describes the position of point in terms of - ;; list-structure with respect to containing lists. - ;; `foo' has a path of (0 4 1) in `((a b c (d foo) f) g)' - (path ()) - ;; set non-nil when somebody works out the indentation to use - calculated - (last-point indent-point) - ;; the position of the open-paren of the innermost containing list - (containing-form-start (elt state 1)) - ;; the column of the above - sexp-column) - ;; Move to start of innermost containing list - (goto-char containing-form-start) - (setq sexp-column (current-column)) - ;; Look over successively less-deep containing forms - (while (and (not calculated) - (< depth lisp-indent-maximum-backtracking)) - (let ((containing-sexp (point))) - (forward-char 1) - (parse-partial-sexp (point) indent-point 1 t) - ;; Move to the car of the relevant containing form - (let (tem function method) - (if (not (looking-at "\\sw\\|\\s_")) - ;; This form doesn't seem to start with a symbol - (setq function nil method nil) - (setq tem (point)) - (forward-sexp 1) - (setq function (downcase (buffer-substring tem (point)))) - (goto-char tem) - (setq tem (intern-soft function) - method (get tem 'common-lisp-indent-function)) - (cond ((and (null method) - (string-match ":[^:]+" function)) - ;; The pleblisp package feature - (setq function (substring function - (1+ (match-beginning 0))) - method (get (intern-soft function) - 'common-lisp-indent-function))) - ((and (null method)) - ;; backwards compatibility - (setq method (get tem 'lisp-indent-function))))) - (let ((n 0)) - ;; How far into the containing form is the current form? - (if (< (point) indent-point) - (while (condition-case () - (progn - (forward-sexp 1) - (if (>= (point) indent-point) - nil - (parse-partial-sexp (point) - indent-point 1 t) - (setq n (1+ n)) - t)) - (error nil)))) - (setq path (cons n path))) - - ;; backwards compatibility. - (cond ((null function)) - ((null method) - (if (null (cdr path)) - ;; (package prefix was stripped off above) - (setq method (cond ((string-match "\\`def" - function) - '(4 (&whole 4 &rest 1) &body)) - ((string-match "\\`\\(with\\|do\\)-" - function) - '(4 &body)))))) - ;; backwards compatibility. Bletch. - ((eq method 'defun) - (setq method '(4 (&whole 4 &rest 1) &body)))) - - (cond ((and (memq (char-after (1- containing-sexp)) '(?\' ?\`)) - (not (eql (char-after (- containing-sexp 2)) ?\#))) - ;; No indentation for "'(...)" elements - (setq calculated (1+ sexp-column))) - ((or (eql (char-after (1- containing-sexp)) ?\,) - (and (eql (char-after (1- containing-sexp)) ?\@) - (eql (char-after (- containing-sexp 2)) ?\,))) - ;; ",(...)" or ",@(...)" - (setq calculated normal-indent)) - ((eql (char-after (1- containing-sexp)) ?\#) - ;; "#(...)" - (setq calculated (1+ sexp-column))) - ((null method)) - ((integerp method) - ;; convenient top-level hack. - ;; (also compatible with lisp-indent-function) - ;; The number specifies how many `distinguished' - ;; forms there are before the body starts - ;; Equivalent to (4 4 ... &body) - (setq calculated (cond ((cdr path) - normal-indent) - ((<= (car path) method) - ;; `distinguished' form - (list (+ sexp-column 4) - containing-form-start)) - ((= (car path) (1+ method)) - ;; first body form. - (+ sexp-column lisp-body-indent)) - (t - ;; other body form - normal-indent)))) - ((symbolp method) - (setq calculated (funcall method - path state indent-point - sexp-column normal-indent))) - (t - (setq calculated (lisp-indent-259 - method path state indent-point - sexp-column normal-indent))))) - (goto-char containing-sexp) - (setq last-point containing-sexp) - (if (not calculated) - (condition-case () - (progn (backward-up-list 1) - (setq depth (1+ depth))) - (error (setq depth lisp-indent-maximum-backtracking)))))) - calculated))) - - -(defun lisp-indent-report-bad-format (m) - (error "%s has a badly-formed %s property: %s" - ;; Love those free variable references!! - function 'common-lisp-indent-function m)) - -;; Blame the crufty control structure on dynamic scoping -;; -- not on me! -(defun lisp-indent-259 (method path state indent-point - sexp-column normal-indent) - (catch 'exit - (let ((p path) - (containing-form-start (elt state 1)) - n tem tail) - ;; Isn't tail-recursion wonderful? - (while p - ;; This while loop is for destructuring. - ;; p is set to (cdr p) each iteration. - (if (not (consp method)) (lisp-indent-report-bad-format method)) - (setq n (1- (car p)) - p (cdr p) - tail nil) - (while n - ;; This while loop is for advancing along a method - ;; until the relevant (possibly &rest/&body) pattern - ;; is reached. - ;; n is set to (1- n) and method to (cdr method) - ;; each iteration. - (setq tem (car method)) - - (or (eq tem 'nil) ;default indentation -; (eq tem '&lambda) ;abbrev for (&whole 4 (&rest 1)) - (and (eq tem '&body) (null (cdr method))) - (and (eq tem '&rest) - (consp (cdr method)) (null (cdr (cdr method)))) - (integerp tem) ;explicit indentation specified - (and (consp tem) ;destructuring - (eq (car tem) '&whole) - (or (symbolp (car (cdr tem))) - (integerp (car (cdr tem))))) - (and (symbolp tem) ;a function to call to do the work. - (null (cdr method))) - (lisp-indent-report-bad-format method)) - - (cond ((and tail (not (consp tem))) - ;; indent tail of &rest in same way as first elt of rest - (throw 'exit normal-indent)) - ((eq tem '&body) - ;; &body means (&rest ) - (throw 'exit - (if (and (= n 0) ;first body form - (null p)) ;not in subforms - (+ sexp-column - lisp-body-indent) - normal-indent))) - ((eq tem '&rest) - ;; this pattern holds for all remaining forms - (setq tail (> n 0) - n 0 - method (cdr method))) - ((> n 0) - ;; try next element of pattern - (setq n (1- n) - method (cdr method)) - (if (< n 0) - ;; Too few elements in pattern. - (throw 'exit normal-indent))) - ((eq tem 'nil) - (throw 'exit (list normal-indent containing-form-start))) -; ((eq tem '&lambda) -; ;; abbrev for (&whole 4 &rest 1) -; (throw 'exit -; (cond ((null p) -; (list (+ sexp-column 4) containing-form-start)) -; ((null (cdr p)) -; (+ sexp-column 1)) -; (t normal-indent)))) - ((integerp tem) - (throw 'exit - (if (null p) ;not in subforms - (list (+ sexp-column tem) containing-form-start) - normal-indent))) - ((symbolp tem) ;a function to call - (throw 'exit - (funcall tem path state indent-point - sexp-column normal-indent))) - (t - ;; must be a destructing frob - (if (not (null p)) - ;; descend - (setq method (cdr (cdr tem)) - n nil) - (setq tem (car (cdr tem))) - (throw 'exit - (cond (tail - normal-indent) - ((eq tem 'nil) - (list normal-indent - containing-form-start)) - ((integerp tem) - (list (+ sexp-column tem) - containing-form-start)) - (t - (funcall tem path state indent-point - sexp-column normal-indent)))))))))))) - -(defun lisp-indent-tagbody (path state indent-point sexp-column normal-indent) - (if (not (null (cdr path))) - normal-indent - (save-excursion - (goto-char indent-point) - (beginning-of-line) - (skip-chars-forward " \t") - (list (cond ((looking-at "\\sw\\|\\s_") - ;; a tagbody tag - (+ sexp-column lisp-tag-indentation)) - ((integerp lisp-tag-body-indentation) - (+ sexp-column lisp-tag-body-indentation)) - ((eq lisp-tag-body-indentation 't) - (condition-case () - (progn (backward-sexp 1) (current-column)) - (error (1+ sexp-column)))) - (t (+ sexp-column lisp-body-indent))) -; (cond ((integerp lisp-tag-body-indentation) -; (+ sexp-column lisp-tag-body-indentation)) -; ((eq lisp-tag-body-indentation 't) -; normal-indent) -; (t -; (+ sexp-column lisp-body-indent))) - (elt state 1) - )))) - -(defun lisp-indent-do (path state indent-point sexp-column normal-indent) - (if (>= (car path) 3) - (let ((lisp-tag-body-indentation lisp-body-indent)) - (funcall (function lisp-indent-tagbody) - path state indent-point sexp-column normal-indent)) - (funcall (function lisp-indent-259) - '((&whole nil &rest - ;; the following causes weird indentation - ;;(&whole 1 1 2 nil) - ) - (&whole nil &rest 1)) - path state indent-point sexp-column normal-indent))) - -(defun lisp-indent-function-lambda-hack (path state indent-point - sexp-column normal-indent) - ;; indent (function (lambda () )) kludgily. - (if (or (cdr path) ; wtf? - (> (car path) 3)) - ;; line up under previous body form - normal-indent - ;; line up under function rather than under lambda in order to - ;; conserve horizontal space. (Which is what #' is for.) - (condition-case () - (save-excursion - (backward-up-list 2) - (forward-char 1) - (if (looking-at "\\(lisp:+\\)?function\\(\\Sw\\|\\S_\\)") - (+ lisp-body-indent -1 (current-column)) - (+ sexp-column lisp-body-indent))) - (error (+ sexp-column lisp-body-indent))))) - -;; XEmacs change -(defun lisp-indent-defmethod (path state indent-point - sexp-column normal-indent) - ;; Look for a method combination specifier... - (let* ((combined (if (and (>= (car path) 3) - (null (cdr path))) - (save-excursion - (goto-char (car (cdr state))) - (forward-char) - (forward-sexp) - (forward-sexp) - (forward-sexp) - (backward-sexp) - (if (looking-at ":") - t - nil)) - nil)) - (method (if combined - '(4 4 (&whole 4 &rest 1) &body) - '(4 (&whole 4 &rest 1) &body)))) - (funcall (function lisp-indent-259) - method - path state indent-point sexp-column normal-indent))) - - -(let ((l '((block 1) - (catch 1) - (case (4 &rest (&whole 2 &rest 1))) - (ccase . case) (ecase . case) - (typecase . case) (etypecase . case) (ctypecase . case) - (catch 1) - (cond (&rest (&whole 2 &rest 1))) - (block 1) - (defvar (4 2 2)) - (defconstant . defvar) (defparameter . defvar) - (define-modify-macro - (4 &body)) - (define-setf-method - (4 (&whole 4 &rest 1) &body)) - (defsetf (4 (&whole 4 &rest 1) 4 &body)) - (defun (4 (&whole 4 &rest 1) &body)) - (defmacro . defun) (deftype . defun) - ;; XEmacs change - (defmethod lisp-indent-defmethod) - (defstruct ((&whole 4 &rest (&whole 2 &rest 1)) - &rest (&whole 2 &rest 1))) - (destructuring-bind - ((&whole 6 &rest 1) 4 &body)) - (do lisp-indent-do) - (do* . do) - (dolist ((&whole 4 2 1) &body)) - (dotimes . dolist) - (eval-when 1) - (flet ((&whole 4 &rest (&whole 1 (&whole 4 &rest 1) &body)) - &body)) - (labels . flet) - (macrolet . flet) - ;; `else-body' style - (if (nil nil &body)) - ;; single-else style (then and else equally indented) - (if (&rest nil)) - ;(lambda ((&whole 4 &rest 1) &body)) - (lambda ((&whole 4 &rest 1) - &rest lisp-indent-function-lambda-hack)) - (let ((&whole 4 &rest (&whole 1 1 2)) &body)) - (let* . let) - (compiler-let . let) ;barf - (locally 1) - ;(loop ...) - (multiple-value-bind - ((&whole 6 &rest 1) 4 &body)) - (multiple-value-call - (4 &body)) - (multiple-value-list 1) - (multiple-value-prog1 1) - (multiple-value-setq - (4 2)) - ;; Combines the worst features of BLOCK, LET and TAGBODY - (prog ((&whole 4 &rest 1) &rest lisp-indent-tagbody)) - (prog* . prog) - (prog1 1) - (prog2 2) - (progn 0) - (progv (4 4 &body)) - (return 0) - (return-from (nil &body)) - (tagbody lisp-indent-tagbody) - (throw 1) - (unless 1) - (unwind-protect - (5 &body)) - (when 1)))) - (while l - (put (car (car l)) 'common-lisp-indent-function - (if (symbolp (cdr (car l))) - (get (cdr (car l)) 'common-lisp-indent-function) - (car (cdr (car l))))) - (setq l (cdr l)))) - - -;(defun foo (x) -; (tagbody -; foo -; (bar) -; baz -; (when (losing) -; (with-big-loser -; (yow) -; ((lambda () -; foo) -; big))) -; (flet ((foo (bar baz zap) -; (zip)) -; (zot () -; quux)) -; (do () -; ((lose) -; (foo 1)) -; (quux) -; foo -; (lose)) -; (cond ((x) -; (win 1 2 -; (foo))) -; (t -; (lose -; 3)))))) - - -;(put 'while 'common-lisp-indent-function 1) -;(put 'defwrapper'common-lisp-indent-function ...) -;(put 'def 'common-lisp-indent-function ...) -;(put 'defflavor 'common-lisp-indent-function ...) -;(put 'defsubst 'common-lisp-indent-function ...) - -;(put 'with-restart 'common-lisp-indent-function '((1 4 ((* 1))) (2 &body))) -;(put 'restart-case 'common-lisp-indent-function '((1 4) (* 2 ((0 1) (* 1))))) -;(put 'define-condition 'common-lisp-indent-function '((1 6) (2 6 ((* 1))) (3 4 ((* 1))) (4 &body))) -;(put 'with-condition-handler 'common-lisp-indent-function '((1 4 ((* 1))) (2 &body))) -;(put 'condition-case 'common-lisp-indent-function '((1 4) (* 2 ((0 1) (1 3) (2 &body))))) - -;;; cl-indent.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/cmacexp.el --- a/lisp/modes/cmacexp.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,389 +0,0 @@ -;;; cmacexp.el --- expand C macros in a region - -;; Copyright (C) 1992, 1994, 1996 Free Software Foundation, Inc. - -;; Author: Francesco Potorti` -;; Version: $Id: cmacexp.el,v 1.2 1997/04/19 23:21:02 steve Exp $ -;; Adapted-By: ESR -;; Keywords: c - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34. - -;; USAGE ============================================================= - -;; In C mode C-C C-e is bound to c-macro-expand. The result of the -;; expansion is put in a separate buffer. A user option allows the -;; window displaying the buffer to be optimally sized. -;; -;; When called with a C-u prefix, c-macro-expand replaces the selected -;; region with the expansion. Both the preprocessor name and the -;; initial flag can be set by the user. If c-macro-prompt-flag is set -;; to a non-nil value the user is offered to change the options to the -;; preprocessor each time c-macro-expand is invoked. Preprocessor -;; arguments default to the last ones entered. If c-macro-prompt-flag -;; is nil, one must use M-x set-variable to set a different value for -;; c-macro-cppflags. - -;; A c-macro-expansion function is provided for non-interactive use. - -;; INSTALLATION ====================================================== - -;; Put the following in your ~/.emacs file. - -;; If you want the *Macroexpansion* window to be not higher than -;; necessary: -;;(setq c-macro-shrink-window-flag t) -;; -;; If you use a preprocessor other than /lib/cpp (be careful to set a -;; -C option or equivalent in order to make the preprocessor not to -;; strip the comments): -;;(setq c-macro-preprocessor "gpp -C") -;; -;; If you often use a particular set of flags: -;;(setq c-macro-cppflags "-I /usr/include/local -DDEBUG" -;; -;; If you want the "Preprocessor arguments: " prompt: -;;(setq c-macro-prompt-flag t) - -;; BUG REPORTS ======================================================= - -;; Please report bugs, suggestions, complaints and so on to -;; pot@cnuce.cnr.it (Francesco Potorti`). - -;; IMPROVEMENTS OVER emacs 18.xx cmacexp.el ========================== - -;; - A lot of user and programmer visible changes. See above. -;; - #line directives are inserted, so __LINE__ and __FILE__ are -;; correctly expanded. Works even with START inside a string, a -;; comment or a region #ifdef'd away by cpp. cpp is invoked with -C, -;; making comments visible in the expansion. -;; - All work is done in core memory, no need for temporary files. - -;; ACKNOWLEDGEMENTS ================================================== - -;; A lot of thanks to Don Maszle who did a great work of testing, bug -;; reporting and suggestion of new features. This work has been -;; partially inspired by Don Maszle and Jonathan Segal's. - -;; BUGS ============================================================== - -;; If the start point of the region is inside a macro definition the -;; macro expansion is often inaccurate. - - -(require 'cc-mode) - -(provide 'cmacexp) - -(defgroup c-macro nil - "Expand C macros in a region." - :group 'c) - - -(defcustom c-macro-shrink-window-flag nil - "*Non-nil means shrink the *Macroexpansion* window to fit its contents." - :type 'boolean - :group 'c-macro) - -(defcustom c-macro-prompt-flag nil - "*Non-nil makes `c-macro-expand' prompt for preprocessor arguments." - :type 'boolean - :group 'c-macro) - -(defcustom c-macro-preprocessor - ;; Cannot rely on standard directory on MS-DOS to find CPP. - (cond ((eq system-type 'ms-dos) "cpp -C") - ;; Solaris has it in an unusual place. - ((and (string-match "^[^-]*-[^-]*-\\(solaris\\|sunos5\\)" - system-configuration) - (file-exists-p "/opt/SUNWspro/SC3.0.1/bin/acomp")) - "/opt/SUNWspro/SC3.0.1/bin/acomp -C -E") - (t "/lib/cpp -C")) - "The preprocessor used by the cmacexp package. - -If you change this, be sure to preserve the `-C' (don't strip comments) -option, or to set an equivalent one." - :type 'string - :group 'c-macro) - -(defcustom c-macro-cppflags "" - "*Preprocessor flags used by `c-macro-expand'." - :type 'string - :group 'c-macro) - -(defconst c-macro-buffer-name "*Macroexpansion*") - -;; Autoload for XEmacs -;;;###autoload -(defun c-macro-expand (start end subst) - "Expand C macros in the region, using the C preprocessor. -Normally display output in temp buffer, but -prefix arg means replace the region with it. - -`c-macro-preprocessor' specifies the preprocessor to use. -Prompt for arguments to the preprocessor \(e.g. `-DDEBUG -I ./include') -if the user option `c-macro-prompt-flag' is non-nil. - -Noninteractive args are START, END, SUBST. -For use inside Lisp programs, see also `c-macro-expansion'." - - (interactive "r\nP") - (let ((inbuf (current-buffer)) - (displaybuf (if subst - (get-buffer c-macro-buffer-name) - (get-buffer-create c-macro-buffer-name))) - (expansion "")) - ;; Build the command string. - (if c-macro-prompt-flag - (setq c-macro-cppflags - (read-string "Preprocessor arguments: " - c-macro-cppflags))) - ;; Decide where to display output. - (if (and subst - (and buffer-read-only (not inhibit-read-only)) - (not (eq inbuf displaybuf))) - (progn - (message - "Buffer is read only: displaying expansion in alternate window") - (sit-for 2) - (setq subst nil) - (or displaybuf - (setq displaybuf (get-buffer-create c-macro-buffer-name))))) - ;; Expand the macro and output it. - (setq expansion (c-macro-expansion start end - (concat c-macro-preprocessor " " - c-macro-cppflags) t)) - (if subst - (let ((exchange (= (point) start))) - (delete-region start end) - (insert expansion) - (if exchange - (exchange-point-and-mark))) - (set-buffer displaybuf) - (setq buffer-read-only nil) - (buffer-disable-undo displaybuf) - (erase-buffer) - (insert expansion) - (set-buffer-modified-p nil) - (if (string= "" expansion) - (message "Null expansion") - (c-macro-display-buffer)) - (setq buffer-read-only t) - (setq buffer-auto-save-file-name nil) - (bury-buffer displaybuf)))) - - -;; Display the current buffer in a window which is either just large -;; enough to contain the entire buffer, or half the size of the -;; screen, whichever is smaller. Do not select the new -;; window. -;; -;; Several factors influence window resizing so that the window is -;; sized optimally if it is created anew, and so that it is messed -;; with minimally if it has been created by the user. If the window -;; chosen for display exists already but contains something else, the -;; window is not re-sized. If the window already contains the current -;; buffer, it is never shrunk, but possibly expanded. Finally, if the -;; variable c-macro-shrink-window-flag is nil the window size is *never* -;; changed. -(defun c-macro-display-buffer () - (goto-char (point-min)) - (c-mode) - (let ((oldwinheight (window-height)) - (alreadythere ;the window was already there - (get-buffer-window (current-buffer))) - (popped nil)) ;the window popped changing the layout - (or alreadythere - (progn - (display-buffer (current-buffer) t) - (setq popped (/= oldwinheight (window-height))))) - (if (and c-macro-shrink-window-flag ;user wants fancy shrinking :\) - (or alreadythere popped)) - ;; Enlarge up to half screen, or shrink properly. - (let ((oldwin (selected-window)) - (minheight 0) - (maxheight 0)) - (save-excursion - (select-window (get-buffer-window (current-buffer))) - (setq minheight (if alreadythere - (window-height) - window-min-height)) - ;; XEmacs change - (setq maxheight (/ (screen-height) 2)) - (enlarge-window (- (min maxheight - (max minheight - (+ 2 (vertical-motion (point-max))))) - (window-height))) - (goto-char (point-min)) - (select-window oldwin)))))) - - -(defun c-macro-expansion (start end cppcommand &optional display) - "Run a preprocessor on region and return the output as a string. -Expand the region between START and END in the current buffer using -the shell command CPPCOMMAND (e.g. \"/lib/cpp -C -DDEBUG\"). -Be sure to use a -C (don't strip comments) or equivalent option. -Optional arg DISPLAY non-nil means show messages in the echo area." - -;; Copy the current buffer's contents to a temporary hidden buffer. -;; Delete from END to end of buffer. Insert a preprocessor #line -;; directive at START and after each #endif following START that are -;; not inside a comment or a string. Put all the strings thus -;; inserted (without the "line" substring) in a list named linelist. -;; If START is inside a comment, prepend "*/" and append "/*" to the -;; #line directive. If inside a string, prepend and append "\"". -;; Preprocess the buffer contents, then look for all the lines stored -;; in linelist starting from end of buffer. The last line so found is -;; where START was, so return the substring from point to end of -;; buffer. - (let ((inbuf (current-buffer)) - (outbuf (get-buffer-create " *C Macro Expansion*")) - (filename (if (and buffer-file-name - (string-match (regexp-quote default-directory) - buffer-file-name)) - (substring buffer-file-name (match-end 0)) - (buffer-name))) - (mymsg (format "Invoking %s%s%s on region..." - c-macro-preprocessor - (if (string= "" c-macro-cppflags) "" " ") - c-macro-cppflags)) - (uniquestring "??? !!! ??? start of c-macro expansion ??? !!! ???") - (startlinenum 0) - (linenum 0) - (startstat ()) - (startmarker "") - (exit-status 0) - (tempname (make-temp-name (concat - (or (getenv "TMPDIR") (getenv "TEMP") - (getenv "TMP") "/tmp") - "/")))) - (unwind-protect - (save-excursion - (save-restriction - (widen) - (let ((in-syntax-table (syntax-table))) - (set-buffer outbuf) - (setq buffer-read-only nil) - (erase-buffer) - (set-syntax-table in-syntax-table)) - (insert-buffer-substring inbuf 1 end)) - - ;; We have copied inbuf to outbuf. Point is at end of - ;; outbuf. Inset a newline at the end, so cpp can correctly - ;; parse a token ending at END. - (insert "\n") - - ;; Save sexp status and line number at START. - (setq startstat (parse-partial-sexp 1 start)) - (setq startlinenum (+ (count-lines 1 (point)) - (if (bolp) 1 0))) - - ;; Now we insert the #line directives after all #endif or - ;; #else following START going backward, so the lines we - ;; insert don't change the line numbers. - ;(switch-to-buffer outbuf) (debug) ;debugging instructions - (goto-char (point-max)) - (while (re-search-backward "\n#\\(endif\\|else\\)\\>" start 'move) - (if (equal (nthcdr 3 (parse-partial-sexp start (point) - nil nil startstat)) - '(nil nil nil 0 nil)) ;neither in string nor in - ;comment nor after quote - (progn - (goto-char (match-end 0)) - (setq linenum (+ startlinenum - (count-lines start (point)))) - (insert (format "\n#line %d \"%s\"\n" linenum filename)) - (goto-char (match-beginning 0))))) - - ;; Now we are at START. Insert the first #line directive. - ;; This must work even inside a string or comment, or after a - ;; quote. - (let* ((startinstring (nth 3 startstat)) - (startincomment (nth 4 startstat)) - (startafterquote (nth 5 startstat)) - (startinbcomment (nth 7 startstat))) - (insert (if startafterquote " " "") - (cond (startinstring - (char-to-string startinstring)) - (startincomment "*/") - ("")) - (setq startmarker - (concat "\n" uniquestring - (cond (startinstring - (char-to-string startinstring)) - (startincomment "/*") - (startinbcomment "//")) - (if startafterquote "\\"))) - (format "\n#line %d \"%s\"\n" startlinenum filename))) - - ;; Call the preprocessor. - (if display (message mymsg)) - (setq exit-status - (call-process-region 1 (point-max) - shell-file-name - t (list t tempname) nil "-c" - cppcommand)) - (if display (message (concat mymsg "done"))) - (if (= (buffer-size) 0) - ;; Empty output is normal after a fatal error. - (insert "\nPreprocessor produced no output\n") - ;; Find and delete the mark of the start of the expansion. - ;; Look for `# nn "file.c"' lines and delete them. - (goto-char (point-min)) - (search-forward startmarker) - (delete-region 1 (point))) - (while (re-search-forward (concat "^# [0-9]+ \"" - (regexp-quote filename) - "\"") nil t) - (beginning-of-line) - (let ((beg (point))) - (forward-line 1) - (delete-region beg (point)))) - - ;; If CPP got errors, show them at the beginning. - ;; MS-DOS shells don't return the exit code of their children. - ;; Look at the size of the error message file instead, but - ;; don't punish those MS-DOS users who have a shell that does - ;; return an error code. - (or (and (or (not (boundp 'msdos-shells)) - (not (member (file-name-nondirectory shell-file-name) - msdos-shells))) - (eq exit-status 0)) - (zerop (nth 7 (file-attributes (expand-file-name tempname)))) - (progn - (goto-char (point-min)) - ;; Put the messages inside a comment, so they won't get in - ;; the way of font-lock, highlighting etc. - (insert - (format "/* Preprocessor terminated with status %s\n\n Messages from `%s\':\n\n" - exit-status cppcommand)) - (goto-char (+ (point) - (nth 1 (insert-file-contents tempname)))) - (insert "\n\n*/\n"))) - (delete-file tempname) - - ;; Compute the return value, keeping in account the space - ;; inserted at the end of the buffer. - (buffer-substring 1 (max 1 (- (point-max) 1)))) - - ;; Cleanup. - (kill-buffer outbuf)))) - -;;; cmacexp.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/cperl-mode.el --- a/lisp/modes/cperl-mode.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,5585 +0,0 @@ -;;; cperl-mode.el --- Perl code editing commands for XEmacs - -;; Copyright (C) 1985-1996 Bob Olson, Ilya Zakharevich -;; Copyright (C) 1997 granted to FSF for changes made by -;; Karl M. Hegbloom - -;; Author: Bob Olson, Ilya Zakharevich -;; Maintainer: Karl M. Hegbloom -;; Keywords: languages - -;; This file is part of XEmacs. It may be distributed either under the -;; same terms as XEmacs, or under the same terms as Perl. You should -;; have received a copy of Perl Artistic license along with the Perl -;; distribution. - -;; XEmacs 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., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Corrections made by Ilya Zakharevich ilya@math.mps.ohio-state.edu -;;; XEmacs changes by Peter Arius arius@informatik.uni-erlangen.de -;;; XEmacs 'delete key behavior handling added for XEmacs 20.x by -;;; Gary D. Foster -;;; Karl M. Hegbloom - -;; Original Vendor Version Number: (mostly based on...) -;; $Id: cperl-mode.el,v 1.16 1997/11/08 23:36:57 steve Exp $ - -;; Increment the final digit once per XEmacs-only revision, the other -;; for merges. (sound ok?) -;;; XEmacs Version Number: 1.35-1 - -;;; Commentary: - -;; This code started from the following message of long time ago (IZ): - -;; From: olson@mcs.anl.gov (Bob Olson) -;; Newsgroups: comp.lang.perl -;; Subject: cperl-mode: Another perl mode for Gnuemacs -;; Date: 14 Aug 91 15:20:01 GMT - -;; This mode should autoload when you edit a perl file under XEmacs. - -;;; DO NOT FORGET to read micro-docs. (available from `Perl' menu). <<<<<< -;;; or as help on variables `cperl-tips', `cperl-problems', <<<<<< -;;; `cperl-non-problems', `cperl-praise'. <<<<<< - -;;; The mode information (on C-h m) provides some customization help. -;;; If you use font-lock feature of this mode, it is advisable to use -;;; either lazy-lock-mode or fast-lock-mode (available on ELisp -;;; archive in files lazy-lock.el and fast-lock.el). I prefer lazy-lock. - -;;; Faces used now: three faces for first-class and second-class keywords -;;; and control flow words, one for each: comments, string, labels, -;;; functions definitions and packages, arrays, hashes, and variable -;;; definitions. If you do not see all these faces, your font-lock does -;;; not define them, so you need to define them manually. - -;;; If you have a grayscale monitor, and do not have the variable -;;; font-lock-display-type bound to 'grayscale, insert - -;;; (setq font-lock-display-type 'grayscale) - -;;; into your .xemacs/init.el file. - -;;;; ? what about this `imenu' stuff? Is it worth it? - -;;;; This mode supports font-lock, imenu and mode-compile. In the -;;;; hairy version font-lock is on, but you should activate imenu -;;;; yourself (note that mode-compile is not standard yet). Well, you -;;;; can use imenu from keyboard anyway (M-x imenu), but it is better -;;;; to bind it like that: - -;; (define-key global-map [M-S-down-mouse-3] 'imenu) - -;;; In fact the version of font-lock that this version supports can be -;;; much newer than the version you actually have. This means that a -;;; lot of faces can be set up, but are not visible on your screen -;;; since the coloring rules for this faces are not defined. - -;;; Updates: ======================================== - -;;; Made less hairy by default: parentheses not electric, -;;; linefeed not magic. Bug with abbrev-mode corrected. - -;;;; After 1.4: -;;; Better indentation: -;;; subs inside braces should work now, -;;; Toplevel braces obey customization. -;;; indent-for-comment knows about bad cases, cperl-indent-for-comment -;;; moves cursor to a correct place. -;;; cperl-indent-exp written from the scratch! Slow... (quadratic!) :-( -;;; (50 secs on DB::DB (sub of 430 lines), 486/66) -;;; Minor documentation fixes. -;;; Imenu understands packages as prefixes (including nested). -;;; Hairy options can be switched off one-by-one by setting to null. -;;; Names of functions and variables changed to conform to `cperl-' style. - -;;;; After 1.5: -;;; Some bugs with indentation of labels (and embedded subs) corrected. -;;; `cperl-indent-region' done (slow :-()). -;;; `cperl-fill-paragraph' done. -;;; Better package support for `imenu'. -;;; Progress indicator for indentation (with `imenu' loaded). -;;; `Cperl-set' was busted, now setting the individual hairy option -;;; should be better. - -;;;; After 1.6: -;;; `cperl-set-style' done. -;;; `cperl-check-syntax' done. -;;; Menu done. -;;; New config variables `cperl-close-paren-offset' and `cperl-comment-column'. -;;; Bugs with `cperl-auto-newline' corrected. -;;; `cperl-electric-lbrace' can work with `cperl-auto-newline' in situation -;;; like $hash{. - -;;;; 1.7 XEmacs (arius@informatik.uni-erlangen.de): -;;; - use `next-command-event', if `next-command-events' does not exist -;;; - use `find-face' as def. of `is-face' -;;; - corrected def. of `x-color-defined-p' -;;; - added const defs for font-lock-comment-face, -;;; font-lock-keyword-face and font-lock-function-name-face -;;; - added def. of font-lock-variable-name-face -;;; - added (require 'easymenu) inside an `eval-when-compile' -;;; - replaced 4-argument `substitute-key-definition' with ordinary -;;; `define-key's -;;; - replaced `mark-active' in menu definition by `cperl-use-region-p'. -;;; Todo (at least): -;;; - use emacs-vers.el (http://www.cs.utah.edu/~eeide/emacs/emacs-vers.el.gz) -;;; for portable code? -;;; - should `cperl-mode' do a -;;; (if (featurep 'easymenu) (easy-menu-add cperl-menu)) -;;; or should this be left to the user's `cperl-mode-hook'? - -;;; Some bugs introduced by the above fix corrected (IZ ;-). -;;; Some bugs under XEmacs introduced by the correction corrected. - -;;; Some more can remain since there are two many different variants. -;;; Please feedback! - -;;; We do not support fontification of arrays and hashes under -;;; obsolete font-lock any more. Upgrade. - -;;;; after 1.8 Minor bug with parentheses. -;;;; after 1.9 Improvements from Joe Marzot. -;;;; after 1.10 -;;; Does not need easymenu to compile under XEmacs. -;;; `vc-insert-headers' should work better. -;;; Should work with 19.29 and 19.12. -;;; Small improvements to fontification. -;;; Expansion of keywords does not depend on C-? being backspace. - -;;; after 1.10+ -;;; 19.29 and 19.12 supported. -;;; `cperl-font-lock-enhanced' deprecated. Use font-lock-extra.el. -;;; Support for font-lock-extra.el. - -;;;; After 1.11: -;;; Tools submenu. -;;; Support for perl5-info. -;;; `imenu-go-find-at-position' in Tools requires imenu-go.el (see hints above) -;;; Imenu entries do not work with stock imenu.el. Patch sent to maintainers. -;;; Fontifies `require a if b;', __DATA__. -;;; Arglist for auto-fill-mode was incorrect. - -;;;; After 1.12: -;;; `cperl-lineup-step' and `cperl-lineup' added: lineup constructions -;;; vertically. -;;; `cperl-do-auto-fill' updated for 19.29 style. -;;; `cperl-info-on-command' now has a default. -;;; Workaround for broken C-h on XEmacs. -;;; VC strings escaped. -;;; C-h f now may prompt for function name instead of going on, -;;; controlled by `cperl-info-on-command-no-prompt'. - -;;;; After 1.13: -;;; Msb buffer list includes perl files -;;; Indent-for-comment uses indent-to -;;; Can write tag files using etags. - -;;;; After 1.14: -;;; Recognizes (tries to ;-) {...} which are not blocks during indentation. -;;; `cperl-close-paren-offset' affects ?\] too (and ?\} if not block) -;;; Bug with auto-filling comments started with "##" corrected. - -;;;; Very slow now: on DB::DB 0.91, 486/66: - -;;;Function Name Call Count Elapsed Time Average Time -;;;======================================== ========== ============ ============ -;;;cperl-block-p 469 3.7799999999 0.0080597014 -;;;cperl-get-state 505 163.39000000 0.3235445544 -;;;cperl-comment-indent 12 0.0299999999 0.0024999999 -;;;cperl-backward-to-noncomment 939 4.4599999999 0.0047497337 -;;;cperl-calculate-indent 505 172.22000000 0.3410297029 -;;;cperl-indent-line 505 172.88000000 0.3423366336 -;;;cperl-use-region-p 40 0.0299999999 0.0007499999 -;;;cperl-indent-exp 1 177.97000000 177.97000000 -;;;cperl-to-comment-or-eol 1453 3.9800000000 0.0027391603 -;;;cperl-backward-to-start-of-continued-exp 9 0.0300000000 0.0033333333 -;;;cperl-indent-region 1 177.94000000 177.94000000 - -;;;; After 1.15: -;;; Takes into account white space after opening parentheses during indent. -;;; May highlight pods and here-documents: see `cperl-pod-here-scan', -;;; `cperl-pod-here-fontify', `cperl-pod-face'. Does not use this info -;;; for indentation so far. -;;; Fontification updated to 19.30 style. -;;; The change 19.29->30 did not add all the required functionality, -;;; but broke "font-lock-extra.el". Get "choose-color.el" from -;;; ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs - -;;;; After 1.16: -;;; else # comment -;;; recognized as a start of a block. -;;; Two different font-lock-levels provided. -;;; `cperl-pod-head-face' introduced. Used for highlighting. -;;; `imenu' marks pods, +Packages moved to the head. - -;;;; After 1.17: -;;; Scan for pods highlights here-docs too. -;;; Note that the tag of here-doc may be rehighlighted later by lazy-lock. -;;; Only one here-doc-tag per line is supported, and one in comment -;;; or a string may break fontification. -;;; POD headers were supposed to fill one line only. - -;;;; After 1.18: -;;; `font-lock-keywords' were set in 19.30 style _always_. Current scheme -;;; may break under XEmacs. -;;; `cperl-calculate-indent' dis suppose that `parse-start' was defined. -;;; `fontified' tag is added to fontified text as well as `lazy-lock' (for -;;; compatibility with older lazy-lock.el) (older one overfontifies -;;; something nevertheless :-(). -;;; Will not indent something inside pod and here-documents. -;;; Fontifies the package name after import/no/bootstrap. -;;; Added new entry to menu with meta-info about the mode. - -;;;; After 1.19: -;;; Prefontification works much better with 19.29. Should be checked -;;; with 19.30 as well. -;;; Some misprints in docs corrected. -;;; Now $a{-text} and -text => "blah" are fontified as strings too. -;;; Now the pod search is much stricter, so it can help you to find -;;; pod sections which are broken because of whitespace before =blah -;;; - just observe the fontification. - -;;;; After 1.20 -;;; Anonymous subs are indented with respect to the level of -;;; indentation of `sub' now. -;;; {} is recognized as hash after `bless' and `return'. -;;; Anonymous subs are split by `cperl-linefeed' as well. -;;; Electric parens embrace a region if present. -;;; To make `cperl-auto-newline' useful, -;;; `cperl-auto-newline-after-colon' is introduced. -;;; `cperl-electric-parens' is now t or nul. The old meaning is moved to -;;; `cperl-electric-parens-string'. -;;; `cperl-toggle-auto-newline' introduced, put on C-c C-a. -;;; `cperl-toggle-abbrev' introduced, put on C-c C-k. -;;; `cperl-toggle-electric' introduced, put on C-c C-e. -;;; Beginning-of-defun-regexp was not anchored. - -;;;; After 1.21 -;;; Auto-newline grants `cperl-extra-newline-before-brace' if "{" is typed -;;; after ")". -;;; {} is recognized as expression after `tr' and friends. - -;;;; After 1.22 -;;; Entry Hierarchy added to imenu. Very primitive so far. -;;; One needs newer `imenu-go'.el. A patch to `imenu' is needed as well. -;;; Writes its own TAGS files. -;;; Class viewer based on TAGS files. Does not trace @ISA so far. -;;; 19.31: Problems with scan for PODs corrected. -;;; First POD header correctly fontified. -;;; I needed (setq imenu-use-keymap-menu t) to get good imenu in 19.31. -;;; Apparently it makes a lot of hierarchy code obsolete... - -;;;; After 1.23 -;;; Tags filler now scans *.xs as well. -;;; The info from *.xs scan is used by the hierarchy viewer. -;;; Hierarchy viewer documented. -;;; Bug in 19.31 imenu documented. - -;;;; After 1.24 -;;; New location for info-files mentioned, -;;; Electric-; should work better. -;;; Minor bugs with POD marking. - -;;;; After 1.25 (probably not...) -;;; `cperl-info-page' introduced. -;;; To make `uncomment-region' working, `comment-region' would -;;; not insert extra space. -;;; Here documents delimiters better recognized -;;; (empty one, and non-alphanums in quotes handled). May be wrong with 1<<14? -;;; `cperl-db' added, used in menu. -;;; imenu scan removes text-properties, for better debugging -;;; - but the bug is in 19.31 imenu. -;;; formats highlighted by font-lock and prescan, embedded comments -;;; are not treated. -;;; POD/friends scan merged in one pass. -;;; Syntax class is not used for analyzing the code, only char-syntax -;;; may be checked against _ or'ed with w. -;;; Syntax class of `:' changed to be _. -;;; `cperl-find-bad-style' added. - -;;;; After 1.25 -;;; When search for here-documents, we ignore commented << in simplest cases. -;;; `cperl-get-help' added, available on C-h v and from menu. -;;; Auto-help added. Default with `cperl-hairy', switchable on/off -;;; with startup variable `cperl-lazy-help-time' and from -;;; menu. Requires `run-with-idle-timer'. -;;; Highlighting of @abc{@efg} was wrong - interchanged two regexps. - -;;;; After 1.27 -;;; Indentation: At toplevel after a label - fixed. -;;; 1.27 was put to archives in binary mode ===> DOSish :-( - -;;;; After 1.28 -;;; Thanks to Martin Buchholz : misprints in -;;; comments and docstrings corrected, XEmacs support cleaned up. -;;; The closing parenths would enclose the region into matching -;;; parens under the same conditions as the opening ones. -;;; Minor updates to `cperl-short-docs'. -;;; Will not consider <<= as start of here-doc. - -;;;; After 1.29 -;;; Added an extra advice to look into Micro-docs. ;-). -;;; Enclosing of region when you press a closing parenth is regulated by -;;; `cperl-electric-parens-string'. -;;; Minor updates to `cperl-short-docs'. -;;; `initialize-new-tags-table' called only if present (Does this help -;;; with generation of tags under XEmacs?). -;;; When creating/updating tag files, new info is written at the old place, -;;; or at the end (is this a wanted behaviour? I need this in perl build directory). - -;;;; After 1.30 -;;; All the keywords from keywords.pl included (maybe with dummy explanation). -;;; No auto-help inside strings, comment, here-docs, formats, and pods. -;;; Shrinkwrapping of info, regulated by `cperl-max-help-size', -;;; `cperl-shrink-wrap-info-frame'. -;;; Info on variables as well. -;;; Recognision of HERE-DOCS improved yet more. -;;; Autonewline works on `}' without warnings. -;;; Autohelp works again on $_[0]. - -;;;; After 1.31 -;;; perl-descr.el found its author - hi, Johan! -;;; Some support for correct indent after here-docs and friends (may -;;; be superseeded by eminent change to Emacs internals). -;;; Should work with older Emaxen as well ( `-style stuff removed). - -;;;; After 1.32 - -;;; Started to add support for `syntax-table' property (should work -;;; with patched Emaxen), controlled by -;;; `cperl-use-syntax-table-text-property'. Currently recognized: -;;; All quote-like operators: m, s, y, tr, qq, qw, qx, q, -;;; // in most frequent context: -;;; after block or -;;; ~ { ( = | & + - * ! , ; -;;; or -;;; while if unless until and or not xor split grep map -;;; Here-documents, formats, PODs, -;;; ${...} -;;; 'abc$' -;;; sub a ($); sub a ($) {} -;;; (provide 'cperl-mode) was missing! -;;; `cperl-after-expr-p' is now much smarter after `}'. -;;; `cperl-praise' added to mini-docs. -;;; Utilities try to support subs-with-prototypes. - -;;;; After 1.32.1 -;;; `cperl-after-expr-p' is now much smarter after "() {}" and "word {}": -;;; if word is "else, map, grep". -;;; Updated for new values of syntax-table constants. -;;; Uses `help-char' (at last!) (disabled, does not work?!) -;;; A couple of regexps where missing _ in character classes. -;;; -s could be considered as start of regexp, 1../blah/ was not, -;;; as was not /blah/ at start of file. - -;;;; After 1.32.2 -;;; "\C-hv" was wrongly "\C-hf" -;;; C-hv was not working on `[index()]' because of [] in skip-chars-*. -;;; `__PACKAGE__' supported. -;;; Thanks for Greg Badros: `cperl-lazy-unstall' is more complete, -;;; `cperl-get-help' is made compatible with `query-replace'. - -;;;; As of Apr 15, development version of 19.34 supports -;;;; `syntax-table' text properties. Try setting -;;;; `cperl-use-syntax-table-text-property'. - -;;;; After 1.32.3 -;;; We scan for s{}[] as well. -;;; We scan for $blah'foo as well. -;;; The default is to use `syntax-table' text property if Emacs is good enough. -;;; `cperl-lineup' is put on C-M-| (=C-M-S-\\). -;;; Start of `cperl-beautify-regexp'. - -;;;; After 1.32.4 -;;; `cperl-tags-hier-init' did not work in text-mode. -;;; `cperl-noscan-files-regexp' had a misprint. -;;; Generation of Class Hierarchy was broken due to a bug in `x-popup-menu' -;;; in 19.34. - -;;;; After 1.33: -;;; my,local highlight vars after {} too. -;;; TAGS could not be created before imenu was loaded. -;;; `cperl-indent-left-aligned-comments' created. -;;; Logic of `cperl-indent-exp' changed a little bit, should be more -;;; robust w.r.t. multiline strings. -;;; Recognition of blah'foo takes into account strings. -;;; Added '.al' to the list of Perl extensions. -;;; Class hierarchy is "mostly" sorted (need to rethink algorthm -;;; of pruning one-root-branch subtrees to get yet better sorting.) -;;; Regeneration of TAGS was busted. -;;; Can use `syntax-table' property when generating TAGS -;;; (governed by `cperl-use-syntax-table-text-property-for-tags'). - -;;; Code: - -(defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version)) - - -;;--------------------------------------------------------- -(defgroup perl nil - "CPerl mode 1.35 with XEmacs enhancements." - :prefix "cperl" - :group 'languages) - -;;----------------------------------------------- -(defgroup cperl-indent nil - "CPerl indention control variables." - :prefix "cperl" - :group 'perl) - -(defcustom cperl-tab-always-indent t - "*Non-nil means TAB in CPerl mode should always reindent the current line, -regardless of where in the line point is when the TAB command is used." - :type 'boolean - :group 'cperl-indent) - -(defcustom cperl-extra-newline-before-brace nil - "*Non-nil means that if, elsif, while, until, else, for, foreach -and do constructs look like: - - if () - { - } - -instead of: - - if () { - } -" - :type 'boolean - :group 'cperl-indent) - -(defcustom cperl-indent-level 2 - "*Indentation of CPerl statements with respect to containing block." - :type '(choice (const 1) (const 2) (const 4) (const 6) (const 8)) - :group 'cperl-indent) - -(defcustom cperl-lineup-step nil - "*`cperl-lineup' will always lineup at multiple of this number. -If `nil', the value of `cperl-indent-level' will be used." - :type '(choice (const nil) (const 1) (const 2) (const 4) (const 6) (const 8)) - :group 'cperl-indent) - -(defcustom cperl-brace-imaginary-offset 0 - "*Imagined indentation of a Perl open brace that actually follows a statement. -An open brace following other text is treated as if it were this far -to the right of the start of its line." - :type '(choice (const 0) (const 1) (const 2) (const 4) (const 6) (const 8)) - :group 'cperl-indent) - -(defcustom cperl-brace-offset 0 - "*Extra indentation for braces, compared with other text in same context." - :type '(choice (const 0) (const 1) (const 2) (const 4) (const 6) (const 8)) - :group 'cperl-indent) - -(defcustom cperl-label-offset -2 - "*Offset of CPerl label lines relative to usual indentation." - :type '(choice (const -4) (const -2) (const -1)) - :group 'cperl-indent) - -(defcustom cperl-min-label-indent 1 - "*Minimal offset of CPerl label lines." - :type '(choice (const 1) (const 2) (const 4)) - :group 'cperl-indent) - -(defcustom cperl-continued-statement-offset 2 - "*Extra indent for lines not starting new statements." - :type '(choice (const 2) (const 4) (const 6) (const 8)) - :group 'cperl-indent) - -(defcustom cperl-continued-brace-offset 0 - "*Extra indent for substatements that start with open-braces. -This is in addition to cperl-continued-statement-offset." - :type '(choice (const 0) (const 1) (const 2) (const 4) (const 6) (const 8)) - :group 'cperl-indent) - -(defcustom cperl-close-paren-offset -1 - "*Extra indent for substatements that start with close-parenthesis." - :type '(choice (const -4) (const -3) (const -2) (const -1) (const 0)) - :group 'cperl-indent) - -(defcustom cperl-regexp-indent-step nil - "*indentation used when beautifying regexps. -If `nil', the value of `cperl-indent-level' will be used." - :type '(choice (const nil) (const 0) (const 2) (const 4) (const 6) (const 8)) - :group 'cperl-indent) - -(defcustom cperl-indent-left-aligned-comments t - "*Non-nil means that the comment starting in leftmost column should indent." - :type 'boolean - :group 'cperl-indent) - -;;------------------------------------------- - -(defcustom cperl-hairy nil - "*Not-nil means all the bells and whistles are enabled in CPerl." - :type 'boolean - :group 'perl) - -(defcustom cperl-auto-newline nil - "*Non-nil means automatically newline before and after braces, -and after colons and semicolons, inserted in CPerl code. The following -\\[cperl-electric-backspace] will remove the inserted whitespace. -Insertion after colons requires both this variable and -`cperl-auto-newline-after-colon' set." - :type 'boolean - :group 'perl) - -(defcustom cperl-auto-newline-after-colon nil - "*Non-nil means automatically newline even after colons. -Subject to `cperl-auto-newline' setting." - :type 'boolean - :group 'perl) - -;;-------------------------------------- -(defgroup cperl-electric nil - "Customizable electric behaviour." - :prefix "cperl" - :group 'perl) - -(defcustom cperl-electric-lbrace-space nil - "*Non-nil (and non-null) means { after $ in CPerl buffers should be preceded by ` '. -Can be overwritten by `cperl-hairy' if nil." - :type 'boolean - :group 'cperl-electric) - -(defcustom cperl-electric-parens-string "({[]})<" - "*String of parentheses that should be electric in CPerl." - :type 'string - :group 'cperl-electric) - -(defcustom cperl-electric-parens nil - "*Non-nil (and non-null) means parentheses should be electric in CPerl. -Can be overwritten by `cperl-hairy' if nil." - :type 'boolean - :group 'cperl-electric) - -(defcustom cperl-electric-parens-mark (and window-system - (boundp 'zmacs-regions) - zmacs-regions) - "*Not-nil means that electric parens look for active mark. -Default is yes if there is visual feedback on mark." - :type 'boolean - :group 'cperl-electric) - -(defcustom cperl-electric-linefeed nil - "*If true, LFD should be hairy in CPerl, otherwise C-c LFD is hairy. -In any case these two mean plain and hairy linefeeds together. -Can be overwritten by `cperl-hairy' if nil." - :type 'boolean - :group 'cperl-electric) - -(defcustom cperl-electric-keywords nil - "*Not-nil (and non-null) means keywords are electric in CPerl. -Can be overwritten by `cperl-hairy' if nil." - :type 'boolean - :group 'cperl-electric) -;;------------------------- - -(defcustom cperl-comment-column 32 - "*Column to put comments in CPerl (use \\[cperl-indent]' to lineup with code)." - :type 'integer - :group 'perl) - -(defcustom cperl-vc-header-alist '((RCS "$rcs = ' $Id\$ ' ;") - (CVS "$cvs = ' $Id\$ ' ;") - (SCCS "$sccs = '%W\%' ;")) - "*What to use as `vc-header-alist' in CPerl.") - - -(defcustom cperl-info-on-command-no-prompt nil - "*Not-nil (and non-null) means not to prompt on C-h f. -The opposite behaviour is always available if prefixed with C-c. -Can be overwritten by `cperl-hairy' if nil." - :type 'boolean - :group 'perl) - -(defcustom cperl-help nil - "*Not-nil (and non-null) means to show Auto help." - :type 'boolean - :group 'perl) - - -(defcustom cperl-font-lock (and (boundp 'font-lock-auto-fontify) - font-lock-auto-fontify) - "*Non-nil (and non-null) means CPerl buffers will use font-lock-mode. -Can be overwritten by `cperl-hairy' if nil. If never set, it will be -set to the value of `font-lock-auto-fontify'." - :type 'boolean - :group 'perl) - -;;-------------------------------------------- -(defgroup cperl-faces nil - "Font lock faces for CPerl mode." - :group 'perl - :group 'faces) - -(defface cperl-pod-face - '(( ((class color) (background light)) (:foreground "brown4") ) - ( ((class color) (background dark)) (:foreground "brown1") )) - "*The face used for POD highlighting." - :group 'cperl-faces) - -(defface cperl-pod-head-face - '(( ((class color)) (:foreground "steelblue"))) - "*The face used for POD headers." - :group 'cperl-faces) - -(defface cperl-here-face - '((((type x) (class color) (background light)) - (:foreground "green4" :background "grey85")) - (t (:foreground "green"))) - "*The result of evaluation of this expression is used for here-docs highlighting." - :group 'cperl-faces) - -(defcustom cperl-pod-here-fontify '(featurep 'font-lock) - "*Not-nil after evaluation means to highlight pod and here-docs sections." - :type 'boolean - :group 'perl) - -(defcustom cperl-pod-here-scan t - "*Not-nil means look for pod and here-docs sections during startup. -You can always make lookup from menu or using \\[cperl-find-pods-heres]." - :type 'boolean - :group 'perl) - -;; ToDo: perhaps `imenu' should be ported to XEmacs? -;;(defcustom cperl-imenu-addback nil -;; "*Not-nil means add backreferences to generated `imenu's. -;;May require patched `imenu' and `imenu-go'." -;; :type 'boolean -;; :group 'perl) - -(defcustom cperl-max-help-size 66 - "*Non-nil means shrink-wrapping of info-buffer allowed up to these percents." - :type 'integer - :group 'perl) - -(defcustom cperl-shrink-wrap-info-frame t - "*Non-nil means shrink-wrapping of info-buffer-frame allowed." - :type 'boolean - :group 'perl) - -(defcustom cperl-info-page "perl" - "*Name of the info page containing perl docs. -Older version of this page was called `perl5', newer `perl'." - :type 'string - :group 'perl) - -(defvar cperl-use-syntax-table-text-property nil - "Temporary kludge until I find everything connected to this so I can - rip it out.") - -;;(defcustom cperl-use-syntax-table-text-property -;; (boundp 'parse-sexp-lookup-properties) -;; "*Non-nil means CPerl sets up and uses `syntax-table' text property." -;; :type 'boolean -;; :group 'perl) - -(defvar cperl-use-syntax-table-text-property-for-tags - cperl-use-syntax-table-text-property - "*Non-nil means: set up and use `syntax-table' text property generating TAGS.") - -(defcustom cperl-scan-files-regexp "\\.\\([pP][Llm]\\|xs\\)$" - "*Regexp to match files to scan when generating TAGS." - :type 'regexp - :group 'perl) - -(defcustom cperl-noscan-files-regexp "/\\(\\.\\.?\\|SCCS\\|RCS\\|blib\\)$" - "*Regexp to match files/dirs to skip when generating TAGS." - :type 'regexp - :group 'perl) - - - -;;; Short extra-docs. - -(defvar cperl-tips 'please-ignore-this-line - "Get newest version of this package from - ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs -and/or - ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl - - This particular version has been modified for XEmacs 20. - -Get support packages choose-color.el (or font-lock-extra.el before -19.30), imenu-go.el from the same place. \(Look for other files there -too... ;-) Get a patch for imenu.el in 19.29. Note that for 19.30 and -later you should use choose-color.el *instead* of font-lock-extra.el -\(and you will not get smart highlighting in C :-(). - -Note that to enable Compile choices in the menu you need to install -mode-compile.el. - -Get perl5-info from - $CPAN/doc/manual/info/perl-info.tar.gz -older version was on - http://www.metronet.com:70/9/perlinfo/perl5/manual/perl5-info.tar.gz - -If you use imenu-go, run imenu on perl5-info buffer (you can do it -from CPerl menu). If many files are related, generate TAGS files from -Tools/Tags submenu in CPerl menu. - -If some class structure is too complicated, use Tools/Hierarchy-view -from CPerl menu, or hierarchic view of imenu. The second one uses the -current buffer only, the first one requires generation of TAGS from -CPerl/Tools/Tags menu beforehand. - -Run CPerl/Tools/Insert-spaces-if-needed to fix your lazy typing. - -Switch auto-help on/off with CPerl/Tools/Auto-help. - -Before reporting (non-)problems look in the problem section on what I -know about them.") - -(defvar cperl-problems 'please-ignore-this-line -"Emacs has a _very_ restricted syntax parsing engine. - -It may be corrected on the level of C code, please look in the -`non-problems' section if you want to volunteer. - -CPerl mode tries to corrects some Emacs misunderstandings, however, -for efficiency reasons the degree of correction is different for -different operations. The partially corrected problems are: POD -sections, here-documents, regexps. The operations are: highlighting, -indentation, electric keywords, electric braces. - -This may be confusing, since the regexp s#//#/#\; may be highlighted -as a comment, but it will be recognized as a regexp by the indentation -code. Or the opposite case, when a pod section is highlighted, but -may break the indentation of the following code (though indentation -should work if the balance of delimiters is not broken by POD). - -The main trick (to make $ a \"backslash\") makes constructions like -${aaa} look like unbalanced braces. The only trick I can think of is -to insert it as $ {aaa} (legal in perl5, not in perl4). - -Similar problems arise in regexps, when /(\\s|$)/ should be rewritten -as /($|\\s)/. Note that such a transposition is not always possible -:-(. " ) - -(defvar cperl-non-problems 'please-ignore-this-line -"As you know from `problems' section, Perl syntax is too hard for CPerl. - -Most the time, if you write your own code, you may find an equivalent -\(and almost as readable) expression. - -Try to help CPerl: add comments with embedded quotes to fix CPerl -misunderstandings about the end of quotation: - -$a='500$'; # '; - -You won't need it too often. The reason: $ \"quotes\" the following -character (this saves a life a lot of times in CPerl), thus due to -Emacs parsing rules it does not consider tick (i.e., ' ) after a -dollar as a closing one, but as a usual character. - -Now the indentation code is pretty wise. The only drawback is that it -relies on Emacs parsing to find matching parentheses. And Emacs -*cannot* match parentheses in Perl 100% correctly. So - 1 if s#//#/#; -will not break indentation, but - 1 if ( s#//#/# ); -will. - -By similar reasons - s\"abc\"def\"; -will confuse CPerl a lot. - -If you still get wrong indentation in situation that you think the -code should be able to parse, try: - -a) Check what Emacs thinks about balance of your parentheses. -b) Supply the code to me (IZ). - -Pods are treated _very_ rudimentally. Here-documents are not treated -at all (except highlighting and inhibiting indentation). (This may -change some time. RMS approved making syntax lookup recognize text -attributes, but volunteers are needed to change Emacs C code.) - -To speed up coloring the following compromises exist: - a) sub in $mypackage::sub may be highlighted. - b) -z in [a-z] may be highlighted. - c) if your regexp contains a keyword (like \"s\"), it may be highlighted. - - -Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove -`car' before `imenu-choose-buffer-index' in `imenu'. -") - -(defvar cperl-praise 'please-ignore-this-line - "RMS asked me to list good things about CPerl. Here they go: - -0) It uses the newest `syntax-table' property ;-); - -1) It does 99% of Perl syntax correct (as opposed to 80-90% in Perl -mode - but the latter number may have improved too in last years) even -without `syntax-table' property; When using this property, it should -handle 99.995% of lines correct - or somesuch. - -2) It is generally belived to be \"the most user-friendly Emacs -package\" whatever it may mean (I doubt that the people who say similar -things tried _all_ the rest of Emacs ;-), but this was not a lonely -voice); - -3) Everything is customizable, one-by-one or in a big sweep; - -4) It has many easily-accessable \"tools\": - a) Can run program, check syntax, start debugger; - b) Can lineup vertically \"middles\" of rows, like `=' in - a = b; - cc = d; - c) Can insert spaces where this impoves readability (in one - interactive sweep over the buffer); - d) Has support for imenu, including: - 1) Separate unordered list of \"interesting places\"; - 2) Separate TOC of POD sections; - 3) Separate list of packages; - 4) Hierarchical view of methods in (sub)packages; - 5) and functions (by the full name - with package); - e) Has an interface to INFO docs for Perl; The interface is - very flexible, including shrink-wrapping of - documentation buffer/frame; - f) Has a builtin list of one-line explanations for perl constructs. - g) Can show these explanations if you stay long enough at the - corresponding place (or on demand); - h) Has an enhanced fontification (using 3 or 4 additional faces - comparing to font-lock - basically, different - namespaces in Perl have different colors); - i) Can construct TAGS basing on its knowledge of Perl syntax, - the standard menu has 6 different way to generate - TAGS (if by directory, .xs files - with C-language - bindings - are included in the scan); - j) Can build a hierarchical view of classes (via imenu) basing - on generated TAGS file; - k) Has electric parentheses, electric newlines, uses Abbrev - for electric logical constructs - while () {} - with different styles of expansion (context sensitive - to be not so bothering). Electric parentheses behave - \"as they should\" in a presence of a visible region. - l) Changes msb.el \"on the fly\" to insert a group \"Perl files\"; - -5) The indentation engine was very smart, but most of tricks may be -not needed anymore with the support for `syntax-table' property. Has -progress indicator for indentation (with `imenu' loaded). - -6) Indent-region improves inline-comments as well; - -7) Fill-paragraph correctly handles multi-line comments; -") - - - -;;; Portability stuff: - -(defmacro cperl-define-key (fsf-key definition &optional xemacs-key) - (` (define-key cperl-mode-map - (, (if xemacs-key - (` (if cperl-xemacs-p (, xemacs-key) (, fsf-key))) - fsf-key)) - (, definition)))) - -(defvar del-back-ch (car (append (where-is-internal 'delete-backward-char) - (where-is-internal 'backward-delete-char-untabify))) - "Character generated by key bound to delete-backward-char.") - -(and (vectorp del-back-ch) (= (length del-back-ch) 1) - (setq del-back-ch (aref del-back-ch 0))) - -(if cperl-xemacs-p - (progn - ;; "Active regions" are on: use region only if active - ;; "Active regions" are off: use region unconditionally - (defun cperl-use-region-p () - (if zmacs-regions (mark) t)) - (defun cperl-mark-active () (mark))) - (defun cperl-use-region-p () - (if transient-mark-mode mark-active t)) - (defun cperl-mark-active () mark-active)) - -(defsubst cperl-enable-font-lock () - (or cperl-xemacs-p window-system)) - -(if (boundp 'unread-command-events) - (if cperl-xemacs-p - (defun cperl-putback-char (c) ; XEmacs >= 19.12 - (setq unread-command-events (list (character-to-event c)))) - (defun cperl-putback-char (c) ; Emacs 19 - (setq unread-command-events (list c)))) - (defun cperl-putback-char (c) ; XEmacs <= 19.11 - (setq unread-command-event (character-to-event c)))) - -(or (fboundp 'uncomment-region) - (defun uncomment-region (beg end) - (interactive "r") - (comment-region beg end -1))) - -(defvar cperl-do-not-fontify - (if (string< emacs-version "19.30") - 'fontified - 'lazy-lock) - "Text property which inhibits refontification.") - -(defsubst cperl-put-do-not-fontify (from to) - (put-text-property (max (point-min) (1- from)) - to cperl-do-not-fontify t)) - -(defcustom cperl-mode-hook nil - "Hook run by `cperl-mode'." - :type 'sexp - :group 'perl) - - -;;; Probably it is too late to set these guys already, but it can help later: -;;; #### -(setq auto-mode-alist - (append '(("\\.\\([pP][Llm]\\|al\\)\\'" . perl-mode)) auto-mode-alist )) -(and (boundp 'interpreter-mode-alist) - (setq interpreter-mode-alist (append interpreter-mode-alist - '(("miniperl" . perl-mode))))) -(if (fboundp 'eval-when-compile) - (eval-when-compile - (condition-case nil - (require 'imenu) - (error nil)) - (condition-case nil - (require 'easymenu) - (error nil)) - ;; Calling `cperl-enable-font-lock' below doesn't compile on XEmacs, - ;; macros instead of defsubsts don't work on Emacs, so we do the - ;; expansion manually. Any other suggestions? - (if (or (string-match "XEmacs\\|Lucid" emacs-version) - window-system) - (require 'font-lock)) - (require 'cl) - )) - -(defvar cperl-mode-abbrev-table nil - "Abbrev table in use in Cperl-mode buffers.") - -(add-hook 'edit-var-mode-alist '(perl-mode (regexp . "^cperl-"))) - -(defvar cperl-mode-map () "Keymap used in CPerl mode.") - -(if cperl-mode-map nil - (setq cperl-mode-map (make-sparse-keymap)) - (cperl-define-key "{" 'cperl-electric-lbrace) - (cperl-define-key "[" 'cperl-electric-paren) - (cperl-define-key "(" 'cperl-electric-paren) - (cperl-define-key "<" 'cperl-electric-paren) - (cperl-define-key "}" 'cperl-electric-brace) - (cperl-define-key "]" 'cperl-electric-rparen) - (cperl-define-key ")" 'cperl-electric-rparen) - (cperl-define-key ";" 'cperl-electric-semi) - (cperl-define-key ":" 'cperl-electric-terminator) - (cperl-define-key "\C-cf" 'cperl-find-pods-heres) - (cperl-define-key "\C-j" 'newline-and-indent) - (cperl-define-key "\C-c\C-j" 'cperl-linefeed) - (cperl-define-key "\C-c\C-a" 'cperl-toggle-auto-newline) - (cperl-define-key "\C-c\C-k" 'cperl-toggle-abbrev) - (cperl-define-key "\C-c\C-e" 'cperl-toggle-electric) - (cperl-define-key "\e\C-q" 'cperl-indent-exp) ; Usually not bound - (cperl-define-key [?\C-\M-\|] 'cperl-lineup) - ;;(cperl-define-key "\M-q" 'cperl-fill-paragraph) - ;;(cperl-define-key "\e;" 'cperl-indent-for-comment) - (if cperl-xemacs-p - (progn - (cperl-define-key 'backspace 'cperl-electric-backspace) - (cperl-define-key 'delete 'cperl-electric-delete)) - (cperl-define-key "\177" 'cperl-electric-backspace)) - (cperl-define-key "\t" 'cperl-indent-command) - ;; don't clobber the backspace binding: - (cperl-define-key "\C-c\C-hf" 'cperl-info-on-current-command - [(control c) (control h) f]) - (cperl-define-key "\C-hf" - ;;(concat (char-to-string help-char) "f") ; does not work - 'cperl-info-on-command - [(control h) f]) - (cperl-define-key "\C-hv" - ;;(concat (char-to-string help-char) "v") ; does not work - 'cperl-get-help - [(control h) v]) - (if (and cperl-xemacs-p - (<= emacs-minor-version 11) (<= emacs-major-version 19)) - (progn - ;; substitute-key-definition is usefulness-deenhanced... - (cperl-define-key "\M-q" 'cperl-fill-paragraph) - (cperl-define-key "\e;" 'cperl-indent-for-comment) - (cperl-define-key "\e\C-\\" 'cperl-indent-region)) - (substitute-key-definition - 'indent-sexp 'cperl-indent-exp - cperl-mode-map global-map) - (substitute-key-definition - 'fill-paragraph 'cperl-fill-paragraph - cperl-mode-map global-map) - (substitute-key-definition - 'indent-region 'cperl-indent-region - cperl-mode-map global-map) - (substitute-key-definition - 'indent-for-comment 'cperl-indent-for-comment - cperl-mode-map global-map))) - -(condition-case nil - (progn - (require 'easymenu) - (easy-menu-define cperl-menu cperl-mode-map "Menu for CPerl mode" - '("Perl" - ["Beginning of function" beginning-of-defun t] - ["End of function" end-of-defun t] - ["Mark function" mark-defun t] - ["Indent expression" cperl-indent-exp t] - ["Fill paragraph/comment" cperl-fill-paragraph t] - "----" - ["Line up a construction" cperl-lineup (cperl-use-region-p)] - ["Beautify a regexp" cperl-beautify-regexp - cperl-use-syntax-table-text-property] - "----" - ["Indent region" cperl-indent-region (cperl-use-region-p)] - ["Comment region" cperl-comment-region (cperl-use-region-p)] - ["Uncomment region" cperl-uncomment-region (cperl-use-region-p)] - "----" - ["Run" mode-compile (fboundp 'mode-compile)] - ["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill) - (get-buffer "*compilation*"))] - ["Next error" next-error (get-buffer "*compilation*")] - ["Check syntax" cperl-check-syntax (fboundp 'mode-compile)] - "----" - ["Debugger" cperl-db t] - "----" - ("Tools" -;;; ["Imenu" imenu (fboundp 'imenu)] - ["Insert spaces if needed" cperl-find-bad-style t] - ["Class Hierarchy from TAGS" cperl-tags-hier-init t] - ;;["Update classes" (cperl-tags-hier-init t) tags-table-list] -;;; ["Imenu on info" cperl-imenu-on-info (featurep 'imenu)] - ("Tags" - ["Create tags for current file" cperl-etags t] - ["Add tags for current file" (cperl-etags t) t] - ["Create tags for Perl files in directory" (cperl-etags nil t) t] - ["Add tags for Perl files in directory" (cperl-etags t t) t] - ["Create tags for Perl files in (sub)directories" - (cperl-etags nil 'recursive) t] - ["Add tags for Perl files in (sub)directories" - (cperl-etags t 'recursive) t]) -;;;; cperl-write-tags (&optional file erase recurse dir inbuffer) -;;; ["Create tags for current file" (cperl-write-tags nil t) t] -;;; ["Add tags for current file" (cperl-write-tags) t] -;;; ["Create tags for Perl files in directory" -;;; (cperl-write-tags nil t nil t) t] -;;; ["Add tags for Perl files in directory" -;;; (cperl-write-tags nil nil nil t) t] -;;; ["Create tags for Perl files in (sub)directories" -;;; (cperl-write-tags nil t t t) t] -;;; ["Add tags for Perl files in (sub)directories" -;;; (cperl-write-tags nil nil t t) t]) - ["Recalculate PODs and HEREs" cperl-find-pods-heres t] -;;; ["Define word at point" imenu-go-find-at-position -;;; (fboundp 'imenu-go-find-at-position)] - ["Help on function" cperl-info-on-command t] - ["Help on function at point" cperl-info-on-current-command t] - ["Help on symbol at point" cperl-get-help t] - ) - ("Toggle..." - ["Auto-help" cperl-toggle-help :style toggle :selected cperl-help] - ["Auto newline" cperl-toggle-auto-newline t] - ["Electric parens" cperl-toggle-electric t] - ["Electric keywords" cperl-toggle-abbrev t] - ) - ("Indent styles..." - ["GNU" (cperl-set-style "GNU") t] - ["C++" (cperl-set-style "C++") t] - ["FSF" (cperl-set-style "FSF") t] - ["BSD" (cperl-set-style "BSD") t] - ["Whitesmith" (cperl-set-style "Whitesmith") t] - ) - ("Micro-docs" - ["Tips" (describe-variable 'cperl-tips) t] - ["Problems" (describe-variable 'cperl-problems) t] - ["Non-problems" (describe-variable 'cperl-non-problems) t] - ["Praise" (describe-variable 'cperl-praise) t])))) - (error nil)) - -(autoload 'c-macro-expand "cmacexp" - "Display the result of expanding all C macros occurring in the region. -The expansion is entirely correct because it uses the C preprocessor." - t) - -(defvar cperl-mode-syntax-table nil - "Syntax table in use in Cperl-mode buffers.") - -(defvar cperl-string-syntax-table nil - "Syntax table in use in Cperl-mode string-like chunks.") - -(if cperl-mode-syntax-table - () - (setq cperl-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\\ "\\" cperl-mode-syntax-table) - (modify-syntax-entry ?/ "." cperl-mode-syntax-table) - (modify-syntax-entry ?* "." cperl-mode-syntax-table) - (modify-syntax-entry ?+ "." cperl-mode-syntax-table) - (modify-syntax-entry ?- "." cperl-mode-syntax-table) - (modify-syntax-entry ?= "." cperl-mode-syntax-table) - (modify-syntax-entry ?% "." cperl-mode-syntax-table) - (modify-syntax-entry ?< "." cperl-mode-syntax-table) - (modify-syntax-entry ?> "." cperl-mode-syntax-table) - (modify-syntax-entry ?& "." cperl-mode-syntax-table) - (modify-syntax-entry ?$ "\\" cperl-mode-syntax-table) - (modify-syntax-entry ?\n ">" cperl-mode-syntax-table) - (modify-syntax-entry ?# "<" cperl-mode-syntax-table) - (modify-syntax-entry ?' "\"" cperl-mode-syntax-table) - (modify-syntax-entry ?` "\"" cperl-mode-syntax-table) - (modify-syntax-entry ?_ "w" cperl-mode-syntax-table) - (modify-syntax-entry ?: "_" cperl-mode-syntax-table) - (modify-syntax-entry ?| "." cperl-mode-syntax-table) - (setq cperl-string-syntax-table (copy-syntax-table cperl-mode-syntax-table)) - (modify-syntax-entry ?$ "." cperl-string-syntax-table) - (modify-syntax-entry ?# "." cperl-string-syntax-table) ; (?# comment ) -) - - - -;; Make customization possible "in reverse" -;;(defun cperl-set (symbol to) -;; (or (eq (symbol-value symbol) 'null) (set symbol to))) -(defsubst cperl-val (symbol &optional default hairy) - (cond - ((eq (symbol-value symbol) 'null) default) - (cperl-hairy (or hairy t)) - (t (symbol-value symbol)))) - -;; provide an alias for working with emacs 19. the perl-mode that comes -;; with it is really bad, and this lets us seamlessly replace it. -;;;###autoload -(defalias 'perl-mode 'cperl-mode) -;;;###autoload -(defun cperl-mode () - "Major mode for editing Perl code. -Expression and list commands understand all C brackets. -Tab indents for Perl code. -Paragraphs are separated by blank lines only. -Delete converts tabs to spaces as it moves back. - -Various characters in Perl almost always come in pairs: {}, (), [], -sometimes <>. When the user types the first, she gets the second as -well, with optional special formatting done on {}. (Disabled by -default.) You can always quote (with \\[quoted-insert]) the left -\"paren\" to avoid the expansion. The processing of < is special, -since most the time you mean \"less\". Cperl mode tries to guess -whether you want to type pair <>, and inserts is if it -appropriate. You can set `cperl-electric-parens-string' to the string that -contains the parenths from the above list you want to be electrical. -Electricity of parenths is controlled by `cperl-electric-parens'. -You may also set `cperl-electric-parens-mark' to have electric parens -look for active mark and \"embrace\" a region if possible.' - -CPerl mode provides expansion of the Perl control constructs: - if, else, elsif, unless, while, until, for, and foreach. -=========(Disabled by default, see `cperl-electric-keywords'.) -The user types the keyword immediately followed by a space, which causes -the construct to be expanded, and the user is positioned where she is most -likely to want to be. -eg. when the user types a space following \"if\" the following appears in -the buffer: - if () { or if () - } { - } -and the cursor is between the parentheses. The user can then type some -boolean expression within the parens. Having done that, typing -\\[cperl-linefeed] places you, appropriately indented on a new line -between the braces. If CPerl decides that you want to insert -\"English\" style construct like - bite if angry; -it will not do any expansion. See also help on variable -`cperl-extra-newline-before-brace'. - -\\[cperl-linefeed] is a convenience replacement for typing carriage -return. It places you in the next line with proper indentation, or if -you type it inside the inline block of control construct, like - foreach (@lines) {print; print} -and you are on a boundary of a statement inside braces, it will -transform the construct into a multiline and will place you into an -appropriately indented blank line. If you need a usual -`newline-and-indent' behaviour, it is on \\[newline-and-indent], -see documentation on `cperl-electric-linefeed'. - -\\{cperl-mode-map} - -Setting the variable `cperl-font-lock' to t switches on -font-lock-mode, `cperl-electric-lbrace-space' to t switches on -electric space between $ and {, `cperl-electric-parens-string' is the -string that contains parentheses that should be electric in CPerl (see -also `cperl-electric-parens-mark' and `cperl-electric-parens'), -setting `cperl-electric-keywords' enables electric expansion of -control structures in CPerl. `cperl-electric-linefeed' governs which -one of two linefeed behavior is preferable. You can enable all these -options simultaneously (recommended mode of use) by setting -`cperl-hairy' to t. In this case you can switch separate options off -by setting them to `null'. Note that one may undo the extra whitespace -inserted by semis and braces in `auto-newline'-mode by consequent -\\[cperl-electric-backspace]. - -If your site has perl5 documentation in info format, you can use commands -\\[cperl-info-on-current-command] and \\[cperl-info-on-command] to access it. -These keys run commands `cperl-info-on-current-command' and -`cperl-info-on-command', which one is which is controlled by variable -`cperl-info-on-command-no-prompt' (in turn affected by `cperl-hairy'). - -Even if you have no info-format documentation, short one-liner-style -help is available on \\[cperl-get-help]. - -It is possible to show this help automatically after some idle -time. This is regulated by variable `cperl-lazy-help-time'. Default -with `cperl-hairy' is 5 secs idle time if the value of this variable -is nil. It is also possible to switch this on/off from the -menu. Requires `run-with-idle-timer'. - -Use \\[cperl-lineup] to vertically lineup some construction - put the -beginning of the region at the start of construction, and make region -span the needed amount of lines. - -Variables `cperl-pod-here-scan', `cperl-pod-here-fontify', -`cperl-pod-face', `cperl-pod-head-face' control processing of pod and -here-docs sections. In a future version results of scan may be used -for indentation too, currently they are used for highlighting only. - -Variables controlling indentation style: - `cperl-tab-always-indent' - Non-nil means TAB in CPerl mode should always reindent the current line, - regardless of where in the line point is when the TAB command is used. - `cperl-auto-newline' - Non-nil means automatically newline before and after braces, - and after colons and semicolons, inserted in Perl code. The following - \\[cperl-electric-backspace] will remove the inserted whitespace. - Insertion after colons requires both this variable and - `cperl-auto-newline-after-colon' set. - `cperl-auto-newline-after-colon' - Non-nil means automatically newline even after colons. - Subject to `cperl-auto-newline' setting. - `cperl-indent-level' - Indentation of Perl statements within surrounding block. - The surrounding block's indentation is the indentation - of the line on which the open-brace appears. - `cperl-continued-statement-offset' - Extra indentation given to a substatement, such as the - then-clause of an if, or body of a while, or just a statement continuation. - `cperl-continued-brace-offset' - Extra indentation given to a brace that starts a substatement. - This is in addition to `cperl-continued-statement-offset'. - `cperl-brace-offset' - Extra indentation for line if it starts with an open brace. - `cperl-brace-imaginary-offset' - An open brace following other text is treated as if it the line started - this far to the right of the actual line indentation. - `cperl-label-offset' - Extra indentation for line that is a label. - `cperl-min-label-indent' - Minimal indentation for line that is a label. - -Settings for K&R and BSD indentation styles are - `cperl-indent-level' 5 8 - `cperl-continued-statement-offset' 5 8 - `cperl-brace-offset' -5 -8 - `cperl-label-offset' -5 -8 - -If `cperl-indent-level' is 0, the statement after opening brace in column 0 is indented on `cperl-brace-offset'+`cperl-continued-statement-offset'. - -Turning on CPerl mode calls the hooks in the variable `cperl-mode-hook' -with no args." - (interactive) - (kill-all-local-variables) - ;;(if cperl-hairy - ;; (progn - ;; (cperl-set 'cperl-font-lock cperl-hairy) - ;; (cperl-set 'cperl-electric-lbrace-space cperl-hairy) - ;; (cperl-set 'cperl-electric-parens "{[(<") - ;; (cperl-set 'cperl-electric-keywords cperl-hairy) - ;; (cperl-set 'cperl-electric-linefeed cperl-hairy))) - (use-local-map cperl-mode-map) - (if (cperl-val 'cperl-electric-linefeed) - (progn - (local-set-key "\C-J" 'cperl-linefeed) - (local-set-key "\C-C\C-J" 'newline-and-indent))) - (if (cperl-val 'cperl-info-on-command-no-prompt) - (progn - ;; don't clobber the backspace binding for Ye Olde Emacs - ;;(cperl-define-key "\C-hf" 'cperl-info-on-current-command [(control h) f]) - (cperl-define-key "\C-hf" 'cperl-info-on-current-command [f1 f]) - (cperl-define-key "\C-hf" 'cperl-info-on-current-command [(control h) f]) - (cperl-define-key "\C-c\C-hf" 'cperl-info-on-command - [(control c) (control h) f]))) - (setq major-mode 'perl-mode - mode-name "CPerl" - cperl-mode t) - (if (not cperl-mode-abbrev-table) - (let ((prev-a-c abbrevs-changed)) - (define-abbrev-table 'cperl-mode-abbrev-table '( - ("if" "if" cperl-electric-keyword 0) - ("elsif" "elsif" cperl-electric-keyword 0) - ("while" "while" cperl-electric-keyword 0) - ("until" "until" cperl-electric-keyword 0) - ("unless" "unless" cperl-electric-keyword 0) - ("else" "else" cperl-electric-else 0) - ("for" "for" cperl-electric-keyword 0) - ("foreach" "foreach" cperl-electric-keyword 0) - ("do" "do" cperl-electric-keyword 0))) - (setq abbrevs-changed prev-a-c))) - (setq local-abbrev-table cperl-mode-abbrev-table) - (abbrev-mode (if (cperl-val 'cperl-electric-keywords) 1 0)) - (set-syntax-table cperl-mode-syntax-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "^$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'cperl-indent-line) - (make-local-variable 'require-final-newline) - (setq require-final-newline t) - (make-local-variable 'comment-start) - (setq comment-start "# ") - (make-local-variable 'comment-end) - (setq comment-end "") - (make-local-variable 'comment-column) - (setq comment-column cperl-comment-column) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "#+ *") - (make-local-variable 'defun-prompt-regexp) - (setq defun-prompt-regexp "^[ \t]*sub[ \t]+\\([^ \t\n{(;]+\\)[ \t]*") - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'cperl-comment-indent) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - (make-local-variable 'indent-region-function) - (setq indent-region-function 'cperl-indent-region) - ;;(setq auto-fill-function 'cperl-do-auto-fill) ; Need to switch on and off! - (make-local-variable 'imenu-create-index-function) - (setq imenu-create-index-function - (function imenu-example--create-perl-index)) - (make-local-variable 'imenu-sort-function) - (setq imenu-sort-function nil) - (make-local-variable 'vc-header-alist) - (setq vc-header-alist cperl-vc-header-alist) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults - (if (string< emacs-version "19.30") - '(perl-font-lock-keywords-2) - '((perl-font-lock-keywords - perl-font-lock-keywords-1 - perl-font-lock-keywords-2)))) - (if cperl-use-syntax-table-text-property - (progn - (make-variable-buffer-local 'parse-sexp-lookup-properties) - ;; Do not introduce variable if not needed, we check it! - (set 'parse-sexp-lookup-properties t))) - (or (fboundp 'cperl-old-auto-fill-mode) - (progn - (fset 'cperl-old-auto-fill-mode (symbol-function 'auto-fill-mode)) - (defun auto-fill-mode (&optional arg) - (interactive "P") - (cperl-old-auto-fill-mode arg) - (and auto-fill-function (eq major-mode 'perl-mode) - (setq auto-fill-function 'cperl-do-auto-fill))))) - (if (cperl-enable-font-lock) - (if (cperl-val 'cperl-font-lock) - (progn (or cperl-faces-init (cperl-init-faces)) - (font-lock-mode 1)))) - (and (boundp 'msb-menu-cond) - (not cperl-msb-fixed) - (cperl-msb-fix)) - (if (featurep 'easymenu) - (easy-menu-add cperl-menu)) ; A NOP under FSF Emacs. - (run-hooks 'cperl-mode-hook) - ;; After hooks since fontification will break this - (if cperl-pod-here-scan (cperl-find-pods-heres))) - -;; Fix for perldb - make default reasonable -(defun cperl-db () - (interactive) - (require 'gud) - (perldb (read-from-minibuffer "Run perldb (like this): " - (if (consp gud-perldb-history) - (car gud-perldb-history) - (concat "perl " ;;(file-name-nondirectory - ;; I have problems - ;; in OS/2 - ;; otherwise - (buffer-file-name))) - nil nil - '(gud-perldb-history . 1)))) - -;; Fix for msb.el -(defvar cperl-msb-fixed nil) - -(defun cperl-msb-fix () - ;; Adds perl files to msb menu, supposes that msb is already loaded - (setq cperl-msb-fixed t) - (let* ((l (length msb-menu-cond)) - (last (nth (1- l) msb-menu-cond)) - (precdr (nthcdr (- l 2) msb-menu-cond)) ; cdr of this is last - (handle (1- (nth 1 last)))) - (setcdr precdr (list - (list - '(eq major-mode 'perl-mode) - handle - "Perl Files (%d)") - last)))) - -;; This is used by indent-for-comment -;; to decide how much to indent a comment in CPerl code -;; based on its context. Do fallback if comment is found wrong. - -(defvar cperl-wrong-comment) - -(defun cperl-comment-indent () - (let ((p (point)) (c (current-column)) was) - (if (looking-at "^#") 0 ; Existing comment at bol stays there. - ;; Wrong comment found - (save-excursion - (setq was (cperl-to-comment-or-eol)) - (if (= (point) p) - (progn - (skip-chars-backward " \t") - (max (1+ (current-column)) ; Else indent at comment column - comment-column)) - (if was nil - (insert comment-start) - (backward-char (length comment-start))) - (setq cperl-wrong-comment t) - (indent-to comment-column 1) ; Indent minimum 1 - c))))) ; except leave at least one space. - -;;;(defun cperl-comment-indent-fallback () -;;; "Is called if the standard comment-search procedure fails. -;;;Point is at start of real comment." -;;; (let ((c (current-column)) target cnt prevc) -;;; (if (= c comment-column) nil -;;; (setq cnt (skip-chars-backward "[ \t]")) -;;; (setq target (max (1+ (setq prevc -;;; (current-column))) ; Else indent at comment column -;;; comment-column)) -;;; (if (= c comment-column) nil -;;; (delete-backward-char cnt) -;;; (while (< prevc target) -;;; (insert "\t") -;;; (setq prevc (current-column))) -;;; (if (> prevc target) (progn (delete-char -1) (setq prevc (current-column)))) -;;; (while (< prevc target) -;;; (insert " ") -;;; (setq prevc (current-column))))))) - -(defun cperl-indent-for-comment () - "Substitute for `indent-for-comment' in CPerl." - (interactive) - (let (cperl-wrong-comment) - (indent-for-comment) - (if cperl-wrong-comment - (progn (cperl-to-comment-or-eol) - (forward-char (length comment-start)))))) - -(defun cperl-comment-region (b e arg) - "Comment or uncomment each line in the region in CPerl mode. -See `comment-region'." - (interactive "r\np") - (let ((comment-start "#")) - (comment-region b e arg))) - -(defun cperl-uncomment-region (b e arg) - "Uncomment or comment each line in the region in CPerl mode. -See `comment-region'." - (interactive "r\np") - (let ((comment-start "#")) - (comment-region b e (- arg)))) - -(defvar cperl-brace-recursing nil) - -(defun cperl-electric-brace (arg &optional only-before) - "Insert character and correct line's indentation. -If ONLY-BEFORE and `cperl-auto-newline', will insert newline before the -place (even in empty line), but not after. If after \")\" and the inserted -char is \"{\", insert extra newline before only if -`cperl-extra-newline-before-brace'." - (interactive "P") - (let (insertpos - (other-end (if (and cperl-electric-parens-mark - (cperl-mark-active) - (< (mark) (point))) - (mark) - nil))) - (if (and other-end - (not cperl-brace-recursing) - (cperl-val 'cperl-electric-parens) - (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point))) - ;; Need to insert a matching pair - (progn - (save-excursion - (setq insertpos (point-marker)) - (goto-char other-end) - (setq last-command-char ?\{) - (cperl-electric-lbrace arg insertpos)) - (forward-char 1)) - (if (and (not arg) ; No args, end (of empty line or auto) - (eolp) - (or (and (null only-before) - (save-excursion - (skip-chars-backward " \t") - (bolp))) - (and (eq last-command-char ?\{) ; Do not insert newline - ;; if after ")" and `cperl-extra-newline-before-brace' - ;; is nil, do not insert extra newline. - (not cperl-extra-newline-before-brace) - (save-excursion - (skip-chars-backward " \t") - (eq (preceding-char) ?\)))) - (if cperl-auto-newline - (progn (cperl-indent-line) (newline) t) nil))) - (progn - (insert last-command-char) - (cperl-indent-line) - (if cperl-auto-newline - (setq insertpos (1- (point)))) - (if (and cperl-auto-newline (null only-before)) - (progn - (newline) - (cperl-indent-line))) - (save-excursion - (if insertpos (progn (goto-char insertpos) - (search-forward (make-string - 1 last-command-char)) - (setq insertpos (1- (point))))) - (delete-char -1)))) - (if insertpos - (save-excursion - (goto-char insertpos) - (self-insert-command (prefix-numeric-value arg))) - (self-insert-command (prefix-numeric-value arg)))))) - -(defun cperl-electric-lbrace (arg &optional end) - "Insert character, correct line's indentation, correct quoting by space." - (interactive "P") - (let (pos after - (cperl-brace-recursing t) - (cperl-auto-newline cperl-auto-newline) - (other-end (or end - (if (and cperl-electric-parens-mark - (cperl-mark-active) - (> (mark) (point))) - (save-excursion - (goto-char (mark)) - (point-marker)) - nil)))) - (and (cperl-val 'cperl-electric-lbrace-space) - (eq (preceding-char) ?$) - (save-excursion - (skip-chars-backward "$") - (looking-at "\\(\\$\\$\\)*\\$\\([^\\$]\\|$\\)")) - (insert ? )) - (if (cperl-after-expr-p nil "{;)") nil (setq cperl-auto-newline nil)) - (cperl-electric-brace arg) - (and (cperl-val 'cperl-electric-parens) - (eq last-command-char ?{) - (memq last-command-char - (append cperl-electric-parens-string nil)) - (or (if other-end (goto-char (marker-position other-end))) - t) - (setq last-command-char ?} pos (point)) - (progn (cperl-electric-brace arg t) - (goto-char pos))))) - -(defun cperl-electric-paren (arg) - "Insert a matching pair of parentheses." - (interactive "P") - (let ((beg (save-excursion (beginning-of-line) (point))) - (other-end (if (and cperl-electric-parens-mark - (cperl-mark-active) - (> (mark) (point))) - (save-excursion - (goto-char (mark)) - (point-marker)) - nil))) - (if (and (cperl-val 'cperl-electric-parens) - (memq last-command-char - (append cperl-electric-parens-string nil)) - (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point)) - ;;(not (save-excursion (search-backward "#" beg t))) - (if (eq last-command-char ?<) - (cperl-after-expr-p nil "{;(,:=") - 1)) - (progn - (insert last-command-char) - (if other-end (goto-char (marker-position other-end))) - (insert (cdr (assoc last-command-char '((?{ .?}) - (?[ . ?]) - (?( . ?)) - (?< . ?>))))) - (forward-char -1)) - (insert last-command-char) - ))) - -(defun cperl-electric-rparen (arg) - "Insert a matching pair of parentheses if marking is active. -If not, or if we are not at the end of marking range, would self-insert." - (interactive "P") - (let ((beg (save-excursion (beginning-of-line) (point))) - (other-end (if (and cperl-electric-parens-mark - (cperl-val 'cperl-electric-parens) - (memq last-command-char - (append cperl-electric-parens-string nil)) - (cperl-mark-active) - (< (mark) (point))) - (mark) - nil)) - p) - (if (and other-end - (cperl-val 'cperl-electric-parens) - (memq last-command-char '( ?\) ?\] ?\} ?\> )) - (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point)) - ;;(not (save-excursion (search-backward "#" beg t))) - ) - (progn - (insert last-command-char) - (setq p (point)) - (if other-end (goto-char other-end)) - (insert (cdr (assoc last-command-char '((?\} . ?\{) - (?\] . ?\[) - (?\) . ?\() - (?\> . ?\<))))) - (goto-char (1+ p))) - (call-interactively 'self-insert-command) - ))) - -(defun cperl-electric-keyword () - "Insert a construction appropriate after a keyword." - (let ((beg (save-excursion (beginning-of-line) (point))) - (dollar (eq last-command-char ?$))) - (and (save-excursion - (backward-sexp 1) - (cperl-after-expr-p nil "{;:")) - (save-excursion - (not - (re-search-backward - "[#\"'`]\\|\\" - beg t))) - (save-excursion (or (not (re-search-backward "^=" nil t)) - (looking-at "=cut"))) - (progn - (and dollar (insert " $")) - (cperl-indent-line) - ;;(insert " () {\n}") - (cond - (cperl-extra-newline-before-brace - (insert " ()\n") - (insert "{") - (cperl-indent-line) - (insert "\n") - (cperl-indent-line) - (insert "\n}")) - (t - (insert " () {\n}")) - ) - (or (looking-at "[ \t]\\|$") (insert " ")) - (cperl-indent-line) - (if dollar (progn (search-backward "$") - (forward-char 1)) - (search-backward ")")) - (cperl-putback-char del-back-ch))))) - -(defun cperl-electric-else () - "Insert a construction appropriate after a keyword." - (let ((beg (save-excursion (beginning-of-line) (point)))) - (and (save-excursion - (backward-sexp 1) - (cperl-after-expr-p nil "{;:")) - (save-excursion - (not - (re-search-backward - "[#\"'`]\\|\\" - beg t))) - (save-excursion (or (not (re-search-backward "^=" nil t)) - (looking-at "=cut"))) - (progn - (cperl-indent-line) - ;;(insert " {\n\n}") - (cond - (cperl-extra-newline-before-brace - (insert "\n") - (insert "{") - (cperl-indent-line) - (insert "\n\n}")) - (t - (insert " {\n\n}")) - ) - (or (looking-at "[ \t]\\|$") (insert " ")) - (cperl-indent-line) - (forward-line -1) - (cperl-indent-line) - (cperl-putback-char del-back-ch))))) - -(defun cperl-linefeed () - "Go to end of line, open a new line and indent appropriately." - (interactive) - (let ((beg (save-excursion (beginning-of-line) (point))) - (end (save-excursion (end-of-line) (point))) - (pos (point)) start) - (if (and ; Check if we need to split: - ; i.e., on a boundary and inside "{...}" - (save-excursion (cperl-to-comment-or-eol) - (>= (point) pos)) ; Not in a comment - (or (save-excursion - (skip-chars-backward " \t" beg) - (forward-char -1) - (looking-at "[;{]")) ; After { or ; + spaces - (looking-at "[ \t]*}") ; Before } - (re-search-forward "\\=[ \t]*;" end t)) ; Before spaces + ; - (save-excursion - (and - (eq (car (parse-partial-sexp pos end -1)) -1) - ; Leave the level of parens - (looking-at "[,; \t]*\\($\\|#\\)") ; Comma to allow anon subr - ; Are at end - (progn - (backward-sexp 1) - (setq start (point-marker)) - (<= start pos))))) ; Redundant? Are after the - ; start of parens group. - (progn - (skip-chars-backward " \t") - (or (memq (preceding-char) (append ";{" nil)) - (insert ";")) - (insert "\n") - (forward-line -1) - (cperl-indent-line) - (goto-char start) - (or (looking-at "{[ \t]*$") ; If there is a statement - ; before, move it to separate line - (progn - (forward-char 1) - (insert "\n") - (cperl-indent-line))) - (forward-line 1) ; We are on the target line - (cperl-indent-line) - (beginning-of-line) - (or (looking-at "[ \t]*}[,; \t]*$") ; If there is a statement - ; after, move it to separate line - (progn - (end-of-line) - (search-backward "}" beg) - (skip-chars-backward " \t") - (or (memq (preceding-char) (append ";{" nil)) - (insert ";")) - (insert "\n") - (cperl-indent-line) - (forward-line -1))) - (forward-line -1) ; We are on the line before target - (end-of-line) - (newline-and-indent)) - (end-of-line) ; else - (cond - ((and (looking-at "\n[ \t]*{$") - (save-excursion - (skip-chars-backward " \t") - (eq (preceding-char) ?\)))) ; Probably if () {} group - ; with an extra newline. - (forward-line 2) - (cperl-indent-line)) - ((looking-at "\n[ \t]*$") ; Next line is empty - use it. - (forward-line 1) - (cperl-indent-line)) - (t - (newline-and-indent)))))) - -(defun cperl-electric-semi (arg) - "Insert character and correct line's indentation." - (interactive "P") - (if cperl-auto-newline - (cperl-electric-terminator arg) - (self-insert-command (prefix-numeric-value arg)))) - -(defun cperl-electric-terminator (arg) - "Insert character and correct line's indentation." - (interactive "P") - (let (insertpos (end (point)) - (auto (and cperl-auto-newline - (or (not (eq last-command-char ?:)) - cperl-auto-newline-after-colon)))) - (if (and ;;(not arg) - (eolp) - (not (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (or - ;; Ignore in comment lines - (= (following-char) ?#) - ;; Colon is special only after a label - ;; So quickly rule out most other uses of colon - ;; and do no indentation for them. - (and (eq last-command-char ?:) - (save-excursion - (forward-word 1) - (skip-chars-forward " \t") - (and (< (point) end) - (progn (goto-char (- end 1)) - (not (looking-at ":")))))) - (progn - (beginning-of-defun) - (let ((pps (parse-partial-sexp (point) end))) - (or (nth 3 pps) (nth 4 pps) (nth 5 pps)))))))) - (progn - (insert last-command-char) - ;;(forward-char -1) - (if auto (setq insertpos (point-marker))) - ;;(forward-char 1) - (cperl-indent-line) - (if auto - (progn - (newline) - (cperl-indent-line))) -;; (save-excursion -;; (if insertpos (progn (goto-char (marker-position insertpos)) -;; (search-forward (make-string -;; 1 last-command-char)) -;; (setq insertpos (1- (point))))) -;; (delete-char -1)))) - (save-excursion - (if insertpos (goto-char (1- (marker-position insertpos))) - (forward-char -1)) - (delete-char 1)))) - (if insertpos - (save-excursion - (goto-char insertpos) - (self-insert-command (prefix-numeric-value arg))) - (self-insert-command (prefix-numeric-value arg))))) - -(defun cperl-electric-backspace (arg) - "Backspace-untabify, or remove the whitespace inserted by an electric key." - (interactive "p") - (if (and cperl-auto-newline - (memq last-command '(cperl-electric-semi - cperl-electric-terminator - cperl-electric-lbrace)) - (memq (preceding-char) '(? ?\t ?\n))) - (let (p) - (if (eq last-command 'cperl-electric-lbrace) - (skip-chars-forward " \t\n")) - (setq p (point)) - (skip-chars-backward " \t\n") - (delete-region (point) p)) - (backward-delete-char-untabify arg))) - -;; helper function for deletion, which honors the desired delete direction -;; behavior. Added by Gary D. Foster, and bound -;; to the 'delete keysym by default. - -(defun cperl-electric-delete (arg) - "Delete, or remove the whitespace inserted by an electric key. -Delete direction is controlled by the setting of `delete-key-deletes-forward'." - (interactive "*p") - (if (and cperl-auto-newline - (memq last-command '(cperl-electric-semi - cperl-electric-terminator - cperl-electric-lbrace)) - (memq (preceding-char) '(? ?\t ?\n))) - (let (p) - (if (eq last-command 'cperl-electric-lbrace) - (skip-chars-forward " \t\n")) - (setq p (point)) - (skip-chars-backward " \t\n") - (delete-region (point) p)) - (if (fboundp 'backward-or-forward-delete-char) - (backward-or-forward-delete-char arg) - (backward-delete-char-untabify arg)))) - -(defun cperl-inside-parens-p () - (condition-case () - (save-excursion - (save-restriction - (narrow-to-region (point) - (progn (beginning-of-defun) (point))) - (goto-char (point-max)) - (= (char-after (or (scan-lists (point) -1 1) (point-min))) ?\())) - (error nil))) - -(defun cperl-indent-command (&optional whole-exp) - "Indent current line as Perl code, or in some cases insert a tab character. -If `cperl-tab-always-indent' is non-nil (the default), always indent current line. -Otherwise, indent the current line only if point is at the left margin -or in the line's indentation; otherwise insert a tab. - -A numeric argument, regardless of its value, -means indent rigidly all the lines of the expression starting after point -so that this line becomes properly indented. -The relative indentation among the lines of the expression are preserved." - (interactive "P") - (if whole-exp - ;; If arg, always indent this line as Perl - ;; and shift remaining lines of expression the same amount. - (let ((shift-amt (cperl-indent-line)) - beg end) - (save-excursion - (if cperl-tab-always-indent - (beginning-of-line)) - (setq beg (point)) - (forward-sexp 1) - (setq end (point)) - (goto-char beg) - (forward-line 1) - (setq beg (point))) - (if (> end beg) - (indent-code-rigidly beg end shift-amt "#"))) - (if (and (not cperl-tab-always-indent) - (save-excursion - (skip-chars-backward " \t") - (not (bolp)))) - (insert-tab) - (cperl-indent-line)))) - -(defun cperl-indent-line (&optional symbol) - "Indent current line as Perl code. -Return the amount the indentation changed by." - (let (indent - beg shift-amt - (case-fold-search nil) - (pos (- (point-max) (point)))) - (setq indent (cperl-calculate-indent nil symbol)) - (beginning-of-line) - (setq beg (point)) - (cond ((or (eq indent nil) (eq indent t)) - (setq indent (current-indentation))) - ;;((eq indent t) ; Never? - ;; (setq indent (cperl-calculate-indent-within-comment))) - ;;((looking-at "[ \t]*#") - ;; (setq indent 0)) - (t - (skip-chars-forward " \t") - (if (listp indent) (setq indent (car indent))) - (cond ((looking-at "[A-Za-z_][A-Za-z_0-9]*:[^:]") - (and (> indent 0) - (setq indent (max cperl-min-label-indent - (+ indent cperl-label-offset))))) - ((= (following-char) ?}) - (setq indent (- indent cperl-indent-level))) - ((memq (following-char) '(?\) ?\])) ; To line up with opening paren. - (setq indent (+ indent cperl-close-paren-offset))) - ((= (following-char) ?{) - (setq indent (+ indent cperl-brace-offset)))))) - (skip-chars-forward " \t") - (setq shift-amt (- indent (current-column))) - (if (zerop shift-amt) - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos))) - (delete-region beg (point)) - (indent-to indent) - ;; If initial point was within line's indentation, - ;; position after the indentation. Else stay at same point in text. - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos)))) - shift-amt)) - -(defun cperl-after-label () - ;; Returns true if the point is after label. Does not do save-excursion. - (and (eq (preceding-char) ?:) - (memq (char-syntax (char-after (- (point) 2))) - '(?w ?_)) - (progn - (backward-sexp) - (looking-at "[a-zA-Z_][a-zA-Z0-9_]*:[^:]")))) - -(defun cperl-get-state (&optional parse-start start-state) - ;; returns list (START STATE DEPTH PRESTART), START is a good place - ;; to start parsing, STATE is what is returned by - ;; `parse-partial-sexp'. DEPTH is true is we are immediately after - ;; end of block which contains START. PRESTART is the position - ;; basing on which START was found. - (save-excursion - (let ((start-point (point)) depth state start prestart) - (if parse-start - (goto-char parse-start) - (beginning-of-defun)) - (setq prestart (point)) - (if start-state nil - ;; Try to go out, if sub is not on the outermost level - (while (< (point) start-point) - (setq start (point) parse-start start depth nil - state (parse-partial-sexp start start-point -1)) - (if (> (car state) -1) nil - ;; The current line could start like }}}, so the indentation - ;; corresponds to a different level than what we reached - (setq depth t) - (beginning-of-line 2))) ; Go to the next line. - (if start (goto-char start))) ; Not at the start of file - (setq start (point)) - (if (< start start-point) (setq parse-start start)) - (or state (setq state (parse-partial-sexp start start-point -1 nil start-state))) - (list start state depth prestart)))) - -(defun cperl-block-p () ; Do not C-M-q ! One string contains ";" ! - ;; Positions is before ?\{. Checks whether it starts a block. - ;; No save-excursion! - (cperl-backward-to-noncomment (point-min)) - ;;(skip-chars-backward " \t\n\f") - (or (memq (preceding-char) (append ";){}$@&%\C-@" nil)) ; Or label! \C-@ at bobp - ; Label may be mixed up with `$blah :' - (save-excursion (cperl-after-label)) - (and (memq (char-syntax (preceding-char)) '(?w ?_)) - (progn - (backward-sexp) - ;; Need take into account `bless', `return', `tr',... - (or (and (looking-at "[a-zA-Z0-9_:]+[ \t\n\f]*[{#]") ; Method call syntax - (not (looking-at "\\(bless\\|return\\|qw\\|tr\\|[smy]\\)\\>"))) - (progn - (skip-chars-backward " \t\n\f") - (and (memq (char-syntax (preceding-char)) '(?w ?_)) - (progn - (backward-sexp) - (looking-at - "sub[ \t]+[a-zA-Z0-9_:]+[ \t\n\f]*\\(([^()]*)[ \t\n\f]*\\)?[#{]"))))))))) - -(defvar cperl-look-for-prop '((pod in-pod) (here-doc-delim here-doc-group))) - -(defun cperl-calculate-indent (&optional parse-start symbol) - "Return appropriate indentation for current line as Perl code. -In usual case returns an integer: the column to indent to. -Returns nil if line starts inside a string, t if in a comment." - (save-excursion - (if (or - (memq (get-text-property (point) 'syntax-type) - '(pod here-doc here-doc-delim format)) - ;; before start of POD - whitespace found since do not have 'pod! - (and (looking-at "[ \t]*\n=") - (error "Spaces before pod section!")) - (and (not cperl-indent-left-aligned-comments) - (looking-at "^#"))) - nil - (beginning-of-line) - (let ((indent-point (point)) - (char-after (save-excursion - (skip-chars-forward " \t") - (following-char))) - (in-pod (get-text-property (point) 'in-pod)) - (pre-indent-point (point)) - p prop look-prop) - (cond - (in-pod - ;; In the verbatim part, probably code example. What to do??? - ) - (t - (save-excursion - ;; Not in pod - (cperl-backward-to-noncomment nil) - (setq p (max (point-min) (1- (point))) - prop (get-text-property p 'syntax-type) - look-prop (or (nth 1 (assoc prop cperl-look-for-prop)) - 'syntax-type)) - (if (memq prop '(pod here-doc format here-doc-delim)) - (progn - (goto-char (or (previous-single-property-change p look-prop) - (point-min))) - (beginning-of-line) - (setq pre-indent-point (point))))))) - (goto-char pre-indent-point) - (let* ((case-fold-search nil) - (s-s (cperl-get-state)) - (start (nth 0 s-s)) - (state (nth 1 s-s)) - (containing-sexp (car (cdr state))) - (start-indent (save-excursion - (goto-char start) - (- (current-indentation) - (if (nth 2 s-s) cperl-indent-level 0)))) - old-indent) - ;; (or parse-start (null symbol) - ;; (setq parse-start (symbol-value symbol) - ;; start-indent (nth 2 parse-start) - ;; parse-start (car parse-start))) - ;; (if parse-start - ;; (goto-char parse-start) - ;; (beginning-of-defun)) - ;; ;; Try to go out - ;; (while (< (point) indent-point) - ;; (setq start (point) parse-start start moved nil - ;; state (parse-partial-sexp start indent-point -1)) - ;; (if (> (car state) -1) nil - ;; ;; The current line could start like }}}, so the indentation - ;; ;; corresponds to a different level than what we reached - ;; (setq moved t) - ;; (beginning-of-line 2))) ; Go to the next line. - ;; (if start ; Not at the start of file - ;; (progn - ;; (goto-char start) - ;; (setq start-indent (current-indentation)) - ;; (if moved ; Should correct... - ;; (setq start-indent (- start-indent cperl-indent-level)))) - ;; (setq start-indent 0)) - ;; (if (< (point) indent-point) (setq parse-start (point))) - ;; (or state (setq state (parse-partial-sexp - ;; (point) indent-point -1 nil start-state))) - ;; (setq containing-sexp - ;; (or (car (cdr state)) - ;; (and (>= (nth 6 state) 0) old-containing-sexp)) - ;; old-containing-sexp nil start-state nil) -;;;; (while (< (point) indent-point) -;;;; (setq parse-start (point)) -;;;; (setq state (parse-partial-sexp (point) indent-point -1 nil start-state)) -;;;; (setq containing-sexp -;;;; (or (car (cdr state)) -;;;; (and (>= (nth 6 state) 0) old-containing-sexp)) -;;;; old-containing-sexp nil start-state nil)) - ;; (if symbol (set symbol (list indent-point state start-indent))) - ;; (goto-char indent-point) - (cond ((or (nth 3 state) (nth 4 state)) - ;; return nil or t if should not change this line - (nth 4 state)) - ((null containing-sexp) - ;; Line is at top level. May be data or function definition, - ;; or may be function argument declaration. - ;; Indent like the previous top level line - ;; unless that ends in a closeparen without semicolon, - ;; in which case this line is the first argument decl. - (skip-chars-forward " \t") - (+ start-indent - (if (= (following-char) ?{) cperl-continued-brace-offset 0) - (progn - (cperl-backward-to-noncomment (or parse-start (point-min))) - ;;(skip-chars-backward " \t\f\n") - ;; Look at previous line that's at column 0 - ;; to determine whether we are in top-level decls - ;; or function's arg decls. Set basic-indent accordingly. - ;; Now add a little if this is a continuation line. - (if (or (bobp) - (memq (preceding-char) (append " ;}" nil)) ; Was ?\) - (memq char-after (append ")]}" nil)) - (and (eq (preceding-char) ?\:) ; label - (progn - (forward-sexp -1) - (skip-chars-backward " \t") - (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*[ \t]*:")))) - 0 - cperl-continued-statement-offset)))) - ((/= (char-after containing-sexp) ?{) - ;; line is expression, not statement: - ;; indent to just after the surrounding open, - ;; skip blanks if we do not close the expression. - (goto-char (1+ containing-sexp)) - (or (memq char-after (append ")]}" nil)) - (looking-at "[ \t]*\\(#\\|$\\)") - (skip-chars-forward " \t")) - (current-column)) - ((progn - ;; Containing-expr starts with \{. Check whether it is a hash. - (goto-char containing-sexp) - (not (cperl-block-p))) - (goto-char (1+ containing-sexp)) - (or (eq char-after ?\}) - (looking-at "[ \t]*\\(#\\|$\\)") - (skip-chars-forward " \t")) - (+ (current-column) ; Correct indentation of trailing ?\} - (if (eq char-after ?\}) (+ cperl-indent-level - cperl-close-paren-offset) - 0))) - (t - ;; Statement level. Is it a continuation or a new statement? - ;; Find previous non-comment character. - (goto-char pre-indent-point) - (cperl-backward-to-noncomment containing-sexp) - ;; Back up over label lines, since they don't - ;; affect whether our line is a continuation. - (while (or (eq (preceding-char) ?\,) - (and (eq (preceding-char) ?:) - (or;;(eq (char-after (- (point) 2)) ?\') ; ???? - (memq (char-syntax (char-after (- (point) 2))) - '(?w ?_))))) - (if (eq (preceding-char) ?\,) - ;; Will go to beginning of line, essentially. - ;; Will ignore embedded sexpr XXXX. - (cperl-backward-to-start-of-continued-exp containing-sexp)) - (beginning-of-line) - (cperl-backward-to-noncomment containing-sexp)) - ;; Now we get the answer. - (if (not (memq (preceding-char) (append ", ;}{" '(nil)))) ; Was ?\, - ;; This line is continuation of preceding line's statement; - ;; indent `cperl-continued-statement-offset' more than the - ;; previous line of the statement. - (progn - (cperl-backward-to-start-of-continued-exp containing-sexp) - (+ (if (memq char-after (append "}])" nil)) - 0 ; Closing parenth - cperl-continued-statement-offset) - (current-column) - (if (eq char-after ?\{) - cperl-continued-brace-offset 0))) - ;; This line starts a new statement. - ;; Position following last unclosed open. - (goto-char containing-sexp) - ;; Is line first statement after an open-brace? - (or - ;; If no, find that first statement and indent like - ;; it. If the first statement begins with label, do - ;; not believe when the indentation of the label is too - ;; small. - (save-excursion - (forward-char 1) - (setq old-indent (current-indentation)) - (let ((colon-line-end 0)) - (while (progn (skip-chars-forward " \t\n") - (looking-at "#\\|[a-zA-Z0-9_$]*:[^:]")) - ;; Skip over comments and labels following openbrace. - (cond ((= (following-char) ?\#) - (forward-line 1)) - ;; label: - (t - (save-excursion (end-of-line) - (setq colon-line-end (point))) - (search-forward ":")))) - ;; The first following code counts - ;; if it is before the line we want to indent. - (and (< (point) indent-point) - (if (> colon-line-end (point)) ; After label - (if (> (current-indentation) - cperl-min-label-indent) - (- (current-indentation) cperl-label-offset) - ;; Do not believe: `max' is involved - (+ old-indent cperl-indent-level)) - (current-column))))) - ;; If no previous statement, - ;; indent it relative to line brace is on. - ;; For open brace in column zero, don't let statement - ;; start there too. If cperl-indent-level is zero, - ;; use cperl-brace-offset + cperl-continued-statement-offset instead. - ;; For open-braces not the first thing in a line, - ;; add in cperl-brace-imaginary-offset. - - ;; If first thing on a line: ????? - (+ (if (and (bolp) (zerop cperl-indent-level)) - (+ cperl-brace-offset cperl-continued-statement-offset) - cperl-indent-level) - ;; Move back over whitespace before the openbrace. - ;; If openbrace is not first nonwhite thing on the line, - ;; add the cperl-brace-imaginary-offset. - (progn (skip-chars-backward " \t") - (if (bolp) 0 cperl-brace-imaginary-offset)) - ;; If the openbrace is preceded by a parenthesized exp, - ;; move to the beginning of that; - ;; possibly a different line - (progn - (if (eq (preceding-char) ?\)) - (forward-sexp -1)) - ;; In the case it starts a subroutine, indent with - ;; respect to `sub', not with respect to the the - ;; first thing on the line, say in the case of - ;; anonymous sub in a hash. - ;; - (skip-chars-backward " \t") - (if (and (eq (preceding-char) ?b) - (progn - (forward-sexp -1) - (looking-at "sub\\>")) - (setq old-indent - (nth 1 - (parse-partial-sexp - (save-excursion (beginning-of-line) (point)) - (point))))) - (progn (goto-char (1+ old-indent)) - (skip-chars-forward " \t") - (current-column)) - ;; Get initial indentation of the line we are on. - ;; If line starts with label, calculate label indentation - (if (save-excursion - (beginning-of-line) - (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]")) - (if (> (current-indentation) cperl-min-label-indent) - (- (current-indentation) cperl-label-offset) - (cperl-calculate-indent - (if (and parse-start (<= parse-start (point))) - parse-start))) - (current-indentation)))))))))))))) - -(defvar cperl-indent-alist - '((string nil) - (comment nil) - (toplevel 0) - (toplevel-after-parenth 2) - (toplevel-continued 2) - (expression 1)) - "Alist of indentation rules for CPerl mode. -The values mean: - nil: do not indent; - number: add this amount of indentation.") - -(defun cperl-where-am-i (&optional parse-start start-state) - ;; Unfinished - "Return a list of lists ((TYPE POS)...) of good points before the point. -POS may be nil if it is hard to find, say, when TYPE is `string' or `comment'." - (save-excursion - (let* ((start-point (point)) - (s-s (cperl-get-state)) - (start (nth 0 s-s)) - (state (nth 1 s-s)) - (prestart (nth 3 s-s)) - (containing-sexp (car (cdr state))) - (case-fold-search nil) - (res (list (list 'parse-start start) (list 'parse-prestart prestart)))) - (cond ((nth 3 state) ; In string - (setq res (cons (list 'string nil (nth 3 state)) res))) ; What started string - ((nth 4 state) ; In comment - (setq res (cons '(comment) res))) - ((null containing-sexp) - ;; Line is at top level. - ;; Indent like the previous top level line - ;; unless that ends in a closeparen without semicolon, - ;; in which case this line is the first argument decl. - (cperl-backward-to-noncomment (or parse-start (point-min))) - ;;(skip-chars-backward " \t\f\n") - (cond - ((or (bobp) - (memq (preceding-char) (append ";}" nil))) - (setq res (cons (list 'toplevel start) res))) - ((eq (preceding-char) ?\) ) - (setq res (cons (list 'toplevel-after-parenth start) res))) - (t - (setq res (cons (list 'toplevel-continued start) res))))) - ((/= (char-after containing-sexp) ?{) - ;; line is expression, not statement: - ;; indent to just after the surrounding open. - ;; skip blanks if we do not close the expression. - (setq res (cons (list 'expression-blanks - (progn - (goto-char (1+ containing-sexp)) - (or (looking-at "[ \t]*\\(#\\|$\\)") - (skip-chars-forward " \t")) - (point))) - (cons (list 'expression containing-sexp) res)))) - ((progn - ;; Containing-expr starts with \{. Check whether it is a hash. - (goto-char containing-sexp) - (not (cperl-block-p))) - (setq res (cons (list 'expression-blanks - (progn - (goto-char (1+ containing-sexp)) - (or (looking-at "[ \t]*\\(#\\|$\\)") - (skip-chars-forward " \t")) - (point))) - (cons (list 'expression containing-sexp) res)))) - (t - ;; Statement level. - (setq res (cons (list 'in-block containing-sexp) res)) - ;; Is it a continuation or a new statement? - ;; Find previous non-comment character. - (cperl-backward-to-noncomment containing-sexp) - ;; Back up over label lines, since they don't - ;; affect whether our line is a continuation. - ;; Back up comma-delimited lines too ????? - (while (or (eq (preceding-char) ?\,) - (save-excursion (cperl-after-label))) - (if (eq (preceding-char) ?\,) - ;; Will go to beginning of line, essentially - ;; Will ignore embedded sexpr XXXX. - (cperl-backward-to-start-of-continued-exp containing-sexp)) - (beginning-of-line) - (cperl-backward-to-noncomment containing-sexp)) - ;; Now we get the answer. - (if (not (memq (preceding-char) (append ";}{" '(nil)))) ; Was ?\, - ;; This line is continuation of preceding line's statement. - (list (list 'statement-continued containing-sexp)) - ;; This line starts a new statement. - ;; Position following last unclosed open. - (goto-char containing-sexp) - ;; Is line first statement after an open-brace? - (or - ;; If no, find that first statement and indent like - ;; it. If the first statement begins with label, do - ;; not believe when the indentation of the label is too - ;; small. - (save-excursion - (forward-char 1) - (let ((colon-line-end 0)) - (while (progn (skip-chars-forward " \t\n" start-point) - (and (< (point) start-point) - (looking-at - "#\\|[a-zA-Z_][a-zA-Z0-9_]*:[^:]"))) - ;; Skip over comments and labels following openbrace. - (cond ((= (following-char) ?\#) - ;;(forward-line 1) - (end-of-line)) - ;; label: - (t - (save-excursion (end-of-line) - (setq colon-line-end (point))) - (search-forward ":")))) - ;; Now at the point, after label, or at start - ;; of first statement in the block. - (and (< (point) start-point) - (if (> colon-line-end (point)) - ;; Before statement after label - (if (> (current-indentation) - cperl-min-label-indent) - (list (list 'label-in-block (point))) - ;; Do not believe: `max' is involved - (list - (list 'label-in-block-min-indent (point)))) - ;; Before statement - (list 'statement-in-block (point)))))) - ;; If no previous statement, - ;; indent it relative to line brace is on. - ;; For open brace in column zero, don't let statement - ;; start there too. If cperl-indent-level is zero, - ;; use cperl-brace-offset + cperl-continued-statement-offset instead. - ;; For open-braces not the first thing in a line, - ;; add in cperl-brace-imaginary-offset. - - ;; If first thing on a line: ????? - (+ (if (and (bolp) (zerop cperl-indent-level)) - (+ cperl-brace-offset cperl-continued-statement-offset) - cperl-indent-level) - ;; Move back over whitespace before the openbrace. - ;; If openbrace is not first nonwhite thing on the line, - ;; add the cperl-brace-imaginary-offset. - (progn (skip-chars-backward " \t") - (if (bolp) 0 cperl-brace-imaginary-offset)) - ;; If the openbrace is preceded by a parenthesized exp, - ;; move to the beginning of that; - ;; possibly a different line - (progn - (if (eq (preceding-char) ?\)) - (forward-sexp -1)) - ;; Get initial indentation of the line we are on. - ;; If line starts with label, calculate label indentation - (if (save-excursion - (beginning-of-line) - (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]")) - (if (> (current-indentation) cperl-min-label-indent) - (- (current-indentation) cperl-label-offset) - (cperl-calculate-indent - (if (and parse-start (<= parse-start (point))) - parse-start))) - (current-indentation)))))))) - res))) - -(defun cperl-calculate-indent-within-comment () - "Return the indentation amount for line, assuming that -the current line is to be regarded as part of a block comment." - (let (end star-start) - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (setq end (point)) - (and (= (following-char) ?#) - (forward-line -1) - (cperl-to-comment-or-eol) - (setq end (point))) - (goto-char end) - (current-column)))) - - -(defun cperl-to-comment-or-eol () - "Goes to position before comment on the current line, or to end of line. -Returns true if comment is found." - (let (state stop-in cpoint (lim (progn (end-of-line) (point)))) - (beginning-of-line) - (if (or - (eq (get-text-property (point) 'syntax-type) 'pod) - (re-search-forward "\\=[ \t]*\\(#\\|$\\)" lim t)) - (if (eq (preceding-char) ?\#) (progn (backward-char 1) t)) - ;; Else - (while (not stop-in) - (setq state (parse-partial-sexp (point) lim nil nil nil t)) - ; stop at comment - ;; If fails (beginning-of-line inside sexp), then contains not-comment - ;; Do simplified processing - ;;(if (re-search-forward "[^$]#" lim 1) - ;; (progn - ;; (forward-char -1) - ;; (skip-chars-backward " \t\n\f" lim)) - ;; (goto-char lim)) ; No `#' at all - ;;) - (if (nth 4 state) ; After `#'; - ; (nth 2 state) can be - ; beginning of m,s,qq and so - ; on - (if (nth 2 state) - (progn - (setq cpoint (point)) - (goto-char (nth 2 state)) - (cond - ((looking-at "\\(s\\|tr\\)\\>") - (or (re-search-forward - "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*" - lim 'move) - (setq stop-in t))) - ((looking-at "\\(m\\|q\\([qxw]\\)?\\)\\>") - (or (re-search-forward - "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#" - lim 'move) - (setq stop-in t))) - (t ; It was fair comment - (setq stop-in t) ; Finish - (goto-char (1- cpoint))))) - (setq stop-in t) ; Finish - (forward-char -1)) - (setq stop-in t)) ; Finish - ) - (nth 4 state)))) - -(defsubst cperl-1- (p) - (max (point-min) (1- p))) - -(defsubst cperl-1+ (p) - (min (point-max) (1+ p))) - -(defvar cperl-st-cfence '(14)) ; Comment-fence -(defvar cperl-st-sfence '(15)) ; String-fence -(defvar cperl-st-punct '(1)) -(defvar cperl-st-word '(2)) - -(defun cperl-protect-defun-start (s e) - ;; C code looks for "^\\s(" to skip comment backward in "hard" situations - (save-excursion - (goto-char s) - (while (re-search-forward "^\\s(" e 'to-end) - (put-text-property (1- (point)) (point) 'syntax-table cperl-st-punct)))) - -(defun cperl-commentify (bb e string) - (if cperl-use-syntax-table-text-property - (progn - ;; We suppose that e is _after_ the end of construction, as after eol. - (setq string (if string cperl-st-sfence cperl-st-cfence)) - (put-text-property bb (1+ bb) 'syntax-table string) - (put-text-property bb (1+ bb) 'rear-nonsticky t) - (put-text-property (1- e) e 'syntax-table string) - (put-text-property (1- e) e 'rear-nonsticky t) - (if (and (eq string cperl-st-sfence) (> (- e 2) bb)) - (put-text-property (1+ bb) (1- e) - 'syntax-table cperl-string-syntax-table)) - (cperl-protect-defun-start bb e)))) - -(defun cperl-find-pods-heres (&optional min max) - "Scans the buffer for POD sections and here-documents. -If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify -the sections using `cperl-pod-head-face', `cperl-pod-face', -`cperl-here-face'." - (interactive) - (or min (setq min (point-min))) - (or max (setq max (point-max))) - (let (face head-face here-face b e bb tag qtag err b1 e1 argument st i c - (cperl-pod-here-fontify (eval cperl-pod-here-fontify)) - (case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t) - (modified (buffer-modified-p)) - (after-change-functions nil) - (state-point (point-min)) state - (search - (concat - "\\(\\`\n?\\|\n\n\\)=" - "\\|" - ;; One extra () before this: - "<<" - "\\(" - ;; First variant "BLAH" or just ``. - "\\([\"'`]\\)" - "\\([^\"'`\n]*\\)" - "\\3" - "\\|" - ;; Second variant: Identifier or empty - "\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" - ;; Check that we do not have <<= or << 30 or << $blah. - "\\([^= \t$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" - "\\)" - "\\|" - ;; 1+6 extra () before this: - "^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$" - (if cperl-use-syntax-table-text-property - (concat - "\\|" - ;; 1+6+2=9 extra () before this: - "\\<\\(q[wxq]?\\|[msy]\\|tr\\)\\>" - "\\|" - ;; 1+6+2+1=10 extra () before this: - "\\([?/]\\)" ; /blah/ or ?blah? - "\\|" - ;; 1+6+2+1+1=11 extra () before this: - "\\[ \t]*\\([a-zA-Z_:'0-9]+[ \t]*\\)?\\(([^()]*)\\)" - "\\|" - ;; 1+6+2+1+1+2=13 extra () before this: - "\\$\\(['{]\\)" - "\\|" - ;; 1+6+2+1+1+2+1=14 extra () before this: - "\\(\\") - (progn - (message "=cut is not preceded by a pod section") - (or err (setq err (point)))) - (beginning-of-line) - - (setq b (point) bb b) - (or (re-search-forward "\n\n=cut\\>" max 'toend) - (progn - (message "Cannot find the end of a pod section") - (or err (setq err b)))) - (beginning-of-line 2) ; An empty line after =cut is not POD! - (setq e (point)) - (put-text-property b e 'in-pod t) - (goto-char b) - (while (re-search-forward "\n\n[ \t]" e t) - ;; We start 'pod 1 char earlier to include the preceding line - (beginning-of-line) - (put-text-property (cperl-1- b) (point) 'syntax-type 'pod) - (cperl-put-do-not-fontify b (point)) - ;;(put-text-property (max (point-min) (1- b)) - ;; (point) cperl-do-not-fontify t) - (if cperl-pod-here-fontify (put-text-property b (point) 'face face)) - (re-search-forward "\n\n[^ \t\f\n]" e 'toend) - (beginning-of-line) - (setq b (point))) - (put-text-property (cperl-1- (point)) e 'syntax-type 'pod) - (cperl-put-do-not-fontify (point) e) - ;;(put-text-property (max (point-min) (1- (point))) - ;; e cperl-do-not-fontify t) - (if cperl-pod-here-fontify - (progn (put-text-property (point) e 'face face) - (goto-char bb) - (if (looking-at - "=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$") - (put-text-property - (match-beginning 1) (match-end 1) - 'face head-face)) - (while (re-search-forward - ;; One paragraph - "\n\n=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$" - e 'toend) - (put-text-property - (match-beginning 1) (match-end 1) - 'face head-face)))) - (cperl-commentify bb e nil) - (goto-char e))) - ;; Here document - ;; We do only one here-per-line - ;; 1 () ahead - ;; "<<\\(\\([\"'`]\\)\\([^\"'`\n]*\\)\\3\\|\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)\\)" - ((match-beginning 2) ; 1 + 1 - ;; Abort in comment: - (setq b (point)) - (setq state (parse-partial-sexp state-point b nil nil state) - state-point b) - (if ;;(save-excursion - ;; (beginning-of-line) - ;; (search-forward "#" b t)) - (or (nth 3 state) (nth 4 state)) - (goto-char (match-end 2)) - (if (match-beginning 5) ;4 + 1 - (setq b1 (match-beginning 5) ; 4 + 1 - e1 (match-end 5)) ; 4 + 1 - (setq b1 (match-beginning 4) ; 3 + 1 - e1 (match-end 4))) ; 3 + 1 - (setq tag (buffer-substring b1 e1) - qtag (regexp-quote tag)) - (cond (cperl-pod-here-fontify - (put-text-property b1 e1 'face font-lock-reference-face) - (cperl-put-do-not-fontify b1 e1))) - (forward-line) - (setq b (point)) - (cond ((re-search-forward (concat "^" qtag "$") max 'toend) - (if cperl-pod-here-fontify - (progn - (put-text-property (match-beginning 0) (match-end 0) - 'face font-lock-reference-face) - (cperl-put-do-not-fontify b (match-end 0)) - ;;(put-text-property (max (point-min) (1- b)) - ;; (min (point-max) - ;; (1+ (match-end 0))) - ;; cperl-do-not-fontify t) - (put-text-property b (match-beginning 0) - 'face here-face))) - (setq e1 (cperl-1+ (match-end 0))) - (put-text-property b (match-beginning 0) - 'syntax-type 'here-doc) - (put-text-property (match-beginning 0) e1 - 'syntax-type 'here-doc-delim) - (put-text-property b e1 - 'here-doc-group t) - (cperl-commentify b e1 nil) - (cperl-put-do-not-fontify b (match-end 0))) - (t (message "End of here-document `%s' not found." tag) - (or err (setq err b)))))) - ;; format - ((match-beginning 8) - ;; 1+6=7 extra () before this: - ;;"^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$" - (setq b (point) - name (if (match-beginning 8) ; 7 + 1 - (buffer-substring (match-beginning 8) ; 7 + 1 - (match-end 8)) ; 7 + 1 - "")) - (setq argument nil) - (if cperl-pod-here-fontify - (while (and (eq (forward-line) 0) - (not (looking-at "^[.;]$"))) - (cond - ((looking-at "^#")) ; Skip comments - ((and argument ; Skip argument multi-lines - (looking-at "^[ \t]*{")) - (forward-sexp 1) - (setq argument nil)) - (argument ; Skip argument lines - (setq argument nil)) - (t ; Format line - (setq b1 (point)) - (setq argument (looking-at "^[^\n]*[@^]")) - (end-of-line) - (put-text-property b1 (point) - 'face font-lock-string-face) - (cperl-commentify b1 (point) nil) - (cperl-put-do-not-fontify b1 (point))))) - (re-search-forward (concat "^[.;]$") max 'toend)) - (beginning-of-line) - (if (looking-at "^[.;]$") - (progn - (put-text-property (point) (+ (point) 2) - 'face font-lock-string-face) - (cperl-commentify (point) (+ (point) 2) nil) - (cperl-put-do-not-fontify (point) (+ (point) 2))) - (message "End of format `%s' not found." name) - (or err (setq err b))) - (forward-line) - (put-text-property b (point) 'syntax-type 'format) -;;; (cond ((re-search-forward (concat "^[.;]$") max 'toend) -;;; (if cperl-pod-here-fontify -;;; (progn -;;; (put-text-property b (match-end 0) -;;; 'face font-lock-string-face) -;;; (cperl-put-do-not-fontify b (match-end 0)))) -;;; (put-text-property b (match-end 0) -;;; 'syntax-type 'format) -;;; (cperl-put-do-not-fontify b (match-beginning 0))) -;;; (t (message "End of format `%s' not found." name))) - ) - ;; Regexp: - ((or (match-beginning 10) (match-beginning 11)) - ;; 1+6+2=9 extra () before this: - ;; "\\<\\(q[wxq]?\\|[msy]\\|tr\\)\\>" - ;; "\\|" - ;; "\\([?/]\\)" ; /blah/ or ?blah? - (setq b1 (if (match-beginning 10) 10 11) - argument (buffer-substring - (match-beginning b1) (match-end b1)) - b (point) - i b - c (char-after (match-beginning b1)) - bb (or - (memq (char-after (1- (match-beginning b1))) - '(?\$ ?\@ ?\% ?\& ?\*)) - (and - (eq (char-after (1- (match-beginning b1))) ?-) - (eq c ?s)))) - (or bb - (if (eq b1 11) ; bare /blah/ or ?blah? - (setq argument "" - bb ; Not a regexp - (progn - (goto-char (match-beginning b1)) - (cperl-backward-to-noncomment (point-min)) - (not (or (memq (preceding-char) - (append (if (eq c ?\?) - ;; $a++ ? 1 : 2 - "~{(=|&*!,;" - "~{(=|&+-*!,;") nil)) - (and (eq (preceding-char) ?\}) - (cperl-after-block-p (point-min))) - (and (eq (char-syntax (preceding-char)) ?w) - (progn - (forward-sexp -1) - (looking-at - "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\)\\>"))) - (and (eq (preceding-char) ?.) - (eq (char-after (- (point) 2)) ?.)) - (bobp)))) - b (1- b)))) - (or bb (setq state (parse-partial-sexp - state-point b nil nil state) - state-point b)) - (goto-char b) - (if (or bb (nth 3 state) (nth 4 state)) - (goto-char i) - (skip-chars-forward " \t") - ;; qtag means two-arg matcher, may be reset to - ;; 2 or 3 later if some special quoting is needed. - ;; e1 means matching-char matcher. - (setq b (point) - tag (char-after b) - qtag (if (string-match "^\\([sy]\\|tr\\)$" argument) t) - e1 (cdr (assoc tag '(( ?\( . ?\) ) - ( ?\[ . ?\] ) - ( ?\{ . ?\} ) - ( ?\< . ?\> ) - )))) - ;; What if tag == ?\\ ???? - (or st - (progn - (setq st (make-syntax-table) i 0) - (while (< i 256) - (modify-syntax-entry i "." st) - (setq i (1+ i))) - (modify-syntax-entry ?\\ "\\" st))) - ;; Whether we have an intermediate point - (setq i nil) - ;; Prepare the syntax table: - (cond - ;; $ has TeXish matching rules, so $$ equiv $... - ((and qtag - (not e1) - (eq tag (char-after (cperl-1+ b))) - (eq tag (char-after (+ 2 b)))) - (setq qtag 3)) ; s/// - ((and qtag - (not e1) - (eq tag (char-after (cperl-1+ b)))) - (setq qtag nil)) ; s//blah/, will work anyway - ((and (not e1) - (eq tag (char-after (cperl-1+ b)))) - (setq qtag 2)) ; m// - ((not e1) - (modify-syntax-entry tag "$" st)) ; m/blah/, s/x//, s/x/y/ - (t ; s{}(), m[] - (modify-syntax-entry tag (concat "(" (list e1)) st) - (modify-syntax-entry e1 (concat ")" (list tag)) st))) - (if (numberp qtag) - (forward-char qtag) - (condition-case bb - (progn - (set-syntax-table st) - (forward-sexp 1) ; Wrong if m// - taken care of... - (if qtag - (if e1 - (progn - (setq i (point)) - (set-syntax-table cperl-mode-syntax-table) - (forward-sexp 1)) ; Should be smarter? - ;; "$" has funny matching rules - (if (/= (char-after (- (point) 2)) - (preceding-char)) - (progn - ;; Commenting \\ is dangerous, what about ( ? - (if (eq (following-char) ?\\) nil - (setq i (point))) - (forward-char -1) - (forward-sexp 1))) - ))) - (error (goto-char (point-max)) - (message - "End of `%s%c ... %c' string not found: %s" - argument tag (or e1 tag) bb) - (or err (setq err b))))) - (set-syntax-table cperl-mode-syntax-table) - (if (null i) - (cperl-commentify b (point) t) - (cperl-commentify b i t) - (if (looking-at "\\sw*e") nil ; s///e - (cperl-commentify i (point) t))) - (if (eq (char-syntax (following-char)) ?w) - (forward-word 1)) ; skip modifiers s///s - (modify-syntax-entry tag "." st) - (if e1 (modify-syntax-entry e1 "." st)))) - ((match-beginning 13) ; sub with prototypes - (setq b (match-beginning 0)) - (if (memq (char-after (1- b)) - '(?\$ ?\@ ?\% ?\& ?\*)) - nil - (setq state (parse-partial-sexp - state-point (1- b) nil nil state) - state-point (1- b)) - (if (or (nth 3 state) (nth 4 state)) - nil - ;; Mark as string - (cperl-commentify (match-beginning 13) (match-end 13) t)) - (goto-char (match-end 0)))) - ;; 1+6+2+1+1+2=13 extra () before this: - ;; "\\$\\(['{]\\)" - ((and (match-beginning 14) - (eq (preceding-char) ?\')) ; $' - (setq b (1- (point)) - state (parse-partial-sexp - state-point (1- b) nil nil state) - state-point (1- b)) - (if (nth 3 state) ; in string - (progn - (put-text-property (1- b) b 'syntax-table cperl-st-punct) - (put-text-property (1- b) b 'rear-nonsticky t))) - (goto-char (1+ b))) - ;; 1+6+2+1+1+2=13 extra () before this: - ;; "\\$\\(['{]\\)" - ((match-beginning 14) ; ${ - (setq bb (match-beginning 0)) - (put-text-property bb (1+ bb) 'syntax-table cperl-st-punct) - (put-text-property bb (1+ bb) 'rear-nonsticky t)) - ;; 1+6+2+1+1+2+1=14 extra () before this: - ;; "\\(\\") -;;; (progn -;;; (message "=cut is not preceded by a pod section") -;;; (setq err (point))) -;;; (beginning-of-line) - -;;; (setq b (point) bb b) -;;; (or (re-search-forward "\n\n=cut\\>" max 'toend) -;;; (message "Cannot find the end of a pod section")) -;;; (beginning-of-line 3) -;;; (setq e (point)) -;;; (put-text-property b e 'in-pod t) -;;; (goto-char b) -;;; (while (re-search-forward "\n\n[ \t]" e t) -;;; (beginning-of-line) -;;; (put-text-property b (point) 'syntax-type 'pod) -;;; (cperl-put-do-not-fontify b (point)) -;;; ;;(put-text-property (max (point-min) (1- b)) -;;; ;; (point) cperl-do-not-fontify t) -;;; (if cperl-pod-here-fontify (put-text-property b (point) 'face face)) -;;; (re-search-forward "\n\n[^ \t\f\n]" e 'toend) -;;; (beginning-of-line) -;;; (setq b (point))) -;;; (put-text-property (point) e 'syntax-type 'pod) -;;; (cperl-put-do-not-fontify (point) e) -;;; ;;(put-text-property (max (point-min) (1- (point))) -;;; ;; e cperl-do-not-fontify t) -;;; (if cperl-pod-here-fontify -;;; (progn (put-text-property (point) e 'face face) -;;; (goto-char bb) -;;; (if (looking-at -;;; "=[a-zA-Z0-9]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$") -;;; (put-text-property -;;; (match-beginning 1) (match-end 1) -;;; 'face head-face)) -;;; (while (re-search-forward -;;; ;; One paragraph -;;; "\n\n=[a-zA-Z0-9]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$" -;;; e 'toend) -;;; (put-text-property -;;; (match-beginning 1) (match-end 1) -;;; 'face head-face)))) -;;; (goto-char e))) -;;; (goto-char min) -;;; (while (re-search-forward -;;; ;; We exclude \n to avoid misrecognition inside quotes. -;;; "<<\\(\\([\"'`]\\)\\([^\"'`\n]*\\)\\2\\|\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)\\)" -;;; max t) -;;; (if (match-beginning 4) -;;; (setq b1 (match-beginning 4) -;;; e1 (match-end 4)) -;;; (setq b1 (match-beginning 3) -;;; e1 (match-end 3))) -;;; (setq tag (buffer-substring b1 e1) -;;; qtag (regexp-quote tag)) -;;; (cond (cperl-pod-here-fontify -;;; (put-text-property b1 e1 'face font-lock-reference-face) -;;; (cperl-put-do-not-fontify b1 e1))) -;;; (forward-line) -;;; (setq b (point)) -;;; (cond ((re-search-forward (concat "^" qtag "$") max 'toend) -;;; (if cperl-pod-here-fontify -;;; (progn -;;; (put-text-property (match-beginning 0) (match-end 0) -;;; 'face font-lock-reference-face) -;;; (cperl-put-do-not-fontify b (match-end 0)) -;;; ;;(put-text-property (max (point-min) (1- b)) -;;; ;; (min (point-max) -;;; ;; (1+ (match-end 0))) -;;; ;; cperl-do-not-fontify t) -;;; (put-text-property b (match-beginning 0) -;;; 'face here-face))) -;;; (put-text-property b (match-beginning 0) -;;; 'syntax-type 'here-doc) -;;; (cperl-put-do-not-fontify b (match-beginning 0))) -;;; (t (message "End of here-document `%s' not found." tag)))) -;;; (goto-char min) -;;; (while (re-search-forward -;;; "^[ \t]*format[ \t]*\\(\\([a-zA-Z0-9_]+[ \t]*\\)?\\)=[ \t]*$" -;;; max t) -;;; (setq b (point) -;;; name (buffer-substring (match-beginning 1) -;;; (match-end 1))) -;;; (cond ((re-search-forward (concat "^[.;]$") max 'toend) -;;; (if cperl-pod-here-fontify -;;; (progn -;;; (put-text-property b (match-end 0) -;;; 'face font-lock-string-face) -;;; (cperl-put-do-not-fontify b (match-end 0)))) -;;; (put-text-property b (match-end 0) -;;; 'syntax-type 'format) -;;; (cperl-put-do-not-fontify b (match-beginning 0))) -;;; (t (message "End of format `%s' not found." name)))) -) - (if err (goto-char err) - (message "Scan for pods, formats and here-docs completed."))) - (and (buffer-modified-p) - (not modified) - (set-buffer-modified-p nil)) - (set-syntax-table cperl-mode-syntax-table)))) - -(defun cperl-backward-to-noncomment (lim) - ;; Stops at lim or after non-whitespace that is not in comment - (let (stop p) - (while (and (not stop) (> (point) (or lim 1))) - (skip-chars-backward " \t\n\f" lim) - (setq p (point)) - (beginning-of-line) - (if (looking-at "^[ \t]*\\(#\\|$\\)") nil ; Only comment, skip - ;; Else - (cperl-to-comment-or-eol) - (skip-chars-backward " \t") - (if (< p (point)) (goto-char p)) - (setq stop t))))) - -(defun cperl-after-block-p (lim) - ;; We suppose that the preceding char is }. - (save-excursion - (condition-case nil - (progn - (forward-sexp -1) - (cperl-backward-to-noncomment lim) - (or (eq (preceding-char) ?\) ) ; if () {} - (and (eq (char-syntax (preceding-char)) ?w) ; else {} - (progn - (forward-sexp -1) - (looking-at "\\(else\\|grep\\|map\\)\\>"))) - (cperl-after-expr-p lim))) - (error nil)))) - -(defun cperl-after-expr-p (&optional lim chars test) - "Returns true if the position is good for start of expression. -TEST is the expression to evaluate at the found position. If absent, -CHARS is a string that contains good characters to have before us (however, -`}' is treated \"smartly\" if it is not in the list)." - (let (stop p - (lim (or lim (point-min)))) - (save-excursion - (while (and (not stop) (> (point) lim)) - (skip-chars-backward " \t\n\f" lim) - (setq p (point)) - (beginning-of-line) - (if (looking-at "^[ \t]*\\(#\\|$\\)") nil ; Only comment, skip - ;; Else: last iteration (What to do with labels?) - (cperl-to-comment-or-eol) - (skip-chars-backward " \t") - (if (< p (point)) (goto-char p)) - (setq stop t))) - (or (bobp) - (progn - (if test (eval test) - (or (memq (preceding-char) (append (or chars "{;") nil)) - (and (eq (preceding-char) ?\}) - (cperl-after-block-p lim))))))))) - -(defun cperl-backward-to-start-of-continued-exp (lim) - (if (memq (preceding-char) (append ")]}\"'`" nil)) - (forward-sexp -1)) - (beginning-of-line) - (if (<= (point) lim) - (goto-char (1+ lim))) - (skip-chars-forward " \t")) - - -(defvar innerloop-done nil) -(defvar last-depth nil) - -(defun cperl-indent-exp () - "Simple variant of indentation of continued-sexp. -Should be slow. Will not indent comment if it starts at `comment-indent' -or looks like continuation of the comment on the previous line." - (interactive) - (save-excursion - (let ((tmp-end (progn (end-of-line) (point))) top done) - (save-excursion - (beginning-of-line) - (while (null done) - (setq top (point)) - (while (= (nth 0 (parse-partial-sexp (point) tmp-end - -1)) -1) - (setq top (point))) ; Get the outermost parenths in line - (goto-char top) - (while (< (point) tmp-end) - (parse-partial-sexp (point) tmp-end nil t) ; To start-sexp or eol - (or (eolp) (forward-sexp 1))) - (if (> (point) tmp-end) (progn (end-of-line) (setq tmp-end (point))) - (setq done t))) - (goto-char tmp-end) - (setq tmp-end (point-marker))) - (cperl-indent-region (point) tmp-end)))) - -(defun cperl-indent-region (start end) - "Simple variant of indentation of region in CPerl mode. -Should be slow. Will not indent comment if it starts at `comment-indent' -or looks like continuation of the comment on the previous line. -Indents all the lines whose first character is between START and END -inclusive." - (interactive "r") - (save-excursion - (let (st comm indent-info old-comm-indent new-comm-indent - (pm 0) (imenu-scanning-message "Indenting... (%3d%%)")) - (goto-char start) - (setq old-comm-indent (and (cperl-to-comment-or-eol) - (current-column)) - new-comm-indent old-comm-indent) - (goto-char start) - (or (bolp) (beginning-of-line 2)) - (or (fboundp 'imenu-progress-message) - (message "Indenting... For feedback load `imenu'...")) - (while (and (<= (point) end) (not (eobp))) ; bol to check start - (and (fboundp 'imenu-progress-message) - (imenu-progress-message - pm (/ (* 100 (- (point) start)) (- end start -1)))) - (setq st (point) - indent-info nil - ) ; Believe indentation of the current - (if (and (setq comm (looking-at "[ \t]*#")) - (or (eq (current-indentation) (or old-comm-indent - comment-column)) - (setq old-comm-indent nil))) - (if (and old-comm-indent - (= (current-indentation) old-comm-indent) - (not (eq (get-text-property (point) 'syntax-type) 'pod))) - (let ((comment-column new-comm-indent)) - (indent-for-comment))) - (progn - (cperl-indent-line 'indent-info) - (or comm - (progn - (if (setq old-comm-indent (and (cperl-to-comment-or-eol) - (not (eq (get-text-property (point) 'syntax-type) 'pod)) - (current-column))) - (progn (indent-for-comment) - (skip-chars-backward " \t") - (skip-chars-backward "#") - (setq new-comm-indent (current-column)))))))) - (beginning-of-line 2)) - (if (fboundp 'imenu-progress-message) - (imenu-progress-message pm 100) - (message nil))))) - -;;(defun cperl-slash-is-regexp (&optional pos) -;; (save-excursion -;; (goto-char (if pos pos (1- (point)))) -;; (and -;; (not (memq (get-text-property (point) 'face) -;; '(font-lock-string-face font-lock-comment-face))) -;; (cperl-after-expr-p nil nil ' -;; (or (looking-at "[^]a-zA-Z0-9_)}]") -;; (eq (get-text-property (point) 'face) -;; 'font-lock-keyword-face)))))) - -;; Stolen from lisp-mode with a lot of improvements - -(defun cperl-fill-paragraph (&optional justify iteration) - "Like \\[fill-paragraph], but handle CPerl comments. -If any of the current line is a comment, fill the comment or the -block of it that point is in, preserving the comment's initial -indentation and initial hashes. Behaves usually outside of comment." - (interactive "P") - (let ( - ;; Non-nil if the current line contains a comment. - has-comment - - ;; If has-comment, the appropriate fill-prefix for the comment. - comment-fill-prefix - ;; Line that contains code and comment (or nil) - start - c spaces len dc (comment-column comment-column)) - ;; Figure out what kind of comment we are looking at. - (save-excursion - (beginning-of-line) - (cond - - ;; A line with nothing but a comment on it? - ((looking-at "[ \t]*#[# \t]*") - (setq has-comment t - comment-fill-prefix (buffer-substring (match-beginning 0) - (match-end 0)))) - - ;; A line with some code, followed by a comment? Remember that the - ;; semi which starts the comment shouldn't be part of a string or - ;; character. - ((cperl-to-comment-or-eol) - (setq has-comment t) - (looking-at "#+[ \t]*") - (setq start (point) c (current-column) - comment-fill-prefix - (concat (make-string (current-column) ?\ ) - (buffer-substring (match-beginning 0) (match-end 0))) - spaces (progn (skip-chars-backward " \t") - (buffer-substring (point) start)) - dc (- c (current-column)) len (- start (point)) - start (point-marker)) - (delete-char len) - (insert (make-string dc ?-))))) - (if (not has-comment) - (fill-paragraph justify) ; Do the usual thing outside of comment - ;; Narrow to include only the comment, and then fill the region. - (save-restriction - (narrow-to-region - ;; Find the first line we should include in the region to fill. - (if start (progn (beginning-of-line) (point)) - (save-excursion - (while (and (zerop (forward-line -1)) - (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]"))) - ;; We may have gone to far. Go forward again. - (or (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]") - (forward-line 1)) - (point))) - ;; Find the beginning of the first line past the region to fill. - (save-excursion - (while (progn (forward-line 1) - (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]"))) - (point))) - ;; Remove existing hashes - (goto-char (point-min)) - (while (progn (forward-line 1) (< (point) (point-max))) - (skip-chars-forward " \t") - (and (looking-at "#+") - (delete-char (- (match-end 0) (match-beginning 0))))) - - ;; Lines with only hashes on them can be paragraph boundaries. - (let ((paragraph-start (concat paragraph-start "\\|^[ \t#]*$")) - (paragraph-separate (concat paragraph-start "\\|^[ \t#]*$")) - (fill-prefix comment-fill-prefix)) - (fill-paragraph justify))) - (if (and start) - (progn - (goto-char start) - (if (> dc 0) - (progn (delete-char dc) (insert spaces))) - (if (or (= (current-column) c) iteration) nil - (setq comment-column c) - (indent-for-comment) - ;; Repeat once more, flagging as iteration - (cperl-fill-paragraph justify t))))))) - -(defun cperl-do-auto-fill () - ;; Break out if the line is short enough - (if (> (save-excursion - (end-of-line) - (current-column)) - fill-column) - (let ((c (save-excursion (beginning-of-line) - (cperl-to-comment-or-eol) (point))) - (s (memq (following-char) '(?\ ?\t))) marker) - (if (>= c (point)) nil - (setq marker (point-marker)) - (cperl-fill-paragraph) - (goto-char marker) - ;; Is not enough, sometimes marker is a start of line - (if (bolp) (progn (re-search-forward "#+[ \t]*") - (goto-char (match-end 0)))) - ;; Following space could have gone: - (if (or (not s) (memq (following-char) '(?\ ?\t))) nil - (insert " ") - (backward-char 1)) - ;; Previous space could have gone: - (or (memq (preceding-char) '(?\ ?\t)) (insert " ")))))) - -;;(defvar imenu-example--function-name-regexp-perl -;; (concat -;; "^\\(" -;; "[ \t]*\\(sub\\|package\\)[ \t\n]+\\([a-zA-Z_0-9:']+\\)[ \t]*\\(([^()]*)[ \t]*\\)?" -;; "\\|" -;; "=head\\([12]\\)[ \t]+\\([^\n]+\\)$" -;; "\\)")) - -;;(defun cperl-imenu-addback (lst &optional isback name) -;; ;; We suppose that the lst is a DAG, unless the first element only -;; ;; loops back, and ISBACK is set. Thus this function cannot be -;; ;; applied twice without ISBACK set. -;; (cond ((not cperl-imenu-addback) lst) -;; (t -;; (or name -;; (setq name "+++BACK+++")) -;; (mapcar (function (lambda (elt) -;; (if (and (listp elt) (listp (cdr elt))) -;; (progn -;; ;; In the other order it goes up -;; ;; one level only ;-( -;; (setcdr elt (cons (cons name lst) -;; (cdr elt))) -;; (cperl-imenu-addback (cdr elt) t name) -;; )))) -;; (if isback (cdr lst) lst)) -;; lst))) - -;;(defun imenu-example--create-perl-index (&optional regexp) -;; (require 'cl) -;; ;; #### -;; (require 'imenu) ; May be called from TAGS creator -;; (let ((index-alist '()) (index-pack-alist '()) (index-pod-alist '()) -;; (index-unsorted-alist '()) (i-s-f (default-value 'imenu-sort-function)) -;; (index-meth-alist '()) meth -;; packages ends-ranges p -;; (prev-pos 0) char fchar index index1 name (end-range 0) package) -;; (goto-char (point-min)) -;; (imenu-progress-message prev-pos 0) -;; ;; Search for the function -;; (progn ;;save-match-data -;; (while (re-search-forward -;; (or regexp imenu-example--function-name-regexp-perl) -;; nil t) -;; (imenu-progress-message prev-pos) -;; ;;(backward-up-list 1) -;; (cond -;; ((and ; Skip some noise if building tags -;; (match-beginning 2) ; package or sub -;; (eq (char-after (match-beginning 2)) ?p) ; package -;; (not (save-match-data -;; (looking-at "[ \t\n]*;")))) ; Plain text word 'package' -;; nil) -;; ((and -;; (match-beginning 2) ; package or sub -;; ;; Skip if quoted (will not skip multi-line ''-comments :-(): -;; (null (get-text-property (match-beginning 1) 'syntax-table)) -;; (null (get-text-property (match-beginning 1) 'syntax-type)) -;; (null (get-text-property (match-beginning 1) 'in-pod))) -;; (save-excursion -;; (goto-char (match-beginning 2)) -;; (setq fchar (following-char)) -;; ) -;; ;; (if (looking-at "([^()]*)[ \t\n\f]*") -;; ;; (goto-char (match-end 0))) ; Messes what follows -;; (setq char (following-char) -;; meth nil -;; p (point)) -;; (while (and ends-ranges (>= p (car ends-ranges))) -;; ;; delete obsolete entries -;; (setq ends-ranges (cdr ends-ranges) packages (cdr packages))) -;; (setq package (or (car packages) "") -;; end-range (or (car ends-ranges) 0)) -;; (if (eq fchar ?p) -;; (setq name (buffer-substring (match-beginning 3) (match-end 3)) -;; name (progn -;; (set-text-properties 0 (length name) nil name) -;; name) -;; package (concat name "::") -;; name (concat "package " name) -;; end-range -;; (save-excursion -;; (parse-partial-sexp (point) (point-max) -1) (point)) -;; ends-ranges (cons end-range ends-ranges) -;; packages (cons package packages))) -;; ;; ) -;; ;; Skip this function name if it is a prototype declaration. -;; (if (and (eq fchar ?s) (eq char ?\;)) nil -;; (setq index (imenu-example--name-and-position)) -;; (if (eq fchar ?p) nil -;; (setq name (buffer-substring (match-beginning 3) (match-end 3))) -;; (set-text-properties 0 (length name) nil name) -;; (cond ((string-match "[:']" name) -;; (setq meth t)) -;; ((> p end-range) nil) -;; (t -;; (setq name (concat package name) meth t)))) -;; (setcar index name) -;; (if (eq fchar ?p) -;; (push index index-pack-alist) -;; (push index index-alist)) -;; (if meth (push index index-meth-alist)) -;; (push index index-unsorted-alist))) -;; ((match-beginning 5) ; Pod section -;; ;; (beginning-of-line) -;; (setq index (imenu-example--name-and-position) -;; name (buffer-substring (match-beginning 6) (match-end 6))) -;; (set-text-properties 0 (length name) nil name) -;; (if (eq (char-after (match-beginning 5)) ?2) -;; (setq name (concat " " name))) -;; (setcar index name) -;; (setq index1 (cons (concat "=" name) (cdr index))) -;; (push index index-pod-alist) -;; (push index1 index-unsorted-alist))))) -;; (imenu-progress-message prev-pos 100) -;; (setq index-alist -;; (if (default-value 'imenu-sort-function) -;; (sort index-alist (default-value 'imenu-sort-function)) -;; (nreverse index-alist))) -;; (and index-pod-alist -;; (push (cons "+POD headers+..." -;; (nreverse index-pod-alist)) -;; index-alist)) -;; (and (or index-pack-alist index-meth-alist) -;; (let ((lst index-pack-alist) hier-list pack elt group name) -;; ;; Remove "package ", reverse and uniquify. -;; (while lst -;; (setq elt (car lst) lst (cdr lst) name (substring (car elt) 8)) -;; (if (assoc name hier-list) nil -;; (setq hier-list (cons (cons name (cdr elt)) hier-list)))) -;; (setq lst index-meth-alist) -;; (while lst -;; (setq elt (car lst) lst (cdr lst)) -;; (cond ((string-match "\\(::\\|'\\)[_a-zA-Z0-9]+$" (car elt)) -;; (setq pack (substring (car elt) 0 (match-beginning 0))) -;; (if (setq group (assoc pack hier-list)) -;; (if (listp (cdr group)) -;; ;; Have some functions already -;; (setcdr group -;; (cons (cons (substring -;; (car elt) -;; (+ 2 (match-beginning 0))) -;; (cdr elt)) -;; (cdr group))) -;; (setcdr group (list (cons (substring -;; (car elt) -;; (+ 2 (match-beginning 0))) -;; (cdr elt))))) -;; (setq hier-list -;; (cons (cons pack -;; (list (cons (substring -;; (car elt) -;; (+ 2 (match-beginning 0))) -;; (cdr elt)))) -;; hier-list)))))) -;; (push (cons "+Hierarchy+..." -;; hier-list) -;; index-alist))) -;; (and index-pack-alist -;; (push (cons "+Packages+..." -;; (nreverse index-pack-alist)) -;; index-alist)) -;; (and (or index-pack-alist index-pod-alist -;; (default-value 'imenu-sort-function)) -;; index-unsorted-alist -;; (push (cons "+Unsorted List+..." -;; (nreverse index-unsorted-alist)) -;; index-alist)) -;; (cperl-imenu-addback index-alist))) - -(defvar cperl-compilation-error-regexp-alist - ;; This look like a paranoiac regexp: could anybody find a better one? (which WORK). - '(("^[^\n]* \\(file\\|at\\) \\([^ \t\n]+\\) [^\n]*line \\([0-9]+\\)[\\., \n]" - 2 3)) - "Alist that specifies how to match errors in perl output.") - -(if (fboundp 'eval-after-load) - (eval-after-load - "mode-compile" - '(setq perl-compilation-error-regexp-alist - cperl-compilation-error-regexp-alist))) - - -(defvar cperl-faces-init nil) - -(defun cperl-windowed-init () - "Initialization under windowed version." - (add-hook 'font-lock-mode-hook - (function - (lambda () - (if (or - (eq major-mode 'perl-mode) - (eq major-mode 'cperl-mode)) - (progn - (or cperl-faces-init (cperl-init-faces)))))))) - -(defvar perl-font-lock-keywords-1 nil - "Additional expressions to highlight in Perl mode. Minimal set.") -(defvar perl-font-lock-keywords nil - "Additional expressions to highlight in Perl mode. Default set.") -(defvar perl-font-lock-keywords-2 nil - "Additional expressions to highlight in Perl mode. Maximal set") - -(defun cperl-init-faces () - (condition-case nil - (progn - (require 'font-lock) - (and (fboundp 'font-lock-fontify-anchored-keywords) - (featurep 'font-lock-extra) - (message "You have an obsolete package `font-lock-extra'. Install `choose-color'.")) - (let (t-font-lock-keywords t-font-lock-keywords-1 font-lock-anchored) - ;;(defvar cperl-font-lock-enhanced nil - ;; "Set to be non-nil if font-lock allows active highlights.") - (if (fboundp 'font-lock-fontify-anchored-keywords) - (setq font-lock-anchored t)) - (setq - t-font-lock-keywords - (list - (cons - (concat - "\\(^\\|[^$@%&\\]\\)\\<\\(" - (mapconcat - 'identity - '("if" "until" "while" "elsif" "else" "unless" "for" - "foreach" "continue" "exit" "die" "last" "goto" "next" - "redo" "return" "local" "exec" "sub" "do" "dump" "use" - "require" "package" "eval" "my" "BEGIN" "END") - "\\|") ; Flow control - "\\)\\>") 2) ; was "\\)[ \n\t;():,\|&]" - ; In what follows we use `type' style - ; for overwritable builtins - (list - (concat - "\\(^\\|[^$@%&\\]\\)\\<\\(" - ;; "CORE" "__FILE__" "__LINE__" "abs" "accept" "alarm" - ;; "and" "atan2" "bind" "binmode" "bless" "caller" - ;; "chdir" "chmod" "chown" "chr" "chroot" "close" - ;; "closedir" "cmp" "connect" "continue" "cos" "crypt" - ;; "dbmclose" "dbmopen" "die" "dump" "endgrent" - ;; "endhostent" "endnetent" "endprotoent" "endpwent" - ;; "endservent" "eof" "eq" "exec" "exit" "exp" "fcntl" - ;; "fileno" "flock" "fork" "formline" "ge" "getc" - ;; "getgrent" "getgrgid" "getgrnam" "gethostbyaddr" - ;; "gethostbyname" "gethostent" "getlogin" - ;; "getnetbyaddr" "getnetbyname" "getnetent" - ;; "getpeername" "getpgrp" "getppid" "getpriority" - ;; "getprotobyname" "getprotobynumber" "getprotoent" - ;; "getpwent" "getpwnam" "getpwuid" "getservbyname" - ;; "getservbyport" "getservent" "getsockname" - ;; "getsockopt" "glob" "gmtime" "gt" "hex" "index" "int" - ;; "ioctl" "join" "kill" "lc" "lcfirst" "le" "length" - ;; "link" "listen" "localtime" "log" "lstat" "lt" - ;; "mkdir" "msgctl" "msgget" "msgrcv" "msgsnd" "ne" - ;; "not" "oct" "open" "opendir" "or" "ord" "pack" "pipe" - ;; "quotemeta" "rand" "read" "readdir" "readline" - ;; "readlink" "readpipe" "recv" "ref" "rename" "require" - ;; "reset" "reverse" "rewinddir" "rindex" "rmdir" "seek" - ;; "seekdir" "select" "semctl" "semget" "semop" "send" - ;; "setgrent" "sethostent" "setnetent" "setpgrp" - ;; "setpriority" "setprotoent" "setpwent" "setservent" - ;; "setsockopt" "shmctl" "shmget" "shmread" "shmwrite" - ;; "shutdown" "sin" "sleep" "socket" "socketpair" - ;; "sprintf" "sqrt" "srand" "stat" "substr" "symlink" - ;; "syscall" "sysread" "system" "syswrite" "tell" - ;; "telldir" "time" "times" "truncate" "uc" "ucfirst" - ;; "umask" "unlink" "unpack" "utime" "values" "vec" - ;; "wait" "waitpid" "wantarray" "warn" "write" "x" "xor" - "a\\(bs\\|ccept\\|tan2\\|larm\\|nd\\)\\|" - "b\\(in\\(d\\|mode\\)\\|less\\)\\|" - "c\\(h\\(r\\(\\|oot\\)\\|dir\\|mod\\|own\\)\\|aller\\|rypt\\|" - "lose\\(\\|dir\\)\\|mp\\|o\\(s\\|n\\(tinue\\|nect\\)\\)\\)\\|" - "CORE\\|d\\(ie\\|bm\\(close\\|open\\)\\|ump\\)\\|" - "e\\(x\\(p\\|it\\|ec\\)\\|q\\|nd\\(p\\(rotoent\\|went\\)\\|" - "hostent\\|servent\\|netent\\|grent\\)\\|of\\)\\|" - "f\\(ileno\\|cntl\\|lock\\|or\\(k\\|mline\\)\\)\\|" - "g\\(t\\|lob\\|mtime\\|e\\(\\|t\\(p\\(pid\\|r\\(iority\\|" - "oto\\(byn\\(ame\\|umber\\)\\|ent\\)\\)\\|eername\\|w" - "\\(uid\\|ent\\|nam\\)\\|grp\\)\\|host\\(by\\(addr\\|name\\)\\|" - "ent\\)\\|s\\(erv\\(by\\(port\\|name\\)\\|ent\\)\\|" - "ock\\(name\\|opt\\)\\)\\|c\\|login\\|net\\(by\\(addr\\|name\\)\\|" - "ent\\)\\|gr\\(ent\\|nam\\|gid\\)\\)\\)\\)\\|" - "hex\\|i\\(n\\(t\\|dex\\)\\|octl\\)\\|join\\|kill\\|" - "l\\(i\\(sten\\|nk\\)\\|stat\\|c\\(\\|first\\)\\|t\\|e" - "\\(\\|ngth\\)\\|o\\(caltime\\|g\\)\\)\\|m\\(sg\\(rcv\\|snd\\|" - "ctl\\|get\\)\\|kdir\\)\\|n\\(e\\|ot\\)\\|o\\(pen\\(\\|dir\\)\\|" - "r\\(\\|d\\)\\|ct\\)\\|p\\(ipe\\|ack\\)\\|quotemeta\\|" - "r\\(index\\|and\\|mdir\\|e\\(quire\\|ad\\(pipe\\|\\|lin" - "\\(k\\|e\\)\\|dir\\)\\|set\\|cv\\|verse\\|f\\|winddir\\|name" - "\\)\\)\\|s\\(printf\\|qrt\\|rand\\|tat\\|ubstr\\|e\\(t\\(p\\(r" - "\\(iority\\|otoent\\)\\|went\\|grp\\)\\|hostent\\|s\\(ervent\\|" - "ockopt\\)\\|netent\\|grent\\)\\|ek\\(\\|dir\\)\\|lect\\|" - "m\\(ctl\\|op\\|get\\)\\|nd\\)\\|h\\(utdown\\|m\\(read\\|ctl\\|" - "write\\|get\\)\\)\\|y\\(s\\(read\\|call\\|tem\\|write\\)\\|" - "mlink\\)\\|in\\|leep\\|ocket\\(pair\\|\\)\\)\\|t\\(runcate\\|" - "ell\\(\\|dir\\)\\|ime\\(\\|s\\)\\)\\|u\\(c\\(\\|first\\)\\|" - "time\\|mask\\|n\\(pack\\|link\\)\\)\\|v\\(alues\\|ec\\)\\|" - "w\\(a\\(rn\\|it\\(pid\\|\\)\\|ntarray\\)\\|rite\\)\\|" - "x\\(\\|or\\)\\|__\\(FILE__\\|LINE__\\|PACKAGE__\\)" - "\\)\\>") 2 'font-lock-type-face) - ;; In what follows we use `other' style - ;; for nonoverwritable builtins - ;; Somehow 's', 'm' are not auto-generated??? - (list - (concat - "\\(^\\|[^$@%&\\]\\)\\<\\(" - ;; "AUTOLOAD" "BEGIN" "DESTROY" "END" "__END__" "chomp" - ;; "chop" "defined" "delete" "do" "each" "else" "elsif" - ;; "eval" "exists" "for" "foreach" "format" "goto" - ;; "grep" "if" "keys" "last" "local" "map" "my" "next" - ;; "no" "package" "pop" "pos" "print" "printf" "push" - ;; "q" "qq" "qw" "qx" "redo" "return" "scalar" "shift" - ;; "sort" "splice" "split" "study" "sub" "tie" "tr" - ;; "undef" "unless" "unshift" "untie" "until" "use" - ;; "while" "y" - "AUTOLOAD\\|BEGIN\\|cho\\(p\\|mp\\)\\|d\\(e\\(fined\\|lete\\)\\|" - "o\\)\\|DESTROY\\|e\\(ach\\|val\\|xists\\|ls\\(e\\|if\\)\\)\\|" - "END\\|for\\(\\|each\\|mat\\)\\|g\\(rep\\|oto\\)\\|if\\|keys\\|" - "l\\(ast\\|ocal\\)\\|m\\(ap\\|y\\)\\|n\\(ext\\|o\\)\\|" - "p\\(ackage\\|rint\\(\\|f\\)\\|ush\\|o\\(p\\|s\\)\\)\\|" - "q\\(\\|q\\|w\\|x\\)\\|re\\(turn\\|do\\)\\|s\\(pli\\(ce\\|t\\)\\|" - "calar\\|tudy\\|ub\\|hift\\|ort\\)\\|t\\(r\\|ie\\)\\|" - "u\\(se\\|n\\(shift\\|ti\\(l\\|e\\)\\|def\\|less\\)\\)\\|" - "while\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually - "\\|[sm]" ; Added manually - "\\)\\>") 2 'font-lock-other-type-face) - ;; (mapconcat 'identity - ;; '("#endif" "#else" "#ifdef" "#ifndef" "#if" - ;; "#include" "#define" "#undef") - ;; "\\|") - '("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0 - font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]" - '("\\*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" - (2 font-lock-string-face t) - (0 '(restart 2 t)))) ; To highlight $a{bc}{ef} - (font-lock-anchored - '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" - (2 font-lock-string-face t) - ("\\=[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" - nil nil - (1 font-lock-string-face t)))) - (t '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" - 2 font-lock-string-face t))) - '("[ \t{,(]\\(-?[a-zA-Z0-9_:]+\\)[ \t]*=>" 1 - font-lock-string-face t) - '("^[ \t]*\\([a-zA-Z0-9_]+[ \t]*:\\)[ \t]*\\($\\|{\\|\\<\\(until\\|while\\|for\\(each\\)?\\|do\\)\\>\\)" 1 - font-lock-reference-face) ; labels - '("\\<\\(continue\\|next\\|last\\|redo\\|goto\\)\\>[ \t]+\\([a-zA-Z0-9_:]+\\)" ; labels as targets - 2 font-lock-reference-face) - (cond ((featurep 'font-lock-extra) - '("^[ \t]*\\(my\\|local\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?" - (3 font-lock-variable-name-face) - (4 '(another 4 nil - ("\\=[ \t]*,[ \t]*\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?" - (1 font-lock-variable-name-face) - (2 '(restart 2 nil) nil t))) - nil t))) ; local variables, multiple - (font-lock-anchored - '("^[ \t{}]*\\(my\\|local\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" - (3 font-lock-variable-name-face) - ("\\=[ \t]*,[ \t]*\\([$@%*][a-zA-Z0-9_:]+\\)" - nil nil - (1 font-lock-variable-name-face)))) - (t '("^[ \t{}]*\\(my\\|local\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" - 3 font-lock-variable-name-face))) - '("\\= 19.12 - ((fboundp 'valid-color-name-p) 'valid-color-name-p) - ;; XEmacs 19.11 - (t 'x-valid-color-name-p)))) - (defvar font-lock-reference-face 'font-lock-reference-face) - (defvar font-lock-variable-name-face 'font-lock-variable-name-face) - (or (boundp 'font-lock-type-face) - (defconst font-lock-type-face - 'font-lock-type-face - "Face to use for data types.") - ) - (or (boundp 'font-lock-other-type-face) - (defconst font-lock-other-type-face - 'font-lock-other-type-face - "Face to use for data types from another group.") - ) - (if (not cperl-xemacs-p) nil - (or (boundp 'font-lock-comment-face) - (defconst font-lock-comment-face - 'font-lock-comment-face - "Face to use for comments.") - ) - (or (boundp 'font-lock-keyword-face) - (defconst font-lock-keyword-face - 'font-lock-keyword-face - "Face to use for keywords.") - ) - (or (boundp 'font-lock-function-name-face) - (defconst font-lock-function-name-face - 'font-lock-function-name-face - "Face to use for function names.") - ) - ) - ;;(if (featurep 'font-lock) - (if (face-equal font-lock-type-face font-lock-comment-face) - (defconst font-lock-type-face - 'font-lock-type-face - "Face to use for basic data types.") - ) -;;; (if (fboundp 'eval-after-load) -;;; (eval-after-load "font-lock" -;;; '(if (face-equal font-lock-type-face -;;; font-lock-comment-face) -;;; (defconst font-lock-type-face -;;; 'font-lock-type-face -;;; "Face to use for basic data types.") -;;; ))) ; This does not work :-( Why?! -;;; ; Workaround: added to font-lock-m-h -;;; ) - (or (boundp 'font-lock-other-emphasized-face) - (defconst font-lock-other-emphasized-face - 'font-lock-other-emphasized-face - "Face to use for another type of emphasizing.") - ) - (or (boundp 'font-lock-emphasized-face) - (defconst font-lock-emphasized-face - 'font-lock-emphasized-face - "Face to use for emphasizing.") - ) - ;; Here we try to guess background - (let ((background - (if (boundp 'font-lock-background-mode) - font-lock-background-mode - 'light)) - (face-list (and (fboundp 'face-list) (face-list))) - is-face) - (fset 'is-face - (cond ((fboundp 'find-face) - (symbol-function 'find-face)) - (face-list - (function (lambda (face) (member face face-list)))) - (t - (function (lambda (face) (boundp face)))))) - (defvar cperl-guessed-background - (if (and (boundp 'font-lock-display-type) - (eq font-lock-display-type 'grayscale)) - 'gray - background) - "Background as guessed by CPerl mode") - (if (is-face 'font-lock-type-face) nil - (copy-face 'default 'font-lock-type-face) - (cond - ((eq background 'light) - (set-face-foreground 'font-lock-type-face - (if (x-color-defined-p "seagreen") - "seagreen" - "sea green"))) - ((eq background 'dark) - (set-face-foreground 'font-lock-type-face - (if (x-color-defined-p "os2pink") - "os2pink" - "pink"))) - (t - (set-face-background 'font-lock-type-face "gray90")))) - (if (is-face 'font-lock-other-type-face) - nil - (copy-face 'font-lock-type-face 'font-lock-other-type-face) - (cond - ((eq background 'light) - (set-face-foreground 'font-lock-other-type-face - (if (x-color-defined-p "chartreuse3") - "chartreuse3" - "chartreuse"))) - ((eq background 'dark) - (set-face-foreground 'font-lock-other-type-face - (if (x-color-defined-p "orchid1") - "orchid1" - "orange"))))) - (if (is-face 'font-lock-other-emphasized-face) nil - (copy-face 'bold-italic 'font-lock-other-emphasized-face) - (cond - ((eq background 'light) - (set-face-background 'font-lock-other-emphasized-face - (if (x-color-defined-p "lightyellow2") - "lightyellow2" - (if (x-color-defined-p "lightyellow") - "lightyellow" - "light yellow")))) - ((eq background 'dark) - (set-face-background 'font-lock-other-emphasized-face - (if (x-color-defined-p "navy") - "navy" - (if (x-color-defined-p "darkgreen") - "darkgreen" - "dark green")))) - (t (set-face-background 'font-lock-other-emphasized-face "gray90")))) - (if (is-face 'font-lock-emphasized-face) nil - (copy-face 'bold 'font-lock-emphasized-face) - (cond - ((eq background 'light) - (set-face-background 'font-lock-emphasized-face - (if (x-color-defined-p "lightyellow2") - "lightyellow2" - "lightyellow"))) - ((eq background 'dark) - (set-face-background 'font-lock-emphasized-face - (if (x-color-defined-p "navy") - "navy" - (if (x-color-defined-p "darkgreen") - "darkgreen" - "dark green")))) - (t (set-face-background 'font-lock-emphasized-face "gray90")))) - (if (is-face 'font-lock-variable-name-face) nil - (copy-face 'italic 'font-lock-variable-name-face)) - (if (is-face 'font-lock-reference-face) nil - (copy-face 'italic 'font-lock-reference-face)))) - (setq cperl-faces-init t)) - (error nil))) - - -(defun cperl-ps-print-init () - "Initialization of `ps-print' components for faces used in CPerl." - ;; Guard against old versions - (defvar ps-underlined-faces nil) - (defvar ps-bold-faces nil) - (defvar ps-italic-faces nil) - (setq ps-bold-faces - (append '(font-lock-emphasized-face - font-lock-keyword-face - font-lock-variable-name-face - font-lock-reference-face - font-lock-other-emphasized-face) - ps-bold-faces)) - (setq ps-italic-faces - (append '(font-lock-other-type-face - font-lock-reference-face - font-lock-other-emphasized-face) - ps-italic-faces)) - (setq ps-underlined-faces - (append '(font-lock-emphasized-face - font-lock-other-emphasized-face - font-lock-other-type-face font-lock-type-face) - ps-underlined-faces)) - (cons 'font-lock-type-face ps-underlined-faces)) - - -(if (cperl-enable-font-lock) (cperl-windowed-init)) - -(defun cperl-set-style (style) - "Set CPerl-mode variables to use one of several different indentation styles. -The arguments are a string representing the desired style. -Available styles are GNU, K&R, BSD and Whitesmith." - (interactive - (let ((list (progn - (require 'cc-styles) - (mapcar (function (lambda (elt) (list (car elt)))) - c-style-alist)))) - (list (completing-read "Enter style: " list nil 'insist)))) - (let ((style (cdr (assoc style c-style-alist))) setting str sym) - (while style - (setq setting (car style) style (cdr style)) - (setq str (symbol-name (car setting))) - (and (string-match "^c-" str) - (setq str (concat "cperl-" (substring str 2))) - (setq sym (intern-soft str)) - (boundp sym) - (set sym (cdr setting)))))) - -(defun cperl-check-syntax () - (interactive) - (require 'mode-compile) - (let ((perl-dbg-flags "-wc")) - (mode-compile))) - -(defun cperl-info-buffer (type) - ;; Returns buffer with documentation. Creates if missing. - ;; If TYPE, this vars buffer. - ;; Special care is taken to not stomp over an existing info buffer - (let* ((bname (if type "*info-perl-var*" "*info-perl*")) - (info (get-buffer bname)) - (oldbuf (get-buffer "*info*"))) - (if info info - (save-window-excursion - ;; Get Info running - (require 'info) - (cond (oldbuf - (set-buffer oldbuf) - (rename-buffer "*info-perl-tmp*"))) - (save-window-excursion - (info)) - (Info-find-node cperl-info-page (if type "perlvar" "perlfunc")) - (set-buffer "*info*") - (rename-buffer bname) - (cond (oldbuf - (set-buffer "*info-perl-tmp*") - (rename-buffer "*info*") - (set-buffer bname))) - (make-variable-buffer-local 'window-min-height) - (setq window-min-height 2) - (current-buffer))))) - -(defun cperl-word-at-point (&optional p) - ;; Returns the word at point or at P. - (save-excursion - (if p (goto-char p)) - (or (cperl-word-at-point-hard) - (progn - (require 'etags) - (funcall (or (and (boundp 'find-tag-default-function) - find-tag-default-function) - (get major-mode 'find-tag-default-function) - ;; XEmacs 19.12 has `find-tag-default-hook'; it is - ;; automatically used within `find-tag-default': - 'find-tag-default)))))) - -(defun cperl-info-on-command (command) - "Shows documentation for Perl command in other window. -If perl-info buffer is shown in some frame, uses this frame. -Customized by setting variables `cperl-shrink-wrap-info-frame', -`cperl-max-help-size'." - (interactive - (let* ((default (cperl-word-at-point)) - (read (read-string - (format "Find doc for Perl function (default %s): " - default)))) - (list (if (equal read "") - default - read)))) - - (let ((buffer (current-buffer)) - (cmd-desc (concat "^" (regexp-quote command) "[^a-zA-Z_0-9]")) ; "tr///" - pos isvar height iniheight frheight buf win fr1 fr2 iniwin not-loner - max-height char-height buf-list) - (if (string-match "^-[a-zA-Z]$" command) - (setq cmd-desc "^-X[ \t\n]")) - (setq isvar (string-match "^[$@%]" command) - buf (cperl-info-buffer isvar) - iniwin (selected-window) - fr1 (window-frame iniwin)) - (set-buffer buf) - (beginning-of-buffer) - (or isvar - (progn (re-search-forward "^-X[ \t\n]") - (forward-line -1))) - (if (re-search-forward cmd-desc nil t) - (progn - ;; Go back to beginning of the group (ex, for qq) - (if (re-search-backward "^[ \t\n\f]") - (forward-line 1)) - (beginning-of-line) - ;; Get some of - (setq pos (point) - buf-list (list buf "*info-perl-var*" "*info-perl*")) - (while (and (not win) buf-list) - (setq win (get-buffer-window (car buf-list) t)) - (setq buf-list (cdr buf-list))) - (or (not win) - (eq (window-buffer win) buf) - (set-window-buffer win buf)) - (and win (setq fr2 (window-frame win))) - (if (or (not fr2) (eq fr1 fr2)) - (pop-to-buffer buf) - (special-display-popup-frame buf) ; Make it visible - (select-window win)) - (goto-char pos) ; Needed (?!). - ;; Resize - (setq iniheight (window-height) - frheight (frame-height) - not-loner (< iniheight (1- frheight))) ; Are not alone - (cond ((if not-loner cperl-max-help-size - cperl-shrink-wrap-info-frame) - (setq height - (+ 2 - (count-lines - pos - (save-excursion - (if (re-search-forward - "^[ \t][^\n]*\n+\\([^ \t\n\f]\\|\\'\\)" nil t) - (match-beginning 0) (point-max))))) - max-height - (if not-loner - (/ (* (- frheight 3) cperl-max-help-size) 100) - (setq char-height (frame-char-height)) - ;; Non-functioning under OS/2: - (if (eq char-height 1) (setq char-height 18)) - ;; Title, menubar, + 2 for slack - (- (/ (x-display-pixel-height) char-height) 4) - )) - (if (> height max-height) (setq height max-height)) - ;;(message "was %s doing %s" iniheight height) - (if not-loner - (enlarge-window (- height iniheight)) - (set-frame-height (window-frame win) (1+ height))))) - (set-window-start (selected-window) pos)) - (message "No entry for %s found." command)) - ;;(pop-to-buffer buffer) - (select-window iniwin))) - -(defun cperl-info-on-current-command () - "Shows documentation for Perl command at point in other window." - (interactive) - (cperl-info-on-command (cperl-word-at-point))) - -;;(defun cperl-imenu-info-imenu-search () -;; (if (looking-at "^-X[ \t\n]") nil -;; (re-search-backward -;; "^\n\\([-a-zA-Z_]+\\)[ \t\n]") -;; (forward-line 1))) - -;;(defun cperl-imenu-info-imenu-name () -;; (buffer-substring -;; (match-beginning 1) (match-end 1))) - -;;(defun cperl-imenu-on-info () -;; (interactive) -;; (let* ((buffer (current-buffer)) -;; imenu-create-index-function -;; imenu-prev-index-position-function -;; imenu-extract-index-name-function -;; (index-item (save-restriction -;; (save-window-excursion -;; (set-buffer (cperl-info-buffer nil)) -;; (setq imenu-create-index-function -;; 'imenu-default-create-index-function -;; imenu-prev-index-position-function -;; 'cperl-imenu-info-imenu-search -;; imenu-extract-index-name-function -;; 'cperl-imenu-info-imenu-name) -;; (imenu-choose-buffer-index))))) -;; (and index-item -;; (progn -;; (push-mark) -;; (pop-to-buffer "*info-perl*") -;; (cond -;; ((markerp (cdr index-item)) -;; (goto-char (marker-position (cdr index-item)))) -;; (t -;; (goto-char (cdr index-item)))) -;; (set-window-start (selected-window) (point)) -;; (pop-to-buffer buffer))))) - -(defun cperl-lineup (beg end &optional step minshift) - "Lineup construction in a region. -Beginning of region should be at the start of a construction. -All first occurrences of this construction in the lines that are -partially contained in the region are lined up at the same column. - -MINSHIFT is the minimal amount of space to insert before the construction. -STEP is the tabwidth to position constructions. -If STEP is `nil', `cperl-lineup-step' will be used -\(or `cperl-indent-level', if `cperl-lineup-step' is `nil'). -Will not move the position at the start to the left." - (interactive "r") - (let (search col tcol seen b e) - (save-excursion - (goto-char end) - (end-of-line) - (setq end (point-marker)) - (goto-char beg) - (skip-chars-forward " \t\f") - (setq beg (point-marker)) - (indent-region beg end nil) - (goto-char beg) - (setq col (current-column)) - (if (looking-at "[a-zA-Z0-9_]") - (if (looking-at "\\<[a-zA-Z0-9_]+\\>") - (setq search - (concat "\\<" - (regexp-quote - (buffer-substring (match-beginning 0) - (match-end 0))) "\\>")) - (error "Cannot line up in a middle of the word")) - (if (looking-at "$") - (error "Cannot line up end of line")) - (setq search (regexp-quote (char-to-string (following-char))))) - (setq step (or step cperl-lineup-step cperl-indent-level)) - (or minshift (setq minshift 1)) - (while (progn - (beginning-of-line 2) - (and (< (point) end) - (re-search-forward search end t) - (goto-char (match-beginning 0)))) - (setq tcol (current-column) seen t) - (if (> tcol col) (setq col tcol))) - (or seen - (error "The construction to line up occurred only once")) - (goto-char beg) - (setq col (+ col minshift)) - (if (/= (% col step) 0) (setq step (* step (1+ (/ col step))))) - (while - (progn - (setq e (point)) - (skip-chars-backward " \t") - (delete-region (point) e) - (indent-to-column col); (make-string (- col (current-column)) ?\ )) - (beginning-of-line 2) - (and (< (point) end) - (re-search-forward search end t) - (goto-char (match-beginning 0)))))))) ; No body - -(defun cperl-etags (&optional add all files) - "Run etags with appropriate options for Perl files. -If optional argument ALL is `recursive', will process Perl files -in subdirectories too." - (interactive) - (let ((cmd "etags") - (args '("-l" "none" "-r" "/\\<\\(package\\|sub\\)[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)[ \\t]*\\(([^()]*)[ \t]*\\)?\\([{#]\\|$\\)\\)/\\4/")) - res) - (if add (setq args (cons "-a" args))) - (or files (setq files (list buffer-file-name))) - (cond - ((eq all 'recursive) - ;;(error "Not implemented: recursive") - (setq args (append (list "-e" - "sub wanted {push @ARGV, $File::Find::name if /\\.[pP][Llm]$/} - use File::Find; - find(\\&wanted, '.'); - exec @ARGV;" - cmd) args) - cmd "perl")) - (all - ;;(error "Not implemented: all") - (setq args (append (list "-e" - "push @ARGV, <*.PL *.pl *.pm>; - exec @ARGV;" - cmd) args) - cmd "perl")) - (t - (setq args (append args files)))) - (setq res (apply 'call-process cmd nil nil nil args)) - (or (eq res 0) - (message "etags returned \"%s\"" res)))) - -(defun cperl-toggle-auto-newline () - "Toggle the state of `cperl-auto-newline'." - (interactive) - (setq cperl-auto-newline (not cperl-auto-newline)) - (message "Newlines will %sbe auto-inserted now." - (if cperl-auto-newline "" "not "))) - -(defun cperl-toggle-abbrev () - "Toggle the state of automatic keyword expansion in CPerl mode." - (interactive) - (abbrev-mode (if abbrev-mode 0 1)) - (message "Perl control structure will %sbe auto-inserted now." - (if abbrev-mode "" "not "))) - - -(defun cperl-toggle-electric () - "Toggle the state of parentheses doubling in CPerl mode." - (interactive) - (setq cperl-electric-parens (if (cperl-val 'cperl-electric-parens) 'null t)) - (message "Parentheses will %sbe auto-doubled now." - (if (cperl-val 'cperl-electric-parens) "" "not "))) - -;;;; Tags file creation. - -(defvar cperl-tmp-buffer " *cperl-tmp*") - -(defun cperl-setup-tmp-buf () - (set-buffer (get-buffer-create cperl-tmp-buffer)) - (set-syntax-table cperl-mode-syntax-table) - (buffer-disable-undo) - (auto-fill-mode 0) - (if cperl-use-syntax-table-text-property-for-tags - (progn - (make-variable-buffer-local 'parse-sexp-lookup-properties) - ;; Do not introduce variable if not needed, we check it! - (set 'parse-sexp-lookup-properties t)))) - -(defun cperl-xsub-scan () - (require 'cl) - (require 'imenu) - (let ((index-alist '()) - (prev-pos 0) index index1 name package prefix) - (goto-char (point-min)) - (imenu-progress-message prev-pos 0) - ;; Search for the function - (progn ;;save-match-data - (while (re-search-forward - "^\\([ \t]*MODULE\\>[^\n]*\\\\|\\([a-zA-Z_][a-zA-Z_0-9]*\\)(\\|[ \t]*BOOT:\\)" - nil t) - (imenu-progress-message prev-pos) - (cond - ((match-beginning 2) ; SECTION - (setq package (buffer-substring (match-beginning 2) (match-end 2))) - (goto-char (match-beginning 0)) - (skip-chars-forward " \t") - (forward-char 1) - (if (looking-at "[^\n]*\\") - (setq prefix (buffer-substring (match-beginning 1) (match-end 1))) - (setq prefix nil))) - ((not package) nil) ; C language section - ((match-beginning 3) ; XSUB - (goto-char (1+ (match-beginning 3))) - (setq index (imenu-example--name-and-position)) - (setq name (buffer-substring (match-beginning 3) (match-end 3))) - (if (and prefix (string-match (concat "^" prefix) name)) - (setq name (substring name (length prefix)))) - (cond ((string-match "::" name) nil) - (t - (setq index1 (cons (concat package "::" name) (cdr index))) - (push index1 index-alist))) - (setcar index name) - (push index index-alist)) - (t ; BOOT: section - ;; (beginning-of-line) - (setq index (imenu-example--name-and-position)) - (setcar index (concat package "::BOOT:")) - (push index index-alist))))) - (imenu-progress-message prev-pos 100) - ;;(setq index-alist - ;; (if (default-value 'imenu-sort-function) - ;; (sort index-alist (default-value 'imenu-sort-function)) - ;; (nreverse index-alist))) - index-alist)) - -(defun cperl-find-tags (file xs) - (let (ind (b (get-buffer cperl-tmp-buffer)) lst elt pos ret - (cperl-pod-here-fontify nil)) - (save-excursion - (if b (set-buffer b) - (cperl-setup-tmp-buf)) - (erase-buffer) - (setq file (car (insert-file-contents file))) - (message "Scanning file %s..." file) - (if cperl-use-syntax-table-text-property-for-tags - (cperl-find-pods-heres)) - (if xs - (setq lst (cperl-xsub-scan)) - (setq ind (imenu-example--create-perl-index)) - (setq lst (cdr (assoc "+Unsorted List+..." ind)))) - (setq lst - (mapcar - (function - (lambda (elt) - (cond ((string-match "^[_a-zA-Z]" (car elt)) - (goto-char (cdr elt)) - (list (car elt) - (point) (count-lines 1 (point)) - (buffer-substring (progn - (skip-chars-forward - ":_a-zA-Z0-9") - (or (eolp) (forward-char 1)) - (point)) - (progn - (beginning-of-line) - (point)))))))) - lst)) - (erase-buffer) - (while lst - (setq elt (car lst) lst (cdr lst)) - (if elt - (progn - (insert (elt elt 3) - 127 - (if (string-match "^package " (car elt)) - (substring (car elt) 8) - (car elt) ) - 1 - (number-to-string (elt elt 1)) - "," - (number-to-string (elt elt 2)) - "\n") - (if (and (string-match "^[_a-zA-Z]+::" (car elt)) - (string-match "^sub[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]" - (elt elt 3))) - ;; Need to insert the name without package as well - (setq lst (cons (cons (substring (elt elt 3) - (match-beginning 1) - (match-end 1)) - (cdr elt)) - lst)))))) - (setq pos (point)) - (goto-char 1) - (insert "\f\n" file "," (number-to-string (1- pos)) "\n") - (setq ret (buffer-substring 1 (point-max))) - (erase-buffer) - (message "Scanning file %s finished" file) - ret))) - -(defun cperl-write-tags (&optional file erase recurse dir inbuffer) - ;; If INBUFFER, do not select buffer, and do not save - ;; If ERASE is `ignore', do not erase, and do not try to delete old info. - (require 'etags) - (if file nil - (setq file (if dir default-directory (buffer-file-name))) - (if (and (not dir) (buffer-modified-p)) (error "Save buffer first!"))) - (let ((tags-file-name "TAGS") - (case-fold-search (eq system-type 'emx)) - xs) - (save-excursion - (cond (inbuffer nil) ; Already there - ((file-exists-p tags-file-name) - (visit-tags-table-buffer)) - (t (set-buffer (find-file-noselect tags-file-name)))) - (cond - (dir - (cond ((eq erase 'ignore)) - (erase - (erase-buffer) - (setq erase 'ignore))) - (let ((files - (directory-files file t - (if recurse nil cperl-scan-files-regexp) - t))) - (mapcar (function (lambda (file) - (cond - ((string-match cperl-noscan-files-regexp file) - nil) - ((not (file-directory-p file)) - (if (string-match cperl-scan-files-regexp file) - (cperl-write-tags file erase recurse nil t))) - ((not recurse) nil) - (t (cperl-write-tags file erase recurse t t))))) - files)) - ) - (t - (setq xs (string-match "\\.xs$" file)) - (cond ((eq erase 'ignore) (goto-char (point-max))) - (erase (erase-buffer)) - (t - (goto-char 1) - (if (search-forward (concat "\f\n" file ",") nil t) - (progn - (search-backward "\f\n") - (delete-region (point) - (save-excursion - (forward-char 1) - (if (search-forward "\f\n" nil 'toend) - (- (point) 2) - (point-max))))) - (goto-char (point-max))))) - (insert (cperl-find-tags file xs)))) - (if inbuffer nil ; Delegate to the caller - (save-buffer 0) ; No backup - (if (fboundp 'initialize-new-tags-table) ; Do we need something special in XEmacs? - (initialize-new-tags-table)))))) - -(defvar cperl-tags-hier-regexp-list - (concat - "^\\(" - "\\(package\\)\\>" - "\\|" - "sub\\>[^\n]+::" - "\\|" - "[a-zA-Z_][a-zA-Z_0-9:]*(\C-?[^\n]+::" ; XSUB? - "\\|" - "[ \t]*BOOT:\C-?[^\n]+::" ; BOOT section - "\\)")) - -(defvar cperl-hierarchy '(() ()) - "Global hierarchy of classes") - -(defun cperl-tags-hier-fill () - ;; Suppose we are in a tag table cooked by cperl. - (goto-char 1) - (let (type pack name pos line chunk ord cons1 file str info fileind) - (while (re-search-forward cperl-tags-hier-regexp-list nil t) - (setq pos (match-beginning 0) - pack (match-beginning 2)) - (beginning-of-line) - (if (looking-at (concat - "\\([^\n]+\\)" - "\C-?" - "\\([^\n]+\\)" - "\C-a" - "\\([0-9]+\\)" - "," - "\\([0-9]+\\)")) - (progn - (setq ;;str (buffer-substring (match-beginning 1) (match-end 1)) - name (buffer-substring (match-beginning 2) (match-end 2)) - ;;pos (buffer-substring (match-beginning 3) (match-end 3)) - line (buffer-substring (match-beginning 4) (match-end 4)) - ord (if pack 1 0) - info (etags-snarf-tag) ; Moves to beginning of the next line - file (file-of-tag) - fileind (format "%s:%s" file line)) - ;; Move back - (forward-char -1) - ;; Make new member of hierarchy name ==> file ==> pos if needed - (if (setq cons1 (assoc name (nth ord cperl-hierarchy))) - ;; Name known - (setcdr cons1 (cons (cons fileind (vector file info)) - (cdr cons1))) - ;; First occurrence of the name, start alist - (setq cons1 (cons name (list (cons fileind (vector file info))))) - (if pack - (setcar (cdr cperl-hierarchy) - (cons cons1 (nth 1 cperl-hierarchy))) - (setcar cperl-hierarchy - (cons cons1 (car cperl-hierarchy))))))) - (end-of-line)))) - -(defun cperl-tags-hier-init (&optional update) - "Show hierarchical menu of classes and methods. -Finds info about classes by a scan of loaded TAGS files. -Supposes that the TAGS files contain fully qualified function names. -One may build such TAGS files from CPerl mode menu." - (interactive) - (require 'etags) - (require 'imenu) - (if (or update (null (nth 2 cperl-hierarchy))) - (let (pack name cons1 to l1 l2 l3 l4 - (remover (function (lambda (elt) ; (name (file1...) (file2..)) - (or (nthcdr 2 elt) - ;; Only in one file - (setcdr elt (cdr (nth 1 elt)))))))) - ;; (setq cperl-hierarchy '(() () ())) ; Would write into '() later! - (setq cperl-hierarchy (list l1 l2 l3)) - (or tags-table-list - (call-interactively 'visit-tags-table)) - (message "Updating list of classes...") - (mapcar - (function - (lambda (tagsfile) - (set-buffer (get-file-buffer tagsfile)) - (cperl-tags-hier-fill))) - tags-table-list) - (mapcar remover (car cperl-hierarchy)) - (mapcar remover (nth 1 cperl-hierarchy)) - (setq to (list nil (cons "Packages: " (nth 1 cperl-hierarchy)) - (cons "Methods: " (car cperl-hierarchy)))) - (cperl-tags-treeify to 1) - (setcar (nthcdr 2 cperl-hierarchy) - (cperl-menu-to-keymap (cons '("+++UPDATE+++" . -999) (cdr to)))) - (message "Updating list of classes: done, requesting display...") - ;;(cperl-imenu-addback (nth 2 cperl-hierarchy)) - )) - (or (nth 2 cperl-hierarchy) - (error "No items found")) - (setq update -;;; (imenu-choose-buffer-index "Packages: " (nth 2 cperl-hierarchy)) - (if window-system - (x-popup-menu t (nth 2 cperl-hierarchy)) - (require 'tmm) - (tmm-prompt (nth 2 cperl-hierarchy)))) - (if (and update (listp update)) - (progn (while (cdr update) (setq update (cdr update))) - (setq update (car update)))) ; Get the last from the list - (if (vectorp update) - (progn - (find-file (elt update 0)) - (etags-goto-tag-location (elt update 1)))) - (if (eq update -999) (cperl-tags-hier-init t))) - -(defun cperl-tags-treeify (to level) - ;; cadr of `to' is read-write. On start it is a cons - (let* ((regexp (concat "^\\(" (mapconcat - 'identity - (make-list level "[_a-zA-Z0-9]+") - "::") - "\\)\\(::\\)?")) - (packages (cdr (nth 1 to))) - (methods (cdr (nth 2 to))) - l1 head tail cons1 cons2 ord writeto packs recurse - root-packages root-functions ms many_ms same_name ps - (move-deeper - (function - (lambda (elt) - (cond ((and (string-match regexp (car elt)) - (or (eq ord 1) (match-end 2))) - (setq head (substring (car elt) 0 (match-end 1)) - tail (if (match-end 2) (substring (car elt) - (match-end 2))) - recurse t) - (if (setq cons1 (assoc head writeto)) nil - ;; Need to init new head - (setcdr writeto (cons (list head (list "Packages: ") - (list "Methods: ")) - (cdr writeto))) - (setq cons1 (nth 1 writeto))) - (setq cons2 (nth ord cons1)) ; Either packs or meths - (setcdr cons2 (cons elt (cdr cons2)))) - ((eq ord 2) - (setq root-functions (cons elt root-functions))) - (t - (setq root-packages (cons elt root-packages)))))))) - (setcdr to l1) ; Init to dynamic space - (setq writeto to) - (setq ord 1) - (mapcar move-deeper packages) - (setq ord 2) - (mapcar move-deeper methods) - (if recurse - (mapcar (function (lambda (elt) - (cperl-tags-treeify elt (1+ level)))) - (cdr to))) - ;;Now clean up leaders with one child only - (mapcar (function (lambda (elt) - (if (not (and (listp (cdr elt)) - (eq (length elt) 2))) nil - (setcar elt (car (nth 1 elt))) - (setcdr elt (cdr (nth 1 elt)))))) - (cdr to)) - ;; Sort the roots of subtrees - (if (default-value 'imenu-sort-function) - (setcdr to - (sort (cdr to) (default-value 'imenu-sort-function)))) - ;; Now add back functions removed from display - (mapcar (function (lambda (elt) - (setcdr to (cons elt (cdr to))))) - (if (default-value 'imenu-sort-function) - (nreverse - (sort root-functions (default-value 'imenu-sort-function))) - root-functions)) - ;; Now add back packages removed from display - (mapcar (function (lambda (elt) - (setcdr to (cons (cons (concat "package " (car elt)) - (cdr elt)) - (cdr to))))) - (if (default-value 'imenu-sort-function) - (nreverse - (sort root-packages (default-value 'imenu-sort-function))) - root-packages)) - )) - -;;;(x-popup-menu t -;;; '(keymap "Name1" -;;; ("Ret1" "aa") -;;; ("Head1" "ab" -;;; keymap "Name2" -;;; ("Tail1" "x") ("Tail2" "y")))) - -(defun cperl-list-fold (list name limit) - (let (list1 list2 elt1 (num 0)) - (if (<= (length list) limit) list - (setq list1 nil list2 nil) - (while list - (setq num (1+ num) - elt1 (car list) - list (cdr list)) - (if (<= num imenu-max-items) - (setq list2 (cons elt1 list2)) - (setq list1 (cons (cons name - (nreverse list2)) - list1) - list2 (list elt1) - num 1))) - (nreverse (cons (cons name - (nreverse list2)) - list1))))) - -(defun cperl-menu-to-keymap (menu &optional name) - (let (list) - (cons 'keymap - (mapcar - (function - (lambda (elt) - (cond ((listp (cdr elt)) - (setq list (cperl-list-fold - (cdr elt) (car elt) imenu-max-items)) - (cons nil - (cons (car elt) - (cperl-menu-to-keymap list)))) - (t - (list (cdr elt) (car elt) t))))) ; t is needed in 19.34 - (cperl-list-fold menu "Root" imenu-max-items))))) - - -(defvar cperl-bad-style-regexp - (mapconcat 'identity - '("[^-\n\t <>=+!.&|(*/'`\"#^][-=+<>!|&^]" ; char sign - "[-<>=+^&|]+[^- \t\n=+<>~]" ; sign+ char - ) - "\\|") - "Finds places such that insertion of a whitespace may help a lot.") - -(defvar cperl-not-bad-style-regexp - (mapconcat 'identity - '("[^-\t <>=+]\\(--\\|\\+\\+\\)" ; var-- var++ - "[a-zA-Z0-9_][|&][a-zA-Z0-9_$]" ; abc|def abc&def are often used. - "&[(a-zA-Z0-9_$]" ; &subroutine &(var->field) - "<\\$?\\sw+\\(\\.\\sw+\\)?>" ; - "-[a-zA-Z][ \t]+[_$\"'`]" ; -f file - "-[0-9]" ; -5 - "\\+\\+" ; ++var - "--" ; --var - ".->" ; a->b - "->" ; a SPACE ->b - "\\[-" ; a[-1] - "^=" ; =head - "||" - "&&" - "[CBIXSLFZ]<\\(\\sw\\|\\s \\|\\s_\\|[\n]\\)*>" ; C - "-[a-zA-Z_0-9]+[ \t]*=>" ; -option => value - ;; Unaddressed trouble spots: = -abc, f(56, -abc) --- specialcased below - ;;"[*/+-|&<.]+=" - ) - "\\|") - "If matches at the start of match found by `my-bad-c-style-regexp', -insertion of a whitespace will not help.") - -(defvar found-bad) - -(defun cperl-find-bad-style () - "Find places in the buffer where insertion of a whitespace may help. -Prompts user for insertion of spaces. -Currently it is tuned to C and Perl syntax." - (interactive) - (let (found-bad (p (point))) - (setq last-nonmenu-event 13) ; To disable popup - (beginning-of-buffer) - (map-y-or-n-p "Insert space here? " - (function (lambda (arg) (insert " "))) - 'cperl-next-bad-style - '("location" "locations" "insert a space into") - '((?\C-r (lambda (arg) - (let ((buffer-quit-function - 'exit-recursive-edit)) - (message "Exit with Esc Esc") - (recursive-edit) - t)) ; Consider acted upon - "edit, exit with Esc Esc") - (?e (lambda (arg) - (let ((buffer-quit-function - 'exit-recursive-edit)) - (message "Exit with Esc Esc") - (recursive-edit) - t)) ; Consider acted upon - "edit, exit with Esc Esc")) - t) - (if found-bad (goto-char found-bad) - (goto-char p) - (message "No appropriate place found")))) - -(defun cperl-next-bad-style () - (let (p (not-found t) (point (point)) found) - (while (and not-found - (re-search-forward cperl-bad-style-regexp nil 'to-end)) - (setq p (point)) - (goto-char (match-beginning 0)) - (if (or - (looking-at cperl-not-bad-style-regexp) - ;; Check for a < -b and friends - (and (eq (following-char) ?\-) - (save-excursion - (skip-chars-backward " \t\n") - (memq (preceding-char) '(?\= ?\> ?\< ?\, ?\(, ?\[, ?\{)))) - ;; Now check for syntax type - (save-match-data - (setq found (point)) - (beginning-of-defun) - (let ((pps (parse-partial-sexp (point) found))) - (or (nth 3 pps) (nth 4 pps) (nth 5 pps))))) - (goto-char (match-end 0)) - (goto-char (1- p)) - (setq not-found nil - found-bad found))) - (not not-found))) - - -;;; Getting help -(defvar cperl-have-help-regexp - ;;(concat "\\(" - (mapconcat - 'identity - '("[$@%*&][0-9a-zA-Z_:]+\\([ \t]*[[{]\\)?" ; Usual variable - "[$@]\\^[a-zA-Z]" ; Special variable - "[$@][^ \n\t]" ; Special variable - "-[a-zA-Z]" ; File test - "\\\\[a-zA-Z0]" ; Special chars - "^=[a-z][a-zA-Z0-9_]*" ; Pod sections - "[-!&*+,-./<=>?\\\\^|~]+" ; Operator - "[a-zA-Z_0-9:]+" ; symbol or number - "x=" - "#!" - ) - ;;"\\)\\|\\(" - "\\|" - ) - ;;"\\)" - ;;) - "Matches places in the buffer we can find help for.") - -(defvar cperl-message-on-help-error t) -(defvar cperl-help-from-hook nil) - -(defun cperl-word-at-point-hard () - ;; Does not save-excursion - ;; Get to the something meaningful - (or (eobp) (eolp) (forward-char 1)) - (re-search-backward "[-a-zA-Z0-9_:!&*+,-./<=>?\\\\^|~$%@]" - (save-excursion (beginning-of-line) (point)) - 'to-beg) - ;; (cond - ;; ((or (eobp) (looking-at "[][ \t\n{}();,]")) ; Not at a symbol - ;; (skip-chars-backward " \n\t\r({[]});,") - ;; (or (bobp) (backward-char 1)))) - ;; Try to backtrace - (cond - ((looking-at "[a-zA-Z0-9_:]") ; symbol - (skip-chars-backward "a-zA-Z0-9_:") - (cond - ((and (eq (preceding-char) ?^) ; $^I - (eq (char-after (- (point) 2)) ?\$)) - (forward-char -2)) - ((memq (preceding-char) (append "*$@%&\\" nil)) ; *glob - (forward-char -1)) - ((and (eq (preceding-char) ?\=) - (eq (current-column) 1)) - (forward-char -1))) ; =head1 - (if (and (eq (preceding-char) ?\<) - (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; - (forward-char -1))) - ((and (looking-at "=") (eq (preceding-char) ?x)) ; x= - (forward-char -1)) - ((and (looking-at "\\^") (eq (preceding-char) ?\$)) ; $^I - (forward-char -1)) - ((looking-at "[-!&*+,-./<=>?\\\\^|~]") - (skip-chars-backward "-!&*+,-./<=>?\\\\^|~") - (cond - ((and (eq (preceding-char) ?\$) - (not (eq (char-after (- (point) 2)) ?\$))) ; $- - (forward-char -1)) - ((and (eq (following-char) ?\>) - (string-match "[a-zA-Z0-9_]" (char-to-string (preceding-char))) - (save-excursion - (forward-sexp -1) - (and (eq (preceding-char) ?\<) - (looking-at "\\$?[a-zA-Z0-9_:]+>")))) ; - (search-backward "<")))) - ((and (eq (following-char) ?\$) - (eq (preceding-char) ?\<) - (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; <$fh> - (forward-char -1))) - (if (looking-at cperl-have-help-regexp) - (buffer-substring (match-beginning 0) (match-end 0)))) - -(defun cperl-get-help () - "Get one-line docs on the symbol at the point. -The data for these docs is a little bit obsolete and may be in fact longer -than a line. Your contribution to update/shorten it is appreciated." - (interactive) - (save-match-data ; May be called "inside" query-replace - (save-excursion - (let ((word (cperl-word-at-point-hard))) - (if word - (if (and cperl-help-from-hook ; Bail out if not in mainland - (not (string-match "^#!\\|\\\\\\|^=" word)) ; Show help even in comments/strings. - (or (memq (get-text-property (point) 'face) - '(font-lock-comment-face font-lock-string-face)) - (memq (get-text-property (point) 'syntax-type) - '(pod here-doc format)))) - nil - (cperl-describe-perl-symbol word)) - (if cperl-message-on-help-error - (message "Nothing found for %s..." - (buffer-substring (point) (min (+ 5 (point)) (point-max)))))))))) - -;;; Stolen from perl-descr.el by Johan Vromans: - -(defvar cperl-doc-buffer " *perl-doc*" - "Where the documentation can be found.") -(defvar cperl-last-help nil - "The last help message, for echo area refresh.") -(make-variable-buffer-local 'cperl-last-help) - -(defun cperl-describe-perl-symbol (val) - "Display the documentation of symbol at point, a Perl operator." - (let ((enable-recursive-minibuffers t) - args-file regexp) - (cond - ((string-match "^[&*][a-zA-Z_]" val) - (setq val (concat (substring val 0 1) "NAME"))) - ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*\\[" val) - (setq val (concat "@" (substring val 1 (match-end 1))))) - ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*{" val) - (setq val (concat "%" (substring val 1 (match-end 1))))) - ((and (string= val "x") (string-match "^x=" val)) - (setq val "x=")) - ((string-match "^\\$[\C-a-\C-z]" val) - (setq val (concat "$^" (char-to-string (+ ?A -1 (aref val 1)))))) - ((string-match "^CORE::" val) - (setq val "CORE::")) - ((string-match "^SUPER::" val) - (setq val "SUPER::")) - ((and (string= "<" val) (string-match "^<\\$?[a-zA-Z0-9_:]+>" val)) - (setq val ""))) - (setq regexp (concat "^" - "\\([^a-zA-Z0-9_:]+[ \t]+\\)?" - (regexp-quote val) - "\\([ \t([/]\\|$\\)")) - - ;; get the buffer with the documentation text - (cperl-switch-to-doc-buffer) - - ;; lookup in the doc - (goto-char (point-min)) - (let ((case-fold-search nil)) - (list - (if (re-search-forward regexp (point-max) t) - (save-excursion - (beginning-of-line 1) - (let ((lnstart (point))) - (end-of-line) - (setq cperl-last-help - (cperl-message "%s" (buffer-substring lnstart (point)))))) - (if cperl-message-on-help-error - (cperl-message "No definition for %s" val))))))) - -(defvar cperl-short-docs "Ignore my value" - ;; Perl4 version was written by Johan Vromans (jvromans@squirrel.nl) - "# based on '@(#)@ perl-descr.el 1.9 - describe-perl-symbol' [Perl 5] -! ... Logical negation. -... != ... Numeric inequality. -... !~ ... Search pattern, substitution, or translation (negated). -$! In numeric context: errno. In a string context: error string. -$\" The separator which joins elements of arrays interpolated in strings. -$# The output format for printed numbers. Initial value is %.20g. -$$ Process number of this script. Changes in the fork()ed child process. -$% The current page number of the currently selected output channel. - - The following variables are always local to the current block: - -$1 Match of the 1st set of parentheses in the last match (auto-local). -$2 Match of the 2nd set of parentheses in the last match (auto-local). -$3 Match of the 3rd set of parentheses in the last match (auto-local). -$4 Match of the 4th set of parentheses in the last match (auto-local). -$5 Match of the 5th set of parentheses in the last match (auto-local). -$6 Match of the 6th set of parentheses in the last match (auto-local). -$7 Match of the 7th set of parentheses in the last match (auto-local). -$8 Match of the 8th set of parentheses in the last match (auto-local). -$9 Match of the 9th set of parentheses in the last match (auto-local). -$& The string matched by the last pattern match (auto-local). -$' The string after what was matched by the last match (auto-local). -$` The string before what was matched by the last match (auto-local). - -$( The real gid of this process. -$) The effective gid of this process. -$* Deprecated: Set to 1 to do multiline matching within a string. -$+ The last bracket matched by the last search pattern. -$, The output field separator for the print operator. -$- The number of lines left on the page. -$. The current input line number of the last filehandle that was read. -$/ The input record separator, newline by default. -$0 Name of the file containing the perl script being executed. May be set. -$: String may be broken after these characters to fill ^-lines in a format. -$; Subscript separator for multi-dim array emulation. Default \"\\034\". -$< The real uid of this process. -$= The page length of the current output channel. Default is 60 lines. -$> The effective uid of this process. -$? The status returned by the last ``, pipe close or `system'. -$@ The perl error message from the last eval or do @var{EXPR} command. -$ARGV The name of the current file used with <> . -$[ Deprecated: The index of the first element/char in an array/string. -$\\ The output record separator for the print operator. -$] The perl version string as displayed with perl -v. -$^ The name of the current top-of-page format. -$^A The current value of the write() accumulator for format() lines. -$^D The value of the perl debug (-D) flags. -$^E Information about the last system error other than that provided by $!. -$^F The highest system file descriptor, ordinarily 2. -$^H The current set of syntax checks enabled by `use strict'. -$^I The value of the in-place edit extension (perl -i option). -$^L What formats output to perform a formfeed. Default is \f. -$^O The operating system name under which this copy of Perl was built. -$^P Internal debugging flag. -$^T The time the script was started. Used by -A/-M/-C file tests. -$^W True if warnings are requested (perl -w flag). -$^X The name under which perl was invoked (argv[0] in C-speech). -$_ The default input and pattern-searching space. -$| Auto-flush after write/print on the current output channel? Default 0. -$~ The name of the current report format. -... % ... Modulo division. -... %= ... Modulo division assignment. -%ENV Contains the current environment. -%INC List of files that have been require-d or do-ne. -%SIG Used to set signal handlers for various signals. -... & ... Bitwise and. -... && ... Logical and. -... &&= ... Logical and assignment. -... &= ... Bitwise and assignment. -... * ... Multiplication. -... ** ... Exponentiation. -*NAME Glob: all objects refered by NAME. *NAM1 = *NAM2 aliases NAM1 to NAM2. -&NAME(arg0, ...) Subroutine call. Arguments go to @_. -... + ... Addition. +EXPR Makes EXPR into scalar context. -++ Auto-increment (magical on strings). ++EXPR EXPR++ -... += ... Addition assignment. -, Comma operator. -... - ... Subtraction. --- Auto-decrement (NOT magical on strings). --EXPR EXPR-- -... -= ... Subtraction assignment. --A Access time in days since script started. --B File is a non-text (binary) file. --C Inode change time in days since script started. --M Age in days since script started. --O File is owned by real uid. --R File is readable by real uid. --S File is a socket . --T File is a text file. --W File is writable by real uid. --X File is executable by real uid. --b File is a block special file. --c File is a character special file. --d File is a directory. --e File exists . --f File is a plain file. --g File has setgid bit set. --k File has sticky bit set. --l File is a symbolic link. --o File is owned by effective uid. --p File is a named pipe (FIFO). --r File is readable by effective uid. --s File has non-zero size. --t Tests if filehandle (STDIN by default) is opened to a tty. --u File has setuid bit set. --w File is writable by effective uid. --x File is executable by effective uid. --z File has zero size. -. Concatenate strings. -.. Alternation, also range operator. -.= Concatenate assignment strings -... / ... Division. /PATTERN/ioxsmg Pattern match -... /= ... Division assignment. -/PATTERN/ioxsmg Pattern match. -... < ... Numeric less than. Glob. See , <> as well. - Reads line from filehandle NAME. NAME must be bareword/dollar-bareword. - Glob. (Unless pattern is bareword/dollar-bareword - see ) -<> Reads line from union of files in @ARGV (= command line) and STDIN. -... << ... Bitwise shift left. << start of HERE-DOCUMENT. -... <= ... Numeric less than or equal to. -... <=> ... Numeric compare. -... = ... Assignment. -... == ... Numeric equality. -... =~ ... Search pattern, substitution, or translation -... > ... Numeric greater than. -... >= ... Numeric greater than or equal to. -... >> ... Bitwise shift right. -... >>= ... Bitwise shift right assignment. -... ? ... : ... Condition=if-then-else operator. ?PAT? One-time pattern match. -?PATTERN? One-time pattern match. -@ARGV Command line arguments (not including the command name - see $0). -@INC List of places to look for perl scripts during do/include/use. -@_ Parameter array for subroutines. Also used by split unless in array context. -\\ Creates reference to what follows, like \$var, or quotes non-\w in strings. -\\0 Octal char, e.g. \\033. -\\E Case modification terminator. See \\Q, \\L, and \\U. -\\L Lowercase until \\E . See also \l, lc. -\\U Upcase until \\E . See also \u, uc. -\\Q Quote metacharacters until \\E . See also quotemeta. -\\a Alarm character (octal 007). -\\b Backspace character (octal 010). -\\c Control character, e.g. \\c[ . -\\e Escape character (octal 033). -\\f Formfeed character (octal 014). -\\l Lowercase the next character. See also \\L and \\u, lcfirst. -\\n Newline character (octal 012 on most systems). -\\r Return character (octal 015 on most systems). -\\t Tab character (octal 011). -\\u Upcase the next character. See also \\U and \\l, ucfirst. -\\x Hex character, e.g. \\x1b. -... ^ ... Bitwise exclusive or. -__END__ Ends program source. -__DATA__ Ends program source. -__FILE__ Current (source) filename. -__LINE__ Current line in current source. -__PACKAGE__ Current package. -ARGV Default multi-file input filehandle. is a synonym for <>. -ARGVOUT Output filehandle with -i flag. -BEGIN { ... } Immediately executed (during compilation) piece of code. -END { ... } Pseudo-subroutine executed after the script finishes. -DATA Input filehandle for what follows after __END__ or __DATA__. -accept(NEWSOCKET,GENERICSOCKET) -alarm(SECONDS) -atan2(X,Y) -bind(SOCKET,NAME) -binmode(FILEHANDLE) -caller[(LEVEL)] -chdir(EXPR) -chmod(LIST) -chop[(LIST|VAR)] -chown(LIST) -chroot(FILENAME) -close(FILEHANDLE) -closedir(DIRHANDLE) -... cmp ... String compare. -connect(SOCKET,NAME) -continue of { block } continue { block }. Is executed after `next' or at end. -cos(EXPR) -crypt(PLAINTEXT,SALT) -dbmclose(%HASH) -dbmopen(%HASH,DBNAME,MODE) -defined(EXPR) -delete($HASH{KEY}) -die(LIST) -do { ... }|SUBR while|until EXPR executes at least once -do(EXPR|SUBR([LIST])) (with while|until executes at least once) -dump LABEL -each(%HASH) -endgrent -endhostent -endnetent -endprotoent -endpwent -endservent -eof[([FILEHANDLE])] -... eq ... String equality. -eval(EXPR) or eval { BLOCK } -exec(LIST) -exit(EXPR) -exp(EXPR) -fcntl(FILEHANDLE,FUNCTION,SCALAR) -fileno(FILEHANDLE) -flock(FILEHANDLE,OPERATION) -for (EXPR;EXPR;EXPR) { ... } -foreach [VAR] (@ARRAY) { ... } -fork -... ge ... String greater than or equal. -getc[(FILEHANDLE)] -getgrent -getgrgid(GID) -getgrnam(NAME) -gethostbyaddr(ADDR,ADDRTYPE) -gethostbyname(NAME) -gethostent -getlogin -getnetbyaddr(ADDR,ADDRTYPE) -getnetbyname(NAME) -getnetent -getpeername(SOCKET) -getpgrp(PID) -getppid -getpriority(WHICH,WHO) -getprotobyname(NAME) -getprotobynumber(NUMBER) -getprotoent -getpwent -getpwnam(NAME) -getpwuid(UID) -getservbyname(NAME,PROTO) -getservbyport(PORT,PROTO) -getservent -getsockname(SOCKET) -getsockopt(SOCKET,LEVEL,OPTNAME) -gmtime(EXPR) -goto LABEL -grep(EXPR,LIST) -... gt ... String greater than. -hex(EXPR) -if (EXPR) { ... } [ elsif (EXPR) { ... } ... ] [ else { ... } ] or EXPR if EXPR -index(STR,SUBSTR[,OFFSET]) -int(EXPR) -ioctl(FILEHANDLE,FUNCTION,SCALAR) -join(EXPR,LIST) -keys(%HASH) -kill(LIST) -last [LABEL] -... le ... String less than or equal. -length(EXPR) -link(OLDFILE,NEWFILE) -listen(SOCKET,QUEUESIZE) -local(LIST) -localtime(EXPR) -log(EXPR) -lstat(EXPR|FILEHANDLE|VAR) -... lt ... String less than. -m/PATTERN/iogsmx -mkdir(FILENAME,MODE) -msgctl(ID,CMD,ARG) -msgget(KEY,FLAGS) -msgrcv(ID,VAR,SIZE,TYPE.FLAGS) -msgsnd(ID,MSG,FLAGS) -my VAR or my (VAR1,...) Introduces a lexical variable ($VAR, @ARR, or %HASH). -... ne ... String inequality. -next [LABEL] -oct(EXPR) -open(FILEHANDLE[,EXPR]) -opendir(DIRHANDLE,EXPR) -ord(EXPR) ASCII value of the first char of the string. -pack(TEMPLATE,LIST) -package NAME Introduces package context. -pipe(READHANDLE,WRITEHANDLE) Create a pair of filehandles on ends of a pipe. -pop(ARRAY) -print [FILEHANDLE] [(LIST)] -printf [FILEHANDLE] (FORMAT,LIST) -push(ARRAY,LIST) -q/STRING/ Synonym for 'STRING' -qq/STRING/ Synonym for \"STRING\" -qx/STRING/ Synonym for `STRING` -rand[(EXPR)] -read(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) -readdir(DIRHANDLE) -readlink(EXPR) -recv(SOCKET,SCALAR,LEN,FLAGS) -redo [LABEL] -rename(OLDNAME,NEWNAME) -require [FILENAME | PERL_VERSION] -reset[(EXPR)] -return(LIST) -reverse(LIST) -rewinddir(DIRHANDLE) -rindex(STR,SUBSTR[,OFFSET]) -rmdir(FILENAME) -s/PATTERN/REPLACEMENT/gieoxsm -scalar(EXPR) -seek(FILEHANDLE,POSITION,WHENCE) -seekdir(DIRHANDLE,POS) -select(FILEHANDLE | RBITS,WBITS,EBITS,TIMEOUT) -semctl(ID,SEMNUM,CMD,ARG) -semget(KEY,NSEMS,SIZE,FLAGS) -semop(KEY,...) -send(SOCKET,MSG,FLAGS[,TO]) -setgrent -sethostent(STAYOPEN) -setnetent(STAYOPEN) -setpgrp(PID,PGRP) -setpriority(WHICH,WHO,PRIORITY) -setprotoent(STAYOPEN) -setpwent -setservent(STAYOPEN) -setsockopt(SOCKET,LEVEL,OPTNAME,OPTVAL) -shift[(ARRAY)] -shmctl(ID,CMD,ARG) -shmget(KEY,SIZE,FLAGS) -shmread(ID,VAR,POS,SIZE) -shmwrite(ID,STRING,POS,SIZE) -shutdown(SOCKET,HOW) -sin(EXPR) -sleep[(EXPR)] -socket(SOCKET,DOMAIN,TYPE,PROTOCOL) -socketpair(SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL) -sort [SUBROUTINE] (LIST) -splice(ARRAY,OFFSET[,LENGTH[,LIST]]) -split[(/PATTERN/[,EXPR[,LIMIT]])] -sprintf(FORMAT,LIST) -sqrt(EXPR) -srand(EXPR) -stat(EXPR|FILEHANDLE|VAR) -study[(SCALAR)] -sub [NAME [(format)]] { BODY } sub NAME [(format)]; sub [(format)] {...} -substr(EXPR,OFFSET[,LEN]) -symlink(OLDFILE,NEWFILE) -syscall(LIST) -sysread(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) -system(LIST) -syswrite(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) -tell[(FILEHANDLE)] -telldir(DIRHANDLE) -time -times -tr/SEARCHLIST/REPLACEMENTLIST/cds -truncate(FILE|EXPR,LENGTH) -umask[(EXPR)] -undef[(EXPR)] -unless (EXPR) { ... } [ else { ... } ] or EXPR unless EXPR -unlink(LIST) -unpack(TEMPLATE,EXPR) -unshift(ARRAY,LIST) -until (EXPR) { ... } EXPR until EXPR -utime(LIST) -values(%HASH) -vec(EXPR,OFFSET,BITS) -wait -waitpid(PID,FLAGS) -wantarray Returns true if the sub/eval is called in list context. -warn(LIST) -while (EXPR) { ... } EXPR while EXPR -write[(EXPR|FILEHANDLE)] -... x ... Repeat string or array. -x= ... Repetition assignment. -y/SEARCHLIST/REPLACEMENTLIST/ -... | ... Bitwise or. -... || ... Logical or. -~ ... Unary bitwise complement. -#! OS interpreter indicator. If contains `perl', used for options, and -x. -AUTOLOAD {...} Shorthand for `sub AUTOLOAD {...}'. -CORE:: Prefix to access builtin function if imported sub obscures it. -SUPER:: Prefix to lookup for a method in @ISA classes. -DESTROY Shorthand for `sub DESTROY {...}'. -... EQ ... Obsolete synonym of `eq'. -... GE ... Obsolete synonym of `ge'. -... GT ... Obsolete synonym of `gt'. -... LE ... Obsolete synonym of `le'. -... LT ... Obsolete synonym of `lt'. -... NE ... Obsolete synonym of `ne'. -abs [ EXPR ] absolute value -... and ... Low-precedence synonym for &&. -bless REFERENCE [, PACKAGE] Makes reference into an object of a package. -chomp [LIST] Strips $/ off LIST/$_. Returns count. Special if $/ eq ''! -chr Converts a number to char with the same ordinal. -else Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}. -elsif Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}. -exists $HASH{KEY} True if the key exists. -format [NAME] = Start of output format. Ended by a single dot (.) on a line. -formline PICTURE, LIST Backdoor into \"format\" processing. -glob EXPR Synonym of . -lc [ EXPR ] Returns lowercased EXPR. -lcfirst [ EXPR ] Returns EXPR with lower-cased first letter. -map EXPR, LIST or map {BLOCK} LIST Applies EXPR/BLOCK to elts of LIST. -no PACKAGE [SYMBOL1, ...] Partial reverse for `use'. Runs `unimport' method. -not ... Low-precedence synonym for ! - negation. -... or ... Low-precedence synonym for ||. -pos STRING Set/Get end-position of the last match over this string, see \\G. -quotemeta [ EXPR ] Quote regexp metacharacters. -qw/WORD1 .../ Synonym of split('', 'WORD1 ...') -readline FH Synonym of . -readpipe CMD Synonym of `CMD`. -ref [ EXPR ] Type of EXPR when dereferenced. -sysopen FH, FILENAME, MODE [, PERM] (MODE is numeric, see Fcntl.) -tie VAR, PACKAGE, LIST Hide an object behind a simple Perl variable. -tied Returns internal object for a tied data. -uc [ EXPR ] Returns upcased EXPR. -ucfirst [ EXPR ] Returns EXPR with upcased first letter. -untie VAR Unlink an object from a simple Perl variable. -use PACKAGE [SYMBOL1, ...] Compile-time `require' with consequent `import'. -... xor ... Low-precedence synonym for exclusive or. -prototype \&SUB Returns prototype of the function given a reference. -=head1 Top-level heading. -=head2 Second-level heading. -=head3 Third-level heading (is there such?). -=over [ NUMBER ] Start list. -=item [ TITLE ] Start new item in the list. -=back End list. -=cut Switch from POD to Perl. -=pod Switch from Perl to POD. -") - -(defun cperl-switch-to-doc-buffer () - "Go to the perl documentation buffer and insert the documentation." - (interactive) - (let ((buf (get-buffer-create cperl-doc-buffer))) - (if (interactive-p) - (switch-to-buffer-other-window buf) - (set-buffer buf)) - (if (= (buffer-size) 0) - (progn - (insert (documentation-property 'cperl-short-docs - 'variable-documentation)) - (setq buffer-read-only t))))) - -(defun cperl-beautify-regexp-piece (b e embed) - ;; b is before the starting delimiter, e before the ending - ;; e should be a marker, may be changed, but remains "correct". - (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline) - (if (not embed) - (goto-char (1+ b)) - (goto-char b) - (cond ((looking-at "(\\?\\\\#") ; badly commented (?#) - (forward-char 2) - (delete-char 1) - (forward-char 1)) - ((looking-at "(\\?[^a-zA-Z]") - (forward-char 3)) - ((looking-at "(\\?") ; (?i) - (forward-char 2)) - (t - (forward-char 1)))) - (setq c (1- (current-column)) - c1 (+ c (or cperl-regexp-indent-step cperl-indent-level))) - (or (looking-at "[ \t]*[\n#]") - (progn - (insert "\n"))) - (goto-char e) - (beginning-of-line) - (if (re-search-forward "[^ \t]" e t) - (progn - (goto-char e) - (insert "\n") - (indent-to-column c) - (set-marker e (point)))) - (goto-char b) - (end-of-line 2) - (while (< (point) (marker-position e)) - (beginning-of-line) - (setq s (point) - inline t) - (skip-chars-forward " \t") - (delete-region s (point)) - (indent-to-column c1) - (while (and - inline - (looking-at - (concat "\\([a-zA-Z0-9]+[^*+{?]\\)" ; 1 - "\\|" - "\\$\\([a-zA-Z0-9_]+\\([[{]\\)?\\|[^\n \t)|]\\)" ; 2 3 - "\\|" - "[$^]" - "\\|" - "\\(\\\\.\\|[^][()#|*+?\n]\\)\\([*+{?]\\??\\)?" ; 4 5 - "\\|" - "\\(\\[\\)" ; 6 - "\\|" - "\\((\\(\\?\\)?\\)" ; 7 8 - "\\|" - "\\(|\\)" ; 9 - ))) - (goto-char (match-end 0)) - (setq spaces t) - (cond ((match-beginning 1) ; Alphanum word + junk - (forward-char -1)) - ((or (match-beginning 3) ; $ab[12] - (and (match-beginning 5) ; X* X+ X{2,3} - (eq (preceding-char) ?\{))) - (forward-char -1) - (forward-sexp 1)) - ((match-beginning 6) ; [] - (setq tmp (point)) - (if (looking-at "\\^?\\]") - (goto-char (match-end 0))) - (or (re-search-forward "\\]\\([*+{?]\\)?" e t) - (progn - (goto-char (1- tmp)) - (error "[]-group not terminated"))) - (if (not (eq (preceding-char) ?\{)) nil - (forward-char -1) - (forward-sexp 1))) - ((match-beginning 7) ; () - (goto-char (match-beginning 0)) - (or (eq (current-column) c1) - (progn - (insert "\n") - (indent-to-column c1))) - (setq tmp (point)) - (forward-sexp 1) - ;; (or (forward-sexp 1) - ;; (progn - ;; (goto-char tmp) - ;; (error "()-group not terminated"))) - (set-marker m (1- (point))) - (set-marker m1 (point)) - (cperl-beautify-regexp-piece tmp m t) - (goto-char m1) - (cond ((looking-at "[*+?]\\??") - (goto-char (match-end 0))) - ((eq (following-char) ?\{) - (forward-sexp 1) - (if (eq (following-char) ?\?) - (forward-char)))) - (skip-chars-forward " \t") - (setq spaces nil) - (if (looking-at "[#\n]") - (beginning-of-line 2) - (insert "\n")) - (end-of-line) - (setq inline nil)) - ((match-beginning 9) ; | - (forward-char -1) - (setq tmp (point)) - (beginning-of-line) - (if (re-search-forward "[^ \t]" tmp t) - (progn - (goto-char tmp) - (insert "\n")) - ;; first at line - (delete-region (point) tmp)) - (indent-to-column c) - (forward-char 1) - (skip-chars-forward " \t") - (setq spaces nil) - (if (looking-at "[#\n]") - (beginning-of-line 2) - (insert "\n")) - (end-of-line) - (setq inline nil))) - (or (looking-at "[ \t\n]") - (not spaces) - (insert " ")) - (skip-chars-forward " \t")) - (or (looking-at "[#\n]") - (error "unknown code in a regexp")) - (and inline (end-of-line 2))) - )) - -(defun cperl-beautify-regexp () - "do it. (Experimental, may change semantics, recheck afterwards.) -We suppose that the regexp is scanned already." - (interactive) - (or cperl-use-syntax-table-text-property - (error "I need to have regex marked!")) - ;; Find the start - (re-search-backward "\\s|") ; Assume it is scanned already. - ;;(forward-char 1) - (let ((b (point)) (e (make-marker)) have-x delim (c (current-column)) - (sub-p (eq (preceding-char) ?s)) s) - (forward-sexp 1) - (set-marker e (1- (point))) - (setq delim (preceding-char)) - (if (and sub-p (eq delim (char-after (- (point) 2)))) - (error "Possible s/blah// - do not know how to deal with")) - (if sub-p (forward-sexp 1)) - (if (looking-at "\\sw*x") - (setq have-x t) - (insert "x")) - ;; Protect fragile " ", "#" - (if have-x nil - (goto-char (1+ b)) - (while (re-search-forward "\\(\\=\\|[^\\\\]\\)\\(\\\\\\\\\\)*[ \t\n#]" e t) ; Need to include (?#) too? - (forward-char -1) - (insert "\\") - (forward-char 1))) - (cperl-beautify-regexp-piece b e nil))) - - -;; Part from the original `cperl-lazy-*', and part from `eldoc' -;; Karl M. Hegbloom - -(defun cperl-help (&optional arg) - (interactive "p") - (cond ((and arg (<= arg 0)) - (remove-hook 'post-command-hook 'cperl-get-help-defer) - (remove-hook 'pre-command-hook 'cperl-refresh-echo-area) - (setq cperl-help nil)) - (t - (add-hook 'post-command-hook 'cperl-get-help-defer) - (add-hook 'pre-command-hook 'cperl-refresh-echo-area) - (setq cperl-help t)))) - -(defun cperl-toggle-help () - (interactive) - (if cperl-help - (cperl-help 0) - (cperl-help 1))) - -(defun cperl-get-help-defer () - (if (not (eq major-mode 'perl-mode)) nil - (let ((cperl-message-on-help-error nil) (cperl-help-from-hook t)) - (cperl-get-help)))) - -;; from `eldoc-refresh-*' -(defun cperl-refresh-echo-area () - (and cperl-last-help - (if (and cperl-mode - (not executing-kbd-macro) - (not cursor-in-echo-area) - (not (eq (selected-window) (minibuffer-window)))) - (cperl-message cperl-last-help) - (setq cperl-last-help nil)))) - -;; see `eldoc-message' -(defun cperl-message (&rest args) - (let ((omessage cperl-last-help)) - (cond ((eq (car args) cperl-last-help)) - ((or (null args) - (null (car args))) - (setq cperl-last-help nil)) - (t - (setq cperl-last-help (apply 'format args)))) - ;; Do not put cperl-help messages in the log - (if cperl-last-help - (display-message 'no-log cperl-last-help) - (and omessage - (clear-message 'no-log)))) - cperl-last-help) - -(when cperl-help - (cperl-help 1)) - -(provide 'cperl-mode) diff -r 43306a74e31c -r d44af0c54775 lisp/modes/custom-load.el --- a/lisp/modes/custom-load.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,44 +0,0 @@ -;;; custom-load.el --- automatically extracted custom dependencies - - -;;; Code: - -(custom-add-loads 'message '("sendmail")) -(custom-add-loads 'prolog '("prolog")) -(custom-add-loads 'mouse '("outl-mouse")) -(custom-add-loads 'mail-abbrevs '("mail-abbrevs")) -(custom-add-loads 'pascal '("pascal")) -(custom-add-loads 'tex '("reftex" "texinfo")) -(custom-add-loads 'icon '("icon")) -(custom-add-loads 'texinfo '("texinfo")) -(custom-add-loads 'mail '("mail-abbrevs")) -(custom-add-loads 'docs '("texinfo")) -(custom-add-loads 'lisp-indent '("cl-indent")) -(custom-add-loads 'tools '("hideshow" "lazy-shot" "make-mode")) -(custom-add-loads 'lisp '("cl-indent")) -(custom-add-loads 'reftex '("reftex")) -(custom-add-loads 'outlines '("hideshow" "outl-mouse")) -(custom-add-loads 'perl '("cperl-mode")) -(custom-add-loads 'reftex-label-support '("reftex")) -(custom-add-loads 'outl-mouse '("outl-mouse")) -(custom-add-loads 'frames '("rsz-minibuf")) -(custom-add-loads 'cperl-electric '("cperl-mode")) -(custom-add-loads 'lazy-shot '("lazy-shot")) -(custom-add-loads 'scribe '("scribe")) -(custom-add-loads 'c-macro '("cmacexp")) -(custom-add-loads 'cperl-faces '("cperl-mode")) -(custom-add-loads 'resize-minibuffer '("rsz-minibuf")) -(custom-add-loads 'languages '("cperl-mode" "icon" "pascal" "prolog" "rexx-mode" "vhdl-mode")) -(custom-add-loads 'cperl-indent '("cperl-mode")) -(custom-add-loads 'faces '("cperl-mode" "lazy-shot")) -(custom-add-loads 'hideshow '("hideshow")) -(custom-add-loads 'vhdl '("vhdl-mode")) -(custom-add-loads 'enriched '("enriched")) -(custom-add-loads 'processes '("executable")) -(custom-add-loads 'rexx '("rexx-mode")) -(custom-add-loads 'executable '("executable")) -(custom-add-loads 'wp '("enriched" "scribe" "texinfo")) -(custom-add-loads 'makefile-mode '("make-mode")) -(custom-add-loads 'c '("cmacexp")) - -;;; custom-load.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/eiffel3.el --- a/lisp/modes/eiffel3.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2260 +0,0 @@ -;;; $Id: eiffel3.el,v 1.2 1997/05/29 23:49:51 steve Exp $ -;;;-------------------------------------------------------------------------- -;;; TowerEiffel -- Copyright (c) 1993-1996 Tower Technology Corporation. -;;; All Rights Reserved. -;;; -;;; Use, duplication, or disclosure is subject to restrictions as set forth -;;; in subdivision (c)(1)(ii) of the Rights in Technical Data and Computer -;;; Software clause at DFARS 252.227-7013. -;;; -;;; This file is made available for use and distribution under the same terms -;;; as GNU Emacs. Such availability of this elisp file should not be construed -;;; as granting such availability to the rest of TowerEiffel. -;;;-------------------------------------------------------------------------- -;;; Portions of the file, as indicated below, were derived from "eiffel.el" -;;; (developed by Stephen Omohundro, ISE and Bob Weiner) and "eif-mult-fmt.el" -;;; (developed by Bob Weiner): -;;; eiffel.el and eif-mult-fmt.el are Copyright (C) 1989, 1990 -;;; Free Software Foundation, Inc. and Bob Weiner -;;; Available for use and distribution under the same terms as GNU Emacs. - -;;; Synched up with: Not in FSF. - -;;;-------------------------------------------------------------------------- -;;; Adapted the file for the XEmacs 19.12 distribution. -- jasa (1995/03/11) -;;;-------------------------------------------------------------------------- -;;; -;;; EIFFEL3 : GNU Emacs mode for Eiffel Version 3 -;;; -;;; INSTALLATION -;;; To install, simply copy this file into a directory in your -;;; load-path and add the following two commands in your .emacs file: -;;; -;;; (setq auto-mode-alist (cons '("\\.e$" . eiffel-mode) -;;; auto-mode-alist)) -;;; (autoload 'eiffel-mode "eiffel3" "Mode for Eiffel programs" t) -;;; -;;; TowerEiffel users should do the following instead: See the file -;;; dot-emacs that comes with the TowerEiffel distribution for a sample -;;; ".emacs" file. If all Tower elisp files are already in your -;;; load-path, then simply add the following line to your .emacs file: -;;; -;;; (load "tinstall") -;;; -;;; TOWER EIFFEL -;;; TowerEiffel provides additional Emacs support for Eiffel -;;; programming that integrates Emacs with Tower's Eiffel compiler, -;;; documentation, and browsing tools. For more information on -;;; these tools and their Emacs interface contact: -;;; -;;; Tower Technology Corporation -;;; 1501 Koenig Dr. -;;; Austin TX, 78756 -;;; -;;; tower@twr.com (to reach a human being) -;;; info@twr.com (automated file server) -;;; (512)452-1721 (FAX) -;;; (512)452-9455 (phone) -;;; -;;; SUPPORT -;;; Please send bug reports, fixes or enhancements to: -;;; elisp@atlanta.twr.com -;;; -;;; COMPATIBILITY: -;;; This file has been tested with XEmacs 19.11. Syntax highlighting is -;;; primarily supported with font-lock.el. -;;; -;;; COMMANDS -;;; eif-backward-sexp -;;; eif-feature-quote -;;; eif-forward-sexp -;;; eif-goto-matching-line -;;; eif-indent-region -;;; eif-indent-construct -;;; eif-indent-line -;;; eif-newline -;;; eiffel-mode -;;; -;;; PUBLIC VARIABLES -;;; eif-body-comment-indent -;;; eif-check-keyword-indent -;;; eif-class-level-comment-indent -;;; eif-class-level-kw-indent -;;; eif-extra-body-comment-indent -;;; eif-extra-check-keyword-indent -;;; eif-extra-class-level-comment-indent -;;; eif-extra-class-level-kw-indent -;;; eif-extra-feature-level-comment-indent -;;; eif-extra-feature-level-indent -;;; eif-extra-feature-level-kw-indent -;;; eif-extra-inherit-level-kw-indent -;;; eif-extra-then-indent -;;; eif-feature-level-comment-indent -;;; eif-feature-level-indent -;;; eif-feature-level-kw-indent -;;; eif-indent-increment -;;; eif-inherit-level-kw-indent -;;; eif-rescue-keyword-indent -;;; eif-then-indent -;;; eiffel-mode-abbrev-table -;;; eiffel-mode-hook -;;; eiffel-mode-map -;;; eiffel-mode-syntax-table -;;; -;;; PUBLIC FUNCTIONS -;;; None. -;;; -;;; HISTORY -;;; Fred Hart - Jul 31, 1992: Created. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Indentation Amount Variables. ;;; -;;; ;;; -;;; The default values correspond to style used in ``Eiffel: The ;;; -;;; Language''. Note: for TowerEiffel users the values below ;;; -;;; will be superceded by the values in either tcustom.el or ;;; -;;; ~/.tcustom.el if it is present. ;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar eif-indent-increment 3 - "Default indentation interval (in spaces)") - -(defvar eif-class-level-kw-indent 0 - "Indentation amount for Class level keywords (in number of -eif-indent-increments) (see eif-class-level-keywords variable).") -(defvar eif-extra-class-level-kw-indent 0 - "Number of SPACES to add to eif-class-level-kw-indent to get the -actual indentation of a class level keyword. Can be negative.") - -(defvar eif-class-level-comment-indent 0 - "Indentation of comments at the beginning of the class (in number of -eif-indent-increments)") -(defvar eif-extra-class-level-comment-indent 0 - "Number of SPACES to add to eif-class-level-comment-indent to get the -actual indentation of a class level comment. Can be negative.") - -(defvar eif-inherit-level-kw-indent 2 - "Indentation of keywords falling under the Inherit clause (in number of -eif-indent-increments) (see eif-inherit-level-keywords variable.") -(defvar eif-extra-inherit-level-kw-indent 0 - "Number of SPACES to add to eif-inherit-level-kw-indent to get the -actual indentation of an inherit level keyword. Can be negative.") - -(defvar eif-feature-level-indent 1 - "Indentation amount of features. (in number of eif-indent-increments)") -(defvar eif-extra-feature-level-indent 0 - "Number of SPACES to add to eif-feature-level-indent to get the -actual indentation of a feature. Can be negative.") - -(defvar eif-feature-level-kw-indent 2 - "Indentation of keywords belonging to individual features. (in number of -eif-indent-increments) (see eif-feature-level-keywords variable)") -(defvar eif-extra-feature-level-kw-indent 0 - "Number of SPACES to add to eif-feature-level-kw-indent to get the -actual indentation of a feature level keyword. Can be negative.") - -(defvar eif-feature-level-comment-indent 3 - "Indentation of comments at the beginning of a feature. (in number of -eif-indent-increments)") -(defvar eif-extra-feature-level-comment-indent 0 - "Number of SPACES to add to eif-feature-level-comment-indent to get the -actual indentation of a feature level comment. Can be negative.") - -(defvar eif-body-comment-indent 0 - "Indentation of comments in the body of a routine. (in number of -eif-indent-increments)") -(defvar eif-extra-body-comment-indent 0 - "Number of SPACES to add to eif-body-comment-indent to get the -actual indentation of a routine body comment. Can be negative.") - -(defvar eif-check-keyword-indent 0 - "Extra indentation for the check clause as described in ETL. (in number of -eif-indent-increments). Default is 0, which is different than in ETL's 1.") -(defvar eif-extra-check-keyword-indent 0 - "Number of SPACES to add to eif-check-keyword-indent to get the -actual indentation of a check keyword. Can be negative.") - -(defvar eif-rescue-keyword-indent -1 - "Extra indentation for the rescue clause as described in ETL. (in number of -eif-indent-increments). Default is -1.") -(defvar eif-extra-rescue-keyword-indent 0 - "Number of SPACES to add to eif-rescue-keyword-indent to get the -actual indentation of a rescue keyword. Can be negative.") - -(defvar eif-then-indent 0 - "Indentation for a `then' appearing on a line by itself rather -than on the same line as an `if'. (in number of eif-indent-increments)") -(defvar eif-extra-then-indent 1 - "Number of SPACES to add to eif-then-indent to get the -actual indentation of a `then' appearing on a line by itself. Can be -negative.") - -(defvar eif-continuation-indent 1 - "Extra indentation for a continued statement line. (in number of eif-indent-increments)") -(defvar eif-extra-continuation-indent 0 - "Number of SPACES to add to eif-continuation-indent to get the -actual indentation of a continued statement line. Can be -negative.") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; font-lock, lhilit, and hilit19 support ;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; The value for a font variable must either be a string -;; specifying a valid font, the symbol 'default meaning the -;; default font, or the symbol 'context meaning the font of the -;; surrounding text. -;; -;; Simlarly, the value for a color variable must either be a string -;; specifying a valid color, the symbol 'default meaning the -;; default foreground color, or the symbol 'context meaning the -;; foregound color of the surrounding text. - -(if (or (featurep 'font-lock) (featurep 'lhilit) (featurep 'hilit19)) (progn - -(cond ((eq window-system 'pm) - (defvar eif-comment-font 'default - "The font in which to display comments in Eiffel and Ace files (either a font name string or 'default or 'context)") - (defvar eif-comment-color "firebrick" - "Color of comments in Eiffel and Ace files (either a color name string or 'default or 'context)") - - (defvar eif-hidden-comment-font 'default - "The font in which to display hidden comments in Eiffel and Ace files (either a font name string or 'default or 'context)") - (defvar eif-hidden-comment-color "os2darkgreen" - "Color of hidden comments in Eiffel and Ace files (either a color name string or 'default or 'context)") - - (defvar eif-major-keyword-font 'default - "The font in which to display major keywords in Eiffel and Ace files (either a font name string or 'default or 'context)") - (defvar eif-major-keyword-color 'default - "Color of major keywords in Eiffel and Ace files (either a color name string or 'default or 'context)") - - (defvar eif-assertion-keyword-font 'default - "The font in which to display assertion keywords in Eiffel and Ace files (either a font name string or 'default or 'context)") - (defvar eif-assertion-keyword-color "os2darkblue" - "Color of assertion keywords in Eiffel and Ace files (either a color name string or 'default or 'context)") - - (defvar eif-minor-keyword-font 'default - "The font in which to display minor keywords in Eiffel and Ace files (either a font name string or 'default or 'context)") - (defvar eif-minor-keyword-color 'default - "Color of minor-keywords in Eiffel and Ace files (either a color name string or 'default or 'context)") - - (defvar eif-string-font 'default - "The font in which to display literal strings in Eiffel and Ace files (either a font name string or 'default or 'context)") - (defvar eif-string-color "os2darkcyan" - "Color of literal strings in Eiffel and Ace files (either a color name string or 'default or 'context)") - - (defvar eif-quoted-feature-font 'default - "The font in which to display features names enclosed in `'s in Eiffel and Ace file comments (either a font name string or 'default or 'context)") - (defvar eif-quoted-feature-color 'context - "Color of features names enclosed in `'s in Eiffel and Ace file comments (either a color name string or 'default or 'context)") - ) - - ((eq window-system 'ns) - (defvar eif-comment-font 'default - "The font in which to display comments in Eiffel and Ace files (either a font name string or 'default or 'context)") - (defvar eif-comment-color "red3" - "Color of comments in Eiffel and Ace files (either a color name string or 'default or 'context)") - - (defvar eif-hidden-comment-font 'default - "The font in which to display hidden comments in Eiffel and Ace files (either a font name string or 'default or 'context)") - (defvar eif-hidden-comment-color "ForestGreen" - "Color of hidden comments in Eiffel and Ace files (either a color name string or 'default or 'context)") - - (defvar eif-major-keyword-font "Courier-Bold" - "The font in which to display major keywords in Eiffel and Ace files (either a font name string or 'default or 'context)") - (defvar eif-major-keyword-color 'default - "Color of major keywords in Eiffel and Ace files (either a color name string or 'default or 'context)") - - (defvar eif-assertion-keyword-font "Courier-Bold" - "The font in which to display assertion keywords in Eiffel and Ace files (either a font name string or 'default or 'context)") - (defvar eif-assertion-keyword-color "slate blue" - "Color of assertion keywords in Eiffel and Ace files (either a color name string or 'default or 'context)") - - (defvar eif-minor-keyword-font "Courier-Bold" - "The font in which to display minor keywords in Eiffel and Ace files (either a font name string or 'default or 'context)") - (defvar eif-minor-keyword-color 'default - "Color of minor-keywords in Eiffel and Ace files (either a color name string or 'default or 'context)") - - (defvar eif-string-font 'default - "The font in which to display literal strings in Eiffel and Ace files (either a font name string or 'default or 'context)") - (defvar eif-string-color "sienna" - "Color of literal strings in Eiffel and Ace files (either a color name string or 'default or 'context)") - - (defvar eif-quoted-feature-font 'default - "The font in which to display features names enclosed in `'s in Eiffel and Ace file comments (either a font name string or 'default or 'context)") - (defvar eif-quoted-feature-color 'context - "Color of features names enclosed in `'s in Eiffel and Ace file comments (either a color name string or 'default or 'context)") - ) - - ((eq window-system 'x) - (defvar eif-comment-font 'default - "The font in which to display comments in Eiffel and Ace files (either a font name string or 'default or 'context)") - (defvar eif-comment-color "red3" - "Color of comments in Eiffel and Ace files (either a color name string or 'default or 'context)") - - (defvar eif-hidden-comment-font 'default - "The font in which to display hidden comments in Eiffel and Ace files (either a font name string or 'default or 'context)") - (defvar eif-hidden-comment-color "ForestGreen" - "Color of hidden comments in Eiffel and Ace files (either a color name string or 'default or 'context)") - - (defvar eif-major-keyword-font "-*-fixed-bold-*-*-*-*-100-*-*-*-*-*-*" - "The font in which to display major keywords in Eiffel and Ace files (either a font name string or 'default or 'context)") - (defvar eif-major-keyword-color 'default - "Color of major keywords in Eiffel and Ace files (either a color name string or 'default or 'context)") - - (defvar eif-assertion-keyword-font "-*-fixed-bold-*-*-*-*-100-*-*-*-*-*-*" - "The font in which to display assertion keywords in Eiffel and Ace files (either a font name string or 'default or 'context)") - (defvar eif-assertion-keyword-color "slate blue" - "Color of assertion keywords in Eiffel and Ace files (either a color name string or 'default or 'context)") - - (defvar eif-minor-keyword-font "-*-fixed-bold-*-*-*-*-100-*-*-*-*-*-*" - "The font in which to display minor keywords in Eiffel and Ace files (either a font name string or 'default or 'context)") - (defvar eif-minor-keyword-color 'default - "Color of minor-keywords in Eiffel and Ace files (either a color name string or 'default or 'context)") - - (defvar eif-string-font 'default - "The font in which to display literal strings in Eiffel and Ace files (either a font name string or 'default or 'context)") - (defvar eif-string-color "sienna" - "Color of literal strings in Eiffel and Ace files (either a color name string or 'default or 'context)") - - (defvar eif-quoted-feature-font "-*-times-medium-i-*-*-*-120-*-*-*-*-*-*" - "The font in which to display features names enclosed in `'s in Eiffel and Ace file comments (either a font name string or 'default or 'context)") - (defvar eif-quoted-feature-color 'context - "Color of features names enclosed in `'s in Eiffel and Ace file comments (either a color name string or 'default or 'context)") - ) - ) - -(defvar default-foreground-color 'default - "Default text color in Eiffel and Ace files (either a color name string or 'default or 'context)") - -(defvar disable-color nil "Should hilighting not use colors") - - -(defun eif-set-foreground (face color) - "Set the FACE's foreground color to COLOR if COLOR is a string, to the default foreground color if COLOR is 'default, or to the color of the surrounding text if COLOR is 'context" - (cond ((stringp color) - ;; If the specified color is not useable, use 'default: - (condition-case error - (set-face-foreground face color) - (error - (progn - (message "eif-set-foreground failed for face %s and color %s. Setting to 'default" face color) - (eif-set-foreground face 'default))) - ) - ) - ((eq color 'context) - (remove-face-property face 'foreground) - ) - ((eq color 'default) - (set-face-foreground face (face-foreground 'default)) - ) - ) - ) - -(defun eif-set-font (face font) - "Set the FACE's font to FONT if FONT is a string, to the default font if FONT is 'default, or to the font of the surrounding text if FONT is 'context" - (cond ((stringp font) - ;; If the specified font is not useable, use 'default: - (condition-case error - (set-face-font face font) - (error - (progn - (message "eif-set-font failed for face %s and font %s. Setting to 'default" face font) - (eif-set-font face 'default))) - ) - ) - ((eq font 'context) - (set-face-font face nil) - ) - ((eq font 'default) - (set-face-font face (face-font 'default)) - ) - ) - ) - -(defun eif-supports-color-p () - (and (not disable-color) - (or (and (fboundp 'display-color-p) - (display-color-p)) - (and (fboundp 'x-display-color-p) - (x-display-color-p)) - (and (fboundp 'x-color-display-p) - (x-color-display-p)) - ) - ) - ) - -(defun eif-init-color () - "Reset the Eiffel fonts and faces from the values of their repective variables" - (make-face 'eif-comment) - (make-face 'eif-hidden-comment) - (make-face 'eif-major-keyword) - (make-face 'eif-minor-keyword) - (make-face 'eif-quoted-feature) - (make-face 'eif-assertion) - (make-face 'eif-string) - - (if (eif-supports-color-p) - (progn - (eif-set-foreground 'eif-comment eif-comment-color) - (eif-set-font 'eif-comment eif-comment-font) - (eif-set-foreground 'eif-hidden-comment eif-hidden-comment-color) - (eif-set-font 'eif-hidden-comment eif-hidden-comment-font) - (eif-set-foreground 'eif-quoted-feature eif-quoted-feature-color) - (eif-set-font 'eif-quoted-feature eif-quoted-feature-font) - (eif-set-foreground 'eif-major-keyword eif-major-keyword-color) - (eif-set-font 'eif-major-keyword eif-major-keyword-font) - (eif-set-foreground 'eif-minor-keyword eif-minor-keyword-color) - (eif-set-font 'eif-minor-keyword eif-minor-keyword-font) - (eif-set-foreground 'eif-assertion eif-assertion-keyword-color) - (eif-set-font 'eif-assertion eif-assertion-keyword-font) - (eif-set-foreground 'eif-string eif-string-color) - (eif-set-font 'eif-string eif-string-font) - ) - (eif-set-foreground 'eif-comment default-foreground-color) - (eif-set-font 'eif-comment eif-comment-font) - (eif-set-foreground 'eif-hidden-comment default-foreground-color) - (eif-set-font 'eif-hidden-comment eif-hidden-comment-font) - (eif-set-foreground 'eif-quoted-feature default-foreground-color) - (eif-set-font 'eif-quoted-feature eif-quoted-feature-font) - (eif-set-foreground 'eif-major-keyword default-foreground-color) - (eif-set-font 'eif-major-keyword eif-major-keyword-font) - (eif-set-foreground 'eif-minor-keyword default-foreground-color) - (eif-set-font 'eif-minor-keyword eif-minor-keyword-font) - (eif-set-foreground 'eif-assertion default-foreground-color) - (eif-set-font 'eif-assertion eif-assertion-keyword-font) - (eif-set-foreground 'eif-string default-foreground-color) - (eif-set-font 'eif-string eif-string-font) - ) - - (cond ((featurep 'font-lock) - (copy-face 'eif-comment 'font-lock-comment-face) - (copy-face 'eif-string 'font-lock-string-face) - ) - ((and (featurep 'hilit19) - (not (eq 'eif-comment (car hilit-predefined-face-list))) - ) - (setq hilit-predefined-face-list - (append '(eif-comment - eif-hidden-comment - eif-major-keyword - eif-minor-keyword - eif-quoted-feature - eif-assertion - eif-string - ) - hilit-predefined-face-list - ) - ) - ) - ) - ) - -(eif-init-color) - -)) ;; matches "(if () (progn" above that checks for a highlighting package - -(cond ((featurep 'font-lock) - (copy-face 'eif-comment 'font-lock-comment-face) - (copy-face 'eif-string 'font-lock-string-face) - (defconst eiffel-font-lock-keywords - (purecopy - '(;; major keywords - ("\\(\\(^[ \t]*\\|[ \t]+\\)creation\\|^deferred[ \t]+class\\|^expanded[ \t]+class\\|^class\\|^feature\\|^indexing\\|\\(^[ \t]*\\|[ \t]+\\)inherit\\|^obsolete\\)[ \t\n]" 0 eif-major-keyword nil) - ;; assertions - ("\\(^\\|[^_\n]\\<\\)\\(check\\|ensure then\\|ensure\\|invariant\\|require else\\|require\\|variant\\)\\($\\|\\>[^_\n]\\)" 2 eif-assertion nil) - ;; minor keywords - ("\\(^\\|[^_\n]\\<\\)\\(alias\\|all\\|and not\\|and then\\|and\\|as\\|debug\\|deferred\\|do\\|else\\|elseif\\|end\\|export\\|external\\|from\\|frozen\\|if not\\|if\\|implies not\\|implies\\|infix\\|inspect\\|is deferred\\|is unique\\|is\\|like\\|local\\|loop\\|not\\|obsolete\\|old\\|once\\|or else\\|or not\\|or\\|prefix\\|redefine\\|rename\\|rescue\\|retry\\|select\\|strip\\|then\\|undefine\\|unique\\|until\\|when\\|xor\\)\\($\\|\\>[^_\n]\\)" 2 eif-minor-keyword nil) - ;; hidden comments - ("--|.*" 0 eif-hidden-comment t) - ;; quoted expr's in comments - ("`[^`'\n]*'" 0 eif-quoted-feature t) - ) - ) - "Regular expressions to use with font-lock mode.") - (defconst ace-font-lock-keywords - (purecopy - '(;; major keywords - ("^system\\|^default\\|^root\\|^cluster\\|^external\\|[ \t\n]end\\($\\|\\>[^_\n]\\)" 0 eif-major-keyword nil) - ;; hidden comments - ("--|.*" 0 eif-hidden-comment t) - ;; quoted expr's in comments - ("`[^`'\n]*'" 0 eif-quoted-feature t) - ) - ) - "Ace regular expressions to use with font-lock mode.") - ) - ((featurep 'lhilit) - - ;; ---- Eiffel mode ----- - ;; NOTE: The order of keywords below is generally alphabetical except - ;; when one keyword is the prefix of another (e.g. "and" & "and then") - ;; In such cases, the prefix keyword MUST be the last one. - (defvar eiffel-mode-hilit - '( - ("--|.*" nil eif-hidden-comment 4);; hidden comments - ("--[^\n|].*\\|--$" nil eif-comment 3);; comments - ("`[^`'\n]*'" nil eif-quoted-feature 5);; quoted expr's in comments - ("^creation\\|^deferred[ \t]*class\\|^expanded[ \t]*class\\|^class\\|^feature\\|^indexing\\|^inherit\\|^obsolete" nil eif-major-keyword 1);; major keywords - ("\\(^\\|[^_\n]\\<\\)\\(alias\\|all\\|and not\\|and then\\|and\\|as\\|debug\\|deferred\\|do\\|else\\|elseif\\|end\\|export\\|external\\|from\\|frozen\\|if not\\|if\\|implies not\\|implies\\|infix\\|inspect\\|is deferred\\|is unique\\|is\\|like\\|local\\|loop\\|not\\|obsolete\\|old\\|once\\|or else\\|or not\\|or\\|prefix\\|redefine\\|rename\\|rescue\\|retry\\|select\\|strip\\|then\\|undefine\\|unique\\|until\\|when\\|xor\\)\\($\\|\\>[^_\n]\\)" nil eif-minor-keyword 0 2) ;; minor keywords - ("\\(^\\|[^_\n]\\<\\)\\(check\\|ensure then\\|ensure\\|invariant\\|require else\\|require\\|variant\\)\\($\\|\\>[^_\n]\\)" nil eif-assertion 2 2) ;; assertions - ("\\(\"\"\\)\\|\\(\"\\([^\"%]\\|%.\\|%\n\\)+\"\\)" nil eif-string 2);; strings - )) - (hilit::mode-list-update "Eiffel" eiffel-mode-hilit) - ;; ---- Ace mode ----- - (defvar ace-mode-hilit - '( - ("--|.*" nil eif-hidden-comment 2);; hidden comments - ("--[^\n|].*\\|--$" nil eif-comment 1);; comments - ("`[^`'\n]*'" nil eif-quoted-feature 3);; quoted expr's in comments - ("^system\\|^default\\|^root\\|^cluster\\|^external\\|[ \t\n]end\\($\\|\\>[^_\n]\\)" nil eif-major-keyword);; major keywords - - )) - (hilit::mode-list-update "Ace" ace-mode-hilit) - ) - ;; - ;; NOTE: The hilit19 colors and fonts are _not_ set via the eif-* - ;; faces, fonts, and foreground variables defined above. They - ;; use their own face names which describe the colors and fonts - ;; to use. See hilit19.el for more info. - ((featurep 'hilit19) - - ;; ---- Eiffel mode ----- - ;; NOTE: The order of keywords below is generally alphabetical except - ;; when one keyword is the prefix of another (e.g. "and" & "and then") - ;; In such cases, the prefix keyword MUST be the last one. - (hilit-set-mode-patterns - 'eiffel-mode - '( - ("--|.*" nil eif-hidden-comment 4);; hidden comments - ("--[^\n|].*\\|--$" nil eif-comment 3);; comments - ("`[^`'\n]*'" nil eif-quoted-feature 5);; quoted expr's in comments - ("^creation\\|^deferred[ \t]*class\\|^expanded[ \t]*class\\|^class\\|^feature\\|^indexing\\|^inherit\\|^obsolete" nil eif-major-keyword 1);; major keywords - ("\\(^\\|[^_\n]\\<\\)\\(alias\\|all\\|and not\\|and then\\|and\\|as\\|debug\\|deferred\\|do\\|else\\|elseif\\|end\\|export\\|external\\|from\\|frozen\\|if not\\|if\\|implies not\\|implies\\|infix\\|inspect\\|is deferred\\|is unique\\|is\\|like\\|local\\|loop\\|not\\|obsolete\\|old\\|once\\|or else\\|or not\\|or\\|prefix\\|redefine\\|rename\\|rescue\\|retry\\|select\\|strip\\|then\\|undefine\\|unique\\|until\\|when\\|xor\\)\\($\\|\\>[^_\n]\\)" 2 eif-minor-keyword 0) ;; minor keywords - ("\\(^\\|[^_\n]\\<\\)\\(check\\|ensure then\\|ensure\\|invariant\\|require else\\|require\\|variant\\)\\($\\|\\>[^_\n]\\)" 2 eif-assertion 2) ;; assertions - ("\\(\"\"\\)\\|\\(\"\\([^\"%]\\|%.\\|%\n\\)+\"\\)" nil eif-string 2);; strings - ) - ) - ;; ---- Ace mode ----- - (hilit-set-mode-patterns - 'ace-mode - '( - ("--|.*" nil eif-hidden-comment 2);; hidden comments - ("--[^\n|].*\\|--$" nil eif-comment 1);; comments - ("`[^`'\n]*'" nil eif-quoted-feature 3);; quoted expr's in comments - ("^system\\|^default\\|^root\\|^cluster\\|^external\\|[ \t\n]end\\($\\|\\>[^_\n]\\)" nil eif-major-keyword);; major keywords - - ) - ) - ) - ) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; No user-customizable definitions below this point. ;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defmacro eif-class-level-kw-indent-m () - "Indentation amount for Class level keywords (in number of spaces)." - '(+ (* eif-class-level-kw-indent eif-indent-increment) - eif-extra-class-level-kw-indent) -) - -(defmacro eif-class-level-comment-indent-m () - "Indentation amount for Class level comments (in number of spaces)." - '(+ (* eif-class-level-comment-indent eif-indent-increment) - eif-extra-class-level-comment-indent) -) - -(defmacro eif-inherit-level-kw-indent-m () - "Indentation amount for Inherit level keywords (in number of spaces)." - '(+ (* eif-inherit-level-kw-indent eif-indent-increment) - eif-extra-inherit-level-kw-indent) -) - -(defmacro eif-feature-level-indent-m () - "Indentation amount for features (in number of spaces)." - '(+ (* eif-feature-level-indent eif-indent-increment) - eif-extra-feature-level-indent) -) - -(defmacro eif-feature-level-kw-indent-m () - "Indentation amount for Feature level keywords (in number of spaces)." - '(+ (* eif-feature-level-kw-indent eif-indent-increment) - eif-extra-feature-level-kw-indent) -) - -(defmacro eif-body-comment-indent-m () - "Indentation amount for comments in routine bodies (in number of spaces)." - '(+ (* eif-body-comment-indent eif-indent-increment) - eif-extra-body-comment-indent) -) - -(defmacro eif-feature-level-comment-indent-m () - "Indentation amount for Feature level comments (in number of spaces)." - '(+ (* eif-feature-level-comment-indent eif-indent-increment) - eif-extra-feature-level-comment-indent) -) - -(defmacro eif-check-keyword-indent-m () - "Indentation amount for Check keyword (in number of spaces)." - '(+ (* eif-check-keyword-indent eif-indent-increment) - eif-extra-check-keyword-indent) -) - -(defmacro eif-rescue-keyword-indent-m () - "Indentation amount for Rescue keyword (in number of spaces)." - '(+ (* eif-rescue-keyword-indent eif-indent-increment) - eif-extra-rescue-keyword-indent) -) - -(defmacro eif-then-indent-m () - "Indentation amount for `then' appearing on a line by itself (in number of spaces)." - '(+ (* eif-then-indent eif-indent-increment) - eif-extra-then-indent) -) - -(defmacro eif-continuation-indent-m () - "Indentation amount for a statement continuation line (in number of spaces)." - '(+ (* eif-continuation-indent eif-indent-increment) - eif-extra-continuation-indent) -) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Keyword Regular Expression Variables. ;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar eif-all-keywords-regexp - "\\(indexing\\|class\\|inherit\\|creation\\|feature\\|invariant\\|rename\ -\\|redefine\\|undefine\\|select\\|export\\|require\\|local\\|deferred\ -\\|do\\|once\\|ensure\\|alias\\|external\\|check\\|rescue\\|debug\\|if\ -\\|inspect\\|from\\|else\\|elseif\\|when\\|until\\|variant\\|loop\\|then\ -\\|obsolete\\|end\\)[^a-z0-9_]" - "Regular Expression to identify the presence of any eiffel keyword in a line. -Does not include `is'." - ) - -;; Note invariant is handled as a special case since it is both a -;; class-level and a from-level keyword -;; Note obsolete is handled as a special case since it is both a -;; class-level and a feature-level keyword -(defvar eif-class-level-keywords - "\\(indexing\\|class\\|deferred[ \t]*class\\|expanded[ \t]*class\\|inherit\\|creation\\|feature\\)[^a-z0-9_]" - "Those keywords introducing class-level clauses. Note that `invariant' -and `obsolete' are not included here since can function as more than one type of keyword. " - ) - -(defvar eif-inherit-level-keywords - "\\(rename\\|redefine\\|undefine\\|select\\|export\\)" - "Those keywords which introduce subclauses of the inherit clause." - ) - -(defvar eif-feature-level-keywords - "\\(require\\|local\\|deferred\\|do\\|once\\|ensure\\|alias\\|external\\)[^a-z0-9_]" - "Those keywords which are internal to features (in particular, routines)." - ) - -(defvar eif-end-keyword "end" "The `end' keyword.") - -(defvar eif-end-on-current-line ".*[ \t]end[ \t]*;?[ \t]*\\(--.*\\)?$" - "Regular expression to identify lines ending with the `end' keyword") - -(defvar eif-non-id-char-regexp "[^a-z0-9_]" - "The characters that are not part of identifiers.") - -(defvar eif-end-keyword-regexp "[^a-z0-9_]end[^a-z0-9_]" - "The `end' keyword with context.") - -(defvar eif-end-matching-keywords - "\\(check\\|class\\|feature\\|rename\\|redefine\\|undefine\\|select\\|export\\|do\\|once\\|deferred\\|external\\|alias\\|if\\|inspect\\|from\\|debug\\)[^a-z0-9_]" - "Those keywords whose clause is terminated by an `end' keyword." - ) - -(defvar eif-control-flow-keywords - "\\(if\\|inspect\\|from\\|debug\\)" - "Keywords which introduce control-flow constructs." - ) - -(defvar eif-control-flow-matching-keywords - "\\(deferred\\|do\\|once\\|if\\|inspect\\|from\\|debug\\)[^a-z0-9_]" - "Keywords whose occurrence prior to a control-flow-keyword causes the -indentation of the control-flow-keyword. Note that technically, -`end' is part of this list but it is handled separately in the -functions: eif-matching-indent and eif-matching-kw." - ) - -(defvar eif-check-keyword "check" "The `check' keyword.") - -(defvar eif-check-keywords "\\(check\\)[^a-z0-9_]" - "The `check' keyword (with trailing context).") - -(defvar eif-check-matching-keywords - "\\(deferred\\|do\\|once\\|if\\|inspect\\|from\\|debug\\)[^a-z0-9_]" - "Keywords whose occurrence prior to a check-keyword causes the -indentation of the check-keyword. Note that technically, `end' is -part of this list but it is handled separately in the functions: -eif-matching-indent and eif-matching-kw. (see also -eif-control-flow-matching-keywords)" - ) - -(defvar eif-rescue-keyword "rescue" "The `rescue' keyword.") - -(defvar eif-obsolete-keyword "obsolete" "The `obsolete' keyword.") - -(defvar eif-rescue-keywords "\\(rescue\\)[^a-z0-9_]" - "The `rescue' keyword (with trailing context).") - -(defvar eif-rescue-matching-keywords - "\\(deferred\\|do\\|once\\)[^a-z0-9_]" - "Keywords whose occurrence prior to a rescue-keyword causes the -indentation of the rescue-keyword. Note that technically, `end' is -part of this list but it is handled separately in the functions: -eif-matching-indent and eif-matching-kw. (see also -eif-control-flow-matching-keywords)" - ) - -(defvar eif-from-level-keywords - "\\(until\\|variant\\|loop\\)[^a-z0-9_]" - "Keywords occuring inside of a from clause." - ) - -(defvar eif-from-keyword "from" "The keyword `from'.") - -(defvar eif-if-or-inspect-level-keywords "\\(elseif\\|else\\|when\\)[^a-z0-9_]" - "Keywords occuring inside of an if or inspect clause." - ) - -(defvar eif-if-or-inspect-keyword "\\(if\\|inspect\\)[^a-z0-9_]" - "The `if' or `inspect' keywords." - ) - -(defvar eif-then-keyword ".*[ \t)]then[ \t]*$" - "The keyword `then' with possible leading text.") - -(defvar eif-solitary-then-keyword "then" "The keyword `then'.") - -(defvar eif-then-matching-keywords "\\(if\\|elseif\\|when\\)" - "Keywords whose occurrence prior to a then-keyword sets the -indentation of the then-keyword. Note that technically, `end' is -part of this list but it is handled separately in the functions: -eif-matching-indent and eif-matching-kw. (see also -eif-control-flow-matching-keywords)" - ) - -(defvar eif-invariant-keyword "invariant" "The `invariant' keyword.") - -(defvar eif-invariant-matching-keywords - "\\(from\\|feature\\)" - "Keywords whose occurrence prior to an invariant-keyword causes the -indentation of the invariant-keyword. Note that technically, `end' -is part of this list but it is handled separately in the functions: -eif-matching-indent and eif-matching-kw. (see also -eif-control-flow-matching-keywords)" - ) - -(defvar eif-obsolete-matching-keywords - "\\(is\\|class\\)" - "Keywords whose occurrence prior to an obsolete-keyword causes the -indentation of the obsolete-keyword." - ) - -(defvar eif-white-space-regexp "[ ]*" - "RE to locate whitespace.") - -(defvar eif-comment-line-regexp "[ ]*\\(--.*\\)$" - "RE to match a line with a comment on it.") - -(defvar eif-non-source-line "[ ]*\\(--.*\\)?$" - "RE to match a line with a only a comment or whitespace.") - -(defvar eif-variable-or-const-regexp "[^()\n]*:[^=].*" - "RE to match a variable or constant declaration.") - -(defvar eif-indentation-keywords-regexp - "\\(indexing\\|class\\|check\\|rescue\\|inherit\\|creation\\|feature\\|invariant\\|rename\\|redefine\\|undefine\\|select\\|export\\|require\\|local\\|deferred\\|do\\|once\\|ensure\\|alias\\|external\\|if\\|inspect\\|from\\|debug\\|else\\|elseif\\|when\\|until\\|variant\\|invariant\\|loop\\|obsolete\\)[^a-z0-9_]" - "RE to identify the presence of any eiffel keyword triggering indentation" - ) - -(defvar eif-feature-indentation-keywords-regexp - "\\(creation\\|feature\\)[^a-z0-9_]" - "Keywords which denote the presence of features following them." - ) - -(defvar eif-is-keyword-regexp "\\(.*[ )]\\)?is[ ]*\\(--.*\\)?$" - "The `is' keyword (with some context)." - ) - -(defvar eif-multiline-routine-is-keyword-regexp - ".*([^)]*)\\([ \t\n]*\\|[ \t\n]*:[][ \t\nA-Za-x0-9_,]*\\)is[ ]*\\(--.*\\)?$" - "The `is' keyword (with some context)." - ) - -(defvar eif-operator-regexp - "[ ]*\\([@*/+]\\|-[^-]\\|\\ (eif-in-paren-expression) 0) - (> (setq indent (eif-indent-multi-line)) -1) - ) - (setq indent (eif-manifest-array-indent)) - ) - - ;; multi-line parenthesis expression - ;; Move string continuation lines one column to the left - (if (looking-at "%") - (setq indent (1- indent)) - ) - - ;; Else Find the first preceding line with non-comment source on it - ;; that is not a continuation line of a multi-line parnethesized - ;; expression. - - ;; Record whether this line begins with an operator. We assume - ;; that the line is a continuation line if it begins with an operator - (beginning-of-line) - (if (looking-at eif-operator-regexp) - (setq continuation t) - (setq continuation nil) - ) - ;; Record whether the line being indented begins with an " :" - ;; This is used in indenting assertion tag expressions. - (if (looking-at "[ ]*[a-zA-Z0-9_]+[ ]*:") - (setq id-colon t) - (setq id-colon nil) - ) - - (forward-line -1) - (beginning-of-line) - (while (and (looking-at eif-non-source-line) (not (= (point) 1))) - (previous-line 1) - (beginning-of-line) - ) - (if (eif-line-contains-close-paren) - (backward-sexp) - ) - (end-of-line) - (setq line-end (point)) - (beginning-of-line) - (re-search-forward eif-white-space-regexp line-end t) - - (cond ((and (= (point) 1) - originally-looking-at-comment - (setq indent (eif-class-level-comment-indent-m)) - ) - ) - ;; 'eif-is-keyword-regexp' case must precede - ;; '(not eif-all-keywords-regexp)' case since "is" is not - ;; part of 'eif-all-keywords-regexp' - ((or (looking-at eif-is-keyword-regexp) - (looking-at eif-multiline-routine-is-keyword-regexp) - (looking-at eif-obsolete-keyword) - ) - (if originally-looking-at-comment - ;; Then the line we are trying to indent is a comment - (setq indent (eif-feature-level-comment-indent-m)) - ;; Else the line being indented is not a comment - (setq indent (eif-feature-level-kw-indent-m)) - ) - ) - ((looking-at eif-feature-indentation-keywords-regexp) - (setq indent (eif-feature-level-indent-m)) - ) - ((looking-at eif-indentation-keywords-regexp) - (if (looking-at eif-end-on-current-line) - (setq indent (eif-current-line-indent)) - (setq indent - (+ (eif-current-line-indent) eif-indent-increment)) - ) - ) - ((looking-at eif-solitary-then-keyword) - (setq indent (- (+ (eif-current-line-indent) eif-indent-increment) - (eif-then-indent-m) - ) - ) - ) - ((looking-at eif-then-keyword) - (setq indent (eif-current-line-indent)) - ) - ((looking-at (concat eif-end-keyword eif-non-id-char-regexp)) - (if (= (setq indent (eif-current-line-indent)) - (eif-feature-level-kw-indent-m) - ) - (setq indent (eif-feature-level-indent-m)) - (eif-matching-line) - (if (string-match eif-check-keyword eif-matching-kw-for-end) - (setq indent (- indent (eif-check-keyword-indent-m))) - ) - ) - ) - ((looking-at eif-variable-or-const-regexp) - ;;Either a variable declaration or a pre or post condition tag - (if originally-looking-at-comment - ;; Then the line we are trying to indent is a comment - (if (= (setq indent (eif-current-line-indent)) - (eif-feature-level-indent-m) - ) - ;; Then - a feature level comment - (setq indent (eif-feature-level-comment-indent-m)) - ;; Else - some other kind of comment - (setq indent (+ indent (eif-body-comment-indent-m))) - ) - ;; Else the line being indented is not a comment - (if (setq indent (eif-indent-assertion-continuation id-colon)) - indent - (setq indent (eif-current-line-indent)) - ) - ) - ) - ((setq indent (eif-manifest-array-start)) - indent - ) - ((not (looking-at eif-all-keywords-regexp)) - (if originally-looking-at-comment - ;; Then the line we are trying to indent is a comment - (cond ((eif-continuation-line) - (setq indent - (+ (- (eif-current-line-indent) - eif-indent-increment - ) - (eif-body-comment-indent-m) - ) - ) - ) - ;; preceding line is at eif-feature-level-indent - - ;; assume that the preceding line is a parent - ;; class in an inherit clause - ((= (eif-current-line-indent) - (eif-feature-level-indent-m) - ) - (setq indent - (+ (eif-inherit-level-kw-indent-m) - (eif-body-comment-indent-m) - ) - ) - ) - (t - (setq indent - (+ (eif-current-line-indent) - (eif-body-comment-indent-m) - ) - ) - ) - ) - ;; Else line being indented is not a comment - - ;; The line the point is on is the one above the line being - ;; indented - (beginning-of-line) - (if (or continuation (looking-at eif-operator-eol-regexp)) - ;; Then the line being indented is a continuation line - (if (eif-continuation-line) - ;; The line preceding the line being indented is - ;; also a continuation line. Indent to the current - ;; line indentation. - (setq indent (eif-current-line-indent)) - ;; Else The line preceding the line being indented is - ;; not a continuation line. Indent an extra - ;; eif-continuation-indent - (setq indent (+ (eif-current-line-indent) - (eif-continuation-indent-m))) - ) - ;; Else the line being indented is not a continuation line. - (if (eif-continuation-line) - (if id-colon - ;; Then the line preceding the one being indented - ;; is an assertion continuation. Indent the current - ;; line to the same level as the preceding assertion - ;; tag. - (setq indent (eif-indent-assertion-tag)) - ;; Then the line preceding the one being indented is - ;; a continuation line. Un-indent by an - ;; eif-continuation-indent. - (setq indent (- (eif-current-line-indent) - eif-indent-increment - ) - ) - ) - ;; Else the line preceding the line being indented is - ;; also not a continuation line. Use the current indent. - (setq indent (eif-current-line-indent)) - ) - ) - ) - ) - ) ;; cond - ) ;; if - ) ;; if - ) ;; save-excursion - indent - ) ;; let - ) - -(defun eif-continuation-line () - (or (looking-at eif-operator-regexp) - (save-excursion - (forward-line -1) - (beginning-of-line) - (looking-at eif-operator-eol-regexp) - ) - ) - ) - -(defun eif-indent-assertion-continuation (id-colon) - "Are we inside a pre or a post condition clause on a line that is a -continuation of a multi-line assertion beginning with a tag? If so, return -the indentation of the continuation line." - (let ((limit (point))) - (if (save-excursion - (if (re-search-backward (concat eif-feature-level-keywords "\\|" - eif-end-keyword-regexp) nil t) - (if (looking-at "ensure\\|require") - (setq limit (point)) - nil - ) - nil - ) - ) - (save-excursion - (end-of-line) - (if (and (not id-colon) (re-search-backward ": *" limit t)) - (progn - (goto-char (match-end 0)) - (current-column) - ) - nil - ) - ) - nil - ) - ) - ) - -(defun eif-indent-assertion-tag () - "Are we inside a pre or a post condition clause on a line that is a -continuation of a multi-line assertion beginning with a tag? If so, return -the indentation of the continuation line." - (let (indent) - (save-excursion - (if (re-search-backward "ensure\\|require\\|variant\\|invariant" nil t) - (setq indent (+ (eif-current-line-indent) eif-indent-increment)) - ;; This option should not occur - (error "Could not find assertion tag.") - ) - ) - ) - ) - -(defun eif-matching-indent (matching-keyword-regexp) - "Search backward from the point looking for one of the keywords -in the MATCHING-KEYWORD-REGEXP. Return the indentation of the -keyword found. If an `end' keyword occurs prior to finding one of -the keywords in MATCHING-KEYWORD-REGEXP and it terminates a check -clause, return the indentation of the `end' minus the value of -eif-check-keyword-indent." - (let ((search-regexp (concat "[^a-z0-9A-Z_]" - eif-end-keyword - "[^a-z0-9A-Z_]\\|[^a-z0-9A-Z_]" - matching-keyword-regexp - ) - ) - (indent 0) - (continue t) - ) - (save-excursion - (while (and (re-search-backward search-regexp 1 t) - (or (eif-in-quoted-string-p) - (eif-in-comment-p) - ) - ) - ) - (if (looking-at search-regexp) - ;; Then - (if (and (looking-at eif-end-keyword-regexp) - (eif-matching-line) - (string-match eif-check-keyword eif-matching-kw-for-end) - ) - ;; The keyword "end" was found that terminated a "check" clause - (setq indent (- (eif-current-line-indent) (eif-check-keyword-indent-m))) - ;; Else a keyword in "matching-keyword-regexp" or a normal - ;; "end"was found - (setq indent (eif-current-line-indent)) - ) - ;; Else - (message "No matching indent keyword was found") - ) - indent - - ) - ) - ) - -(defun eif-matching-kw (matching-keyword-regexp) - "Search backward from the point looking for one of the keywords in -the MATCHING-KEYWORD-REGEXP. Return the keyword found. Also set the -value of eif-matching-indent to the indentation of the keyword -found. If an `end' keyword occurs prior to finding one of the -keywords in MATCHING-KEYWORD-REGEXP and it terminates a check -clause, set the value of eif-matching-indent to the indentation of -the `end' minus the value of eif-check-keyword-indent." - (let ((search-regexp (concat "[^a-z0-9A-Z_.]" - eif-end-keyword - "[^a-z0-9A-Z_.]\\|[^a-z0-9A-Z_.]" - matching-keyword-regexp - ) - ) - (keyword "") - ) - (save-excursion - ;; Search backward for a matching keyword. - (while (and (re-search-backward search-regexp 1 t) - (or (eif-in-quoted-string-p) - (eif-in-comment-p) - ) - ) - ) - (if (looking-at search-regexp) - ;; Then - a keyword was found - (progn - (setq keyword - (buffer-substring (match-beginning 0) (match-end 0)) - ) - (if (and (looking-at eif-end-keyword-regexp) - (eif-matching-line) - (string-match eif-check-keyword eif-matching-kw-for-end) - ) - ;; Then - (setq eif-matching-indent - (- (eif-current-line-indent) (eif-check-keyword-indent-m)) - ) - ;; Else - (setq eif-matching-indent (eif-current-line-indent)) - ) - ) - ;; Else no keyword was found. I think this is an error - (setq eif-matching-indent 0) - (message "No matching indent keyword was found") - ) - keyword - ) - ) - ) - -(defun eif-line-contains-close-paren () - "This function returns t if the current line contains a close paren and -nil otherwise. If a close paren is found, the point is placed immediately -after the last close paren on the line. If no paren is found, the point is -placed at the beginning of the line." - (let ((search-min 0)) - (beginning-of-line) - (setq search-min (point)) - (end-of-line) - (if (search-backward ")" search-min t) - ;; Then - (progn - (forward-char 1) - t - ) - ;; Else - (beginning-of-line) - nil - ) - ) - ) - -;;;; Not Currently Used -;;;(defun eif-quoted-string-on-line-p () -;;; "t if an Eiffel quoted string begins, ends, or is continued -;;; on current line." -;;; (save-excursion -;;; (beginning-of-line) -;;; ;; Line must either start with optional whitespace immediately followed -;;; ;; by a '%' or include a '\"'. It must either end with a '%' character -;;; ;; or must include a second '\"' character. -;;; (looking-at "^\\([ \t]*%\\|[^\"\n]*\"\\)[^\"\n]*\\(%$\\|\"\\)") -;;; ) -;;;) - -(defvar eif-opening-regexp - "\\<\\(external\\|check\\|deferred\\|do\\|once\\|from\\|if\\|inspect\\)\\>" - "Keywords that open eiffel nesting constructs." - ) -(defvar eif-closing-regexp "\\" - "Keywords that close eiffel nesting constructs." - ) -(defvar eif-do-regexp "\\" - "Keyword that opens eiffel routine body." - ) -(defvar eif-opening-or-closing-regexp - (concat "\\(" eif-opening-regexp "\\|" eif-closing-regexp "\\)") - "Keywords that open or close eiffel nesting constructs." - ) - -;;; -;;; Code to allow indenting whole eiffel blocks -;;; - -(defun eif-matching-line (&optional return-line-break direction) - "Return the character position of the keyword matching the eiffel -keyword on the current line. (e.g. a line containing the keyword -'do' is matched by a line containing the keyword 'end' and a line -containing 'end' may be matched by a number of opening keywords. -If the optional parameter 'return-line-break' is not nil, the -character position returned is the beginning (or end) of the line -containing the matching keyword instead of the position of the -keyword itself. If the second optional parameter, direction, is -non-null, the current line is not searched for a keyword. Instead, -if the value of direction is 'forward, the function acts as if -an eif-opening-regexp is on the current line. If the value of direction -is 'backward, the function acts as if a eif-closing-regexp is on the -current line. The effect of using the direction parameter is to -locate either the opening or closing keyword of the syntactic -construct containing the point." - (let ((nesting-level 0) - (matching-point nil) - (search-end 0) - (opening-keyword nil) - (match-start nil) - (match-end nil) - (success nil) - (start-point nil) - ) - (unwind-protect - (save-excursion - (modify-syntax-entry ?_ "w ") - (setq eif-matching-kw-for-end "");; public variable set by this function - (setq start-point (point)) - (end-of-line) - (setq search-end (point)) - (beginning-of-line) - ;; Set starting state: If direction was specified use it. - ;; If direction is nil, search for a keyword on the current line - ;; If the keyword is in eif-opening-regexp, set the search - ;; direction to 'forward, if the keyword on the current line is `end' - ;; set the search direction to 'backward. - (cond ((eq direction 'forward) - (end-of-line);; So we wont see any keywords on the current line - (setq nesting-level 1) - ) - ((eq direction 'backward) - (beginning-of-line);; So we wont see any keywords on the current line - (setq nesting-level -1) - ) - ((and (re-search-forward eif-opening-regexp search-end t) - (not (or (eif-in-quoted-string-p) - (eif-in-comment-p) - ) - ) - ) - (setq match-start (match-beginning 0)) - (goto-char match-start) - (if (not (or (eif-in-quoted-string-p) (eif-in-comment-p))) - (setq nesting-level 1) - ) - (setq opening-keyword - (cons (buffer-substring match-start (match-end 0)) - opening-keyword - ) - ) - (goto-char (match-end 0)) - ) - ((and (progn (beginning-of-line) t) - (re-search-forward eif-closing-regexp search-end t) - (not (or (eif-in-quoted-string-p) - (eif-in-comment-p) - ) - ) - ) - (goto-char (match-beginning 0)) - (if (not (or (eif-in-quoted-string-p) (eif-in-comment-p))) - (setq nesting-level -1) - ) - ) - ) - ;; Perform the search - (while (not (= nesting-level 0)) - (if (> nesting-level 0) - ;; Then search forward for the next keyword not in a comment - (while (and (re-search-forward eif-opening-or-closing-regexp nil 1) - (goto-char (setq match-start (match-beginning 0))) - (setq match-end (match-end 0)) - (setq success t) - (or (eif-in-quoted-string-p) (eif-in-comment-p)) - ) - (goto-char match-end) - (setq success nil) - ) - ;; Else search backward for the next keyword not in a comment - (while (and (re-search-backward eif-opening-or-closing-regexp nil 1) - (goto-char (setq match-start (match-beginning 0))) - (setq success t) - (or (eif-in-quoted-string-p) (eif-in-comment-p)) - ) - (setq success nil) - ) - ) - (cond ((and (looking-at eif-opening-regexp) success) - ;; Found an opening keyword - (if (> nesting-level 0) - ;; Then - (if (looking-at eif-do-regexp) - ;; Then - (setq nesting-level -1) - ;; Else - (setq opening-keyword - (cons (buffer-substring match-start (match-end 0)) - opening-keyword - ) - ) - (goto-char (match-end 0)) - ) - ;; Else - (if (= nesting-level -1) - ;; Then - (progn - (setq eif-matching-kw-for-end - (buffer-substring match-start (match-end 0)) - ) - (if (looking-at "[ \t\n]+") (goto-char (match-end 0))) - ) - ;; Else - (if (looking-at eif-do-regexp) - ;; Then - (progn - (goto-char (eif-matching-line nil 'forward)) - (setq nesting-level -1) - ) - ) - ) - (setq opening-keyword (cdr opening-keyword)) - (if return-line-break - (beginning-of-line) - ) - ) - (setq nesting-level (1+ nesting-level)) - ) - ((and (looking-at eif-closing-regexp) success) - ;; Found an opening keyword - (if (> nesting-level 0) - ;; Then - (progn - (setq opening-keyword (cdr opening-keyword)) - (if return-line-break - (end-of-line) - ) - (goto-char (match-end 0)) - ) - ;; Else - (setq opening-keyword - (cons (buffer-substring (match-beginning 0) - (match-end 0) - ) - opening-keyword - ) - ) - ) - (setq nesting-level (1- nesting-level)) - ) - (t (message (concat "Could not find match" - (if (car opening-keyword) - (concat " for: " (car opening-keyword)) - ) - ) - ) - (goto-char start-point) - (setq nesting-level 0) - ) - );; cond - );; while - (setq matching-point (point)) - );; save-excursion - (modify-syntax-entry ?_ "_ ") - );; unwind-protect - (set-mark matching-point) - );; let - );; eif-matching-line - -;;; ENHANCEME: Make this function correctly indent more than just routine -;;; bodies and their sub-constructs. At the least it should -;;; handle whole routines also. -(defun eif-indent-construct () - "Indents an entire eiffel syntactic construct. It is assumed that -the point is within a nesting construct ('do', `once', 'check', 'if', -'from', or 'inspect'). The whole construct is indented up to the -matching end. If the point is not within such a construct, then -only that line is indented" - (interactive) - (let ((end-point 0)) - (save-excursion - (end-of-line) - (if (not (= (point) (point-max))) (forward-char 1)) - (goto-char (eif-matching-line t 'backward)) - (setq end-point (eif-matching-line t 'forward)) - (while (< (point) end-point) - (eif-indent-line) - (next-line 1) - (beginning-of-line) - ) - ) - ) - ) - -(defun eif-indent-region (&optional start end) - "Indents the lines in the current region" - (interactive) - (let ((start-point (or start (region-beginning))) - (end-point (copy-marker (or end (region-end)))) - ) - (save-excursion - (goto-char start-point) - (cond ((eq major-mode 'ace-mode) - (while (< (point) end-point) - (if (not (looking-at "[ ]*$")) - (ace-indent-line) - ) - (next-line 1) - (beginning-of-line) - ) - ) - ((eq major-mode 'eiffel-mode) - (while (< (point) end-point) - (if (not (looking-at "[ ]*$")) - (eif-indent-line) - ) - (next-line 1) - (beginning-of-line) - ) - ) - (t (error "Buffer must be in eiffel or ace mode.")) - ) - ) - ) - ) - -;;(defun eif-goto-matching-line (&optional direction) -;; "Place the cursor on the line which closes(opens) the current -;;opening(closing) syntactic construct. For example if the point -;;is on `from', executing goto-matching-line places the point -;;on the matching `end' and vice-versa." -;; (interactive) -;; (if (not direction) -;; (progn -;; (cond ((save-excursion (beginning-of-line) (looking-at "[ ]*end.*$")) -;; (goto-char (eif-matching-line nil 'backward)) -;; ) -;; ((looking-at "(") -;; (forward-sexp) -;; ) -;; ((save-excursion (backward-char 1) (looking-at ")")) -;; (backward-sexp) -;; ) -;; (t -;; (goto-char (eif-matching-line nil 'forward)) -;; ) -;; ) -;; ) -;; ) -;; ) - -(defun eif-forward-sexp () - "Place the cursor on the line which closes the current opening syntactic construct. For example if the point is on `from', executing eif-forward-sexp places the point on the matching `end'. This also does matching of parens ala forward-sexp." - (interactive) - (cond ((looking-at "[[(]") - (forward-sexp) - ) - (t - (goto-char (eif-matching-line nil 'forward)) - ) - ) - ) - -(defun eif-backward-sexp () - "Place the cursor on the line which opens the current closing syntactic construct. For example if the point is on the terminating `end' of an `if' statement, executing eif-backward-sexp places the point on the opening `if'. This also does matching of parens ala backward-sexp." - (interactive) - (cond ((save-excursion (backward-char 1) (looking-at "[])]")) - (backward-sexp) - ) - (t - (goto-char (eif-matching-line nil 'backward)) - ) - ) - ) - -(defun eif-local-indent (amount) - "Set the value of eif-indent-increment to amount and make the change local to this buffer." - (interactive "NNumber of spaces for eif-indent-increment: ") - (make-local-variable 'eif-indent-increment) - (setq eif-indent-increment amount) - ) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Utility Functions. ;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun eif-feature-quote () - "Put a `' around the current feature name" - (interactive) - (save-excursion - (backward-sexp) - (insert "`") - (forward-sexp) - (insert "'") - ) - (if (looking-at "'") - (forward-char 1)) - ) - -(defvar eiffel-mode-abbrev-table nil) -(define-abbrev-table 'eiffel-mode-abbrev-table ()) - -;;; ---------------------------------------------------------------------- -;;; This next portion of the file is derived from "eiffel.el" -;;; Copyright (C) 1989, 1990 Free Software Foundation, Inc. and Bob Weiner -;;; Available for use and distribution under the same terms as GNU Emacs. -;;; ---------------------------------------------------------------------- - -(defvar eiffel-mode-map nil - "Keymap for Eiffel mode.") - -(defvar eiffel-mode-syntax-table nil - "Syntax table in use in Eiffel-mode buffers.") - -(if eiffel-mode-syntax-table - nil - (let ((table (make-syntax-table)) - (i 0)) - (while (< i ?0) - (modify-syntax-entry i "_ " table) - (setq i (1+ i))) - (setq i (1+ ?9)) - (while (< i ?A) - (modify-syntax-entry i "_ " table) - (setq i (1+ i))) - (setq i (1+ ?Z)) - (while (< i ?a) - (modify-syntax-entry i "_ " table) - (setq i (1+ i))) - (setq i (1+ ?z)) - (while (< i 128) - (modify-syntax-entry i "_ " table) - (setq i (1+ i))) - (modify-syntax-entry ? " " table) - (modify-syntax-entry ?- ". 12" table) - (modify-syntax-entry ?_ "_ " table) - (modify-syntax-entry ?\t " " table) - (modify-syntax-entry ?\n "> " table) - (modify-syntax-entry ?\f "> " table) - (modify-syntax-entry ?\" "\" " table) - (modify-syntax-entry ?\\ "." table) - (modify-syntax-entry ?\( "() " table) - (modify-syntax-entry ?\) ")( " table) - (modify-syntax-entry ?\[ "(] " table) - (modify-syntax-entry ?\] ")[ " table) - (modify-syntax-entry ?\{ "(} " table) - (modify-syntax-entry ?\} "){ " table) - (modify-syntax-entry ?' "\"" table) - (modify-syntax-entry ?` "." table) - (modify-syntax-entry ?/ "." table) - (modify-syntax-entry ?* "." table) - (modify-syntax-entry ?+ "." table) - (modify-syntax-entry ?= "." table) - (modify-syntax-entry ?% "\\" table) - (modify-syntax-entry ?< "." table) - (modify-syntax-entry ?> "." table) - (modify-syntax-entry ?& "." table) - (modify-syntax-entry ?| "." table) - (modify-syntax-entry ?\; "." table) - (modify-syntax-entry ?: "." table) - (modify-syntax-entry ?! "." table) - (modify-syntax-entry ?. "." table) - (setq eiffel-mode-syntax-table table)) - ) - -(if eiffel-mode-map - nil - (setq eiffel-mode-map (make-sparse-keymap)) - (define-key eiffel-mode-map "\t" 'eif-indent-line) - (define-key eiffel-mode-map "\C-j" 'eif-newline) - (if (and (boundp 'eif-cr-function) eif-cr-function) - (define-key eiffel-mode-map "\C-m" eif-cr-function) - ) - (define-key eiffel-mode-map "\M-\C-q" 'eif-indent-construct) - (define-key eiffel-mode-map "\M-'" 'eif-feature-quote) - (define-key eiffel-mode-map "\M-q" 'eif-fill-paragraph) - ) - -;;;###autoload -(defun eiffel-mode () - "Major mode for editing Eiffel programs." - (interactive) - (setq major-mode 'eiffel-mode) - (setq mode-name "Eiffel") - (use-local-map eiffel-mode-map) - (set-syntax-table eiffel-mode-syntax-table) - - ;; Make local variables. - (make-local-variable 'paragraph-start) - (make-local-variable 'paragraph-separate) - (make-local-variable 'paragraph-ignore-fill-prefix) - (make-local-variable 'require-final-newline) - (make-local-variable 'parse-sexp-ignore-comments) - (make-local-variable 'indent-line-function) - (make-local-variable 'indent-region-function) - (make-local-variable 'comment-start) - (make-local-variable 'comment-end) - (make-local-variable 'comment-column) - (make-local-variable 'comment-start-skip) - ;; Now set their values. - (setq paragraph-start (concat "^$\\|" page-delimiter) - paragraph-separate paragraph-start - paragraph-ignore-fill-prefix t - require-final-newline 'ask - parse-sexp-ignore-comments t - indent-line-function 'eif-indent-line - indent-region-function 'eif-indent-region - comment-start "-- " - comment-end "" - comment-column 32 - comment-start-skip "--+ *") - - (run-hooks 'eiffel-mode-hook) - (setq local-abbrev-table eiffel-mode-abbrev-table) - (setq auto-fill-function 'eif-auto-fill) - ) - -(defun eif-in-comment-p () - "t if point is in a comment." - (save-excursion - (and (/= (point) (point-max)) (forward-char 1)) - (search-backward "--" (save-excursion (beginning-of-line) (point)) t))) - - -;; ENHANCEME: Currently eif-beginning-of-feature only works for routines. -;; It should be made more general. -;; - -(defun eif-beginning-of-feature (&optional arg) - "Move backward to next feature beginning. With argument, do this that many -times. Returns t unless search stops due to beginning of buffer." - (interactive "p") - (and arg (< arg 0) (forward-char 1)) - (if (or (re-search-backward eif-multiline-routine-is-keyword-regexp - nil t (or arg 1)) - (re-search-backward eif-is-keyword-regexp - nil 'move (or arg 1)) - ) - (progn - (backward-sexp 1) - (if (looking-at "(") - (backward-word 1) - ) - (beginning-of-line) - ) - nil - ) - ) - -(defun eif-current-line-indent () - "Return the indentation of the line containing the point." - (save-excursion - (let ((line-end 0) - (indent 0) - ) - (end-of-line) - (setq line-end (point)) - (beginning-of-line) - (re-search-forward eif-white-space-regexp line-end t) - (setq indent (current-column)) - ) - ) - ) - -(defun eif-in-quoted-string-p (&optional non-strict-p) - "t if point is in a quoted string. Optional argument NON-STRICT-P if true -causes the function to return true even if the point is located in leading -white space on a continuation line. Normally leading white space is not -considered part of the string." - (let ((initial-regexp "^[ \t]*%\\|[^%]\"\\|%[ \t]*$") - (search-limit (point)) - (count 0) - ) - (save-excursion - ;; Line must either start with optional whitespace immediately followed - ;; by a '%' or include a '\"' before the search-limit. - (beginning-of-line) - (while (re-search-forward initial-regexp search-limit t) - (setq count (1+ count)) - (if (= count 1) (setq search-limit (1+ search-limit))) - ) - ;; If the number of quotes (including continuation line markers) is odd, - ;; then we are inside of a string. Also if non-strict-p and we are in - ;; the leading white space of a continuation line, then we are in a quote. - (if (= (% count 2) 1) - t - (beginning-of-line) - (if non-strict-p - (if (looking-at "^[ \t]*%") - t - nil - ) - nil - );; if - );; if - );; save-excursion - );; let - );; e-in-quoted-string - -;;; ---------------------------------------------------------------------- -;;; End of portion derived from "eiffel.el" -;;; ---------------------------------------------------------------------- - -(defun eif-comment-prefix () - "Prefix that starts a comment that begins a line. - Comments that are not the only thing on a line return nil as their prefix." - (save-excursion - (end-of-line) - (let ((limit (point)) len - (in-string (eif-in-quoted-string-p)) - ) - (beginning-of-line) - (cond ((re-search-forward "^[ \t]*--|?[ \t]*" limit t) - (buffer-substring (match-beginning 0) (match-end 0)) - ) - ;; Handle string-literal continuation lines - (in-string - (end-of-line) - (re-search-backward "^[ \t]*%\\|[^%]\"" nil t) - (re-search-forward "%\\|\"" nil t) - (setq len (1- (current-column))) - (concat (make-string len ? ) "%") - ) - (t nil) - ) - ) - ) - ) - - -(defun eif-auto-fill () - (let ((fill-prefix (eif-comment-prefix)) (pm (point-marker))) - (if (and (> (current-column) fill-column) fill-prefix) - (if (string-match "^[ \t]*%" fill-prefix) - (progn - (backward-char 1) - (re-search-backward "[^][a-zA-Z0-9]" nil t) - (forward-char 1) - (insert "%\n") - (insert fill-prefix) - (goto-char pm) - ) - ;; (do-auto-fill) - (backward-char 1) - (re-search-backward "\\s-" nil t) - (forward-char 1) - (insert "\n") - (insert fill-prefix) - (goto-char pm) - ) - ) - ) - ) - -(defun eif-fill-paragraph () - "Textually fills Eiffel comments ala fill-paragraph" - (interactive) - (save-excursion - (let ((current-point (point)) - (last-point nil) - (para-begin nil) - (para-end nil) - (fill-prefix (eif-comment-prefix)) - ) - (if fill-prefix - (progn - (setq last-point (point)) - (forward-line -1) - (end-of-line) - (while (and (not (= (point) last-point)) - (eif-comment-prefix) - ) - (setq last-point (point)) - (forward-line -1) - (end-of-line) - ) - (if (= (point) last-point) - (setq para-begin (save-excursion (beginning-of-line) (point))) - (setq para-begin (1+ (point))) - ) - (goto-char current-point) - (setq last-point (point)) - (next-line 1) - (end-of-line) - (while (and (not (= (point) last-point)) - (eif-comment-prefix) - ) - (setq last-point (point)) - (next-line 1) - (end-of-line) - ) - (if (= (point) last-point) - (setq para-end (point)) - (beginning-of-line) - (setq para-end (point)) - ) - (fill-region para-begin para-end) - ) - ) - ) - ) - ) - -(defun eif-newline () - "Insert a newline and indent the new line." - (interactive) - (insert "\n") - (eif-indent-line) - ) - -(defun eif-indent-and-newline () - "Indent the current line. Insert a newline and indent the new line." - (interactive) - (eif-indent-line) - (insert "\n") - (eif-indent-line) - ) - -(defun eif-indent-line (&optional whole-exp) - "Indent the current line as Eiffel code. -With argument, indent any additional lines of the same clause -rigidly along with this one (not implemented yet)." - (interactive "p") - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (let ((indent (eif-calc-indent))) - (if (not (= indent (current-column))) - (progn - (delete-horizontal-space) - (indent-to indent) - ) - ) - ) - ) - (skip-chars-forward " \t")) - -(defun eif-move-to-prev-non-blank () - "Moves point to previous line excluding blank lines. -Returns t if successful, nil if not." - (beginning-of-line) - (re-search-backward "^[ \t]*[^ \t\n]" nil t)) - -(defvar eif-last-feature-level-indent -1) -(defvar eif-feature-level-indent-regexp nil) -(defun eif-in-paren-expression () - "Determine if we are inside of a parenthesized expression" - (interactive) - (let ((paren-count 0) (limit 0)) - (save-excursion - (if (= eif-last-feature-level-indent (eif-feature-level-indent-m)) - (setq limit - (re-search-backward eif-feature-level-indent-regexp nil t)) - (setq eif-last-feature-level-indent (eif-feature-level-indent-m)) - (setq eif-feature-level-indent-regexp - (concat "^" (make-string eif-last-feature-level-indent ? ) - "[^ \t\n]") - ) - (setq limit - (or (re-search-backward eif-feature-level-indent-regexp nil t) - 0) - ) - ) - ) - (save-excursion - (while (re-search-backward "[][()]" limit t) - (if (looking-at "[[(]") - (setq paren-count (1+ paren-count)) - (setq paren-count (1- paren-count)) - ) - ) - ) - paren-count - ) -) - -(defun eif-manifest-array-indent () - "Determine if we are inside of a manifest array" - (interactive) - (let ((paren-count 0) (indent nil) - (limit 0)) - (save-excursion - (if (= eif-last-feature-level-indent (eif-feature-level-indent-m)) - (setq limit - (re-search-backward eif-feature-level-indent-regexp nil t)) - (setq eif-last-feature-level-indent (eif-feature-level-indent-m)) - (setq eif-feature-level-indent-regexp - (concat "^" (make-string eif-last-feature-level-indent ? ) - "[^ \t\n]") - ) - (setq limit - (or (re-search-backward eif-feature-level-indent-regexp nil t) - 0) - ) - ) - ) - (save-excursion - (while (and (<= paren-count 0) (re-search-backward "<<\\|>>" nil t)) - (if (looking-at "<<") - (setq paren-count (1+ paren-count)) - (setq paren-count (1- paren-count)) - ) - ) - (if (> paren-count 0) - (let ((eol (save-excursion (end-of-line) (point)))) - (setq indent - (or (and (re-search-forward "[^< \t]" eol t) - (1- (current-column))) - (+ (current-column) 2) - ) - ) - ) - ) - ) - indent - ) - ) - -(defun eif-manifest-array-start () - "Determine the indentation of the statement containing a manifest array" - (interactive) - (let ((paren-count 0) (indent nil) - (limit 0)) - (save-excursion - (if (= eif-last-feature-level-indent (eif-feature-level-indent-m)) - (setq limit - (re-search-backward eif-feature-level-indent-regexp nil t)) - (setq eif-last-feature-level-indent (eif-feature-level-indent-m)) - (setq eif-feature-level-indent-regexp - (concat "^" (make-string eif-last-feature-level-indent ? ) - "[^ \t\n]") - ) - (setq limit - (or (re-search-backward eif-feature-level-indent-regexp nil t) - 0) - ) - ) - ) - (save-excursion - (while (and (<= paren-count 0) (re-search-backward "<<\\|>>" nil t)) - (if (looking-at "<<") - (setq paren-count (1+ paren-count)) - (setq paren-count (1- paren-count)) - ) - ) - (if (> paren-count 0) - (let ((limit (progn (end-of-line) (point)))) - (beginning-of-line) - (if (re-search-forward "^[ \t]*<<" limit t) - (setq indent (- (current-column) 2 eif-indent-increment)) - (re-search-forward "^[ \t]*" limit t) - (setq indent (current-column)) - ) - ) - ) - ) - indent - ) - ) - -;;; ---------------------------------------------------------------------- -;;; The function below is derived from "eif-mult-fmt.el" -;;; Copyright (C) 1985 Free Software Foundation, Inc. -;;; Copyright (C) 1990 Bob Weiner, Motorola Inc. -;;; Available for use and distribution under the same terms as GNU Emacs. -;;; ---------------------------------------------------------------------- - -(defun eif-indent-multi-line (&optional parse-start) - "Return integer giving appropriate indentation for current Eiffel code -line between parentheses or double quotes, otherwise -1. Optional -PARSE-START is buffer position at which to begin parsing, default is to begin -at the feature enclosing or preceding point." - (let ((eif-opoint (point)) - (indent-point (progn (beginning-of-line) (point))) - (eif-ind-val -1) - (eif-in-str nil) - (eif-paren-depth 0) - (retry t) - state - ;; setting this to a number inhibits calling hook - last-sexp containing-sexp) - (if parse-start - (goto-char parse-start) - (eif-beginning-of-feature)) - ;; Find outermost containing sexp - (while (< (point) indent-point) - (setq state (parse-partial-sexp (point) indent-point 0))) - ;; Find innermost containing sexp - (while (and retry - state - (> (setq eif-paren-depth (elt state 0)) 0)) - (setq retry nil) - (setq last-sexp (elt state 2)) - (setq containing-sexp (elt state 1)) - ;; Position following last unclosed open. - (goto-char (1+ containing-sexp)) - ;; Is there a complete sexp since then? - (if (and last-sexp (> last-sexp (point))) - ;; Yes, but is there a containing sexp after that? - (let ((peek (parse-partial-sexp last-sexp indent-point 0))) - (if (setq retry (car (cdr peek))) (setq state peek))))) - (if retry - nil - ;; Innermost containing sexp found - (goto-char (1+ containing-sexp)) - (if (not last-sexp) - ;; indent-point immediately follows open paren. - nil - ;; Find the start of first element of containing sexp. - (parse-partial-sexp (point) last-sexp 0 t) - (cond ((looking-at "\\s(") - ;; First element of containing sexp is a list. - ;; Indent under that list. - ) - ((> (save-excursion (forward-line 1) (point)) - last-sexp) - ;; This is the first line to start within the containing sexp. - (backward-prefix-chars)) - (t - ;; Indent beneath first sexp on same line as last-sexp. - ;; Again, it's almost certainly a routine call. - (goto-char last-sexp) - (beginning-of-line) - (parse-partial-sexp (point) last-sexp 0 t) - (backward-prefix-chars)))) - (setq eif-ind-val (current-column)) - ) - ;; Point is at the point to indent under unless we are inside a string. - (setq eif-in-str (elt state 3)) - (goto-char eif-opoint) - (if (not eif-in-str) - nil - ;; Inside a string, indent 1 past string start - (setq eif-paren-depth 1);; To account for being inside string - (save-excursion - (if (re-search-backward "\"" nil t) - (setq eif-ind-val (1+ (current-column))) - (goto-char indent-point) - (if (looking-at "^[ \t]*[^ \t\n]") - (eif-move-to-prev-non-blank)) - (skip-chars-forward " \t") - (setq eif-ind-val (current-column))))) - (if (> eif-paren-depth 0) eif-ind-val -1) - )) - -(provide 'eiffel3) diff -r 43306a74e31c -r d44af0c54775 lisp/modes/enriched.el --- a/lisp/modes/enriched.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,530 +0,0 @@ -;;; enriched.el --- read and save files in text/enriched format - -;; Copyright (c) 1994, 1995, 1996 Free Software Foundation, Inc. - -;; XEmacs version: Mike Sperber -;; Original author: Boris Goldowsky -;; Keywords: wp, faces - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 20.2. - -;;; Commentary: - -;; This file implements reading, editing, and saving files with -;; text-properties such as faces, levels of indentation, and true line -;; breaks distinguished from newlines just used to fit text into the window. - -;; The file format used is the MIME text/enriched format, which is a -;; standard format defined in internet RFC 1563. All standard annotations -;; are supported except for and , which are currently not -;; possible to display. - -;; A separate file, enriched.doc, contains further documentation and other -;; important information about this code. It also serves as an example -;; file in text/enriched format. It should be in the etc directory of your -;; emacs distribution. - -;;; TODO for the XEmacs port: -;; -;; Currently XEmacs does not support default-text-properties. The -;; original enriched.el uses this to set the left-margin, -;; right-margin, and justification properties to 'front-sticky. -;; If you know the Right Way to fix this, contact -;; Mike Sperber . - -;;; Code: - -(provide 'enriched) - -;;; -;;; Variables controlling the display -;;; - -(defgroup enriched nil - "Read and save files in text/enriched format" - :group 'wp) - -(defcustom enriched-verbose t - "*If non-nil, give status messages when reading and writing files." - :type 'boolean - :group 'enriched) - -;;; -;;; Set up faces & display table -;;; - -;; Emacs doesn't have a "fixed" face by default, since all faces currently -;; have to be fixed-width. So we just pick one that looks different from the -;; default. -(defface fixed - '((t (:bold t))) - "Face used for text that must be shown in fixed width. -Currently, emacs can only display fixed-width fonts, but this may change. -This face is used for text specifically marked as fixed-width, for example -in text/enriched files." - :group 'enriched) - -(defface excerpt - '((t (:italic t))) - "Face used for text that is an excerpt from another document. -This is used in enriched-mode for text explicitly marked as an excerpt." - :group 'enriched) - -(defconst enriched-display-table - ;; XEmacs change - ;; (or (copy-sequence standard-display-table) - ;; (make-display-table))) - (make-display-table)) -(aset enriched-display-table ?\f (make-vector (1- (frame-width)) ?-)) - -(defconst enriched-par-props '(left-margin right-margin justification) - "Text-properties that usually apply to whole paragraphs. -These are set front-sticky everywhere except at hard newlines.") - -;;; -;;; Variables controlling the file format -;;; (bidirectional) - -(defconst enriched-initial-annotation - (lambda () - (format "Content-Type: text/enriched\nText-Width: %d\n\n" - fill-column)) - "What to insert at the start of a text/enriched file. -If this is a string, it is inserted. If it is a list, it should be a lambda -expression, which is evaluated to get the string to insert.") - -(defconst enriched-annotation-format "<%s%s>" - "General format of enriched-text annotations.") - -(defconst enriched-annotation-regexp "<\\(/\\)?\\([-A-za-z0-9]+\\)>" - "Regular expression matching enriched-text annotations.") - -(defconst enriched-translations - '((face (bold-italic "bold" "italic") - (bold "bold") - (italic "italic") - (underline "underline") - (fixed "fixed") - (excerpt "excerpt") - (default ) - (nil enriched-encode-other-face)) - (left-margin (4 "indent")) - (right-margin (4 "indentright")) - (justification (none "nofill") - (right "flushright") - (left "flushleft") - (full "flushboth") - (center "center")) - (PARAMETER (t "param")) ; Argument of preceding annotation - ;; The following are not part of the standard: - (FUNCTION (enriched-decode-foreground "x-color") - (enriched-decode-background "x-bg-color") - ;; XEmacs addition - (facemenu-make-larger "bigger") - (facemenu-make-smaller "smaller")) - (read-only (t "x-read-only")) - (unknown (nil format-annotate-value)) -; (font-size (2 "bigger") ; unimplemented -; (-2 "smaller")) -) - "List of definitions of text/enriched annotations. -See `format-annotate-region' and `format-deannotate-region' for the definition -of this structure.") - -(defconst enriched-ignore - '(front-sticky rear-nonsticky hard) - "Properties that are OK to ignore when saving text/enriched files. -Any property that is neither on this list nor dealt with by -`enriched-translations' will generate a warning.") - -;;; Internal variables - -(defvar enriched-mode nil - "True if Enriched mode is in use.") -(make-variable-buffer-local 'enriched-mode) - -(if (not (assq 'enriched-mode minor-mode-alist)) - (setq minor-mode-alist - (cons '(enriched-mode " Enriched") - minor-mode-alist))) - -(defcustom enriched-mode-hook nil - "Functions to run when entering Enriched mode. -If you set variables in this hook, you should arrange for them to be restored -to their old values if you leave Enriched mode. One way to do this is to add -them and their old values to `enriched-old-bindings'." - :type 'hook - :group 'enriched) - -(defvar enriched-old-bindings nil - "Store old variable values that we change when entering mode. -The value is a list of \(VAR VALUE VAR VALUE...).") -(make-variable-buffer-local 'enriched-old-bindings) - -;;; -;;; Define the mode -;;; - -;;;###autoload -(defun enriched-mode (&optional arg) - "Minor mode for editing text/enriched files. -These are files with embedded formatting information in the MIME standard -text/enriched format. -Turning the mode on runs `enriched-mode-hook'. - -More information about Enriched mode is available in the file -etc/enriched.doc in the Emacs distribution directory. - -Commands: - -\\\\{enriched-mode-map}" - (interactive "P") - (let ((mod (buffer-modified-p))) - (cond ((or (<= (prefix-numeric-value arg) 0) - (and enriched-mode (null arg))) - ;; Turn mode off - (setq enriched-mode nil) - (setq buffer-file-format (delq 'text/enriched buffer-file-format)) - ;; restore old variable values - (while enriched-old-bindings - (funcall 'set (car enriched-old-bindings) - (car (cdr enriched-old-bindings))) - (setq enriched-old-bindings (cdr (cdr enriched-old-bindings))))) - - (enriched-mode nil) ; Mode already on; do nothing. - - (t (setq enriched-mode t) ; Turn mode on - (add-to-list 'buffer-file-format 'text/enriched) - ;; Save old variable values before we change them. - ;; These will be restored if we exit Enriched mode. - (setq enriched-old-bindings - ;; XEmacs change - (list ; 'buffer-display-table buffer-display-table - 'indent-line-function indent-line-function - 'default-text-properties default-text-properties)) - (make-local-variable 'indent-line-function) - (make-local-variable 'default-text-properties) - (setq indent-line-function 'indent-to-left-margin - ;; XEmacs change - ;; buffer-display-table enriched-display-table - ) - (use-hard-newlines 1 nil) - (let ((sticky (plist-get default-text-properties 'front-sticky)) - (p enriched-par-props)) - (while p - (add-to-list 'sticky (car p)) - (setq p (cdr p))) - (if sticky - (setq default-text-properties - (plist-put default-text-properties - 'front-sticky sticky)))) - (run-hooks 'enriched-mode-hook))) - (set-buffer-modified-p mod) - ;; XEmacs change - (redraw-modeline))) - -;;; -;;; Keybindings -;;; - -(defvar enriched-mode-map nil - "Keymap for Enriched mode.") - -(if (null enriched-mode-map) - (fset 'enriched-mode-map (setq enriched-mode-map (make-sparse-keymap)))) - -(if (not (assq 'enriched-mode minor-mode-map-alist)) - (setq minor-mode-map-alist - (cons (cons 'enriched-mode enriched-mode-map) - minor-mode-map-alist))) - -(define-key enriched-mode-map "\C-a" 'beginning-of-line-text) -(define-key enriched-mode-map "\C-m" 'reindent-then-newline-and-indent) -(define-key enriched-mode-map "\C-j" 'reindent-then-newline-and-indent) -(define-key enriched-mode-map "\M-j" 'facemenu-justification-menu) -(define-key enriched-mode-map "\M-S" 'set-justification-center) -(define-key enriched-mode-map "\C-x\t" 'increase-left-margin) -(define-key enriched-mode-map "\C-c\C-l" 'set-left-margin) -(define-key enriched-mode-map "\C-c\C-r" 'set-right-margin) - -;;; -;;; Some functions dealing with text-properties, especially indentation -;;; - -(defun enriched-map-property-regions (prop func &optional from to) - "Apply a function to regions of the buffer based on a text property. -For each contiguous region of the buffer for which the value of PROPERTY is -eq, the FUNCTION will be called. Optional arguments FROM and TO specify the -region over which to scan. - -The specified function receives three arguments: the VALUE of the property in -the region, and the START and END of each region." - (save-excursion - (save-restriction - (if to (narrow-to-region (point-min) to)) - (goto-char (or from (point-min))) - (let ((begin (point)) - end - (marker (make-marker)) - (val (get-text-property (point) prop))) - (while (setq end (text-property-not-all begin (point-max) prop val)) - (move-marker marker end) - (funcall func val begin (marker-position marker)) - (setq begin (marker-position marker) - val (get-text-property marker prop))) - (if (< begin (point-max)) - (funcall func val begin (point-max))))))) - -(put 'enriched-map-property-regions 'lisp-indent-hook 1) - -(defun enriched-insert-indentation (&optional from to) - "Indent and justify each line in the region." - (save-excursion - (save-restriction - (if to (narrow-to-region (point-min) to)) - (goto-char (or from (point-min))) - (if (not (bolp)) (forward-line 1)) - (while (not (eobp)) - (if (eolp) - nil ; skip blank lines - (indent-to (current-left-margin)) - (justify-current-line t nil t)) - (forward-line 1))))) - -;;; -;;; Encoding Files -;;; - -;;;###autoload -(defun enriched-encode (from to &optional orig-buf) - (if enriched-verbose (message "Enriched: encoding document...")) - (save-restriction - (narrow-to-region from to) - (delete-to-left-margin) - (unjustify-region) - (goto-char from) - (format-replace-strings '(("<" . "<<"))) - (format-insert-annotations - (format-annotate-region from (point-max) enriched-translations - 'enriched-make-annotation enriched-ignore)) - (goto-char from) - (insert (if (stringp enriched-initial-annotation) - enriched-initial-annotation - (save-excursion - ;; Eval this in the buffer we are annotating. This - ;; fixes a bug which was saving incorrect File-Width - ;; information, since we were looking at local - ;; variables in the wrong buffer. - (if orig-buf (set-buffer orig-buf)) - (funcall enriched-initial-annotation)))) - (enriched-map-property-regions 'hard - (lambda (v b e) - (if (and v (= ?\n (char-after b))) - (progn (goto-char b) (insert "\n")))) - (point) nil) - (if enriched-verbose (message nil)) - ;; Return new end. - (point-max))) - -(defun enriched-make-annotation (name positive) - "Format an annotation called NAME. -If POSITIVE is non-nil, this is the opening annotation, if nil, this is the -matching close." - (cond ((stringp name) - (format enriched-annotation-format (if positive "" "/") name)) - ;; Otherwise it is an annotation with parameters, represented as a list - (positive - (let ((item (car name)) - (params (cdr name))) - (concat (format enriched-annotation-format "" item) - (mapconcat (lambda (i) (concat "" i "")) - params "")))) - (t (format enriched-annotation-format "/" (car name))))) - -;; XEmacs addition -(defun enriched-face-strip-size (face) - "Create a symbol from the name of FACE devoid of size information, -i.e. remove all larger- and smaller- prefixes." - (let* ((face-symbol (face-name face)) - (face-name (symbol-name face-symbol)) - (old-name face-name) - new-name) - (while - (not (string-equal - old-name - (setq new-name (replace-in-string old-name "^larger-" "")))) - (setq old-name new-name)) - - (while - (not (string-equal - old-name - (setq new-name (replace-in-string old-name "^smaller-" "")))) - (setq old-name new-name)) - - (if (string-equal new-name face-name) - face-symbol - (intern new-name)))) - -(defun enriched-encode-other-face (old new) - "Generate annotations for random face change. -One annotation each for foreground color, background color, italic, etc." - (cons (and old (enriched-face-ans old)) - (and new (enriched-face-ans new)))) - -(defun enriched-face-ans (face) - "Return annotations specifying FACE." - ;; XEmacs change (entire body of this function) - (let ((face-name (symbol-name face))) - (cond ((string-match "^fg:" face-name) - (list (list "x-color" (substring face-name 3)))) - ((string-match "^bg:" face-name) - (list (list "x-bg-color" (substring face-name 3)))) - ((or (string-match "^larger-" face-name) - (string-match "^smaller-" face-name)) - (cdr (format-annotate-single-property-change - 'face nil (enriched-face-strip-size face) - enriched-translations))) - (t - (let* ((fg (and (not (eq (face-foreground face) - (face-foreground 'default))) - (color-name (face-foreground face)))) - (bg (and (not (eq (face-background face) - (face-background 'default))) - (color-name (face-background face)))) - (ans '())) - (if fg (setq ans (cons (list "x-color" fg) ans))) - (if bg (setq ans (cons (list "x-bg-color" bg) ans))) - ans))))) - -;; XEmacs addition -(defun enriched-size-annotation (n annotation) - "Generate ANNOTATION N times." - (let ((l '())) - (while (not (zerop n)) - (setq l (cons annotation l)) - (setq n (1- n))) - l)) - -;; XEmacs addition -(defun enriched-encode-size (old new) - "Return annotations specifying SIZE." - (let* ((old (or old 0)) - (new (or new 0)) - (closing-annotation - (enriched-size-annotation (abs old) - (if (> old 0) "bigger" "smaller"))) - (opening-annotation - (enriched-size-annotation (abs new) - (if (> new 0) "bigger" "smaller")))) - (cons closing-annotation - opening-annotation))) - -;;; -;;; Decoding files -;;; - -;;;###autoload -(defun enriched-decode (from to) - (if enriched-verbose (message "Enriched: decoding document...")) - (use-hard-newlines 1 'never) - (save-excursion - (save-restriction - (narrow-to-region from to) - (goto-char from) - - ;; Deal with header - (let ((file-width (enriched-get-file-width))) - (enriched-remove-header) - - ;; Deal with newlines - (while (search-forward-regexp "\n\n+" nil t) - (if (current-justification) - (delete-char -1)) - (set-hard-newline-properties (match-beginning 0) (point))) - - ;; Translate annotations - (format-deannotate-region from (point-max) enriched-translations - 'enriched-next-annotation) - - ;; Indent or fill the buffer - (cond (file-width ; File was filled to this width - (setq fill-column file-width) - (if enriched-verbose (message "Indenting...")) - (enriched-insert-indentation)) - (t ; File was not filled. - (if enriched-verbose (message "Filling paragraphs...")) - (fill-region (point-min) (point-max)))) - (if enriched-verbose (message nil))) - (point-max)))) - -(defun enriched-next-annotation () - "Find and return next text/enriched annotation. -Any \"<<\" strings encountered are converted to \"<\". -Return value is \(begin end name positive-p), or nil if none was found." - (while (and (search-forward "<" nil 1) - (progn (goto-char (match-beginning 0)) - (not (looking-at enriched-annotation-regexp)))) - (forward-char 1) - (if (= ?< (char-after (point))) - (delete-char 1) - ;; A single < that does not start an annotation is an error, - ;; which we note and then ignore. - (message "Warning: malformed annotation in file at %s" - (1- (point))))) - (if (not (eobp)) - (let* ((beg (match-beginning 0)) - (end (match-end 0)) - (name (downcase (buffer-substring - (match-beginning 2) (match-end 2)))) - (pos (not (match-beginning 1)))) - (list beg end name pos)))) - -(defun enriched-get-file-width () - "Look for file width information on this line." - (save-excursion - (if (search-forward "Text-Width: " (+ (point) 1000) t) - (read (current-buffer))))) - -(defun enriched-remove-header () - "Remove file-format header at point." - (while (looking-at "^[-A-Za-z]+: .*\n") - (delete-region (point) (match-end 0))) - (if (looking-at "^\n") - (delete-char 1))) - -(defun enriched-decode-foreground (from to &optional color) - ;; XEmacs change - (let ((face (facemenu-get-face (intern (concat "fg:" color))))) - (if (not face) - (progn - (make-face face) - (message "Warning: Color \"%s\" can't be displayed." color))) - (list from to 'face face))) - -(defun enriched-decode-background (from to &optional color) - ;; XEmacs change - (let ((face (facemenu-get-face (intern (concat "bg:" color))))) - (if (not face) - (progn - (make-face face) - (message "Warning: Color \"%s\" can't be displayed." color))) - (list from to 'face face))) - -;;; enriched.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/executable.el --- a/lisp/modes/executable.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,266 +0,0 @@ -;;; executable.el --- base functionality for executable interpreter scripts - -;; Copyright (C) 1994, 1995, 1996 by Free Software Foundation, Inc. - -;; Author: Daniel.Pfeiffer@Informatik.START.dbp.de, fax (+49 69) 7588-2389 -;; Keywords: languages, unix - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34. - -;;; Commentary: - -;; executable.el is used by certain major modes to insert a suitable -;; #! line at the beginning of the file, if the file does not already -;; have one. - -;; Unless it has a magic number, a Unix file with executable mode is passed to -;; a new instance of the running shell (or to a Bourne shell if a csh is -;; running and the file starts with `:'). Only a shell can start such a file, -;; exec() cannot, which is why it is important to have a magic number in every -;; executable script. Such a magic number is made up by the characters `#!' -;; the filename of an interpreter (in COFF, ELF or somesuch format) and one -;; optional argument. - -;; This library is for certain major modes like sh-, awk-, perl-, tcl- or -;; makefile-mode to insert or update a suitable #! line at the beginning of -;; the file, if the file does not already have one and the file is not a -;; default file of that interpreter (like .profile or makefile). It also -;; makes the file executable if it wasn't, as soon as it's saved. - -;; It also allows debugging scripts, with an adaptation of compile, as far -;; as interpreters give out meaningful error messages. - -;; Modes that use this should nconc `executable-map' to the end of their own -;; keymap and `executable-font-lock-keywords' to the end of their own font -;; lock keywords. Their mode-setting commands should call -;; `executable-set-magic'. - -;;; Code: - - -(defgroup executable nil - "Base functionality for executable interpreter scripts" - :group 'processes) - - -(defcustom executable-insert 'other - "*What to do when newly found file has no or wrong magic number: - nil do nothing - t insert or update magic number - other insert or update magic number, but mark as unmodified. -When the insertion is marked as unmodified, you can save it with \\[write-file] RET. -This variable is used when `executable-set-magic' is called as a function, -e.g. when Emacs sets some Un*x interpreter script mode. -With \\[executable-set-magic], this is always treated as if it were `t'." - :type '(choice (const :tag "off" nil) - (const :tag "on" t) - symbol) - :group 'executable) - - -(defcustom executable-query 'function - "*If non-`nil', ask user before inserting or changing magic number. -When this is `function', only ask when called non-interactively." - :type '(choice (const :tag "Don't Ask" nil) - (const :tag "Ask" t) - (const :tag "Ask when non-interactive" function)) - :group 'executable) - - -(defcustom executable-magicless-file-regexp "/[Mm]akefile$\\|/\\.\\(z?profile\\|bash_profile\\|z?login\\|bash_login\\|z?logout\\|bash_logout\\|.+shrc\\|esrc\\|rcrc\\|[kz]shenv\\)$" - "*On files with this kind of name no magic is inserted or changed." - :type 'regexp - :group 'executable) - - -(defcustom executable-prefix "#! " - "*Interpreter magic number prefix inserted when there was no magic number." - :type 'string - :group 'executable) - - - -(defcustom executable-chmod 73 - "*After saving, if the file is not executable, set this mode. -This mode passed to `set-file-modes' is taken absolutely when negative, or -relative to the files existing modes. Do nothing if this is nil. -Typical values are 73 (+x) or -493 (rwxr-xr-x)." - :type 'integer - :group 'executable) - - -(defvar executable-command nil) - -(defcustom executable-self-display "tail" - "*Command you use with argument `+2' to make text files self-display. -Note that the like of `more' doesn't work too well under Emacs \\[shell]." - :type 'string - :group 'executable) - - -(defvar executable-font-lock-keywords - '(("\\`#!.*/\\([^ \t\n]+\\)" 1 font-lock-keyword-face t)) - "*Rules for highlighting executable scripts' magic number. -This can be included in `font-lock-keywords' by modes that call `executable'.") - - -(defvar executable-error-regexp-alist - '(;; /bin/xyz: syntax error at line 14: `(' unexpected - ;; /bin/xyz[5]: syntax error at line 8 : ``' unmatched - ("^\\(.*[^[/]\\)\\(\\[[0-9]+\\]\\)?: .* error .* line \\([0-9]+\\)" 1 3) - ;; /bin/xyz[27]: ehco: not found - ("^\\(.*[^/]\\)\\[\\([0-9]+\\)\\]: .*: " 1 2) - ;; /bin/xyz: syntax error near unexpected token `)' - ;; /bin/xyz: /bin/xyz: line 2: `)' - ("^\\(.*[^/]\\): [^0-9\n]+\n\\1: \\1: line \\([0-9]+\\):" 1 2) - ;; /usr/bin/awk: syntax error at line 5 of file /bin/xyz - (" error .* line \\([0-9]+\\) of file \\(.+\\)$" 2 1) - ;; /usr/bin/awk: calling undefined function toto - ;; input record number 3, file awktestdata - ;; source line 4 of file /bin/xyz - ("^[^ ].+\n\\( .+\n\\)* line \\([0-9]+\\) of file \\(.+\\)$" 3 2) - ;; makefile:1: *** target pattern contains no `%'. Stop. - ("^\\(.+\\):\\([0-9]+\\): " 1 2)) - "Alist of regexps used to match script errors. -See `compilation-error-regexp-alist'.") - -;; The C function openp slightly modified would do the trick fine -(defun executable-find (command) - "Search for COMMAND in exec-path and return the absolute file name. -Return nil if COMMAND is not found anywhere in `exec-path'." - (let ((list exec-path) - file) - (while list - (setq list (if (and (setq file (expand-file-name command (car list))) - (file-executable-p file) - (not (file-directory-p file))) - nil - (setq file nil) - (cdr list)))) - file)) - - -(defun executable-chmod () - "This gets called after saving a file to assure that it be executable. -You can set the absolute or relative mode in variable `executable-chmod' for -non-executable files." - (and executable-chmod - buffer-file-name - (or (file-executable-p buffer-file-name) - (set-file-modes buffer-file-name - (if (< executable-chmod 0) - (- executable-chmod) - (logior executable-chmod - (file-modes buffer-file-name))))))) - - -(defun executable-interpret (command) - "Run script with user-specified args, and collect output in a buffer. -While script runs asynchronously, you can use the \\[next-error] command -to find the next error." - (interactive (list (read-string "Run script: " - (or executable-command - buffer-file-name)))) - (require 'compile) - (save-some-buffers (not compilation-ask-about-save)) - (make-local-variable 'executable-command) - (compile-internal (setq executable-command command) - "No more errors." "Interpretation" - ;; Give it a simpler regexp to match. - nil executable-error-regexp-alist)) - - - -;;;###autoload -(defun executable-set-magic (interpreter &optional argument - no-query-flag insert-flag) - "Set this buffer's interpreter to INTERPRETER with optional ARGUMENT. -The variables `executable-magicless-file-regexp', `executable-prefix', -`executable-insert', `executable-query' and `executable-chmod' control -when and how magic numbers are inserted or replaced and scripts made -executable." - (interactive - (let* ((name (read-string "Name or file name of interpreter: ")) - (arg (read-string (format "Argument for %s: " name)))) - (list name arg (eq executable-query 'function) t))) - (setq interpreter (if (file-name-absolute-p interpreter) - interpreter - (or (executable-find interpreter) - (error "Interpreter %s not recognized" interpreter))) - argument (concat interpreter - (and argument (string< "" argument) " ") - argument)) - (or buffer-read-only - (if buffer-file-name - (string-match executable-magicless-file-regexp - buffer-file-name)) - (not (or insert-flag executable-insert)) - (> (point-min) 1) - (save-excursion - (let ((point (point-marker)) - (buffer-modified-p (buffer-modified-p))) - (goto-char (point-min)) - (make-local-hook 'after-save-hook) - (add-hook 'after-save-hook 'executable-chmod nil t) - (if (looking-at "#![ \t]*\\(.*\\)$") - (and (goto-char (match-beginning 1)) - ;; If the line ends in a space, - ;; don't offer to change it. - (not (= (char-after (1- (match-end 1))) ?\ )) - (not (string= argument - (buffer-substring (point) (match-end 1)))) - (if (or (not executable-query) no-query-flag - (save-window-excursion - ;; Make buffer visible before question. - (switch-to-buffer (current-buffer)) - (y-or-n-p (concat "Replace magic number by `" - executable-prefix argument "'? ")))) - (progn - (replace-match (concat executable-prefix argument) - t t nil 1) - (message "Magic number changed to `%s'" - (concat executable-prefix argument))))) - (insert executable-prefix argument ?\n) - (message "Magic number changed to `%s'" - (concat executable-prefix argument))) -;;; (or insert-flag -;;; (eq executable-insert t) -;;; (set-buffer-modified-p buffer-modified-p)) - ))) - interpreter) - - - -;;;###autoload -(defun executable-self-display () - "Turn a text file into a self-displaying Un*x command. -The magic number of such a command displays all lines but itself." - (interactive) - (if (eq this-command 'executable-self-display) - (setq this-command 'executable-set-magic)) - (executable-set-magic executable-self-display "+2")) - - - -(provide 'executable) - -;; executable.el ends here - - diff -r 43306a74e31c -r d44af0c54775 lisp/modes/hideif.el --- a/lisp/modes/hideif.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1053 +0,0 @@ -;;; hide-ifdef-mode.el --- hides selected code within ifdef. - -;; Copyright (C) 1988, 1994 Free Software Foundation, Inc. - -;; Author: Dan LaLiberte -;; Maintainer: FSF -;; Keywords: c, outlines - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34. - -;;; Commentary: - -;; To initialize, toggle the hide-ifdef minor mode with -;; -;; M-x hide-ifdef-mode -;; -;; This will set up key bindings and call hide-ifdef-mode-hook if it -;; has a value. To explicitly hide ifdefs using a buffer-local -;; define list (default empty), type -;; -;; M-x hide-ifdefs or C-c @ h -;; -;; Hide-ifdef suppresses the display of code that the preprocessor wouldn't -;; pass through. The support of constant expressions in #if lines is -;; limited to identifiers, parens, and the operators: &&, ||, !, and -;; "defined". Please extend this. -;; -;; The hidden code is marked by ellipses (...). Be -;; cautious when editing near ellipses, since the hidden text is -;; still in the buffer, and you can move the point into it and modify -;; text unawares. If you don't want to see the ellipses, set -;; selective-display-ellipses to nil. But this can be dangerous. -;; You can make your buffer read-only while hide-ifdef-hiding by setting -;; hide-ifdef-read-only to a non-nil value. You can toggle this -;; variable with hide-ifdef-toggle-read-only (C-c @ C-q). -;; -;; You can undo the effect of hide-ifdefs by typing -;; -;; M-x show-ifdefs or C-c @ s -;; -;; Use M-x hide-ifdef-define (C-c @ d) to define a symbol. -;; Use M-x hide-ifdef-undef (C-c @ u) to undefine a symbol. -;; -;; If you define or undefine a symbol while hide-ifdef-mode is in effect, -;; the display will be updated. Only the define list for the current -;; buffer will be affected. You can save changes to the local define -;; list with hide-ifdef-set-define-alist. This adds entries -;; to hide-ifdef-define-alist. -;; -;; If you have defined a hide-ifdef-mode-hook, you can set -;; up a list of symbols that may be used by hide-ifdefs as in the -;; following example: -;; -;; (setq hide-ifdef-mode-hook -;; '(lambda () -;; (if (not hide-ifdef-define-alist) -;; (setq hide-ifdef-define-alist -;; '((list1 ONE TWO) -;; (list2 TWO THREE) -;; ))) -;; (hide-ifdef-use-define-alist 'list2) ; use list2 by default -;; )) -;; -;; You can call hide-ifdef-use-define-alist (C-c u) at any time to specify -;; another list to use. -;; -;; To cause ifdefs to be hidden as soon as hide-ifdef-mode is called, -;; set hide-ifdef-initially to non-nil. -;; -;; If you set hide-ifdef-lines to t, hide-ifdefs hides all the #ifdef lines. -;; In the absence of highlighting, that might be a bad idea. If you set -;; hide-ifdef-lines to nil (the default), the surrounding preprocessor -;; lines will be displayed. That can be confusing in its own -;; right. Other variations on display are possible, but not much -;; better. -;; -;; You can explicitly hide or show individual ifdef blocks irrespective -;; of the define list by using hide-ifdef-block and show-ifdef-block. -;; -;; You can move the point between ifdefs with forward-ifdef, backward-ifdef, -;; up-ifdef, down-ifdef, next-ifdef, and previous-ifdef. -;; -;; If you have minor-mode-alist in your mode line (the default) two labels -;; may appear. "Ifdef" will appear when hide-ifdef-mode is active. "Hiding" -;; will appear when text may be hidden ("hide-ifdef-hiding" is non-nil). -;; -;; Written by Brian Marick, at Gould, Computer Systems Division, Urbana IL. -;; Extensively modified by Daniel LaLiberte (while at Gould). -;; -;; You may freely modify and distribute this, but keep a record -;; of modifications and send comments to: -;; liberte@a.cs.uiuc.edu or ihnp4!uiucdcs!liberte -;; I will continue to upgrade hide-ifdef-mode -;; with your contributions. - -;;; Code: - -(require 'cc-mode) - -(defvar hide-ifdef-mode-submap nil - "Keymap used with Hide-Ifdef mode.") - -(defvar hide-ifdef-mode-map nil - "Keymap used with Hide-Ifdef mode.") - -(defconst hide-ifdef-mode-prefix-key "\C-c@" - "Prefix key for all Hide-Ifdef mode commands.") - -;; Set up the submap that goes after the prefix key. -(if hide-ifdef-mode-submap - () ; Don't redefine it. - (setq hide-ifdef-mode-submap (make-sparse-keymap)) - (define-key hide-ifdef-mode-submap "d" 'hide-ifdef-define) - (define-key hide-ifdef-mode-submap "u" 'hide-ifdef-undef) - (define-key hide-ifdef-mode-submap "D" 'hide-ifdef-set-define-alist) - (define-key hide-ifdef-mode-submap "U" 'hide-ifdef-use-define-alist) - - (define-key hide-ifdef-mode-submap "h" 'hide-ifdefs) - (define-key hide-ifdef-mode-submap "s" 'show-ifdefs) - (define-key hide-ifdef-mode-submap "\C-d" 'hide-ifdef-block) - (define-key hide-ifdef-mode-submap "\C-s" 'show-ifdef-block) - - (define-key hide-ifdef-mode-submap "\C-q" 'hide-ifdef-toggle-read-only) - (let ((where (where-is-internal 'toggle-read-only nil t))) - (if where - (define-key hide-ifdef-mode-submap - where - 'hide-ifdef-toggle-outside-read-only))) - ) - -;; Set up the mode's main map, which leads via the prefix key to the submap. -(if hide-ifdef-mode-map - () - (setq hide-ifdef-mode-map (make-sparse-keymap)) - (define-key hide-ifdef-mode-map hide-ifdef-mode-prefix-key - hide-ifdef-mode-submap)) - -(defvar hide-ifdef-mode nil - "Non-nil when hide-ifdef-mode is activated.") - -(defvar hide-ifdef-hiding nil - "Non-nil when text may be hidden.") - -(or (assq 'hide-ifdef-hiding minor-mode-alist) - (setq minor-mode-alist - (cons '(hide-ifdef-hiding " Hiding") - minor-mode-alist))) - -;(or (assq 'hide-ifdef-mode minor-mode-alist) -; (setq minor-mode-alist -; (cons '(hide-ifdef-mode " Ifdef") -; minor-mode-alist))) -;; XEmacs: do it right. -;;;###autoload -(add-minor-mode 'hide-ifdef-mode " Ifdef" 'hide-ifdef-mode-map) - -;; fix c-mode syntax table so we can recognize whole symbols. -(defvar hide-ifdef-syntax-table - (copy-syntax-table c-mode-syntax-table) - "Syntax table used for tokenizing #if expressions.") - -(modify-syntax-entry ?_ "w" hide-ifdef-syntax-table) -(modify-syntax-entry ?& "." hide-ifdef-syntax-table) -(modify-syntax-entry ?\| "." hide-ifdef-syntax-table) - -;;;###autoload -(defun hide-ifdef-mode (arg) - "Toggle Hide-Ifdef mode. This is a minor mode, albeit a large one. -With ARG, turn Hide-Ifdef mode on if arg is positive, off otherwise. -In Hide-Ifdef mode, code within #ifdef constructs that the C preprocessor -would eliminate may be hidden from view. Several variables affect -how the hiding is done: - -hide-ifdef-env - An association list of defined and undefined symbols for the - current buffer. Initially, the global value of `hide-ifdef-env' - is used. - -hide-ifdef-define-alist - An association list of defined symbol lists. - Use `hide-ifdef-set-define-alist' to save the current `hide-ifdef-env' - and `hide-ifdef-use-define-alist' to set the current `hide-ifdef-env' - from one of the lists in `hide-ifdef-define-alist'. - -hide-ifdef-lines - Set to non-nil to not show #if, #ifdef, #ifndef, #else, and - #endif lines when hiding. - -hide-ifdef-initially - Indicates whether `hide-ifdefs' should be called when Hide-Ifdef mode - is activated. - -hide-ifdef-read-only - Set to non-nil if you want to make buffers read only while hiding. - After `show-ifdefs', read-only status is restored to previous value. - -\\{hide-ifdef-mode-map}" - - (interactive "P") - (make-local-variable 'hide-ifdef-mode) - (setq hide-ifdef-mode - (if (null arg) - (not hide-ifdef-mode) - (> (prefix-numeric-value arg) 0))) - - ;; XEmacs change - (redraw-modeline) - - (if hide-ifdef-mode - (progn - ; fix c-mode syntax table so we can recognize whole symbols. - ;; XEmacs: Maybe we don't need this any more with cc-mode? -sb - ;; (modify-syntax-entry ?_ "w") - ;; (modify-syntax-entry ?& ".") - ;; (modify-syntax-entry ?\| ".") - - ; inherit global values - (make-local-variable 'hide-ifdef-env) - (setq hide-ifdef-env (default-value 'hide-ifdef-env)) - - (make-local-variable 'hide-ifdef-hiding) - (setq hide-ifdef-hiding (default-value 'hide-ifdef-hiding)) - - (make-local-variable 'hif-outside-read-only) - (setq hif-outside-read-only buffer-read-only) - - (run-hooks 'hide-ifdef-mode-hook) - - (if hide-ifdef-initially - (hide-ifdefs) - (show-ifdefs)) - (message "Enter Hide-Ifdef mode") - ) - ; else end hide-ifdef-mode - (if hide-ifdef-hiding - (show-ifdefs)) - (message "Exit Hide-Ifdef mode") - )) - - -;; from outline.el with docstring fixed. -(defun hif-outline-flag-region (from to flag) - "Hides or shows lines from FROM to TO, according to FLAG. -If FLAG is \\n (newline character) then text is shown, while if FLAG is \\^M -\(control-M) the text is hidden." - (let ((modp (buffer-modified-p))) - (unwind-protect (progn - (subst-char-in-region from to - (if (= flag ?\n) ?\^M ?\n) - flag t) ) - (set-buffer-modified-p modp)) - )) - -(defun hif-show-all () - "Show all of the text in the current buffer." - (interactive) - (hif-outline-flag-region (point-min) (point-max) ?\n)) - -;; By putting this on after-revert-hook, we arrange that it only -;; does anything when revert-buffer avoids turning off the mode. -;; (That can happen in VC.) -(defun hif-before-revert-function () - (and hide-ifdef-mode hide-ifdef-hiding - (hide-ifdefs t))) -(add-hook 'after-revert-hook 'hif-before-revert-function) - -(defun hide-ifdef-region (start end) - "START is the start of a #if or #else form. END is the ending part. -Everything including these lines is made invisible." - (hif-outline-flag-region start end ?\^M) - ) - -(defun hif-show-ifdef-region (start end) - "Everything between START and END is made visible." - (hif-outline-flag-region start end ?\n) - ) - - - -;===%%SF%% evaluation (Start) === - -;; It is not useful to set this to anything but `eval'. -;; In fact, the variable might as well be eliminated. -(defvar hide-ifdef-evaluator 'eval - "The function to use to evaluate a form. -The evaluator is given a canonical form and returns t if text under -that form should be displayed.") - -(defvar hif-undefined-symbol nil - "...is by default considered to be false.") - -(defvar hide-ifdef-env nil - "An alist of defined symbols and their values.") - - -(defun hif-set-var (var value) - "Prepend (var value) pair to hide-ifdef-env." - (setq hide-ifdef-env (cons (cons var value) hide-ifdef-env))) - - -(defun hif-lookup (var) -; (message "hif-lookup %s" var) - (let ((val (assoc var hide-ifdef-env))) - (if val - (cdr val) - hif-undefined-symbol))) - -(defun hif-defined (var) - (hif-lookup var) - ; when #if expressions are fully supported, defined result should be 1 - ; (if (assoc var hide-ifdef-env) - ; 1 - ; nil) -) - - -;===%%SF%% evaluation (End) === - - - -;===%%SF%% parsing (Start) === -;;; The code that understands what ifs and ifdef in files look like. - -(defconst hif-cpp-prefix "\\(^\\|\r\\)[ \t]*#[ \t]*") -(defconst hif-ifndef-regexp (concat hif-cpp-prefix "ifndef")) -(defconst hif-ifx-regexp (concat hif-cpp-prefix "if\\(n?def\\)?[ \t]+")) -(defconst hif-else-regexp (concat hif-cpp-prefix "else")) -(defconst hif-endif-regexp (concat hif-cpp-prefix "endif")) -(defconst hif-ifx-else-endif-regexp - (concat hif-ifx-regexp "\\|" hif-else-regexp "\\|" hif-endif-regexp)) - - -(defun hif-infix-to-prefix (token-list) - "Convert list of tokens in infix into prefix list" -; (message "hif-infix-to-prefix: %s" token-list) - (if (= 1 (length token-list)) - (` (hif-lookup (quote (, (car token-list))))) - (hif-parse-if-exp token-list)) - ) - -; pattern to match initial identifier, !, &&, ||, (, or ). -; Added ==, + and -: garyo@avs.com 8/9/94 -(defconst hif-token-regexp "^\\(!\\|&&\\|||\\|[!=]=\\|[()+-]\\|\\w+\\)") -(defconst hif-end-of-comment "\\*/") - - -(defun hif-tokenize (expr-string) - "Separate string into a list of tokens" - (let ((token-list nil) - (expr-start 0) - (expr-length (length expr-string)) - (current-syntax-table (syntax-table))) - (unwind-protect - (progn - (set-syntax-table hide-ifdef-syntax-table) - (while (< expr-start expr-length) -; (message "expr-start = %d" expr-start) (sit-for 1) - (cond - ((string-match "^[ \t]+" expr-string expr-start) - ;; skip whitespace - (setq expr-start (match-end 0)) - ;; stick newline in string so ^ matches on the next string-match - (aset expr-string (1- expr-start) ?\n)) - - ((string-match "^/\\*" expr-string expr-start) - (setq expr-start (match-end 0)) - (aset expr-string (1- expr-start) ?\n) - (or - (string-match hif-end-of-comment - expr-string expr-start) ; eat comment - (string-match "$" expr-string expr-start)) ; multi-line comment - (setq expr-start (match-end 0)) - (aset expr-string (1- expr-start) ?\n)) - - ((string-match "^//" expr-string expr-start) - (string-match "$" expr-string expr-start) - (setq expr-start (match-end 0))) - - ((string-match hif-token-regexp expr-string expr-start) - (let ((token (substring expr-string expr-start (match-end 0)))) - (setq expr-start (match-end 0)) - (aset expr-string (1- expr-start) ?\n) -; (message "token: %s" token) (sit-for 1) - (setq token-list - (cons - (cond - ((string-equal token "||") 'or) - ((string-equal token "&&") 'and) - ((string-equal token "==") 'equal) - ((string-equal token "!=") 'hif-notequal) - ((string-equal token "!") 'not) - ((string-equal token "defined") 'hif-defined) - ((string-equal token "(") 'lparen) - ((string-equal token ")") 'rparen) - ((string-equal token "+") 'hif-plus) - ((string-equal token "-") 'hif-minus) - (t (intern token))) - token-list)))) - (t (error "Bad #if expression: %s" expr-string))))) - (set-syntax-table current-syntax-table)) - (nreverse token-list))) - -;;;----------------------------------------------------------------- -;;; Translate C preprocessor #if expressions using recursive descent. -;;; This parser is limited to the operators &&, ||, !, and "defined". -;;; Added ==, !=, +, and -. Gary Oberbrunner, garyo@avs.com, 8/9/94 - -(defun hif-parse-if-exp (token-list) - "Parse the TOKEN-LIST. Return translated list in prefix form." - (hif-nexttoken) - (prog1 - (hif-expr) - (if token ; is there still a token? - (error "Error: unexpected token: %s" token)))) - -(defun hif-nexttoken () - "Pop the next token from token-list into the let variable \"token\"." - (setq token (car token-list)) - (setq token-list (cdr token-list)) - token) - -(defun hif-expr () - "Parse an expression as found in #if. - expr : term | expr '||' term." - (let ((result (hif-term))) - (while (eq token 'or) - (hif-nexttoken) - (setq result (list 'or result (hif-term)))) - result)) - -(defun hif-term () - "Parse a term : eq-expr | term '&&' eq-expr." - (let ((result (hif-eq-expr))) - (while (eq token 'and) - (hif-nexttoken) - (setq result (list 'and result (hif-eq-expr)))) - result)) - -(defun hif-eq-expr () - "Parse an eq-expr : math | eq-expr '=='|'!=' math." - (let ((result (hif-math)) - (eq-token nil)) - (while (or (eq token 'equal) (eq token 'hif-notequal)) - (setq eq-token token) - (hif-nexttoken) - (setq result (list eq-token result (hif-math)))) - result)) - -(defun hif-math () - "Parse an expression with + or - and simpler things. - math : factor | math '+|-' factor." - (let ((result (hif-factor)) - (math-op nil)) - (while (or (eq token 'hif-plus) (eq token 'hif-minus)) - (setq math-op token) - (hif-nexttoken) - (setq result (list math-op result (hif-factor)))) - result)) - -(defun hif-factor () - "Parse a factor: '!' factor | '(' expr ')' | 'defined(' id ')' | id." - (cond - ((eq token 'not) - (hif-nexttoken) - (list 'not (hif-factor))) - - ((eq token 'lparen) - (hif-nexttoken) - (let ((result (hif-expr))) - (if (not (eq token 'rparen)) - (error "Bad token in parenthesized expression: %s" token) - (hif-nexttoken) - result))) - - ((eq token 'hif-defined) - (hif-nexttoken) - (if (not (eq token 'lparen)) - (error "Error: expected \"(\" after \"defined\"")) - (hif-nexttoken) - (let ((ident token)) - (if (memq token '(or and not hif-defined lparen rparen)) - (error "Error: unexpected token: %s" token)) - (hif-nexttoken) - (if (not (eq token 'rparen)) - (error "Error: expected \")\" after identifier")) - (hif-nexttoken) - (` (hif-defined (quote (, ident)))) - )) - - (t ; identifier - (let ((ident token)) - (if (memq ident '(or and)) - (error "Error: missing identifier")) - (hif-nexttoken) - (` (hif-lookup (quote (, ident)))) - )) - )) - -(defun hif-mathify (val) - "Treat VAL as a number: if it's t or nil, use 1 or 0." - (cond ((eq val t) - 1) - ((null val) - 0) - (t val))) - -(defun hif-plus (a b) - "Like ordinary plus but treat t and nil as 1 and 0." - (+ (hif-mathify a) (hif-mathify b))) -(defun hif-minus (a b) - "Like ordinary minus but treat t and nil as 1 and 0." - (- (hif-mathify a) (hif-mathify b))) -(defun hif-notequal (a b) - "Like (not (equal A B)) but as one symbol." - (not (equal a b))) - -;;;----------- end of parser ----------------------- - - -(defun hif-canonicalize () - "When at beginning of #ifX, returns a Lisp expression for its condition." - (save-excursion - (let ((negate (looking-at hif-ifndef-regexp))) - (re-search-forward hif-ifx-regexp) - (let* ((expr-string - (buffer-substring (point) - (progn (skip-chars-forward "^\n\r") (point)))) - (expr (hif-infix-to-prefix (hif-tokenize expr-string)))) -; (message "hif-canonicalized: %s" expr) - (if negate - (list 'not expr) - expr))))) - - -(defun hif-find-any-ifX () - "Move to next #if..., or #ifndef, at point or after." -; (message "find ifX at %d" (point)) - (prog1 - (re-search-forward hif-ifx-regexp (point-max) t) - (beginning-of-line))) - - -(defun hif-find-next-relevant () - "Move to next #if..., #else, or #endif, after the current line." -; (message "hif-find-next-relevant at %d" (point)) - (end-of-line) - ; avoid infinite recursion by only going to beginning of line if match found - (if (re-search-forward hif-ifx-else-endif-regexp (point-max) t) - (beginning-of-line))) - -(defun hif-find-previous-relevant () - "Move to previous #if..., #else, or #endif, before the current line." -; (message "hif-find-previous-relevant at %d" (point)) - (beginning-of-line) - ; avoid infinite recursion by only going to beginning of line if match found - (if (re-search-backward hif-ifx-else-endif-regexp (point-min) t) - (beginning-of-line))) - - -(defun hif-looking-at-ifX () ;; Should eventually see #if - (looking-at hif-ifx-regexp)) -(defun hif-looking-at-endif () - (looking-at hif-endif-regexp)) -(defun hif-looking-at-else () - (looking-at hif-else-regexp)) - - - -(defun hif-ifdef-to-endif () - "If positioned at #ifX or #else form, skip to corresponding #endif." -; (message "hif-ifdef-to-endif at %d" (point)) (sit-for 1) - (hif-find-next-relevant) - (cond ((hif-looking-at-ifX) - (hif-ifdef-to-endif) ; find endif of nested if - (hif-ifdef-to-endif)) ; find outer endif or else - ((hif-looking-at-else) - (hif-ifdef-to-endif)) ; find endif following else - ((hif-looking-at-endif) - 'done) - (t - (error "Mismatched #ifdef #endif pair")))) - - -(defun hif-endif-to-ifdef () - "If positioned at #endif form, skip backward to corresponding #ifX." -; (message "hif-endif-to-ifdef at %d" (point)) - (let ((start (point))) - (hif-find-previous-relevant) - (if (= start (point)) - (error "Mismatched #ifdef #endif pair"))) - (cond ((hif-looking-at-endif) - (hif-endif-to-ifdef) ; find beginning of nested if - (hif-endif-to-ifdef)) ; find beginning of outer if or else - ((hif-looking-at-else) - (hif-endif-to-ifdef)) - ((hif-looking-at-ifX) - 'done) - (t))) ; never gets here - - -(defun forward-ifdef (&optional arg) - "Move point to beginning of line of the next ifdef-endif. -With argument, do this that many times." - (interactive "p") - (or arg (setq arg 1)) - (if (< arg 0) - (backward-ifdef (- arg))) - (while (< 0 arg) - (setq arg (- arg)) - (let ((start (point))) - (if (not (hif-looking-at-ifX)) - (hif-find-next-relevant)) - (if (hif-looking-at-ifX) - (hif-ifdef-to-endif) - (goto-char start) - (error "No following #ifdef") - )))) - - -(defun backward-ifdef (&optional arg) - "Move point to beginning of the previous ifdef-endif. -With argument, do this that many times." - (interactive "p") - (or arg (setq arg 1)) - (if (< arg 0) - (forward-ifdef (- arg))) - (while (< 0 arg) - (setq arg (1- arg)) - (beginning-of-line) - (let ((start (point))) - (if (not (hif-looking-at-endif)) - (hif-find-previous-relevant)) - (if (hif-looking-at-endif) - (hif-endif-to-ifdef) - (goto-char start) - (error "No previous #ifdef"))))) - - -(defun down-ifdef () - "Move point to beginning of nested ifdef or else-part." - (interactive) - (let ((start (point))) - (hif-find-next-relevant) - (if (or (hif-looking-at-ifX) (hif-looking-at-else)) - () - (goto-char start) - (error "No following #ifdef")))) - - -(defun up-ifdef () - "Move point to beginning of enclosing ifdef or else-part." - (interactive) - (beginning-of-line) - (let ((start (point))) - (if (not (hif-looking-at-endif)) - (hif-find-previous-relevant)) - (if (hif-looking-at-endif) - (hif-endif-to-ifdef)) - (if (= start (point)) - (error "No previous #ifdef")))) - -(defun next-ifdef (&optional arg) - "Move to the beginning of the next #ifX, #else, or #endif. -With argument, do this that many times." - (interactive "p") - (or arg (setq arg 1)) - (if (< arg 0) - (previous-ifdef (- arg))) - (while (< 0 arg) - (setq arg (1- arg)) - (hif-find-next-relevant) - (if (eolp) - (progn - (beginning-of-line) - (error "No following #ifdefs, #elses, or #endifs"))))) - -(defun previous-ifdef (&optional arg) - "Move to the beginning of the previous #ifX, #else, or #endif. -With argument, do this that many times." - (interactive "p") - (or arg (setq arg 1)) - (if (< arg 0) - (next-ifdef (- arg))) - (while (< 0 arg) - (setq arg (1- arg)) - (let ((start (point))) - (hif-find-previous-relevant) - (if (= start (point)) - (error "No previous #ifdefs, #elses, or #endifs"))))) - - -;===%%SF%% parsing (End) === - - -;===%%SF%% hide-ifdef-hiding (Start) === - - -;;; A range is a structure with four components: -;;; ELSE-P True if there was an else clause for the ifdef. -;;; START The start of the range. (beginning of line) -;;; ELSE The else marker (beginning of line) -;;; Only valid if ELSE-P is true. -;;; END The end of the range. (beginning of line) - -(defun hif-make-range (else-p start end &optional else) - (list else-p start else end)) - -(defun hif-range-else-p (range) (elt range 0)) -(defun hif-range-start (range) (elt range 1)) -(defun hif-range-else (range) (elt range 2)) -(defun hif-range-end (range) (elt range 3)) - - - -;;; Find-Range -;;; The workhorse, it delimits the #if region. Reasonably simple: -;;; Skip until an #else or #endif is found, remembering positions. If -;;; an #else was found, skip some more, looking for the true #endif. - -(defun hif-find-range () - "Returns a Range structure describing the current #if region. -Point is left unchanged." -; (message "hif-find-range at %d" (point)) - (save-excursion - (beginning-of-line) - (let ((start (point)) - (else-p nil) - (else nil) - (end nil)) - ;; Part one. Look for either #endif or #else. - ;; This loop-and-a-half dedicated to E. Dijkstra. - (hif-find-next-relevant) - (while (hif-looking-at-ifX) ; Skip nested ifdef - (hif-ifdef-to-endif) - (hif-find-next-relevant)) - ;; Found either a #else or an #endif. - (cond ((hif-looking-at-else) - (setq else-p t) - (setq else (point))) - (t - (setq end (point)) ; (save-excursion (end-of-line) (point)) - )) - ;; If found #else, look for #endif. - (if else-p - (progn - (hif-find-next-relevant) - (while (hif-looking-at-ifX) ; Skip nested ifdef - (hif-ifdef-to-endif) - (hif-find-next-relevant)) - (if (hif-looking-at-else) - (error "Found two elses in a row? Broken!")) - (setq end (point)) ; (save-excursion (end-of-line) (point)) - )) - (hif-make-range else-p start end else)))) - - -;;; A bit slimy. -;;; NOTE: If there's an #ifdef at the beginning of the file, we can't -;;; hide it. There's no previous newline to replace. If we added -;;; one, we'd throw off all the counts. Feh. - -(defun hif-hide-line (point) - "Hide the line containing point. Does nothing if `hide-ifdef-lines' is nil." - (if hide-ifdef-lines - (save-excursion - (goto-char point) - (let ((modp (buffer-modified-p))) - (unwind-protect - (progn - (beginning-of-line) - (if (not (= (point) 1)) - (hide-ifdef-region (1- (point)) (point)))) - (set-buffer-modified-p modp)) - )) - )) - - -;;; Hif-Possibly-Hide -;;; There are four cases. The #ifX expression is "taken" if it -;;; the hide-ifdef-evaluator returns T. Presumably, this means the code -;;; inside the #ifdef would be included when the program was -;;; compiled. -;;; -;;; Case 1: #ifX taken, and there's an #else. -;;; The #else part must be hidden. The #if (then) part must be -;;; processed for nested #ifX's. -;;; Case 2: #ifX taken, and there's no #else. -;;; The #if part must be processed for nested #ifX's. -;;; Case 3: #ifX not taken, and there's an #else. -;;; The #if part must be hidden. The #else part must be processed -;;; for nested #ifs. -;;; Case 4: #ifX not taken, and there's no #else. -;;; The #ifX part must be hidden. -;;; -;;; Further processing is done by narrowing to the relevant region -;;; and just recursively calling hide-ifdef-guts. -;;; -;;; When hif-possibly-hide returns, point is at the end of the -;;; possibly-hidden range. - -(defun hif-recurse-on (start end) - "Call `hide-ifdef-guts' after narrowing to end of START line and END line." - (save-excursion - (save-restriction - (goto-char start) - (end-of-line) - (narrow-to-region (point) end) - (hide-ifdef-guts)))) - -(defun hif-possibly-hide () - "Called at #ifX expression, this hides those parts that should be hidden. -It uses the judgement of `hide-ifdef-evaluator'." -; (message "hif-possibly-hide") (sit-for 1) - (let ((test (hif-canonicalize)) - (range (hif-find-range))) -; (message "test = %s" test) (sit-for 1) - - (hif-hide-line (hif-range-end range)) - (if (funcall hide-ifdef-evaluator test) - (cond ((hif-range-else-p range) ; case 1 - (hif-hide-line (hif-range-else range)) - (hide-ifdef-region (hif-range-else range) - (1- (hif-range-end range))) - (hif-recurse-on (hif-range-start range) - (hif-range-else range))) - (t ; case 2 - (hif-recurse-on (hif-range-start range) - (hif-range-end range)))) - (cond ((hif-range-else-p range) ; case 3 - (hif-hide-line (hif-range-else range)) - (hide-ifdef-region (hif-range-start range) - (1- (hif-range-else range))) - (hif-recurse-on (hif-range-else range) - (hif-range-end range))) - (t ; case 4 - (hide-ifdef-region (point) - (1- (hif-range-end range)))) - )) - (hif-hide-line (hif-range-start range)) ; Always hide start. - (goto-char (hif-range-end range)) - (end-of-line) - )) - - - -(defun hide-ifdef-guts () - "Does most of the work of `hide-ifdefs'. -It does not do the work that's pointless to redo on a recursive entry." -; (message "hide-ifdef-guts") - (save-excursion - (goto-char (point-min)) - (while (hif-find-any-ifX) - (hif-possibly-hide)))) - -;===%%SF%% hide-ifdef-hiding (End) === - - -;===%%SF%% exports (Start) === - -;;;###autoload -(defvar hide-ifdef-initially nil - "*Non-nil means call `hide-ifdefs' when Hide-Ifdef mode is first activated.") - -;;;###autoload -(defvar hide-ifdef-read-only nil - "*Set to non-nil if you want buffer to be read-only while hiding text.") - -(defvar hif-outside-read-only nil - "Internal variable. Saves the value of `buffer-read-only' while hiding.") - -;;;###autoload -(defvar hide-ifdef-lines nil - "*Non-nil means hide the #ifX, #else, and #endif lines.") - -(defun hide-ifdef-toggle-read-only () - "Toggle hide-ifdef-read-only." - (interactive) - (setq hide-ifdef-read-only (not hide-ifdef-read-only)) - (message "Hide-Read-Only %s" - (if hide-ifdef-read-only "ON" "OFF")) - (if hide-ifdef-hiding - (setq buffer-read-only (or hide-ifdef-read-only hif-outside-read-only))) - ;; XEmacs change - (redraw-modeline)) - -(defun hide-ifdef-toggle-outside-read-only () - "Replacement for `toggle-read-only' within Hide-Ifdef mode." - (interactive) - (setq hif-outside-read-only (not hif-outside-read-only)) - (message "Read only %s" - (if hif-outside-read-only "ON" "OFF")) - (setq buffer-read-only - (or (and hide-ifdef-hiding hide-ifdef-read-only) - hif-outside-read-only) - ) - ;; XEmacs change - (redraw-modeline)) - - -(defun hide-ifdef-define (var) - "Define a VAR so that #ifdef VAR would be included." - (interactive "SDefine what? ") - (hif-set-var var 1) - (if hide-ifdef-hiding (hide-ifdefs))) - -(defun hide-ifdef-undef (var) - "Undefine a VAR so that #ifdef VAR would not be included." - (interactive "SUndefine what? ") - (hif-set-var var nil) - (if hide-ifdef-hiding (hide-ifdefs))) - - -(defun hide-ifdefs (&optional nomsg) - "Hide the contents of some #ifdefs. -Assume that defined symbols have been added to `hide-ifdef-env'. -The text hidden is the text that would not be included by the C -preprocessor if it were given the file with those symbols defined. - -Turn off hiding by calling `show-ifdefs'." - - (interactive) - (message "Hiding...") - (setq hif-outside-read-only buffer-read-only) - (if (not hide-ifdef-mode) - (hide-ifdef-mode 1)) ; turn on hide-ifdef-mode - (if hide-ifdef-hiding - (show-ifdefs)) ; Otherwise, deep confusion. - (let ((inhibit-read-only t)) - (setq selective-display t) - (setq hide-ifdef-hiding t) - (hide-ifdef-guts)) - (setq buffer-read-only (or hide-ifdef-read-only hif-outside-read-only)) - (or nomsg - (message "Hiding done"))) - - -(defun show-ifdefs () - "Cancel the effects of `hide-ifdef': show the contents of all #ifdefs." - (interactive) - (setq buffer-read-only hif-outside-read-only) - (setq selective-display nil) ; defaults - (let ((inhibit-read-only t)) - (hif-show-all)) - (setq hide-ifdef-hiding nil)) - - -(defun hif-find-ifdef-block () - "Utility for hide and show `ifdef-block'. -Set top and bottom of ifdef block." - (let (max-bottom) - (save-excursion - (beginning-of-line) - (if (not (or (hif-looking-at-else) (hif-looking-at-ifX))) - (up-ifdef)) - (setq top (point)) - (hif-ifdef-to-endif) - (setq max-bottom (1- (point)))) - (save-excursion - (beginning-of-line) - (if (not (hif-looking-at-endif)) - (hif-find-next-relevant)) - (while (hif-looking-at-ifX) - (hif-ifdef-to-endif) - (hif-find-next-relevant)) - (setq bottom (min max-bottom (1- (point))))))) - - -(defun hide-ifdef-block () - "Hide the ifdef block (true or false part) enclosing or before the cursor." - (interactive) - (if (not hide-ifdef-mode) - (hide-ifdef-mode 1)) - (setq selective-display t) - (let (top bottom (inhibit-read-only t)) - (hif-find-ifdef-block) ; set top and bottom - dynamic scoping - (hide-ifdef-region top bottom) - (if hide-ifdef-lines - (progn - (hif-hide-line top) - (hif-hide-line (1+ bottom)))) - (setq hide-ifdef-hiding t)) - (setq buffer-read-only (or hide-ifdef-read-only hif-outside-read-only))) - - -(defun show-ifdef-block () - "Show the ifdef block (true or false part) enclosing or before the cursor." - (interactive) - (let ((inhibit-read-only t)) - (if hide-ifdef-lines - (save-excursion - (beginning-of-line) - (hif-show-ifdef-region (1- (point)) (progn (end-of-line) (point)))) - - (let (top bottom) - (hif-find-ifdef-block) - (hif-show-ifdef-region (1- top) bottom))))) - - -;;; definition alist support - -(defvar hide-ifdef-define-alist nil - "A global assoc list of pre-defined symbol lists") - -(defun hif-compress-define-list (env) - "Compress the define list ENV into a list of defined symbols only." - (let ((defs (mapcar '(lambda (arg) - (if (hif-lookup (car arg)) (car arg))) - env)) - (new-defs nil)) - (while defs - (if (car defs) - (setq new-defs (cons (car defs) new-defs))) - (setq defs (cdr defs))) - new-defs)) - -(defun hide-ifdef-set-define-alist (name) - "Set the association for NAME to `hide-ifdef-env'." - (interactive "SSet define list: ") - (setq hide-ifdef-define-alist - (cons (cons name (hif-compress-define-list hide-ifdef-env)) - hide-ifdef-define-alist))) - -(defun hide-ifdef-use-define-alist (name) - "Set `hide-ifdef-env' to the define list specified by NAME." - (interactive "SUse define list: ") - (let ((define-list (assoc name hide-ifdef-define-alist))) - (if define-list - (setq hide-ifdef-env - (mapcar '(lambda (arg) (cons arg t)) - (cdr define-list))) - (error "No define list for %s" name)) - (if hide-ifdef-hiding (hide-ifdefs)))) - -(provide 'hideif) - -;;; hideif.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/hideshow.el --- a/lisp/modes/hideshow.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,492 +0,0 @@ -;;; hideshow.el --- minor mode cmds to selectively display blocks of code - -;; Copyright (C) 1994,1995,1996 Free Software Foundation - -;; Author: Thien-Thi Nguyen -;; Version: 3.4 -;; Keywords: C C++ lisp tools editing -;; Time-of-Day-Author-Most-Likely-to-be-Recalcitrant: early morning - -;; This file is part of XEmacs. - -;; XEmacs 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 of the License, or -;; (at your option) any later version. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34. - -;; LCD Archive Entry: -;; hideshow|Thien-Thi Nguyen|ttn@netcom.com| -;; minor mode commands to selectively display blocks of code| -;; 18-Oct-1994|3.4|~/modes/hideshow.el.Z| - -;;; Commentary: - -;; This file provides `hs-minor-mode'. When active, six commands: -;; hs-{hide,show}-{all,block}, hs-show-region and hs-minor-mode -;; are available. They implement block hiding and showing. Blocks are -;; defined in mode-specific way. In c-mode or c++-mode, they are simply -;; curly braces, while in lisp-ish modes they are parens. Multi-line -;; comments (c-mode) can also be hidden. The command M-x hs-minor-mode -;; toggles the minor mode or sets it (similar to outline minor mode). -;; See documentation for each command for more info. -;; -;; The variable `hs-unbalance-handler-method' controls hideshow's behavior -;; in the case of "unbalanced parentheses". See doc for more info. -;; -;; 30 May 1997 Pete Ware (ware@cis.ohio-state.edu) -;; * Modified to use easymenu interface. -;; * Removed tests for XEmacs vs GNU Emacs -;; * Got it to work under XEmacs - -;; Suggested usage: - -;; (load-library "hideshow") -;; (defun my-hs-setup () "enables hideshow and binds some commands" -;; (hs-minor-mode 1) -;; (define-key hs-minor-mode-map "\C-ch" 'hs-hide-block) -;; (define-key hs-minor-mode-map "\C-cs" 'hs-show-block) -;; (define-key hs-minro-mode-map "\C-cH" 'hs-hide-all) -;; (define-key hs-minro-mode-map "\C-cS" 'hs-show-all) -;; (define-key hs-minor-mode-map "\C-cR" 'hs-show-region)) -;; (add-hook 'X-mode-hook 'my-hs-setup t) ; other modes similarly -;; -;; where X = {emacs-lisp,c,c++,perl,...}. See the doc for the variable -;; `hs-special-modes-alist' if you'd like to use hideshow w/ other modes. - -;; Etc: - -;; Bug reports and fixes welcome (comments, too). Thanks go to -;; Dean Andrews -;; Preston F. Crow -;; Gael Marziou -;; Keith Sheffield -;; Jan Djarv -;; Lars Lindberg -;; Alf-Ivar Holm -;; for valuable feedback, code and bug reports. - -;;; Code: - -(require 'easymenu) - -;;;---------------------------------------------------------------------------- -;;; user-configurable variables - -(defgroup hideshow nil - "Selectively display blocks of code." - :prefix "hs-" - :group 'outlines - :group 'tools) - - -;;;###autoload -(defcustom hs-minor-mode nil - "Non-nil if using hideshow mode as a minor mode of some other mode. -Use the command `hs-minor-mode' to toggle this variable." - :type 'boolean - :set (lambda (symbol value) - (hs-minor-mode (or value 0))) - :initialize 'custom-initialize-default - :require 'hideshow - :group 'hideshow) - -(defcustom hs-unbalance-handler-method 'top-level - "*Symbol representing how \"unbalanced parentheses\" should be handled. -This error is usually signaled by `hs-show-block'. One of four values: -`top-level', `next-line', `signal' or `ignore'. Default is `top-level'. - -- `top-level' -- Show top-level block containing the currently troublesome - block. -- `next-line' -- Use the fact that, for an already hidden block, its end - will be on the next line. Attempt to show this block. -- `signal' -- Pass the error through, stopping execution. -- `ignore' -- Ignore the error, continuing execution. - -Values other than these four will be interpreted as `signal'." - :type '(radio (const :tag "Show top-level block" top-level) - (const :tag "Show block to next line" next-line) - (sexp :format "%t\n" :tag "Signal the error" signal) - (const :tag "Ignore the error" ignore)) - :group 'hideshow) - -(defcustom hs-special-modes-alist '((c-mode "{" "}") - (c++-mode "{" "}")) - "*Alist of the form (MODE START-RE END-RE FORWARD-SEXP-FUNC). -If present, hideshow will use these values for the start and end regexps, -respectively. Since Algol-ish languages do not have single-character -block delimiters, the function `forward-sexp' which is used by hideshow -doesn't work. In this case, if a similar function is provided, you can -register it and have hideshow use it instead of `forward-sexp'. To add -more values, use - -\t(pushnew '(new-mode st-re end-re function-name) -\t hs-special-modes-alist :test 'equal) - -For example: - -\t(pushnew '(simula-mode \"begin\" \"end\" simula-next-statement) -\t hs-special-modes-alist :test 'equal) - -Note that the regexps should not contain leading or trailing whitespace." - :type 'sexp ; too hard to do right - :group 'hideshow) - -(defcustom hs-hide-hook nil - "*Hooks called at the end of `hs-hide-all' and `hs-hide-block'." - :type 'hook - :group 'hideshow) - -(defcustom hs-show-hook nil - "*Hooks called at the end of commands to show text. -These commands include `hs-show-all', `hs-show-block' and `hs-show-region'." - :type 'hook - :group 'hideshow) - -(defcustom hs-minor-mode-prefix "\C-c" - "*Prefix key to use for hideshow commands in hideshow minor mode." - :type 'hook - :group 'hideshow) - - -;;;---------------------------------------------------------------------------- -;;; internal variables - - -(defvar hs-minor-mode-map (make-sparse-keymap) - "Mode map for hideshow minor mode.") - -(easy-menu-define - hs-minor-mode-menu hs-minor-mode-map "Menu for hideshow minor mode" - '("Hideshow" - ["Hide Block" hs-hide-block t] - ["Show Block" hs-show-block t] - ["Hide All" hs-hide-all t] - ["Show All" hs-show-all t] - ["Show Region" hs-show-region t])) - -(defvar hs-c-start-regexp nil - "Regexp for beginning of comments. Buffer-local. -Differs from mode-specific comment regexps in that surrounding -whitespace is stripped.") - -(defvar hs-c-end-regexp nil - "Regexp for end of comments. Buffer-local. -See `hs-c-start-regexp'.") - -(defvar hs-block-start-regexp nil - "Regexp for beginning of block. Buffer-local.") - -(defvar hs-block-end-regexp nil - "Regexp for end of block. Buffer-local.") - -(defvar hs-forward-sexp-func 'forward-sexp - "Function used to do a forward-sexp. Should change for Algol-ish modes. -For single-character block delimiters -- ie, the syntax table regexp for the -character is either `(' or `)' -- `hs-forward-sexp-func' would just be -`forward-sexp'. For other modes such as simula, a more specialized function -is necessary.") - -;;;---------------------------------------------------------------------------- -;;; support funcs - -;; snarfed from outline.el, but added buffer-read-only -(defun hs-flag-region (from to flag) - "Hides or shows lines from FROM to TO, according to FLAG. -If FLAG is `?\\n' (the newline character) then show the text; -if FLAG is `?\\^M' \(control-M) then hide the text." - (let ((modp (buffer-modified-p)) - buffer-read-only) ; nothing is immune - (unwind-protect (progn - (subst-char-in-region - from to - (if (= flag ?\n) ?\C-m ?\n) - flag t)) - (set-buffer-modified-p modp)))) - -(defun hs-hide-block-at-point (&optional end) - "Hide block iff on block beginning, optional END means reposition at end." - (if (looking-at hs-block-start-regexp) - (let* ((p (point)) - (q (progn (funcall hs-forward-sexp-func 1) (point)))) - (forward-line -1) (end-of-line) - (if (and (< p (point)) (> (count-lines p q) 1)) - (hs-flag-region p (point) ?\C-m)) - (goto-char (if end q p))))) - -(defun hs-show-block-at-point (&optional end) - "Show block iff on block beginning. Optional END means reposition at end." - (if (looking-at hs-block-start-regexp) - (let* ((p (point)) - (q - (condition-case error ; probably unbalanced paren - (progn - (funcall hs-forward-sexp-func 1) - (point)) - (error - (cond - ((eq hs-unbalance-handler-method 'ignore) - ;; just ignore this block - (point)) - ((eq hs-unbalance-handler-method 'top-level) - ;; try to get out of rat's nest and expose the whole func - (if (/= (current-column) 0) (beginning-of-defun)) - (setq p (point)) - (re-search-forward (concat "^" hs-block-start-regexp) - (point-max) t 2) - (point)) - ((eq hs-unbalance-handler-method 'next-line) - ;; assumption is that user knows what s/he's doing - (beginning-of-line) (setq p (point)) - (end-of-line 2) (point)) - (t - ;; pass error through -- this applies to `signal', too - (signal (car error) (cdr error)))))))) - (hs-flag-region p q ?\n) - (goto-char (if end (1+ (point)) p))))) - -(defun hs-safety-is-job-n () - "Warn if `selective-display' or `selective-display-ellipses' is nil." - (let ((str "")) - (or selective-display - (setq str "selective-display nil ")) - (or selective-display-ellipses - (setq str (concat str "selective-display-ellipses nil"))) - (if (= (length str) 0) - nil - (message "warning: %s" str) - (sit-for 2)))) - -(defun hs-inside-comment-p () - "Returns non-nil if point is inside a comment, otherwise nil. -Actually, for multi-line-able comments, returns a list containing -the buffer position of the start and the end of the comment." - ;; is it single-line-only or multi-line-able? - (save-excursion - (let ((p (point)) - q) - (if (string= comment-end "") ; single line - (let (found) - (beginning-of-line) - (setq found (re-search-forward hs-c-start-regexp p t)) - (and found (not (search-forward "\"" p t)))) - (re-search-forward hs-c-end-regexp (point-max) 1) - (setq q (point)) - (forward-comment -1) - (re-search-forward hs-c-start-regexp (point-max) 1) - (if (< (- (point) (length comment-start)) p) - (list (match-beginning 0) q)))))) - -(defun hs-grok-mode-type () - "Setup variables for new buffers where applicable." - (if (and (boundp 'comment-start) - (boundp 'comment-end)) - (progn - (setq hs-c-start-regexp (regexp-quote comment-start)) - (if (string-match " +$" hs-c-start-regexp) - (setq hs-c-start-regexp - (substring hs-c-start-regexp 0 (1- (match-end 0))))) - (setq hs-c-end-regexp (if (string= "" comment-end) "\n" - (regexp-quote comment-end))) - (if (string-match "^ +" hs-c-end-regexp) - (setq hs-c-end-regexp - (substring hs-c-end-regexp (match-end 0)))) - (let ((lookup (assoc major-mode hs-special-modes-alist))) - (setq hs-block-start-regexp (or (nth 1 lookup) "\\s\(") - hs-block-end-regexp (or (nth 2 lookup) "\\s\)") - hs-forward-sexp-func (or (nth 3 lookup) 'forward-sexp)))))) - -(defun hs-find-block-beginning () - "Repositions point at block-start. Return point, or nil if top-level." - (let (done - (here (point)) - (both-regexps (concat "\\(" hs-block-start-regexp "\\)\\|\\(" - hs-block-end-regexp "\\)"))) - (while (and (not done) - (re-search-backward both-regexps (point-min) t)) - (if (match-beginning 1) ; start of start-regexp - (setq done (match-beginning 1)) - (goto-char (match-end 2)) ; end of end-regexp - (funcall hs-forward-sexp-func -1))) - (goto-char (or done here)) - done)) - -(defmacro hs-life-goes-on (&rest body) - "Executes optional BODY iff variable `hs-minor-mode' is non-nil." - (list 'if 'hs-minor-mode (cons 'progn body))) - - -;;;---------------------------------------------------------------------------- -;;; commands - -;;;###autoload -(defun hs-hide-all () - "Hides all top-level blocks, displaying only first and last lines. -It moves point to the beginning of the line, and it runs the normal hook -`hs-hide-hook'. See documentation for `run-hooks'." - (interactive) - (hs-life-goes-on - (message "hiding all blocks ...") - (save-excursion - (hs-flag-region (point-min) (point-max) ?\n) ; eliminate weirdness - (goto-char (point-min)) - (let ((count 0) - (top-level-re (concat "^" hs-block-start-regexp))) - (while (progn - (forward-comment (buffer-size)) - (re-search-forward top-level-re (point-max) t)) - (goto-char (match-beginning 0)) - (hs-hide-block-at-point t) - (message "hiding ... %d" (setq count (1+ count))))) - (hs-safety-is-job-n)) - (beginning-of-line) - (message "hiding all blocks ... done") - (run-hooks 'hs-hide-hook))) - -(defun hs-show-all () - "Shows all top-level blocks. -This does not change point; it runs the normal hook `hs-show-hook'. -See documentation for `run-hooks'." - (interactive) - (hs-life-goes-on - (message "showing all blocks ...") - (hs-flag-region (point-min) (point-max) ?\n) - (message "showing all blocks ... done") - (run-hooks 'hs-show-hook))) - -;;;###autoload -(defun hs-hide-block (&optional end) - "Selects a block and hides it. With prefix arg, reposition at end. -Block is defined as a sexp for lispish modes, mode-specific otherwise. -Comments are blocks, too. Upon completion, point is at repositioned and -the normal hook `hs-hide-hook' is run. See documentation for `run-hooks'." - (interactive "P") - (hs-life-goes-on - (let ((c-reg (hs-inside-comment-p))) - (if c-reg - (cond ((string= comment-end "") - (message "can't hide a single-line comment")) - ((< (count-lines (car c-reg) (nth 1 c-reg)) 2) - (message "not enough comment lines to hide")) - (t - (goto-char (nth 1 c-reg)) - (forward-line -1) - (hs-flag-region (car c-reg) (point) ?\C-m) - (goto-char (if end (nth 1 c-reg) (car c-reg))) - (hs-safety-is-job-n) - (run-hooks 'hs-hide-hook))) - (if (or (looking-at hs-block-start-regexp) - (hs-find-block-beginning)) - (progn - (hs-hide-block-at-point end) - (hs-safety-is-job-n) - (run-hooks 'hs-hide-hook))))))) - -(defun hs-show-block (&optional end) - "Selects a block and shows it. With prefix arg, reposition at end. -Upon completion, point is repositioned and the normal hook -`hs-show-hook' is run. See documentation for `hs-hide-block' and `run-hooks'." - (interactive "P") - (hs-life-goes-on - (let ((c-reg (hs-inside-comment-p))) - (if c-reg - (cond ((string= comment-end "") - (message "already looking at the entire comment")) - (t - (hs-flag-region (car c-reg) (nth 1 c-reg) ?\n) - (goto-char (if end (nth 1 c-reg) (car c-reg))))) - (if (or (looking-at hs-block-start-regexp) - (hs-find-block-beginning)) - (progn - (hs-show-block-at-point end) - (hs-safety-is-job-n) - (run-hooks 'hs-show-hook))))))) - -(defun hs-show-region (beg end) - "Shows all lines from BEG to END, without doing any block analysis. -Note:` hs-show-region' is intended for use when when `hs-show-block' signals -`unbalanced parentheses' and so is an emergency measure only. You may -become very confused if you use this command indiscriminately." - (interactive "r") - (hs-life-goes-on - (hs-flag-region beg end ?\n) - (hs-safety-is-job-n) - (run-hooks 'hs-show-hook))) - -;;;###autoload -(defun hs-minor-mode (&optional arg) - "Toggle hideshow minor mode. -With ARG, turn hideshow minor mode on if ARG is positive, off otherwise. -When hideshow minor mode is on, the menu bar is augmented with hideshow -commands and the hideshow commands are enabled. The variables -`selective-display' and `selective-display-ellipses' are set to t. -Last, the normal hook `hs-minor-mode-hook' is run; see the doc for `run-hooks'. - -Turning hideshow minor mode off reverts the menu bar and the -variables to default values and disables the hideshow commands." - (interactive "P") - (setq hs-minor-mode - (if (null arg) - (not hs-minor-mode) - (> (prefix-numeric-value arg) 0))) - (if hs-minor-mode - (progn - (easy-menu-add hs-minor-mode-menu hs-minor-mode-map) - (setq selective-display t - selective-display-ellipses t) - (hs-grok-mode-type) - (run-hooks 'hs-minor-mode-hook)) - (easy-menu-remove hs-minor-mode-menu) - (kill-local-variable 'selective-display) - (kill-local-variable 'selective-display-ellipses))) - - -;;;---------------------------------------------------------------------------- -;;; load-time setup routines - -(if (fboundp 'add-minor-mode) - (progn - ;; XEmacs: need this for the change in add-minor-mode - ;; ### Why? -- pete@cis.ohio-state.edu - (fset 'hs-minor-mode-map hs-minor-mode-map) - (add-minor-mode 'hs-minor-mode " hs" 'hs-minor-mode-map)) - ;;else - (or (assq 'hs-minor-mode minor-mode-map-alist) - (setq minor-mode-map-alist - (cons (cons 'hs-minor-mode hs-minor-mode-map) - minor-mode-map-alist))) - (or (assq 'hs-minor-mode minor-mode-alist) - (setq minor-mode-alist (append minor-mode-alist - (list '(hs-minor-mode " hs")))))) -;; make some variables buffer-local -(make-variable-buffer-local 'hs-minor-mode) -(make-variable-buffer-local 'hs-c-start-regexp) -(make-variable-buffer-local 'hs-c-end-regexp) -(make-variable-buffer-local 'hs-block-start-regexp) -(make-variable-buffer-local 'hs-block-end-regexp) -(make-variable-buffer-local 'hs-forward-sexp-func) -(put 'hs-minor-mode 'permanent-local t) -(put 'hs-c-start-regexp 'permanent-local t) -(put 'hs-c-end-regexp 'permanent-local t) -(put 'hs-block-start-regexp 'permanent-local t) -(put 'hs-block-end-regexp 'permanent-local t) -(put 'hs-forward-sexp-func 'permanent-local t) - - -;;;---------------------------------------------------------------------------- -;;; that's it - -(provide 'hideshow) - -;;; hideshow.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/icon.el --- a/lisp/modes/icon.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,576 +0,0 @@ -;;; icon.el --- mode for editing Icon code - -;; Copyright (C) 1989 Free Software Foundation, Inc. - -;; Author: Chris Smith -;; Created: 15 Feb 89 -;; Keywords: languages - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34. - -;;; Commentary: - -;; A major mode for editing the Icon programming language. - -;;; Code: - -(defvar icon-mode-abbrev-table nil - "Abbrev table in use in Icon-mode buffers.") -(define-abbrev-table 'icon-mode-abbrev-table ()) - -(defvar icon-mode-map () - "Keymap used in Icon mode.") -(if icon-mode-map - () - (setq icon-mode-map (make-sparse-keymap)) - (define-key icon-mode-map "{" 'electric-icon-brace) - (define-key icon-mode-map "}" 'electric-icon-brace) - (define-key icon-mode-map "\e\C-h" 'mark-icon-function) - (define-key icon-mode-map "\e\C-a" 'beginning-of-icon-defun) - (define-key icon-mode-map "\e\C-e" 'end-of-icon-defun) - (define-key icon-mode-map "\e\C-q" 'indent-icon-exp) - (define-key icon-mode-map "\t" 'icon-indent-command)) - -(defvar icon-mode-syntax-table nil - "Syntax table in use in Icon-mode buffers.") - -(if icon-mode-syntax-table - () - (setq icon-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\\ "\\" icon-mode-syntax-table) - (modify-syntax-entry ?# "<" icon-mode-syntax-table) - (modify-syntax-entry ?\n ">" icon-mode-syntax-table) - (modify-syntax-entry ?$ "." icon-mode-syntax-table) - (modify-syntax-entry ?/ "." icon-mode-syntax-table) - (modify-syntax-entry ?* "." icon-mode-syntax-table) - (modify-syntax-entry ?+ "." icon-mode-syntax-table) - (modify-syntax-entry ?- "." icon-mode-syntax-table) - (modify-syntax-entry ?= "." icon-mode-syntax-table) - (modify-syntax-entry ?% "." icon-mode-syntax-table) - (modify-syntax-entry ?< "." icon-mode-syntax-table) - (modify-syntax-entry ?> "." icon-mode-syntax-table) - (modify-syntax-entry ?& "." icon-mode-syntax-table) - (modify-syntax-entry ?| "." icon-mode-syntax-table) - (modify-syntax-entry ?\' "\"" icon-mode-syntax-table)) - -(defgroup icon nil - "Mode for editing icon code." - :group 'languages) - - -(defcustom icon-indent-level 4 - "*Indentation of Icon statements with respect to containing block." - :type 'integer - :group 'icon) -(defcustom icon-brace-imaginary-offset 0 - "*Imagined indentation of a Icon open brace that actually follows a statement." - :type 'integer - :group 'icon) -(defcustom icon-brace-offset 0 - "*Extra indentation for braces, compared with other text in same context." - :type 'integer - :group 'icon) -(defcustom icon-continued-statement-offset 4 - "*Extra indent for lines not starting new statements." - :type 'integer - :group 'icon) -(defcustom icon-continued-brace-offset 0 - "*Extra indent for substatements that start with open-braces. -This is in addition to icon-continued-statement-offset." - :type 'integer - :group 'icon) - -(defcustom icon-auto-newline nil - "*Non-nil means automatically newline before and after braces -inserted in Icon code." - :type 'boolean - :group 'icon) - -(defcustom icon-tab-always-indent t - "*Non-nil means TAB in Icon mode should always reindent the current line, -regardless of where in the line point is when the TAB command is used." - :type 'integer - :group 'icon) - -;;;###autoload -(defun icon-mode () - "Major mode for editing Icon code. -Expression and list commands understand all Icon brackets. -Tab indents for Icon code. -Paragraphs are separated by blank lines only. -Delete converts tabs to spaces as it moves back. -\\{icon-mode-map} -Variables controlling indentation style: - icon-tab-always-indent - Non-nil means TAB in Icon mode should always reindent the current line, - regardless of where in the line point is when the TAB command is used. - icon-auto-newline - Non-nil means automatically newline before and after braces - inserted in Icon code. - icon-indent-level - Indentation of Icon statements within surrounding block. - The surrounding block's indentation is the indentation - of the line on which the open-brace appears. - icon-continued-statement-offset - Extra indentation given to a substatement, such as the - then-clause of an if or body of a while. - icon-continued-brace-offset - Extra indentation given to a brace that starts a substatement. - This is in addition to `icon-continued-statement-offset'. - icon-brace-offset - Extra indentation for line if it starts with an open brace. - icon-brace-imaginary-offset - An open brace following other text is treated as if it were - this far to the right of the start of its line. - -Turning on Icon mode calls the value of the variable `icon-mode-hook' -with no args, if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map icon-mode-map) - (setq major-mode 'icon-mode) - (setq mode-name "Icon") - (setq local-abbrev-table icon-mode-abbrev-table) - (set-syntax-table icon-mode-syntax-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'icon-indent-line) - (make-local-variable 'require-final-newline) - (setq require-final-newline t) - (make-local-variable 'comment-start) - (setq comment-start "# ") - (make-local-variable 'comment-end) - (setq comment-end "") - (make-local-variable 'comment-column) - (setq comment-column 32) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "# *") - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'icon-comment-indent) - (run-hooks 'icon-mode-hook)) - -;; This is used by indent-for-comment to decide how much to -;; indent a comment in Icon code based on its context. -(defun icon-comment-indent () - (if (looking-at "^#") - 0 - (save-excursion - (skip-chars-backward " \t") - (max (if (bolp) 0 (1+ (current-column))) - comment-column)))) - -(defun electric-icon-brace (arg) - "Insert character and correct line's indentation." - (interactive "P") - (let (insertpos) - (if (and (not arg) - (eolp) - (or (save-excursion - (skip-chars-backward " \t") - (bolp)) - (if icon-auto-newline - (progn (icon-indent-line) (newline) t) - nil))) - (progn - (insert last-command-char) - (icon-indent-line) - (if icon-auto-newline - (progn - (newline) - ;; (newline) may have done auto-fill - (setq insertpos (- (point) 2)) - (icon-indent-line))) - (save-excursion - (if insertpos (goto-char (1+ insertpos))) - (delete-char -1)))) - (if insertpos - (save-excursion - (goto-char insertpos) - (self-insert-command (prefix-numeric-value arg))) - (self-insert-command (prefix-numeric-value arg))))) - -(defun icon-indent-command (&optional whole-exp) - (interactive "P") - "Indent current line as Icon code, or in some cases insert a tab character. -If `icon-tab-always-indent' is non-nil (the default), always indent current -line. Otherwise, indent the current line only if point is at the left margin -or in the line's indentation; otherwise insert a tab. - -A numeric argument, regardless of its value, means indent rigidly all the -lines of the expression starting after point so that this line becomes -properly indented. The relative indentation among the lines of the -expression are preserved." - (if whole-exp - ;; If arg, always indent this line as Icon - ;; and shift remaining lines of expression the same amount. - (let ((shift-amt (icon-indent-line)) - beg end) - (save-excursion - (if icon-tab-always-indent - (beginning-of-line)) - (setq beg (point)) - (forward-sexp 1) - (setq end (point)) - (goto-char beg) - (forward-line 1) - (setq beg (point))) - (if (> end beg) - (indent-code-rigidly beg end shift-amt "#"))) - (if (and (not icon-tab-always-indent) - (save-excursion - (skip-chars-backward " \t") - (not (bolp)))) - (insert-tab) - (icon-indent-line)))) - -(defun icon-indent-line () - "Indent current line as Icon code. -Return the amount the indentation changed by." - (let ((indent (calculate-icon-indent nil)) - beg shift-amt - (case-fold-search nil) - (pos (- (point-max) (point)))) - (beginning-of-line) - (setq beg (point)) - (cond ((eq indent nil) - (setq indent (current-indentation))) - ((eq indent t) - (setq indent (calculate-icon-indent-within-comment))) - ((looking-at "[ \t]*#") - (setq indent 0)) - (t - (skip-chars-forward " \t") - (if (listp indent) (setq indent (car indent))) - (cond ((and (looking-at "else\\b") - (not (looking-at "else\\s_"))) - (setq indent (save-excursion - (icon-backward-to-start-of-if) - (current-indentation)))) - ((or (= (following-char) ?}) - (looking-at "end\\b")) - (setq indent (- indent icon-indent-level))) - ((= (following-char) ?{) - (setq indent (+ indent icon-brace-offset)))))) - (skip-chars-forward " \t") - (setq shift-amt (- indent (current-column))) - (if (zerop shift-amt) - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos))) - (delete-region beg (point)) - (indent-to indent) - ;; If initial point was within line's indentation, - ;; position after the indentation. Else stay at same point in text. - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos)))) - shift-amt)) - -(defun calculate-icon-indent (&optional parse-start) - "Return appropriate indentation for current line as Icon code. -In usual case returns an integer: the column to indent to. -Returns nil if line starts inside a string, t if in a comment." - (save-excursion - (beginning-of-line) - (let ((indent-point (point)) - (case-fold-search nil) - state - containing-sexp - toplevel) - (if parse-start - (goto-char parse-start) - (setq toplevel (beginning-of-icon-defun))) - (while (< (point) indent-point) - (setq parse-start (point)) - (setq state (parse-partial-sexp (point) indent-point 0)) - (setq containing-sexp (car (cdr state)))) - (cond ((or (nth 3 state) (nth 4 state)) - ;; return nil or t if should not change this line - (nth 4 state)) - ((and containing-sexp - (/= (char-after containing-sexp) ?{)) - ;; line is expression, not statement: - ;; indent to just after the surrounding open. - (goto-char (1+ containing-sexp)) - (current-column)) - (t - (if toplevel - ;; Outside any procedures. - (progn (icon-backward-to-noncomment (point-min)) - (if (icon-is-continuation-line) - icon-continued-statement-offset 0)) - ;; Statement level. - (if (null containing-sexp) - (progn (beginning-of-icon-defun) - (setq containing-sexp (point)))) - (goto-char indent-point) - ;; Is it a continuation or a new statement? - ;; Find previous non-comment character. - (icon-backward-to-noncomment containing-sexp) - ;; Now we get the answer. - (if (icon-is-continuation-line) - ;; This line is continuation of preceding line's statement; - ;; indent icon-continued-statement-offset more than the - ;; first line of the statement. - (progn - (icon-backward-to-start-of-continued-exp containing-sexp) - (+ icon-continued-statement-offset (current-column) - (if (save-excursion (goto-char indent-point) - (skip-chars-forward " \t") - (eq (following-char) ?{)) - icon-continued-brace-offset 0))) - ;; This line starts a new statement. - ;; Position following last unclosed open. - (goto-char containing-sexp) - ;; Is line first statement after an open-brace? - (or - ;; If no, find that first statement and indent like it. - (save-excursion - (if (looking-at "procedure\\s ") - (forward-sexp 3) - (forward-char 1)) - (while (progn (skip-chars-forward " \t\n") - (looking-at "#")) - ;; Skip over comments following openbrace. - (forward-line 1)) - ;; The first following code counts - ;; if it is before the line we want to indent. - (and (< (point) indent-point) - (current-column))) - ;; If no previous statement, - ;; indent it relative to line brace is on. - ;; For open brace in column zero, don't let statement - ;; start there too. If icon-indent-level is zero, - ;; use icon-brace-offset + icon-continued-statement-offset - ;; instead. - ;; For open-braces not the first thing in a line, - ;; add in icon-brace-imaginary-offset. - (+ (if (and (bolp) (zerop icon-indent-level)) - (+ icon-brace-offset - icon-continued-statement-offset) - icon-indent-level) - ;; Move back over whitespace before the openbrace. - ;; If openbrace is not first nonwhite thing on the line, - ;; add the icon-brace-imaginary-offset. - (progn (skip-chars-backward " \t") - (if (bolp) 0 icon-brace-imaginary-offset)) - ;; Get initial indentation of the line we are on. - (current-indentation)))))))))) - -;; List of words to check for as the last thing on a line. -;; If cdr is t, next line is a continuation of the same statement, -;; if cdr is nil, next line starts a new (possibly indented) statement. - -(defconst icon-resword-alist - '(("by" . t) ("case" . t) ("create") ("do") ("dynamic" . t) ("else") - ("every" . t) ("if" . t) ("global" . t) ("initial" . t) - ("link" . t) ("local" . t) ("of") ("record" . t) ("repeat" . t) - ("static" . t) ("then") ("to" . t) ("until" . t) ("while" . t))) - -(defun icon-is-continuation-line () - (let* ((ch (preceding-char)) - (ch-syntax (char-syntax ch))) - (if (eq ch-syntax ?w) - (assoc (buffer-substring - (progn (forward-word -1) (point)) - (progn (forward-word 1) (point))) - icon-resword-alist) - (not (memq ch '(0 ?\; ?\} ?\{ ?\) ?\] ?\" ?\' ?\n)))))) - -(defun icon-backward-to-noncomment (lim) - (let (opoint stop) - (while (not stop) - (skip-chars-backward " \t\n\f" lim) - (setq opoint (point)) - (beginning-of-line) - (if (and (nth 5 (parse-partial-sexp (point) opoint)) - (< lim (point))) - (search-backward "#") - (setq stop t))))) - -(defun icon-backward-to-start-of-continued-exp (lim) - (if (memq (preceding-char) '(?\) ?\])) - (forward-sexp -1)) - (beginning-of-line) - (skip-chars-forward " \t") - (cond - ((<= (point) lim) (goto-char (1+ lim))) - ((not (icon-is-continued-line)) 0) - ((and (eq (char-syntax (following-char)) ?w) - (cdr - (assoc (buffer-substring (point) - (save-excursion (forward-word 1) (point))) - icon-resword-alist))) 0) - (t (end-of-line 0) (icon-backward-to-start-of-continued-exp lim)))) - -(defun icon-is-continued-line () - (save-excursion - (end-of-line 0) - (icon-is-continuation-line))) - -(defun icon-backward-to-start-of-if (&optional limit) - "Move to the start of the last \"unbalanced\" if." - (or limit (setq limit (save-excursion (beginning-of-icon-defun) (point)))) - (let ((if-level 1) - (case-fold-search nil)) - (while (not (zerop if-level)) - (backward-sexp 1) - (cond ((looking-at "else\\b") - (setq if-level (1+ if-level))) - ((looking-at "if\\b") - (setq if-level (1- if-level))) - ((< (point) limit) - (setq if-level 0) - (goto-char limit)))))) - -(defun mark-icon-function () - "Put mark at end of Icon function, point at beginning." - (interactive) - (push-mark (point)) - (end-of-icon-defun) - (push-mark (point)) - (beginning-of-line 0) - (beginning-of-icon-defun)) - -(defun beginning-of-icon-defun () - "Go to the start of the enclosing procedure; return t if at top level." - (interactive) - (if (re-search-backward "^procedure\\s \\|^end[ \t\n]" (point-min) 'move) - (looking-at "e") - t)) - -(defun end-of-icon-defun () - (interactive) - (if (not (bobp)) (forward-char -1)) - (re-search-forward "\\(\\s \\|^\\)end\\(\\s \\|$\\)" (point-max) 'move) - (forward-word -1) - (forward-line 1)) - -(defun indent-icon-exp () - "Indent each line of the Icon grouping following point." - (interactive) - (let ((indent-stack (list nil)) - (contain-stack (list (point))) - (case-fold-search nil) - restart outer-loop-done inner-loop-done state ostate - this-indent last-sexp - at-else at-brace at-do - (opoint (point)) - (next-depth 0)) - (save-excursion - (forward-sexp 1)) - (save-excursion - (setq outer-loop-done nil) - (while (and (not (eobp)) (not outer-loop-done)) - (setq last-depth next-depth) - ;; Compute how depth changes over this line - ;; plus enough other lines to get to one that - ;; does not end inside a comment or string. - ;; Meanwhile, do appropriate indentation on comment lines. - (setq innerloop-done nil) - (while (and (not innerloop-done) - (not (and (eobp) (setq outer-loop-done t)))) - (setq ostate state) - (setq state (parse-partial-sexp (point) (progn (end-of-line) (point)) - nil nil state)) - (setq next-depth (car state)) - (if (and (car (cdr (cdr state))) - (>= (car (cdr (cdr state))) 0)) - (setq last-sexp (car (cdr (cdr state))))) - (if (or (nth 4 ostate)) - (icon-indent-line)) - (if (or (nth 3 state)) - (forward-line 1) - (setq innerloop-done t))) - (if (<= next-depth 0) - (setq outer-loop-done t)) - (if outer-loop-done - nil - (if (/= last-depth next-depth) - (setq last-sexp nil)) - (while (> last-depth next-depth) - (setq indent-stack (cdr indent-stack) - contain-stack (cdr contain-stack) - last-depth (1- last-depth))) - (while (< last-depth next-depth) - (setq indent-stack (cons nil indent-stack) - contain-stack (cons nil contain-stack) - last-depth (1+ last-depth))) - (if (null (car contain-stack)) - (setcar contain-stack (or (car (cdr state)) - (save-excursion (forward-sexp -1) - (point))))) - (forward-line 1) - (skip-chars-forward " \t") - (if (eolp) - nil - (if (and (car indent-stack) - (>= (car indent-stack) 0)) - ;; Line is on an existing nesting level. - ;; Lines inside parens are handled specially. - (if (/= (char-after (car contain-stack)) ?{) - (setq this-indent (car indent-stack)) - ;; Line is at statement level. - ;; Is it a new statement? Is it an else? - ;; Find last non-comment character before this line - (save-excursion - (setq at-else (looking-at "else\\W")) - (setq at-brace (= (following-char) ?{)) - (icon-backward-to-noncomment opoint) - (if (icon-is-continuation-line) - ;; Preceding line did not end in comma or semi; - ;; indent this line icon-continued-statement-offset - ;; more than previous. - (progn - (icon-backward-to-start-of-continued-exp (car contain-stack)) - (setq this-indent - (+ icon-continued-statement-offset (current-column) - (if at-brace icon-continued-brace-offset 0)))) - ;; Preceding line ended in comma or semi; - ;; use the standard indent for this level. - (if at-else - (progn (icon-backward-to-start-of-if opoint) - (setq this-indent (current-indentation))) - (setq this-indent (car indent-stack)))))) - ;; Just started a new nesting level. - ;; Compute the standard indent for this level. - (let ((val (calculate-icon-indent - (if (car indent-stack) - (- (car indent-stack)))))) - (setcar indent-stack - (setq this-indent val)))) - ;; Adjust line indentation according to its contents - (if (or (= (following-char) ?}) - (looking-at "end\\b")) - (setq this-indent (- this-indent icon-indent-level))) - (if (= (following-char) ?{) - (setq this-indent (+ this-indent icon-brace-offset))) - ;; Put chosen indentation into effect. - (or (= (current-column) this-indent) - (progn - (delete-region (point) (progn (beginning-of-line) (point))) - (indent-to this-indent))) - ;; Indent any comment following the text. - (or (looking-at comment-start-skip) - (if (re-search-forward comment-start-skip (save-excursion (end-of-line) (point)) t) - (progn (indent-for-comment) (beginning-of-line)))))))))) - -;;; icon.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/image-mode.el --- a/lisp/modes/image-mode.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,205 +0,0 @@ -;;; image-mode.el --- Major mode for navigate images - -;; Copyright (C) 1997 MORIOKA Tomohiko - -;; Author: MORIOKA Tomohiko -;; Created: 1997/6/27 -;; Version: image-mode.el,v 20.3.1.2 1997/07/01 17:29:44 morioka Exp -;; Keywords: image, graphics - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Code: - -(defvar buffer-image-format nil) -(make-variable-buffer-local 'buffer-image-format) - -(defsubst image-decode (start end type) - "Decode the image between START and END which is encoded in TYPE." - (save-excursion - (let ((image (make-image-instance - (vector type :data (buffer-string)) nil nil 'no-error))) - (delete-region start end) - (if image - (let ((glyph (make-glyph image))) - (set-extent-begin-glyph (make-extent start start) glyph) - (setq buffer-read-only t) - ) - (insert (format "%s is not supported!\n" type)) - (let ((overriding-local-map image-mode-map)) - (insert - (substitute-command-keys - " -Please type `\\[image-toggle-decoding]' if you would like to display -raw data. -Please type `\\[image-enter-hexl-mode]' if you would like to edit hex -data. -Please type `\\[image-enter-xpm-mode]' if you would like to edit xpm -data. -Please type `\\[image-start-external-viewer]' if you would like to -display contents of this buffer by external viewer.\n"))) - (call-interactively 'fill-paragraph) - ) - start))) - -(defvar image-mode-map (make-keymap)) -(suppress-keymap image-mode-map) -(define-key image-mode-map "v" 'image-start-external-viewer) -(define-key image-mode-map "t" 'image-toggle-decoding) -(define-key image-mode-map "h" 'image-enter-hexl-mode) -(define-key image-mode-map "e" 'image-enter-xpm-mode) -(define-key image-mode-map "q" 'image-mode-quit) - -(defvar image-external-viewer - (cond ((exec-installed-p "display") "display") ; ImageMagic - ((exec-installed-p "xv") "xv") ; xv - ) - "*External viewer for image-mode.") - -(defun image-start-external-viewer () - "Start external image viewer for current-buffer. -It uses `image-external-viewer' as external image viewer." - (interactive) - (start-process "external image viewer" nil - image-external-viewer buffer-file-name) - ) - -(defun image-toggle-decoding () - "Toggle image display mode in current buffer." - (interactive) - (if buffer-file-format - (progn - (setq buffer-read-only nil) - (erase-buffer) - (map-extents (function - (lambda (extent maparg) - (delete-extent extent) - )) nil (point-min)(point-min)) - (setq buffer-file-format nil) - (insert-file-contents-literally buffer-file-name) - (set-buffer-modified-p nil) - ) - (format-decode-buffer buffer-image-format) - )) - -(defun image-exit-hexl-mode-function () - (format-decode-buffer) - (remove-hook 'hexl-mode-exit-hook 'image-exit-hexl-mode-function) - ) - -(defun image-enter-hexl-mode () - "Enter to hexl-mode." - (interactive) - (when buffer-file-format - (setq buffer-read-only nil) - (erase-buffer) - (map-extents (function - (lambda (extent maparg) - (delete-extent extent) - )) nil (point-min)(point-min)) - (setq buffer-file-format nil) - (insert-file-contents-literally buffer-file-name) - (set-buffer-modified-p nil) - (add-hook 'hexl-mode-exit-hook 'image-exit-hexl-mode-function) - ) - (hexl-mode) - ) - -(defun image-enter-xpm-mode () - "Enter to xpm-mode." - (interactive) - (if (not (eq buffer-image-format 'image/x-xpm)) - (error "Not a xpm-picture.")) - (when buffer-file-format - (setq buffer-read-only nil) - (erase-buffer) - (map-extents (function - (lambda (extent maparg) - (delete-extent extent) - )) nil (point-min)(point-min)) - (setq buffer-file-format nil) - (insert-file-contents-literally buffer-file-name) - (set-buffer-modified-p nil) - ) - (xpm-mode 1) - ) - -(defun image-mode-quit () - "Exit image-mode." - (interactive) - (kill-buffer (current-buffer)) - ) - -(defun image-maybe-restore () - "Restore buffer from file if it is decoded as `buffer-file-format'." - (when (and buffer-file-format - buffer-file-name) - (setq buffer-read-only nil) - (erase-buffer) - (map-extents (function - (lambda (extent maparg) - (delete-extent extent) - )) nil (point-min)(point-min)) - (setq buffer-file-format nil) - (insert-file-contents-literally buffer-file-name) - (set-buffer-modified-p nil) - )) - -(add-hook 'change-major-mode-hook 'image-maybe-restore) - - -;;;###autoload -(defun image-mode (&optional arg) - "\\{image-mode-map}" - (interactive) - (setq major-mode 'image-mode) - (setq mode-name "Image") - (use-local-map image-mode-map) - ) - -;;;###autoload -(defun image-decode-jpeg (start end) - "Decode JPEG image between START and END." - (setq buffer-image-format 'image/jpeg) - (image-decode start end 'jpeg) - ) - -;;;###autoload -(defun image-decode-gif (start end) - "Decode GIF image between START and END." - (setq buffer-image-format 'image/gif) - (image-decode start end 'gif) - ) - -;;;###autoload -(defun image-decode-png (start end) - "Decode PNG image between START and END." - (setq buffer-image-format 'image/png) - (image-decode start end 'png) - ) - -;;;###autoload -(defun image-decode-xpm (start end) - "Decode XPM image between START and END." - (setq buffer-image-format 'image/x-xpm) - (image-decode start end 'xpm) - ) - -(provide 'image-mode) - -;;; image-mode.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/lazy-shot.el --- a/lisp/modes/lazy-shot.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,277 +0,0 @@ -;;; lazy-shot.el --- Lazy font locking for XEmacs - -;; Copyright (C) 1997 Jan Vroonhof - -;; Author: Jan Vroonhof -;; Keywords: languages, faces - -;; This file is part of XEmacs - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Not in FSF (mostly equivalent to lazy-lock 2.09 -;;; in FSF 20.2). - -;;; Commentary: - -;;; This is an experimental demand based font-lock implemenation. It -;;; is almost equal in functionality and interface to lazy-lock 2.09 -;;; Does somebody really need defer-locking? -;;; -;;; To use: put -;;; (add-hook 'font-lock-mode-hook 'turn-on-lazy-shot) -;;; in .emacs (.xemacs/init.el). Do not use in combination with -;;; lazy-lock. - -;;; It is exprimental in the sense that it relies on C support from -;;; the redisplay engine, that is experimental. The code in this file -;;; is more or less finished. The C code support experimental because -;;; the current design is rumoured to be ugly. Secondly because -;;; XEmacs does actually display the "un-font-locked" parts of the -;;; buffer first, the user notices flashing as the buffer is repainted -;;; with color/fonts. - -;;; Code: - -(require 'font-lock) -(require 'itimer) - -(defvar lazy-shot-mode nil) - - -(defgroup lazy-shot nil - "Lazy-shot customizations" - :group 'tools - :group 'faces - :prefix "lazy-shot-") - -(defcustom lazy-shot-minimum-size 0 - "*Minimum size of a buffer for demand-driven fontification. -On-demand fontification occurs if the buffer size is greater than this value. -If nil, means demand-driven fontification is never performed." - :type '(choice (const :tag "Off" nil) - (integer :tag "Size")) - :group 'lazy-shot) - - -(defcustom lazy-shot-step-size 1024 ; Please test diffent sizes - "Minimum size of each fontification shot." - :type 'integer - :group 'lazy-shot) - -(defcustom lazy-shot-stealth-time 30 - "*Time in seconds to delay before beginning stealth fontification. -Stealth fontification occurs if there is no input within this time. -If nil, means stealth fontification is never performed. - -The value of this variable is used when Lazy Shot mode is turned on." - :type '(choice (const :tag "Off" nil) - (number :tag "Time")) - :group 'lazy-shot) - -(defcustom lazy-shot-stealth-lines (if font-lock-maximum-decoration 100 250) - "*Maximum size of a chunk of stealth fontification. -Each iteration of stealth fontification can fontify this number of lines. -To speed up input response during stealth fontification, at the cost of stealth -taking longer to fontify, you could reduce the value of this variable." - :type 'integer - :group 'lazy-shot) - -(defcustom lazy-shot-stealth-nice - (/ (float 1) (float 8)) - "*Time in seconds to pause between chunks of stealth fontification. -Each iteration of stealth fontification is separated by this amount of time. -To reduce machine load during stealth fontification, at the cost of stealth -taking longer to fontify, you could increase the value of this variable." - :type 'number - :group 'lazy-shot) - -(defcustom lazy-shot-verbose (not (null font-lock-verbose)) - "*If non-nil, means demand fontification should show status messages." - :type 'boolean - :group 'lazy-shot) - -(defcustom lazy-shot-stealth-verbose (not (null lazy-shot-verbose)) - "*If non-nil, means stealth fontification should show status messages." - :type 'boolean - :group 'lazy-shot) - - - -;;;###autoload -(defun lazy-shot-mode (&optional arg) - "Toggle Lazy Lock mode. -With arg, turn Lazy Lock mode on if and only if arg is positive." - (interactive "P") - (let ((was-on lazy-shot-mode)) - (set (make-local-variable 'lazy-shot-mode) - (and (if arg (> (prefix-numeric-value arg) 0) (not lazy-shot-mode)))) - (cond ((and lazy-shot-mode (not font-lock-mode)) - ;; Turned on `lazy-shot-mode' rather than `font-lock-mode'. - (let ((font-lock-support-mode 'lazy-shot-mode)) - (font-lock-mode t))) - (lazy-shot-mode - ;; Turn ourselves on. - (lazy-shot-install)) - (was-on - ;; Turn ourselves off. - (lazy-shot-unstall))))) - -(custom-add-option 'font-lock-mode-hook 'turn-on-lazy-lock) - -;;;###autoload -(defun turn-on-lazy-shot () - "Unconditionally turn on Lazy Lock mode." - (lazy-shot-mode t)) - - ;; Can we do something intelligent here? - ;; I would want to set-extent-end-position start on extents that - ;; only partially overlap! -(defun lazy-shot-clean-up-extents (start end) - "Make sure there are no lazy-shot-extens betweeen START and END. -This improves efficiency and C-g behavior." - ;; Be carefull this function is typically called with inhibit-quit! - (map-extents (lambda (e b) (delete-extent e)) - nil start end nil 'start-and-end-in-region 'initial-redisplay-function - 'lazy-shot-redisplay-function)) - -(defun lazy-shot-redisplay-function (extent) - "Lazy lock the EXTENT when it has become visisble." - (lazy-shot-lock-extent extent nil)) - - -(defun lazy-shot-lock-extent (extent stealth) - "Font-lock the EXTENT. Called from redisplay-trigger functions and -stealth locking functions" - (when (extent-live-p extent) - (let ((start (extent-start-position extent)) - (end (extent-end-position extent)) - (buffer (extent-object extent))) - (delete-extent extent) - (lazy-shot-fontify-internal buffer start end - (or lazy-shot-verbose - (and stealth - lazy-shot-stealth-verbose)) - (if stealth "stealthy " ""))))) - -(defun lazy-shot-fontify-internal (buffer start end verbose message) - (save-excursion - ;; Should inhibit quit here - (set-buffer buffer) ;; with-current-buffer is silly here - ;; This magic should really go into font-lock-fonity-region - (goto-char start) - (setq start (point-at-bol)) - (goto-char end) - (setq end (point-at-bol 2)) - (lazy-shot-clean-up-extents start end) - ;; and a allow quit here - (if verbose - (display-message 'progress - (format "Lazy-shot fontifying %sfrom %s to %s in %s" - message start end buffer))) - (save-match-data - (font-lock-fontify-region start end)))) - -;; Note this is suboptimal but works for now. It is not called that often. -(defun lazy-shot-fontify-region (start end &optional buffer) - (lazy-shot-fontify-internal (or buffer (current-buffer)) - start end lazy-shot-verbose - "on request ")) - -(defun lazy-shot-stealth-lock (buffer) - "Find an extent to lazy lock in buffer." - (if (buffer-live-p buffer) - (with-current-buffer buffer - (let ((extent t)) - (while (and extent (sit-for lazy-shot-stealth-nice)) - (setq extent - (or ;; First after point - (map-extents (lambda (e n) e) nil (point) nil nil nil - 'initial-redisplay-function - 'lazy-shot-redisplay-function) - ;; Then before it - (map-extents (lambda (e n) e) nil nil (point) nil nil - 'initial-redisplay-function - 'lazy-shot-redisplay-function))) - (if extent - (lazy-shot-lock-extent extent t) - (delete-itimer current-itimer) - (setq lazy-shot-stealth-timer nil))))) - (delete-itimer current-itimer))) - -(defun lazy-shot-install-extent (spos epos &optional buffer) - "Make an extent that will lazy-shot if it is displayed." - (let ((extent (make-extent spos epos buffer))) - (when extent - (set-extent-initial-redisplay-function extent - 'lazy-shot-redisplay-function)) - extent)) - - -(defun lazy-shot-install-extents (fontifying) - ;; - ;; Add hook if lazy-shot.el is deferring or is fontifying on scrolling. - (when fontifying - (let ((max (point-max)) - start) - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (setq start (point)) - (goto-char (min max (+ start lazy-shot-step-size))) - (forward-line 1) - (lazy-shot-install-extent start (point))))))) - -(defun lazy-shot-install-timer (fontifying) - (when (and lazy-shot-stealth-time fontifying) - (make-variable-buffer-local 'lazy-shot-stealth-timer) - (setq lazy-shot-stealth-timer - (start-itimer (format "lazy shot for %s" (current-buffer)) - 'lazy-shot-stealth-lock lazy-shot-stealth-time - lazy-shot-stealth-time - t t (current-buffer))))) - - -(defun lazy-shot-install () - (make-local-variable 'font-lock-fontified) - (setq font-lock-fontified (and lazy-shot-minimum-size - (>= (buffer-size) lazy-shot-minimum-size))) - (lazy-shot-install-extents font-lock-fontified) - (lazy-shot-install-timer font-lock-fontified) - (add-hook 'font-lock-after-fontify-buffer-hook - 'lazy-shot-unstall-after-fontify)) - -;; Kludge needed untill lazy-lock-fontify-region is more intelligent -(defun lazy-shot-unstall-after-fontify () - (lazy-shot-unstall 1)) - -(defun lazy-shot-unstall (&optional no-fontify) - ;; Stop the timer - (when (and (boundp 'lazy-shot-stealth-timer) lazy-shot-stealth-timer) - (delete-itimer lazy-shot-stealth-timer) - (setq lazy-shot-stealth-timer nil)) - ;; Remove the extents. - (map-extents - (lambda (e arg) (delete-extent e) nil) - nil nil nil nil nil 'initial-redisplay-function 'lazy-shot-redisplay-function) - (when (and font-lock-mode (not no-fontify)) - (save-restriction - (widen) - (lazy-shot-fontify-region (point-min) (point-max))))) - -(provide 'lazy-shot) - -;;; lazy-shot.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/linuxdoc-sgml.el --- a/lisp/modes/linuxdoc-sgml.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,176 +0,0 @@ -;;; linuxdoc-sgml.el --- sgml-mode enhancements for linuxdoc - -;; Copyright (C) 1996 by Free Software Foundation, Inc. - -;; Author: Arun Sharma -;; Keywords: docs, languages - -;; 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., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Installation: -;; Make sure that this file is in your load-path and put this line -;; in your .emacs. -;; (autoload 'linuxdoc-sgml-mode "linuxdoc-sgml" t t) -;; (setq auto-mode-alist (cons '("\\.sgml$" . linuxdoc-sgml-mode) -;; auto-mode-alist)) -;; -;; Optionally: -;; (add-hook 'linuxdoc-sgml-mode-hook 'turn-on-font-lock) -;; -;; Caveat: I've had problems getting sgml/html code to work with -;; lazy-lock. Currently under investigation. -;;; Code: - -(require 'sgml-mode) - -(defvar linuxdoc-sgml-tag-alist - (let* ((htmlurl '(("ftp:") ("file:") ("finger:") - ("gopher:") ("http:") ("mailto:") ("news:") - ("rlogin:") ("telnet:") ("tn3270:") ("wais:") - ("/cgi-bin/"))) - (name '(str)) - (id '(str))) - `(("abstract" \n) - ("article" \n) - ("author" t) - ("bf") - ("date" t) - ("descrip" \n) - ("enum" \n) - ("footnote") - ("htmlurl" t ("url" ,@htmlurl) ("name" ,@name)) - ("item" t) - ("itemize" \n) - ("label" ("id" ,@id)) - ("p" t) - ("quote" \n) - ("ref" t ("id") ("name" ,@name)) - ("sect" (t (setq str (read-input "Sect: ")) "\n

\n")) - ("sect1" (t (setq str (read-input "Sect1: ")) "\n

\n")) - ("sect2" (t (setq str (read-input "Sect2: ")) "\n

\n")) - ("sect3" (t (setq str (read-input "Sect3: ")) "\n

\n")) - ("sect4" (t (setq str (read-input "Sect4: ")) "\n

\n")) - ("tag //" t) - ("title" (t (setq str (read-input "Title: ")) "\n")) - ("toc" t) - ("tscreen") - ("tt" (nil (setq str (read-input "Text: ")))) - ("url" t ("url" ,@htmlurl) ("name" ,@name)) - ("verb" \n))) - "Linuxdoc specific tags") - -(defvar linuxdoc-sgml-tag-help - '(("abstract" . "Abstract of the document") - ("article" . "Beginning of the article") - ("author" . "Name of the Author") - ("bf" . "Bold font") - ("date" . "Date") - ("descrip" . "Description environment") - ("enum" . "Enumerated items") - ("footnote" . "Footnotes") - ("htmlurl" . "Insert a URL that shows up only in the HTML version") - ("item" . "An enumerated or unordered item") - ("itemize" . "Unordered list") - ("label" . "A label for cross reference") - ("p" . "Marks the end of the sect* tag") - ("quote" . "Quote a piece of text") - ("ref" . "Cross reference") - ("sect" . "Main section heading") - ("sect1" . "Level 1 section heading") - ("sect2" . "Level 2 section heading") - ("sect3" . "Level 3 section heading") - ("sect4" . "Level 4 section heading") - ("tag //" . "A description tag") - ("title" . "Title of the document") - ("toc" . "The table of contents") - ("tscreen" . "Indents the text and uses tt font") - ("tt" . "Uses the tt font") - ("url" . "Insert a URL") - ("verb" . "The text will be typed verbatim")) - "Help for linuxdoc specific tags") - -(defvar linuxdoc-sgml-tag-face-alist - '(("abstract" . underline) - ("article" . italic) - ("author" . italic) - ("bf" . bold) - ("date" . italic) - ("descrip" . font-lock-reference-face) - ("enum" . font-lock-type-face) - ("footnote" . font-lock-keyword-face) - ("htmlurl" . font-lock-string-face) - ("item" . font-lock-function-name-face) - ("itemize" . font-lock-type-face) - ("label" . font-lock-comment-face) - ("p" . default) - ("quote" . underline) - ("ref" . font-lock-comment-face) - ("sect" . underline) - ("sect1" . underline) - ("sect2" . underline) - ("sect3" . underline) - ("sect4" . underline) - ("tag" . font-lock-function-name-face) - ("title" . underline) - ("toc" . default) - ("tscreen" . underline) - ("tt" . underline) - ("url" . font-lock-string-face) - ("verb" . underline)) - "Value of `sgml-tag-face-alist' for linuxdoc-sgml mode.") - -(defvar linuxdoc-sgml-font-lock-keywords - '(("<\\([^>]*\\)>" . font-lock-comment-face)) - "Patterns to highlight in LD-SGML buffers.") - -;;;###autoload -(defun linuxdoc-sgml-mode () - "Major mode based on SGML mode for editing linuxdoc-sgml documents. -See the documentation on sgml-mode for more info. This mode -understands the linuxdoc-sgml tags." - (interactive) - (sgml-mode-common linuxdoc-sgml-tag-face-alist nil) - (use-local-map sgml-mode-map) - (make-local-variable 'sgml-tag-alist) - (make-local-variable 'sgml-face-tag-alist) - (make-local-variable 'sgml-tag-help) - (make-local-variable 'outline-regexp) - (make-local-variable 'outline-heading-end-regexp) - (make-local-variable 'outline-level) - (make-local-variable 'sgml-font-lock-keywords) - (setq mode-name "LD-SGML" - major-mode 'linuxdoc-sgml-mode - sgml-tag-alist linuxdoc-sgml-tag-alist - sgml-face-tag-alist linuxdoc-sgml-tag-face-alist - sgml-tag-help linuxdoc-sgml-tag-help - outline-regexp "^.*" - outline-heading-end-regexp "

" - sgml-font-lock-keywords-1 (append sgml-font-lock-keywords-1 - linuxdoc-sgml-font-lock-keywords - sgml-font-lock-keywords) - - outline-level (lambda () - (char-after (1- (match-end 0))))) - (run-hooks 'linuxdoc-sgml-mode-hook)) - - -(provide 'linuxdoc-sgml) - -;;; linuxdoc-sgml.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/lisp-mnt.el --- a/lisp/modes/lisp-mnt.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,576 +0,0 @@ -;;; lisp-mnt.el --- minor mode for Emacs Lisp maintainers - -;; Copyright (C) 1992, 1994 Free Software Foundation, Inc. - -;; Author: Eric S. Raymond -;; Maintainer: Eric S. Raymond -;; Created: 14 Jul 1992 -;; Version: $Id: lisp-mnt.el,v 1.1.1.1 1996/12/18 22:42:47 steve Exp $ -;; Keywords: docs -;; X-Modified-by: Bob Weiner , 4/14/95, to support InfoDock -;; headers. -;; X-Bogus-Bureaucratic-Cruft: Gruad will get you if you don't watch out! - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34. - -;;; Commentary: - -;; This minor mode adds some services to Emacs-Lisp editing mode. -;; -;; First, it knows about the header conventions for library packages. -;; One entry point supports generating synopses from a library directory. -;; Another can be used to check for missing headers in library files. -;; -;; Another entry point automatically addresses bug mail to a package's -;; maintainer or author. - -;; This file can be loaded by your lisp-mode-hook. Have it (require 'lisp-mnt) - -;; This file is an example of the header conventions. Note the following -;; features: -;; -;; * Header line --- makes it possible to extract a one-line summary of -;; the package's uses automatically for use in library synopses, KWIC -;; indexes and the like. -;; -;; Format is three semicolons, followed by the filename, followed by -;; three dashes, followed by the summary. All fields space-separated. -;; -;; * Author line --- contains the name and net address of at least -;; the principal author. -;; -;; If there are multiple authors, they should be listed on continuation -;; lines led by ;;, like this: -;; -;; ;; Author: Ashwin Ram -;; ;; Dave Sill -;; ;; David Lawrence -;; ;; Noah Friedman -;; ;; Joe Wells -;; ;; Dave Brennan -;; ;; Eric Raymond -;; -;; This field may have some special values; notably "FSF", meaning -;; "Free Software Foundation". -;; -;; * Maintainer line --- should be a single name/address as in the Author -;; line, or an address only, or the string "FSF". If there is no maintainer -;; line, the person(s) in the Author field are presumed to be it. The example -;; in this file is mildly bogus because the maintainer line is redundant. -;; The idea behind these two fields is to be able to write a Lisp function -;; that does "send mail to the author" without having to mine the name out by -;; hand. Please be careful about surrounding the network address with <> if -;; there's also a name in the field. -;; -;; * Created line --- optional, gives the original creation date of the -;; file. For historical interest, basically. -;; -;; * Version line --- intended to give the reader a clue if they're looking -;; at a different version of the file than the one they're accustomed to. This -;; may be an RCS or SCCS header. -;; -;; * Adapted-By line --- this is for FSF's internal use. The person named -;; in this field was the one responsible for installing and adapting the -;; package for the distribution. (This file doesn't have one because the -;; author *is* one of the maintainers.) -;; -;; * Keywords line --- used by the finder code (now under construction) -;; for finding Emacs Lisp code related to a topic. -;; -;; * X-Bogus-Bureaucratic-Cruft line --- this is a joke and an example -;; of a comment header. Headers starting with `X-' should never be used -;; for any real purpose; this is the way to safely add random headers -;; without invoking the wrath of any program. -;; -;; * Commentary line --- enables Lisp code to find the developer's and -;; maintainers' explanations of the package internals. -;; -;; * Change log line --- optional, exists to terminate the commentary -;; section and start a change-log part, if one exists. -;; -;; * Code line --- exists so Lisp can know where commentary and/or -;; change-log sections end. -;; -;; * Footer line --- marks end-of-file so it can be distinguished from -;; an expanded formfeed or the results of truncation. - -;;; Change Log: - -;; Tue Jul 14 23:44:17 1992 ESR -;; * Created. - -;;; Code: - -(require 'picture) ; provides move-to-column-force -(require 'emacsbug) - -;;; Variables: - -(defvar lm-header-prefix "^;;*[ \t]+\\(@\(#\)\\)?[ \t]*\\([\$]\\)?" - "Prefix that is ignored before the tag. -For example, you can write the 1st line synopsis string and headers like this -in your Lisp package: - - ;; @(#) package.el -- pacakge description - ;; - ;; @(#) $Maintainer: Person Foo Bar $ - -The @(#) construct is used by unix what(1) and -then $identifier: doc string $ is used by GNU ident(1)") - -(defvar lm-comment-column 16 - "Column used for placing formatted output.") - -(defvar lm-commentary-header "Commentary\\|Documentation" - "Regexp which matches start of documentation section.") - -(defvar lm-history-header "Change Log\\|History" - "Regexp which matches the start of code log section.") - -;;; Functions: - -;; These functions all parse the headers of the current buffer - -(defsubst lm-get-header-re (header &optional mode) - "Returns regexp for matching HEADER. -If called with optional MODE and with value `section', -return section regexp instead." - (cond ((eq mode 'section) - (concat "^;;;;* " header ":[ \t]*$")) - (t - (concat lm-header-prefix header ":[ \t]*")))) - -(defsubst lm-get-package-name () - "Returns package name by looking at the first line." - (save-excursion - (goto-char (point-min)) - (if (and (looking-at (concat lm-header-prefix)) - (progn (goto-char (match-end 0)) - (looking-at "\\([^\t ]+\\)") - (match-end 1))) - (buffer-substring (match-beginning 1) (match-end 1)) - ))) - -(defun lm-section-mark (header &optional after) - "Return the buffer location of a given section start marker. -The HEADER is the section mark string to search for. -If AFTER is non-nil, return the location of the next line." - (save-excursion - (let ((case-fold-search t)) - (goto-char (point-min)) - (if (re-search-forward (lm-get-header-re header 'section) nil t) - (progn - (beginning-of-line) - (if after (forward-line 1)) - (point)) - nil)))) - -(defsubst lm-code-mark () - "Return the buffer location of the `Code' start marker." - (lm-section-mark "Code")) - -(defsubst lm-commentary-mark () - "Return the buffer location of the `Commentary' start marker." - (lm-section-mark lm-commentary-header)) - -(defsubst lm-history-mark () - "Return the buffer location of the `History' start marker." - (lm-section-mark lm-history-header)) - -(defun lm-header (header) - "Return the contents of the header named HEADER." - (goto-char (point-min)) - (let ((case-fold-search t)) - (if (and (re-search-forward (lm-get-header-re header) (lm-code-mark) t) - ;; RCS ident likes format "$identifier: data$" - (looking-at "\\([^$\n]+\\)") - (match-end 1)) - (buffer-substring (match-beginning 1) (match-end 1)) - nil))) - -(defun lm-header-multiline (header) - "Return the contents of the header named HEADER, with continuation lines. -The returned value is a list of strings, one per line." - (save-excursion - (goto-char (point-min)) - (let ((res (lm-header header))) - (cond - (res - (setq res (list res)) - (forward-line 1) - - (while (and (looking-at (concat lm-header-prefix "[\t ]+")) - (progn - (goto-char (match-end 0)) - (looking-at "\\(.*\\)")) - (match-end 1)) - (setq res (cons (buffer-substring - (match-beginning 1) - (match-end 1)) - res)) - (forward-line 1)) - )) - res - ))) - -;; These give us smart access to the header fields and commentary - -(defun lm-summary (&optional file) - "Return the one-line summary of file FILE, or current buffer if FILE is nil." - (save-excursion - (if file - (find-file file)) - (goto-char (point-min)) - (prog1 - (if (and - (looking-at lm-header-prefix) - (progn (goto-char (match-end 0)) - (looking-at "[^ ]+[ \t]+--+[ \t]+\\(.*\\)"))) - (buffer-substring (match-beginning 1) (match-end 1))) - (if file - (kill-buffer (current-buffer))) - ))) - -(defun lm-crack-address (x) - "Split up an email address into full name and real email address. -The value is a cons of the form (FULLNAME . ADDRESS)." - (cond ((string-match "\\(.+\\) [(<]\\(\\S-+@\\S-+\\)[>)]" x) - (cons (substring x (match-beginning 1) (match-end 1)) - (substring x (match-beginning 2) (match-end 2)))) - ((string-match "\\(\\S-+@\\S-+\\) [(<]\\(.*\\)[>)]" x) - (cons (substring x (match-beginning 2) (match-end 2)) - (substring x (match-beginning 1) (match-end 1)))) - ((string-match "\\S-+@\\S-+" x) - (cons nil x)) - (t - (cons x nil)))) - -(defun lm-authors (&optional file) - "Return the author list of file FILE, or current buffer if FILE is nil. -Each element of the list is a cons; the car is the full name, -the cdr is an email address." - (save-excursion - (if file - (find-file file)) - ;; XEmacs change (Is E-MAIL an infodock header? -sb) - (let* ((authorlist (lm-header-multiline "author")) - (email-list (lm-header-multiline "E-MAIL")) - (authors authorlist)) - (prog1 - (if (null email-list) - (mapcar 'lm-crack-address authorlist) - (while (and email-list authors) - (setcar authors (cons (car authors) (car email-list))) - (setq email-list (cdr email-list) - authors (cdr authors))) - authorlist) - (if file - (kill-buffer (current-buffer)))) - ))) - -(defun lm-maintainer (&optional file) - "Return the maintainer of file FILE, or current buffer if FILE is nil. -The return value has the form (NAME . ADDRESS)." - (save-excursion - (if file - (find-file file)) - (prog1 - (let ((maint (lm-header "maintainer"))) - (if maint - (lm-crack-address maint) - (car (lm-authors)))) - (if file - (kill-buffer (current-buffer)))))) - -(defun lm-creation-date (&optional file) - "Return the created date given in file FILE, or current buffer if FILE is nil." - (save-excursion - (if file - (find-file file)) - (prog1 - ;; XEmacs change (Is ORIG-DATE an Infodock header? -sb) - (or (lm-header "created") - (let ((date-and-time (lm-header "ORIG-DATE"))) - (if date-and-time - (substring date-and-time 0 - (string-match " " date-and-time))))) - (if file - (kill-buffer (current-buffer))) - ))) - -(defun lm-last-modified-date (&optional file) - "Return the modify-date given in file FILE, or current buffer if FILE is nil." - (save-excursion - (if file - (find-file file)) - (prog1 - (if (progn - (goto-char (point-min)) - (re-search-forward - "\\$Id: [^ ]+ [^ ]+ \\([^/]+\\)/\\([^/]+\\)/\\([^ ]+\\) " - (lm-code-mark) t)) - (format "%s %s %s" - (buffer-substring (match-beginning 3) (match-end 3)) - (nth (string-to-int - (buffer-substring (match-beginning 2) (match-end 2))) - '("" "Jan" "Feb" "Mar" "Apr" "May" "Jun" - "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")) - (buffer-substring (match-beginning 1) (match-end 1))) - ;; XEmacs change (Infodock change? -sb) - (let ((date-and-time (lm-header "LAST-MOD"))) - (if date-and-time - (substring date-and-time 0 - (string-match " " date-and-time))))) - (if file - (kill-buffer (current-buffer))) - ))) - -(defun lm-version (&optional file) - "Return the version listed in file FILE, or current buffer if FILE is nil. -This can befound in an RCS or SCCS header to crack it out of." - (save-excursion - (if file - (find-file file)) - (prog1 - (or - (lm-header "version") - (let ((header-max (lm-code-mark))) - (goto-char (point-min)) - (cond - ;; Look for an RCS header - ((re-search-forward "\\$Id: [^ ]+ \\([^ ]+\\) " header-max t) - (buffer-substring (match-beginning 1) (match-end 1))) - - ;; Look for an SCCS header - ((re-search-forward - (concat - (regexp-quote "@(#)") - (regexp-quote (file-name-nondirectory (buffer-file-name))) - "\t\\([012345679.]*\\)") - header-max t) - (buffer-substring (match-beginning 1) (match-end 1))) - - (t nil)))) - (if file - (kill-buffer (current-buffer))) - ))) - -(defun lm-keywords (&optional file) - "Return the keywords given in file FILE, or current buffer if FILE is nil." - (save-excursion - (if file - (find-file file)) - (prog1 - (let ((keywords (lm-header "keywords"))) - (and keywords (downcase keywords))) - (if file - (kill-buffer (current-buffer))) - ))) - -(defun lm-adapted-by (&optional file) - "Return the adapted-by names in file FILE, or current buffer if FILE is nil. -This is the name of the person who cleaned up this package for -distribution." - (save-excursion - (if file - (find-file file)) - (prog1 - (lm-header "adapted-by") - (if file - (kill-buffer (current-buffer))) - ))) - -(defun lm-commentary (&optional file) - "Return the commentary in file FILE, or current buffer if FILE is nil. -The value is returned as a string. In the text, the commentary starts -with tag `Commentary' and ends with tag `Change Log' or `History'." - (save-excursion - (if file - (find-file file)) - (prog1 - (let ((commentary (lm-commentary-mark)) - (change-log (lm-history-mark)) - (code (lm-code-mark)) - ) - (cond - ((and commentary change-log) - (buffer-substring commentary change-log)) - ((and commentary code) - (buffer-substring commentary code)) - (t - ;; XEmacs change (Infodock headers? -sb) - (setq commentary (lm-section-mark "DESCRIPTION" t) - code (lm-section-mark "DESCRIP-END")) - (and commentary end (buffer-substring commentary code))))) - (if file - (kill-buffer (current-buffer))) - ))) - -;;; Verification and synopses - -(defun lm-insert-at-column (col &rest strings) - "Insert list of STRINGS, at column COL." - (if (> (current-column) col) (insert "\n")) - (move-to-column-force col) - (apply 'insert strings)) - -(defun lm-verify (&optional file showok &optional verb) - "Check that the current buffer (or FILE if given) is in proper format. -If FILE is a directory, recurse on its files and generate a report in -a temporary buffer." - (interactive) - (let* ((verb (or verb (interactive-p))) - ret - name - ) - (if verb - (setq ret "Ok.")) ;init value - - (if (and file (file-directory-p file)) - (setq - ret - (progn - (switch-to-buffer (get-buffer-create "*lm-verify*")) - (erase-buffer) - (mapcar - '(lambda (f) - (if (string-match ".*\\.el$" f) - (let ((status (lm-verify f))) - (if status - (progn - (insert f ":") - (lm-insert-at-column lm-comment-column status "\n")) - (and showok - (progn - (insert f ":") - (lm-insert-at-column lm-comment-column "OK\n"))))))) - (directory-files file)) - )) - (save-excursion - (if file - (find-file file)) - (setq name (lm-get-package-name)) - - (setq - ret - (prog1 - (cond - ((null name) - "Can't find a package NAME") - - ((not (lm-authors)) - "Author: tag missing.") - - ((not (lm-maintainer)) - "Maintainer: tag missing.") - - ((not (lm-summary)) - "Can't find a one-line 'Summary' description") - - ((not (lm-keywords)) - "Keywords: tag missing.") - - ((not (lm-commentary-mark)) - "Can't find a 'Commentary' section marker.") - - ((not (lm-history-mark)) - "Can't find a 'History' section marker.") - - ((not (lm-code-mark)) - "Can't find a 'Code' section marker") - - ((progn - (goto-char (point-max)) - (not - (re-search-backward - (concat "^;;;[ \t]+" name "[ \t]+ends here[ \t]*$" - "\\|^;;;[ \t]+ End of file[ \t]+" name) - nil t - ))) - (format "Can't find a footer line for [%s]" name)) - (t - ret)) - (if file - (kill-buffer (current-buffer))) - )))) - (if verb - (message ret)) - ret - )) - -(defun lm-synopsis (&optional file showall) - "Generate a synopsis listing for the buffer or the given FILE if given. -If FILE is a directory, recurse on its files and generate a report in -a temporary buffer. If SHOWALL is non-nil, also generate a line for files -which do not include a recognizable synopsis." - (interactive - (list - (read-file-name "Synopsis for (file or dir): "))) - - (if (and file (file-directory-p file)) - (progn - (switch-to-buffer (get-buffer-create "*lm-verify*")) - (erase-buffer) - (mapcar - '(lambda (f) - (if (string-match ".*\\.el$" f) - (let ((syn (lm-synopsis f))) - (if syn - (progn - (insert f ":") - (lm-insert-at-column lm-comment-column syn "\n")) - (and showall - (progn - (insert f ":") - (lm-insert-at-column lm-comment-column "NA\n"))))))) - (directory-files file)) - ) - (save-excursion - (if file - (find-file file)) - (prog1 - (lm-summary) - (if file - (kill-buffer (current-buffer))) - )))) - -(defun lm-report-bug (topic) - "Report a bug in the package currently being visited to its maintainer. -Prompts for bug subject. Leaves you in a mail buffer." - (interactive "sBug Subject: ") - (let ((package (lm-get-package-name)) - (addr (lm-maintainer)) - (version (lm-version))) - (mail nil - (if addr - (concat (car addr) " <" (cdr addr) ">") - bug-gnu-emacs) - topic) - (goto-char (point-max)) - (insert "\nIn " - package - (if version (concat " version " version) "") - "\n\n") - (message - (substitute-command-keys "Type \\[mail-send] to send bug report.")))) - -(provide 'lisp-mnt) - -;;; lisp-mnt.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/mail-abbrevs.el --- a/lisp/modes/mail-abbrevs.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,767 +0,0 @@ -;;; Abbrev-expansion of mail aliases. -;;; Copyright (C) 1985-1994 Free Software Foundation, Inc. -;;; Created: 19 oct 90, Jamie Zawinski -;;; Modified: 5 apr 92, Roland McGrath -;;; Last change 4-may-94. jwz - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; This file ensures that, when the point is in a To:, CC:, BCC:, or From: -;;; field, word-abbrevs are defined for each of your mail aliases. These -;;; aliases will be defined from your .mailrc file (or the file specified by -;;; the MAILRC environment variable) if it exists. Your mail aliases will -;;; expand any time you type a word-delimiter at the end of an abbreviation. -;;; -;;; What you see is what you get: no abbreviations will be expanded after you -;;; have sent the mail, unlike the old system. This means you don't suffer -;;; the annoyance of having the system do things behind your back -- if an -;;; address you typed is going to be rewritten, you know it immediately, -;;; instead of after the mail has been sent and it's too late to do anything -;;; about it. You will never again be screwed because you forgot to delete an -;;; old alias from your .mailrc when a new local user arrives and is given a -;;; userid which conflicts with one of your aliases, for example. -;;; -;;; Your mail alias abbrevs will be in effect only when the point is in an -;;; appropriate header field. When in the body of the message, or other -;;; header fields, the mail aliases will not expand. Rather, the normal -;;; mode-specific abbrev table (mail-mode-abbrev-table) will be used if -;;; defined. So if you use mail-mode specific abbrevs, this code will not -;;; adversely affect you. You can control which header fields the abbrevs -;;; are used in by changing the variable mail-abbrev-mode-regexp. -;;; -;;; If auto-fill mode is on, abbrevs will wrap at commas instead of at word -;;; boundaries; also, header continuation-lines will be properly indented. -;;; -;;; You can also insert a mail alias with mail-interactive-insert-alias -;;; (bound to C-c C-a), which prompts you for an alias (with completion) -;;; and inserts its expansion at point. -;;; -;;; This file fixes a bug in the old system which prohibited your .mailrc -;;; file from having lines like -;;; -;;; alias someone "John Doe " -;;; -;;; That is, if you want an address to have embedded spaces, simply surround it -;;; with quotes. This is necessary because the format of the .mailrc file -;;; bogusly uses spaces as address delimiters. The following line defines an -;;; alias which expands to three addresses: -;;; -;;; alias foobar addr-1 addr-2 "address three " -;;; -;;; (This is bogus because mail-delivery programs want commas, not spaces, -;;; but that's what the file format is, so we have to live with it.) -;;; -;;; If you like, you can call the function define-mail-alias to define your -;;; mail-aliases instead of using a .mailrc file. When you call it in this -;;; way, addresses are separated by commas. -;;; -;;; CAVEAT: This works on most Sun systems; I have been told that some versions -;;; of /bin/mail do not understand double-quotes in the .mailrc file. So you -;;; should make sure your version does before including verbose addresses like -;;; this. One solution to this, if you are on a system whose /bin/mail doesn't -;;; work that way, (and you still want to be able to /bin/mail to send mail in -;;; addition to emacs) is to define minimal aliases (without full names) in -;;; your .mailrc file, and use define-mail-alias to redefine them when sending -;;; mail from emacs; this way, mail sent from /bin/mail will work, and mail -;;; sent from emacs will be pretty. -;;; -;;; Aliases in the mailrc file may be nested. If you define aliases like -;;; alias group1 fred ethel -;;; alias group2 larry curly moe -;;; alias everybody group1 group2 -;;; Then when you type "everybody" on the To: line, it will be expanded to -;;; fred, ethyl, larry, curly, moe -;;; -;;; Aliases may also contain forward references; the alias of "everybody" can -;;; precede the aliases of "group1" and "group2". -;;; -;;; This code also understands the "source" .mailrc command, for reading -;;; aliases from some other file as well. -;;; -;;; Aliases may contain hyphens, as in "alias foo-bar foo@bar"; word-abbrevs -;;; normally cannot contain hyphens, but this code works around that for the -;;; specific case of mail-alias word-abbrevs. -;;; -;;; To read in the contents of another .mailrc-type file from emacs, use the -;;; command Meta-X merge-mail-aliases. The rebuild-mail-aliases command is -;;; similar, but will delete existing aliases first. -;;; -;;; If you want multiple addresses separated by a string other than ", " then -;;; you can set the variable mail-alias-separator-string to it. This has to -;;; be a comma bracketed by whitespace if you want any kind of reasonable -;;; behaviour. -;;; -;;; Some versions of /bin/mail append the contents of multiple definitions of -;;; the same alias together, so that -;;; alias group one two three -;;; alias group four five -;;; would define "group" as "one two three four five" instead of "four five". -;;; This code does *not* support that syntax, because it's a horrible syntax -;;; and isn't worth the effort or added code complexity. (So there.) -;;; -;;; Thanks to Harald Hanche-Olsen, Michael Ernst, David Loeffler, Noah -;;; Friedman, and Michelangelo Grigni for suggestions and bug reports. -;;; -;;; INSTALLATION -;;; -;;; If you are using Emacs 18, you shouldn't have to do anything at all to -;;; install this code other than load this file. You might want to do this -;;; to have this code loaded only when needed: -;;; -;;; (setq mail-setup-hook '(lambda () (require 'mail-abbrevs))) -;;; -;;; Simply loading this file will redefine and overload the required -;;; functions. -;;; -;;; If you want to install this code more permanently (instead of loading -;;; it as a patch) you need to do the following: -;;; -;;; - Remove the entire file mailalias.el; -;;; - Remove the definition of mail-aliases from sendmail.el; -;;; - Add a call to mail-aliases-setup to the front of the function -;;; mail-setup in the file sendmail.el; -;;; - Remove the call to expand-mail-aliases from the function -;;; sendmail-send-it in the file sendmail.el; -;;; - Remove the autoload of expand-mail-aliases from the file sendmail.el; -;;; - Remove the autoload of build-mail-aliases from the file sendmail.el; -;;; - Add an autoload of define-mail-alias to loaddefs.el. - -(require 'sendmail) - -(defgroup mail-abbrevs nil - "Mail abbreviation (addressbook)" - :group 'mail) - -;;;###autoload -(defcustom mail-abbrev-mailrc-file nil - "Name of file with mail aliases. If nil, ~/.mailrc is used." - :type '(choice (const :tag "Default" nil) - file) - :group 'mail-abbrevs) - -(defmacro mail-abbrev-mailrc-file () - '(or mail-abbrev-mailrc-file - (setq mail-abbrev-mailrc-file - (or (getenv "MAILRC") "~/.mailrc")))) - -;; originally defined in sendmail.el - used to be an alist, now is a table. -;;;###autoload -(defvar mail-aliases nil - "Word-abbrev table of mail address aliases. -If this is nil, it means the aliases have not yet been initialized and -should be read from the .mailrc file. (This is distinct from there being -no aliases, which is represented by this being a table with no entries.)") - -;;;###autoload -(defun mail-aliases-setup () - (if (and (not (vectorp mail-aliases)) - (file-exists-p (mail-abbrev-mailrc-file))) - (build-mail-aliases)) - (make-local-variable 'pre-abbrev-expand-hook) - (setq pre-abbrev-expand-hook - (cond ((and (listp pre-abbrev-expand-hook) - (not (eq 'lambda (car pre-abbrev-expand-hook)))) - (cons 'sendmail-pre-abbrev-expand-hook pre-abbrev-expand-hook)) - (t - (list 'sendmail-pre-abbrev-expand-hook pre-abbrev-expand-hook)))) - (abbrev-mode 1)) - -;;; Originally defined in mailalias.el. Changed to call define-mail-alias -;;; with an additional argument. -;;;###autoload -(defun build-mail-aliases (&optional file recursivep) - "Read mail aliases from .mailrc and set mail-aliases." - (setq file (expand-file-name (or file (mail-abbrev-mailrc-file)))) - (or (vectorp mail-aliases) - (setq mail-aliases (make-abbrev-table))) - (message "Parsing %s..." file) - (let ((buffer nil) - (obuf (current-buffer))) - (unwind-protect - (progn - (setq buffer (generate-new-buffer "mailrc")) - (buffer-disable-undo buffer) - (set-buffer buffer) - (cond ((get-file-buffer file) - (insert (save-excursion - (set-buffer (get-file-buffer file)) - (buffer-substring (point-min) (point-max))))) - ((not (file-exists-p file))) - (t (insert-file-contents file))) - ;; Don't lose if no final newline. - (goto-char (point-max)) - (or (eq (preceding-char) ?\n) (newline)) - (goto-char (point-min)) - ;; Delete comments from the file - (while (search-forward "# " nil t) - (let ((p (- (point) 2))) - (end-of-line) - (delete-region p (point)))) - (goto-char (point-min)) - ;; handle "\\\n" continuation lines - (while (not (eobp)) - (end-of-line) - (if (= (preceding-char) ?\\) - (progn (delete-char -1) (delete-char 1) (insert ?\ )) - (forward-char 1))) - (goto-char (point-min)) - (while (re-search-forward - "^\\(a\\(lias\\)?\\|g\\(roup\\)?\\|source\\)[ \t]+" nil t) - (beginning-of-line) - (if (looking-at "source[ \t]+\\([^ \t\n]+\\)") - (progn - (end-of-line) - (build-mail-aliases - (substitute-in-file-name - (buffer-substring (match-beginning 1) (match-end 1))) - t)) - (re-search-forward "[ \t]+\\([^ \t\n]+\\)") - (let* ((name (buffer-substring - (match-beginning 1) (match-end 1))) - (start (progn (skip-chars-forward " \t") (point)))) - (end-of-line) -; (message "** %s \"%s\"" name (buffer-substring start (point)))(sit-for 1) - (define-mail-alias - name - (buffer-substring start (point)) - t)))) - ;; Resolve forward references in .mailrc file. - ;; This would happen automatically before the first abbrev was - ;; expanded, but why not do it now. - (or recursivep (mail-resolve-all-aliases)) - ) - (if buffer (kill-buffer buffer)) - (set-buffer obuf))) - (message "Parsing %s... done" file)) - -(defcustom mail-alias-separator-string ", " - "*A string inserted between addresses in multi-address mail aliases. -This has to contain a comma, so \", \" is a reasonable value. You might -also want something like \",\\n \" to get each address on its own line." - :type 'string - :group 'mail-abbrevs) - -;; define-mail-alias sets this flag, which causes mail-resolve-all-aliases -;; to be called before expanding abbrevs if it's necessary. -(defvar mail-abbrev-aliases-need-to-be-resolved t) - -;; originally defined in mailalias.el ; build-mail-aliases calls this with -;; stuff parsed from the .mailrc file. -;; -;;;###autoload -(defun define-mail-alias (name definition &optional from-mailrc-file) - "Define NAME as a mail-alias that translates to DEFINITION. -If DEFINITION contains multiple addresses, separate them with commas." - ;; When this is called from build-mail-aliases, the third argument is - ;; true, and we do some evil space->comma hacking like /bin/mail does. - (interactive "sDefine mail alias: \nsDefine %s as mail alias for: ") - ;; Read the defaults first, if we have not done so. - (if (vectorp mail-aliases) - nil - (setq mail-aliases (make-abbrev-table)) - (if (file-exists-p (mail-abbrev-mailrc-file)) - (build-mail-aliases))) - ;; strip garbage from front and end - (if (string-match "\\`[ \t\n,]+" definition) - (setq definition (substring definition (match-end 0)))) - (if (string-match "[ \t\n,]+\\'" definition) - (setq definition (substring definition 0 (match-beginning 0)))) - (let ((result '()) - (start 0) - (L (length definition)) - end) - (while start - ;; If we're reading from the mailrc file, then addresses are delimited - ;; by spaces, and addresses with embedded spaces must be surrounded by - ;; single or double-quotes. Otherwise, addresses are separated by - ;; commas. - (if from-mailrc-file - (cond ((eq ?\" (aref definition start)) - (setq start (1+ start) - end (string-match "\"[ \t,]*" definition start))) - ((eq ?\' (aref definition start)) - (setq start (1+ start) - end (string-match "\'[ \t,]*" definition start))) - (t - (setq end (string-match "[ \t,]+" definition start)))) - (setq end (string-match "[ \t\n,]*,[ \t\n,]*" definition start))) - (setq result (cons (substring definition start end) result)) - (setq start (and end - (/= (match-end 0) L) - (match-end 0)))) - (setq definition (mapconcat (function identity) - (nreverse result) - mail-alias-separator-string))) - (setq mail-abbrev-aliases-need-to-be-resolved t) - (setq name (downcase name)) - ;; use an abbrev table instead of an alist for mail-aliases. - (let ((abbrevs-changed abbrevs-changed)) ; protect this from being changed. - (define-abbrev mail-aliases name definition 'mail-abbrev-expand-hook))) - - -(defun mail-resolve-all-aliases () - "Resolve all forward references in the mail aliases table." - (if mail-abbrev-aliases-need-to-be-resolved - (progn -;; (message "Resolving mail aliases...") - (if (vectorp mail-aliases) - (mapatoms (function mail-resolve-all-aliases-1) mail-aliases)) - (setq mail-abbrev-aliases-need-to-be-resolved nil) -;; (message "Resolving mail aliases... done.") - ))) - -(defun mail-resolve-all-aliases-1 (sym &optional so-far) - (if (memq sym so-far) - (error "mail alias loop detected: %s" - (mapconcat 'symbol-name (cons sym so-far) " <- "))) - (let ((definition (and (boundp sym) (symbol-value sym)))) - (if definition - (let ((result '()) - (start 0)) - (while start - (let ((end (string-match "[ \t\n]*,[, \t\n]*" definition start))) - (setq result (cons (substring definition start end) result) - start (and end (match-end 0))))) - (setq definition - (mapconcat (function (lambda (x) - (or (mail-resolve-all-aliases-1 - (intern-soft (downcase x) mail-aliases) - (cons sym so-far)) - x))) - (nreverse result) - mail-alias-separator-string)) - (set sym definition)))) - (symbol-value sym)) - - -(defun mail-abbrev-expand-hook () - "For use as the fourth arg to define-abbrev. -After expanding a mail-abbrev, if fill-mode is on and we're past the -fill-column, break the line at the previous comma, and indent the next -line." - (save-excursion - (let ((p (point)) - bol comma fp) - (beginning-of-line) - (setq bol (point)) - (goto-char p) - (while (and auto-fill-function - (>= (current-column) fill-column) - (search-backward "," bol t)) - (setq comma (point)) - (forward-char 1) ; Now we are just past the comma. - (insert "\n") - (delete-horizontal-space) - (setq p (point)) - ;; Prevent abbrev expansion from happening again, since - ;; sendmail-pre-abbrev-expand-hook will already have done it. - (let ((abbrev-mode nil)) - (indent-relative)) - (setq fp (buffer-substring p (point))) - ;; Go to the end of the new line. - (end-of-line) - (if (> (current-column) fill-column) - ;; It's still too long; do normal auto-fill. - (let ((fill-prefix (or fp "\t"))) - (do-auto-fill))) - ;; Resume the search. - (goto-char comma) - )))) - -;;; Syntax tables and abbrev-expansion - -(defcustom mail-abbrev-mode-regexp - "^\\(Resent-\\)?\\(To\\|From\\|CC\\|BCC\\|Reply-to\\):" - "*Regexp to select mail-headers in which mail aliases should be expanded. -This string it will be handed to `looking-at' with the point at the beginning -of the current line; if it matches, abbrev mode will be turned on, otherwise -it will be turned off. (You don't need to worry about continuation lines.) -This should be set to match those mail fields in which you want abbreviations -turned on." - :type 'regexp - :group 'mail-abbrevs) - -(defvar mail-mode-syntax-table (copy-syntax-table text-mode-syntax-table) - "The syntax table which is used in send-mail mode message bodies.") - -(defvar mail-mode-header-syntax-table - (let ((tab (copy-syntax-table text-mode-syntax-table))) - ;; This makes the characters "@%!._-" be considered symbol-consituents - ;; but not word-constituents, so forward-sexp will move you over an - ;; entire address, but forward-word will only move you over a sequence - ;; of alphanumerics. (Clearly the right thing.) - (modify-syntax-entry ?@ "_" tab) - (modify-syntax-entry ?% "_" tab) - (modify-syntax-entry ?! "_" tab) - (modify-syntax-entry ?. "_" tab) - (modify-syntax-entry ?_ "_" tab) - (modify-syntax-entry ?- "_" tab) - (modify-syntax-entry ?< "(>" tab) - (modify-syntax-entry ?> ")<" tab) - tab) - "The syntax table used in send-mail mode when in a mail-address header. -mail-mode-syntax-table is used when the cursor is in the message body or in -non-address headers.") - -(defvar mail-abbrev-syntax-table - (let ((tab (copy-syntax-table mail-mode-header-syntax-table))) - (if (vectorp tab) - (let ((i (1- (length tab))) - (_ (aref (standard-syntax-table) ?_)) - (w (aref (standard-syntax-table) ?w))) - (while (>= i 0) - (if (= (aref tab i) _) (aset tab i w)) - (setq i (1- i)))) - (map-syntax-table - #'(lambda (key val) - (if (eq (char-syntax-from-code val) ?_) - (put-char-table key (set-char-syntax-in-code val ?w) tab) - )) - tab)) - tab) - "The syntax-table used for abbrev-expansion purposes; this is not actually -made the current syntax table of the buffer, but simply controls the set of -characters which may be a part of the name of a mail-alias.") - - -(defun mail-abbrev-in-expansion-header-p () - "Whether point is in a mail-address header field." - (let ((case-fold-search t)) - (and ;; - ;; we are on an appropriate header line... - (save-excursion - (beginning-of-line) - ;; skip backwards over continuation lines. - (while (and (looking-at "^[ \t]") - (not (= (point) (point-min)))) - (forward-line -1)) - ;; are we at the front of an appropriate header line? - (looking-at mail-abbrev-mode-regexp)) - ;; - ;; ...and we are before the mail-header-separator - (< (point) - (save-excursion - (goto-char (point-min)) - (search-forward (concat "\n" mail-header-separator "\n") - nil 0) - (point)))))) - -(defvar mail-mode-abbrev-table) ; quiet the compiler - -(defun sendmail-pre-abbrev-expand-hook () - (if mail-abbrev-aliases-need-to-be-resolved - (mail-resolve-all-aliases)) - (if (and mail-aliases (not (eq mail-aliases t))) - (if (not (mail-abbrev-in-expansion-header-p)) - ;; - ;; If we're not in a mail header in which mail aliases should - ;; be expanded, then use the normal mail-mode abbrev table (if any) - ;; and the normal mail-mode syntax table. - ;; - (progn - (setq local-abbrev-table (and (boundp 'mail-mode-abbrev-table) - mail-mode-abbrev-table)) - (set-syntax-table mail-mode-syntax-table)) - ;; - ;; Otherwise, we are in a To: (or CC:, or whatever) header, and - ;; should use word-abbrevs to expand mail aliases. - ;; - First, install the mail-aliases as the word-abbrev table. - ;; - Then install the mail-abbrev-syntax-table, which temporarily - ;; marks all of the non-alphanumeric-atom-characters (the "_" - ;; syntax ones) as being normal word-syntax. We do this because - ;; the C code for expand-abbrev only works on words, and we want - ;; these characters to be considered words for the purpose of - ;; abbrev expansion. - ;; - Then we call expand-abbrev again, recursively, to do the abbrev - ;; expansion with the above syntax table. - ;; - Then we do a trick which tells the expand-abbrev frame which - ;; invoked us to not continue (and thus not expand twice.) - ;; This means that any abbrev expansion will happen as a result - ;; of this function's call to expand-abbrev, and not as a result - ;; of the call to expand-abbrev which invoked *us*. - ;; - Then we set the syntax table to mail-mode-header-syntax-table, - ;; which doesn't have anything to do with abbrev expansion, but - ;; is just for the user's convenience (see its doc string.) - ;; - (setq local-abbrev-table mail-aliases) - ;; If the character just typed was non-alpha-symbol-syntax, then don't - ;; expand the abbrev now (that is, don't expand when the user types -.) - ;; Check the character's syntax in the mail-mode-header-syntax-table. - (set-syntax-table mail-mode-header-syntax-table) - (or (and last-command-char - (eq (char-syntax last-command-char) ?_)) - (let ((pre-abbrev-expand-hook nil)) ; That's us; don't loop. - ;; Use this table so that abbrevs can have hyphens in them. - (set-syntax-table mail-abbrev-syntax-table) - (expand-abbrev) - ;; Now set it back to what it was before. - (set-syntax-table mail-mode-header-syntax-table))) - (setq abbrev-start-location (point) ; This is the trick. - abbrev-start-location-buffer (current-buffer)) - ))) - - -;;; Reading addresses from the minibuffer; by David Hughes - -(defun mail-abbrev-minibuffer-setup-hook () - ;; Use as the value of minibuffer-setup-hook when reading addresses - ;; from the minibuffer, as in: - ;; (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook)) - ;; (read-string "Who: ")) - (if (and (not (vectorp mail-aliases)) - (file-exists-p (mail-abbrev-mailrc-file))) - (build-mail-aliases)) - (make-local-variable 'pre-abbrev-expand-hook) - (setq pre-abbrev-expand-hook - (function - (lambda () - (setq local-abbrev-table mail-aliases) - (set-syntax-table mail-mode-header-syntax-table) - (or (and last-command-char - (eq (char-syntax last-command-char) ?_)) - (let ((pre-abbrev-expand-hook nil)) ; That's us; don't loop. - ;; Use this table so that abbrevs can have hyphens in them. - (set-syntax-table mail-abbrev-syntax-table) - (expand-abbrev) - ;; Now set it back to what it was before. - (set-syntax-table mail-mode-header-syntax-table))) - (setq abbrev-start-location (point) ; This is the trick. - abbrev-start-location-buffer (current-buffer))))) - (abbrev-mode 1)) - - -;;; utilities - -(defun merge-mail-aliases (file) - "Merge mail aliases from the given file with existing ones." - (interactive (list - (let ((insert-default-directory t) - (default-directory (expand-file-name "~/")) - (def (mail-abbrev-mailrc-file))) - (read-file-name - (format "Read additional aliases from file: (default %s) " - def) - default-directory - (expand-file-name def default-directory) - t)))) - (build-mail-aliases file)) - -(defun rebuild-mail-aliases (file) - "Rebuild all the mail aliases from the given file." - (interactive (list - (let ((insert-default-directory t) - (default-directory (expand-file-name "~/")) - (def (mail-abbrev-mailrc-file))) - (read-file-name - (format "Read mail aliases from file: (default %s) " def) - default-directory - (expand-file-name def default-directory) - t)))) - (setq mail-aliases nil) - (build-mail-aliases file)) - -(defun mail-interactive-insert-alias (&optional alias) - "Prompt for and insert a mail alias." - (interactive (progn - (if (not (vectorp mail-aliases)) (mail-aliases-setup)) - (list (completing-read "Expand alias: " mail-aliases nil t)))) - (if (not (vectorp mail-aliases)) (mail-aliases-setup)) - (insert (or (and alias (symbol-value (intern-soft alias mail-aliases))) ""))) - -;; call-interactively is so that zmacs-regions gets hacked correctly -;; without making the interactive specs incompatible with v18. - -(defun abbrev-hacking-next-line () - "Just like `next-line' (\\\\[next-line]) but expands abbrevs \ -when at end of line." - (interactive) - (if (and (looking-at "[ \t]*\n") - (= (char-syntax (preceding-char)) ?w)) - (expand-abbrev)) - (setq this-command 'next-line) - (call-interactively 'next-line)) - -(defun abbrev-hacking-end-of-buffer () - "Just like `end-of-buffer' (\\\\[end-of-buffer]) but expands \ -abbrevs when at end of buffer." - (interactive) - (if (and (looking-at "[ \t]*\n") - (= (char-syntax (preceding-char)) ?w)) - (expand-abbrev)) - (setq this-command 'end-of-buffer) - (call-interactively 'end-of-buffer)) - -(define-key mail-mode-map "\C-c\C-a" 'mail-interactive-insert-alias) - -;(define-key mail-mode-map "\C-n" 'abbrev-hacking-next-line) -;(define-key mail-mode-map "\M->" 'abbrev-hacking-end-of-buffer) -(let ((subst '((next-line . abbrev-hacking-next-line) - (fkey-next-line . abbrev-hacking-next-line) - (end-of-buffer . abbrev-hacking-end-of-buffer) - (fkey-end-of-buffer . abbrev-hacking-end-of-buffer) - ))) - (while subst - (let ((keys - (delq nil - (nconc (where-is-internal (car (car subst)) mail-mode-map) - (where-is-internal (car (car subst))))))) - (while keys - (define-key mail-mode-map (car keys) (cdr (car subst))) - (setq keys (cdr keys)))) - (setq subst (cdr subst)))) - -(provide 'mail-abbrevs) - - -;;; V18 compatibility -;;; -;;; All of the Emacs18 stuff is isolated down here so that it will be -;;; easy to delete once v18 finally bites the dust. -;;; -;;; These defuns and defvars aren't inside the cond in deference to -;;; the intense brokenness of the v18 byte-compiler. -;;; -;;; All the code on this page is gross and hidious and awful and might -;;; not even work all that well. Comfort yourself with knowing that the -;;; v19 code above works wonderfully. - -(defun sendmail-v18-self-insert-command (arg) - "Just like self-insert-command, but runs sendmail-pre-abbrev-expand-hook." - (interactive "p") - (if (not (and last-command-char - (eq (char-syntax last-command-char) ?w))) - (progn - (sendmail-pre-abbrev-expand-hook) - ;; Unhack expand-abbrev, so it will work right next time around. - (setq abbrev-start-location nil))) - ;; this is gross and wasteful. - (let ((abbrev-mode (if (mail-abbrev-in-expansion-header-p) - nil - abbrev-mode))) - (self-insert-command arg))) - -(defun abbrev-hacking-next-line-v18 (arg) - (if (looking-at "[ \t]*\n") (sendmail-pre-abbrev-expand-hook)) - (setq this-command 'next-line) - (next-line arg)) - -(defun abbrev-hacking-end-of-buffer-v18 (arg) - (if (looking-at "[ \t]*\n") (sendmail-pre-abbrev-expand-hook)) - (setq this-command 'end-of-buffer) - (end-of-buffer arg)) - -(defvar mail-abbrevs-v18-map-munged nil) - -(defun mail-abbrevs-v18-munge-map () - ;; For every key that is bound to self-insert-command in global-map, - ;; bind that key to sendmail-self-insert-command in mail-mode-map. - ;; We used to do this by making the mail-mode-map be a non-sparse map, - ;; but that made the esc-map be shared in such a way that making a - ;; local meta binding in the mail-mode-map made a *global* binding - ;; instead. Yucko. - (let ((global-map (current-global-map)) - new-bindings - (i 0)) - (while (< i 128) - (if (eq 'self-insert-command (or (cdr (assq i mail-mode-map)) - (aref global-map i))) - (setq new-bindings - (cons (cons i 'sendmail-v18-self-insert-command) - new-bindings))) - (setq i (1+ i))) - (setq mail-mode-map - (nconc (copy-keymap mail-mode-map) (nreverse new-bindings)))) - (setq mail-abbrevs-v18-map-munged t)) - -(defun mail-aliases-setup-v18 () - "Put this on `mail-setup-hook' to use mail-abbrevs." - (if (not (eq major-mode 'mail-mode)) - nil - (or (and mail-mode-map (eq (current-local-map) mail-mode-map)) - (error "shut 'er down clancy, she's suckin' mud")) - (if (and (not (vectorp mail-aliases)) - (file-exists-p (mail-abbrev-mailrc-file))) - (build-mail-aliases)) - (or mail-abbrevs-v18-map-munged (mail-abbrevs-v18-munge-map)) - (use-local-map mail-mode-map) - (abbrev-mode 1))) - - -(cond ((or (string-match "^18\\." emacs-version) - (and (boundp 'epoch::version) epoch::version)) - ;; - ;; v19 (and this code) uses a new name for this function. - (or (fboundp 'buffer-disable-undo) - (fset 'buffer-disable-undo 'buffer-flush-undo)) - ;; - ;; v19 (and this code) uses a new name for auto-fill-hook (-function). - ;; Encapsulate the function that uses it to bind the new name. - (or (fboundp 'mail-abbrev-expand-hook-v19) - (fset 'mail-abbrev-expand-hook-v19 - (symbol-function 'mail-abbrev-expand-hook))) - (fset 'mail-abbrev-expand-hook - (function (lambda () - (let ((auto-fill-function auto-fill-hook)) - (mail-abbrev-expand-hook-v19))))) - ;; - ;; Turn off the broken v18 code (that is still called from sendmail.el) - (fset 'expand-mail-aliases - (function (lambda (&rest args) - "Obsoleted by mail-abbrevs. Does nothing." - nil))) - ;; - ;; Redefine the abbrev-hacking functions. Yuck. - (fset 'abbrev-hacking-next-line - (function (lambda (p) (interactive "p") - (abbrev-hacking-next-line-v18 p)))) - (fset 'abbrev-hacking-end-of-buffer - (function (lambda (p) (interactive "P") - (abbrev-hacking-end-of-buffer-v18 p)))) - ;; - ;; Encapsulate mail-setup to do the necessary buffer initializations. - (or (fboundp 'mail-setup-v18) - (fset 'mail-setup-v18 (symbol-function 'mail-setup))) - (fset 'mail-setup - (function (lambda (&rest args) - (mail-aliases-setup-v18) - (apply 'mail-setup-v18 args)))) - - ;; - ;; Encapsulate VM's version of mail-setup as well, if vm-mail is - ;; defined as a function or as an autoload. - (cond ((and (fboundp 'vm-mail) - (if (eq 'autoload (car-safe (symbol-function 'vm-mail))) - (load (nth 1 (symbol-function 'vm-mail)) t) - t)) - (or (fboundp 'vm-mail-internal-v18) - (fset 'vm-mail-internal-v18 - (symbol-function 'vm-mail-internal))) - (fset 'vm-mail-internal - (function (lambda (&rest args) - (apply 'vm-mail-internal-v18 args) - (mail-aliases-setup-v18)))))) - - ;; If we're being loaded from mail-setup-hook or mail-mode-hook - ;; as run from inside mail-setup or vm-mail-internal, then install - ;; right now. - (if (eq major-mode 'mail-mode) - (mail-aliases-setup-v18)) - ) - - (t ; v19 - (fmakunbound 'expand-mail-aliases))) diff -r 43306a74e31c -r d44af0c54775 lisp/modes/make-mode.el --- a/lisp/modes/make-mode.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1485 +0,0 @@ -;;; make-mode.el --- makefile editing commands for Emacs - -;; Copyright (C) 1992, 1994 Free Software Foundation, Inc. - -;; Author: Thomas Neumann -;; Eric S. Raymond -;; Adapted-By: ESR -;; Keywords: unix, tools - -;; RMS: -;; This needs work. -;; Also, the doc strings need fixing: the first line doesn't stand alone, -;; and other usage is not high quality. Symbol names don't have `...'. - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34. - -;;; Commentary: - -;; A major mode for editing makefiles. The mode knows about Makefile -;; syntax and defines M-n and M-p to move to next and previous productions. -;; -;; The keys $, =, : and . are electric; they try to help you fill in a -;; macro reference, macro definition, ordinary target name, or special -;; target name, respectively. Such names are completed using a list of -;; targets and macro names parsed out of the makefile. This list is -;; automatically updated, if necessary, whenever you invoke one of -;; these commands. You can force it to be updated with C-c C-p. -;; -;; The command C-c C-f adds certain filenames in the current directory -;; as targets. You can filter out filenames by setting the variable -;; makefile-ignored-files-in-pickup-regex. -;; -;; The command C-c C-u grinds for a bit, then pops up a report buffer -;; showing which target names are up-to-date with respect to their -;; prerequisites, which targets are out-of-date, and which have no -;; prerequisites. -;; -;; The command C-c C-b pops up a browser window listing all target and -;; macro names. You can mark or unmark items wit C-c SPC, and insert -;; all marked items back in the Makefile with C-c TAB. -;; -;; The command C-c TAB in the makefile buffer inserts a GNU make builtin. -;; You will be prompted for the builtin's args. -;; -;; There are numerous other customization variables. - -;; -;; To Do: -;; -;; * makefile-backslash-region should be given better behavior. -;; * Consider binding C-c C-c to comment-region (like cc-mode). -;; * Eliminate electric stuff entirely. -;; * It might be nice to highlight targets differently depending on -;; whether they are up-to-date or not. Not sure how this would -;; interact with font-lock. -;; * Would be nice to edit the commands in ksh-mode and have -;; indentation and slashification done automatically. Hard. -;; * Consider removing browser mode. It seems useless. -;; * ":" should notice when a new target is made and add it to the -;; list (or at least set makefile-need-target-pickup). -;; * Make browser into a major mode. -;; * Clean up macro insertion stuff. It is a mess. -;; * Browser entry and exit is weird. Normalize. -;; * Browser needs to be rewritten. Right now it is kind of a crock. -;; Should at least: -;; * Act more like dired/buffer menu/whatever. -;; * Highlight as mouse traverses. -;; * B2 inserts. -;; * Update documentation above. -;; * Update texinfo manual. -;; * Update files.el. - - - -;;; Code: - -(provide 'makefile) - -(defgroup makefile-mode nil - "Makefile mode customizations" - :group 'tools - :prefix "makefile-") - - -;; Sadly we need this for a macro. -(eval-when-compile - (unless (featurep 'xemacs) - (require 'imenu))) - -;;; ------------------------------------------------------------ -;;; Configurable stuff -;;; ------------------------------------------------------------ - -(defcustom makefile-browser-buffer-name "*Macros and Targets*" - "Name of the macro- and target browser buffer." - :type 'string - :group 'makefile-mode) - -(defcustom makefile-target-colon ":" - "String to append to all target names inserted by `makefile-insert-target'. -\":\" or \"::\" are common values." - :type 'string - :group 'makefile-mode) - -(defcustom makefile-macro-assign " = " - "String to append to all macro names inserted by `makefile-insert-macro'. -The normal value should be \" = \", since this is what -standard make expects. However, newer makes such as dmake -allow a larger variety of different macro assignments, so you -might prefer to use \" += \" or \" := \" ." - :type 'string - :group 'makefile-mode) - -(defcustom makefile-electric-keys nil - "If non-nil, install electric keybindings. -Default is nil." - :type 'boolean - :group 'makefile-mode) - -(defcustom makefile-use-curly-braces-for-macros-p nil - "Controls the style of generated macro references. -t (actually non-nil) means macro references should use curly braces, -like `${this}'. -nil means use parentheses, like `$(this)'." - :type 'boolean - :group 'makefile-mode) - -(defcustom makefile-tab-after-target-colon t - "If non-nil, insert a TAB after a target colon. -Otherwise, a space is inserted. -The default is t." - :type 'boolean - :group 'makefile-mode) - -(defcustom makefile-browser-leftmost-column 10 - "Number of blanks to the left of the browser selection mark." - :type 'integer - :group 'makefile-mode) - -(defcustom makefile-browser-cursor-column 10 - "Column in which the cursor is positioned when it moves -up or down in the browser." - :type 'integer - :group 'makefile-mode) - -(defcustom makefile-backslash-column 48 - "*Column in which `makefile-backslash-region' inserts backslashes." - :type 'integer - :group 'makefile-mode) - -(defcustom makefile-browser-selected-mark "+ " - "String used to mark selected entries in the browser." - :type 'string - :group 'makefile-mode) - -(defcustom makefile-browser-unselected-mark " " - "String used to mark unselected entries in the browser." - :type 'string - :group 'makefile-mode) - -(defcustom makefile-browser-auto-advance-after-selection-p t - "If non-nil, cursor will move after item is selected in browser." - :type 'boolean - :group 'makefile-mode) - -(defcustom makefile-pickup-everything-picks-up-filenames-p nil - "If non-nil, `makefile-pickup-everything' picks up filenames as targets. -\(i.e. it calls `makefile-find-filenames-as-targets'). -Otherwise filenames are omitted." - :type 'boolean - :group 'makefile-mode) - -(defcustom makefile-cleanup-continuations-p t - "If non-nil, automatically clean up continuation lines when saving. -A line is cleaned up by removing all whitespace following a trailing -backslash. This is done silently. -IMPORTANT: Please note that enabling this option causes makefile-mode -to MODIFY A FILE WITHOUT YOUR CONFIRMATION when \'it seems necessary\'." - :type 'boolean - :group 'makefile-mode) - -;;; those suspicious line warnings are really annoying and -;;; seem to be generated for every makefile I've ever seen. -;;; add a simple mechanism to disable them. -gk -(defcustom makefile-warn-suspicious-lines-p t - "In non-nil, warn about suspicious lines when saving the makefile" - :type 'boolean - :group 'makefile-mode) - -(defcustom makefile-browser-hook '() - "The hook to run when entering makefile browser." - :type 'hook - :group 'makefile-mode) - -;; -;; Special targets for DMake, Sun's make ... -;; -(defvar makefile-special-targets-list - '(("DEFAULT") ("DONE") ("ERROR") ("EXPORT") - ("FAILED") ("GROUPEPILOG") ("GROUPPROLOG") ("IGNORE") - ("IMPORT") ("INCLUDE") ("INCLUDEDIRS") ("INIT") - ("KEEP_STATE") ("MAKEFILES") ("MAKE_VERSION") ("NO_PARALLEL") - ("PARALLEL") ("PHONY") ("PRECIOUS") ("REMOVE") - ("SCCS_GET") ("SILENT") ("SOURCE") ("SUFFIXES") - ("WAIT") ("c.o") ("C.o") ("m.o") - ("el.elc") ("y.c") ("s.o")) - "List of special targets. -You will be offered to complete on one of those in the minibuffer whenever -you enter a \".\" at the beginning of a line in makefile-mode.") - -(defvar makefile-runtime-macros-list - '(("@") ("&") (">") ("<") ("*") ("^") ("+") ("?") ("%") ("$")) - "List of macros that are resolved by make at runtime. -If you insert a macro reference using makefile-insert-macro-ref, the name -of the macro is checked against this list. If it can be found its name will -not be enclosed in { } or ( ).") - -;; Note that the first big subexpression is used by font lock. Note -;; that if you change this regexp you must fix the imenu index -;; function defined at the end of the file. -(defconst makefile-dependency-regex - "^\\([^ \n\t#:]+\\([ \t]+[^ \t\n#:]+\\)*\\)[ \t]*:\\([ \t]*$\\|\\([^=\n].*$\\)\\)" - "Regex used to find dependency lines in a makefile.") - -;; Note that the first subexpression is used by font lock. Note that -;; if you change this regexp you must fix the imenu index function -;; defined at the end of the file. -(defconst makefile-macroassign-regex - "^\\([^ \n\t][^:#= \t\n]*\\)[ \t]*[*:+]?:?=" - "Regex used to find macro assignment lines in a makefile.") - -(defconst makefile-ignored-files-in-pickup-regex - "\\(^\\..*\\)\\|\\(.*~$\\)\\|\\(.*,v$\\)\\|\\(\\.[chy]\\)" - "Regex for filenames that will NOT be included in the target list.") - -;#### -;(add-to-list 'facemenu-unlisted-faces 'makefile-space-face) -; Bogus FSFmacs crap. -(defface makefile-space-face - '((((class color)) - (:background "hotpink")) ; Yeah! - ;; Everything else, just choose the most visible background - ;; color. We don't care about foreground, since it is only used - ;; for whitespace. - (((background light)) - (:background "black")) - (((background dark)) - (:background "white"))) - "Face to use for highlighting leading Makefile spaces in Font-Lock mode." - :group 'makefile-mode) - -;Older version of same. -;(defconst makefile-font-lock-keywords (purecopy -; (list -; '("^#.*$" . font-lock-comment-face) -; '("[^$]#.*$" . font-lock-comment-face) -; ;; rules -; '("^\\([^ \t\n]*%?[^ \t\n]*[ \t]*::?\\)[ \t]" 1 font-lock-type-face t) -; '("^\\(\\.[A-Za-z][A-Za-z]?\\..[ \t]*::?\\)" 1 font-lock-type-face t) -; '("^[^ \t\n]+[ \t]*:;?\\(.*\\)$" 1 font-lock-doc-string-face t) -; ;; variable definition -; '("^[_A-Za-z0-9]+[ \t]*\+?=" . font-lock-function-name-face) -; '("\\( \\|:=\\)[_A-Za-z0-9]+[ \t]*\\+=" . font-lock-function-name-face) -; ;; variable references -; '("\\(\\$\\$?\\([^ \t\n{(]\\|[{(][^ \t\n)}]+[)}]\\)\\)" -; 1 font-lock-keyword-face t) -; '("^include " . font-lock-string-face) -; )) - -(defconst makefile-font-lock-keywords (purecopy - (list - ;; Do macro assignments. These get the "variable-name" face rather - ;; arbitrarily. - (list makefile-macroassign-regex 1 'font-lock-variable-name-face) - ;; - ;; Variable references even in targets/strings/comments: - '("\\$[({]\\([a-zA-Z0-9_]+\\)[})]" 1 font-lock-reference-face prepend) - ;; - ;; Do dependencies. These get the function name face. - (list makefile-dependency-regex 1 'font-lock-function-name-face 'prepend) - - ;; Highlight lines that contain just whitespace. - ;; They can cause trouble, especially if they start with a tab. - '("^[ \t]+$" . makefile-space-face) - - ;; Highlight shell comments that Make treats as commands, - ;; since these can fool people. - '("^\t+#" 0 makefile-space-face t) - - ;; Highlight spaces that precede tabs. - ;; They can make a tab fail to be effective. - '("^\\( +\\)\t" 1 makefile-space-face))) - "Additional expressions to highlight in makefiles") - -(put 'makefile-mode 'font-lock-defaults '(makefile-font-lock-keywords)) - -;;; ------------------------------------------------------------ -;;; The following configurable variables are used in the -;;; up-to-date overview . -;;; The standard configuration assumes that your `make' program -;;; can be run in question/query mode using the `-q' option, this -;;; means that the command -;;; -;;; make -q foo -;;; -;;; should return an exit status of zero if the target `foo' is -;;; up to date and a nonzero exit status otherwise. -;;; Many makes can do this although the docs/manpages do not mention -;;; it. Try it with your favourite one. GNU make, System V make, and -;;; Dennis Vadura's DMake have no problems. -;;; Set the variable `makefile-brave-make' to the name of the -;;; make utility that does this on your system. -;;; To understand what this is all about see the function definition -;;; of `makefile-query-by-make-minus-q' . -;;; ------------------------------------------------------------ - -(defcustom makefile-brave-make "make" - "A make that can handle the `-q' option." - :type 'string - :group 'makefile-mode) - -(defcustom makefile-query-one-target-method 'makefile-query-by-make-minus-q - "Function to call to determine whether a make target is up to date. -The function must satisfy this calling convention: - -* As its first argument, it must accept the name of the target to - be checked, as a string. - -* As its second argument, it may accept the name of a makefile - as a string. Depending on what you're going to do you may - not need this. - -* It must return the integer value 0 (zero) if the given target - should be considered up-to-date in the context of the given - makefile, any nonzero integer value otherwise." - :type 'function - :group 'makefile-mode) - -(defcustom makefile-up-to-date-buffer-name "*Makefile Up-to-date overview*" - "Name of the Up-to-date overview buffer." - :type 'string - :group 'makefile-mode) - -;;; --- end of up-to-date-overview configuration ------------------ - -(defvar makefile-mode-map nil - "The keymap that is used in Makefile mode.") - -(if makefile-mode-map - () - (setq makefile-mode-map (make-sparse-keymap 'makefile-mode-map)) - ;; set up the keymap - (define-key makefile-mode-map "\C-c:" 'makefile-insert-target-ref) - (if makefile-electric-keys - (progn - (define-key makefile-mode-map "$" 'makefile-insert-macro-ref) - (define-key makefile-mode-map ":" 'makefile-electric-colon) - (define-key makefile-mode-map "=" 'makefile-electric-equal) - (define-key makefile-mode-map "." 'makefile-electric-dot))) - (define-key makefile-mode-map "\C-c\C-f" 'makefile-pickup-filenames-as-targets) - (define-key makefile-mode-map "\C-c\C-b" 'makefile-switch-to-browser) - (define-key makefile-mode-map "\C-c\C-p" 'makefile-pickup-everything) - (define-key makefile-mode-map "\C-c\C-u" 'makefile-create-up-to-date-overview) - (define-key makefile-mode-map "\C-c\C-i" 'makefile-insert-gmake-function) - (define-key makefile-mode-map "\C-c\C-\\" 'makefile-backslash-region) - (define-key makefile-mode-map "\M-p" 'makefile-previous-dependency) - (define-key makefile-mode-map "\M-n" 'makefile-next-dependency) - (define-key makefile-mode-map "\e\t" 'makefile-complete)) - -;; XEmacs change -(defconst makefile-menubar-menu - (purecopy - '("Makefile" - ["Move to Next Dependency" makefile-next-dependency t] - ["Move to Previous Dependency" makefile-previous-dependency t] - "---" - ["Find Targets and Macros" makefile-pickup-everything t] - ["Complete Target or Macro" makefile-complete t] - ["Pop up Makefile Browser" makefile-switch-to-browser t]))) - -;; XEmacs change -(defconst makefile-popup-menu - (purecopy - (cons "Makefile Mode Commands" - (cdr makefile-menubar-menu)))) - -(defvar makefile-browser-map nil - "The keymap that is used in the macro- and target browser.") -(if makefile-browser-map - () - (setq makefile-browser-map (make-sparse-keymap)) - (define-key makefile-browser-map "n" 'makefile-browser-next-line) - (define-key makefile-browser-map "\C-n" 'makefile-browser-next-line) - (define-key makefile-browser-map "p" 'makefile-browser-previous-line) - (define-key makefile-browser-map "\C-p" 'makefile-browser-previous-line) - (define-key makefile-browser-map " " 'makefile-browser-toggle) - (define-key makefile-browser-map "i" 'makefile-browser-insert-selection) - (define-key makefile-browser-map "I" 'makefile-browser-insert-selection-and-quit) - (define-key makefile-browser-map "\C-c\C-m" 'makefile-browser-insert-continuation) - (define-key makefile-browser-map "q" 'makefile-browser-quit) - ;; disable horizontal movement - (define-key makefile-browser-map "\C-b" 'undefined) - (define-key makefile-browser-map "\C-f" 'undefined)) - - -(defvar makefile-mode-syntax-table nil) -(if makefile-mode-syntax-table - () - (setq makefile-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\( "() " makefile-mode-syntax-table) - (modify-syntax-entry ?\) ")( " makefile-mode-syntax-table) - (modify-syntax-entry ?\[ "(] " makefile-mode-syntax-table) - (modify-syntax-entry ?\] ")[ " makefile-mode-syntax-table) - (modify-syntax-entry ?\{ "(} " makefile-mode-syntax-table) - (modify-syntax-entry ?\} "){ " makefile-mode-syntax-table) - (modify-syntax-entry ?\' "\" " makefile-mode-syntax-table) - (modify-syntax-entry ?\` "\" " makefile-mode-syntax-table) - (modify-syntax-entry ?# "< " makefile-mode-syntax-table) - (modify-syntax-entry ?\n "> " makefile-mode-syntax-table)) - - -;;; ------------------------------------------------------------ -;;; Internal variables. -;;; You don't need to configure below this line. -;;; ------------------------------------------------------------ - -(defvar makefile-target-table nil - "Table of all target names known for this buffer.") - -(defvar makefile-macro-table nil - "Table of all macro names known for this buffer.") - -(defvar makefile-browser-client - "A buffer in Makefile mode that is currently using the browser.") - -(defvar makefile-browser-selection-vector nil) -(defvar makefile-has-prereqs nil) -(defvar makefile-need-target-pickup t) -(defvar makefile-need-macro-pickup t) - -(defvar makefile-mode-hook '()) - -;; Each element looks like '("GNU MAKE FUNCTION" "ARG" "ARG" ... ) -;; Each "ARG" is used as a prompt for a required argument. -(defconst makefile-gnumake-functions-alist - '( - ;; Text functions - ("subst" "From" "To" "In") - ("patsubst" "Pattern" "Replacement" "In") - ("strip" "Text") - ("findstring" "Find what" "In") - ("filter" "Pattern" "Text") - ("filter-out" "Pattern" "Text") - ("sort" "List") - ;; Filename functions - ("dir" "Names") - ("notdir" "Names") - ("suffix" "Names") - ("basename" "Names") - ("addprefix" "Prefix" "Names") - ("addsuffix" "Suffix" "Names") - ("join" "List 1" "List 2") - ("word" "Index" "Text") - ("words" "Text") - ("firstword" "Text") - ("wildcard" "Pattern") - ;; Misc functions - ("foreach" "Variable" "List" "Text") - ("origin" "Variable") - ("shell" "Command"))) - - -;;; ------------------------------------------------------------ -;;; The mode function itself. -;;; ------------------------------------------------------------ - -;;;###autoload -(defun makefile-mode () - "Major mode for editing Makefiles. -This function ends by invoking the function(s) `makefile-mode-hook'. - -\\{makefile-mode-map} - -In the browser, use the following keys: - -\\{makefile-browser-map} - -Makefile mode can be configured by modifying the following variables: - -makefile-browser-buffer-name: - Name of the macro- and target browser buffer. - -makefile-target-colon: - The string that gets appended to all target names - inserted by `makefile-insert-target'. - \":\" or \"::\" are quite common values. - -makefile-macro-assign: - The string that gets appended to all macro names - inserted by `makefile-insert-macro'. - The normal value should be \" = \", since this is what - standard make expects. However, newer makes such as dmake - allow a larger variety of different macro assignments, so you - might prefer to use \" += \" or \" := \" . - -makefile-tab-after-target-colon: - If you want a TAB (instead of a space) to be appended after the - target colon, then set this to a non-nil value. - -makefile-browser-leftmost-column: - Number of blanks to the left of the browser selection mark. - -makefile-browser-cursor-column: - Column in which the cursor is positioned when it moves - up or down in the browser. - -makefile-browser-selected-mark: - String used to mark selected entries in the browser. - -makefile-browser-unselected-mark: - String used to mark unselected entries in the browser. - -makefile-browser-auto-advance-after-selection-p: - If this variable is set to a non-nil value the cursor - will automagically advance to the next line after an item - has been selected in the browser. - -makefile-pickup-everything-picks-up-filenames-p: - If this variable is set to a non-nil value then - `makefile-pickup-everything' also picks up filenames as targets - (i.e. it calls `makefile-find-filenames-as-targets'), otherwise - filenames are omitted. - -makefile-cleanup-continuations-p: - If this variable is set to a non-nil value then makefile-mode - will assure that no line in the file ends with a backslash - (the continuation character) followed by any whitespace. - This is done by silently removing the trailing whitespace, leaving - the backslash itself intact. - IMPORTANT: Please note that enabling this option causes makefile-mode - to MODIFY A FILE WITHOUT YOUR CONFIRMATION when \"it seems necessary\". - -makefile-browser-hook: - A function or list of functions to be called just before the - browser is entered. This is executed in the makefile buffer. - -makefile-special-targets-list: - List of special targets. You will be offered to complete - on one of those in the minibuffer whenever you enter a `.'. - at the beginning of a line in Makefile mode." - - (interactive) - (kill-all-local-variables) - (make-local-variable 'local-write-file-hooks) - (setq local-write-file-hooks - '(makefile-cleanup-continuations makefile-warn-suspicious-lines)) - (make-local-variable 'makefile-target-table) - (make-local-variable 'makefile-macro-table) - (make-local-variable 'makefile-has-prereqs) - (make-local-variable 'makefile-need-target-pickup) - (make-local-variable 'makefile-need-macro-pickup) - - ;; Font lock. - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(makefile-font-lock-keywords)) - - ;; Add-log. - (make-local-variable 'add-log-current-defun-function) - (setq add-log-current-defun-function 'makefile-add-log-defun) - - ;; Imenu. - (unless (featurep 'xemacs) - (make-local-variable 'imenu-create-index-function) - (setq imenu-create-index-function 'makefile-menu-index-function)) - - ;; Dabbrev. - (make-local-variable 'dabbrev-abbrev-skip-leading-regexp) - (setq dabbrev-abbrev-skip-leading-regexp "\\$") - - ;; Comment stuff. - (make-local-variable 'comment-start) - (setq comment-start "#") - (make-local-variable 'comment-end) - (setq comment-end "") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "#+[ \t]*") - - ;; become the current major mode - (setq major-mode 'makefile-mode) - (setq mode-name "Makefile") - - ;; Activate keymap and syntax table. - (use-local-map makefile-mode-map) - (set-syntax-table makefile-mode-syntax-table) - - ;; Set menu - ;; XEmacs addition - (setq mode-popup-menu makefile-popup-menu) - (if (featurep 'menubar) - (progn - ;; make a local copy of the menubar, so our modes don't - ;; change the global menubar - (set-buffer-menubar current-menubar) - (add-submenu nil makefile-menubar-menu))) - - ;; Real TABs are important in makefiles - (setq indent-tabs-mode t) - (run-hooks 'makefile-mode-hook)) - - - -;;; Motion code. - -(defun makefile-next-dependency () - "Move point to the beginning of the next dependency line." - (interactive) - (let ((here (point))) - (end-of-line) - (if (re-search-forward makefile-dependency-regex (point-max) t) - (progn (beginning-of-line) t) ; indicate success - (goto-char here) nil))) - -(defun makefile-previous-dependency () - "Move point to the beginning of the previous dependency line." - (interactive) - (let ((here (point))) - (beginning-of-line) - (if (re-search-backward makefile-dependency-regex (point-min) t) - (progn (beginning-of-line) t) ; indicate success - (goto-char here) nil))) - - - -;;; Electric keys. Blech. - -(defun makefile-electric-dot (arg) - "Prompt for the name of a special target to insert. -Only does electric insertion at beginning of line. -Anywhere else just self-inserts." - (interactive "p") - (if (bolp) - (makefile-insert-special-target) - (self-insert-command arg))) - -(defun makefile-insert-special-target () - "Propmt for and insert a special target name. -Uses `makefile-special-targets' list." - (interactive) - (makefile-pickup-targets) - (let ((special-target - (completing-read "Special target: " - makefile-special-targets-list nil nil nil))) - (if (zerop (length special-target)) - () - (insert "." special-target ":") - (makefile-forward-after-target-colon)))) - -(defun makefile-electric-equal (arg) - "Prompt for name of a macro to insert. -Only does prompting if point is at beginning of line. -Anywhere else just self-inserts." - (interactive "p") - (makefile-pickup-macros) - (if (bolp) - (call-interactively 'makefile-insert-macro) - (self-insert-command arg) - ;; from here down is new -- if they inserted a macro without using - ;; the electric behavior, pick it up anyway -gk - (save-excursion - (beginning-of-line) - (if (looking-at makefile-macroassign-regex) - (makefile-add-this-line-macro))))) - -(defun makefile-insert-macro (macro-name) - "Prepare definition of a new macro." - (interactive "sMacro Name: ") - (makefile-pickup-macros) - (if (not (zerop (length macro-name))) - (progn - (beginning-of-line) - (insert macro-name makefile-macro-assign) - (setq makefile-need-macro-pickup t) - (makefile-remember-macro macro-name)))) - -(defun makefile-insert-macro-ref (macro-name) - "Complete on a list of known macros, then insert complete ref at point." - (interactive - (list - (progn - (makefile-pickup-macros) - (completing-read "Refer to macro: " makefile-macro-table nil nil nil)))) - (makefile-do-macro-insertion macro-name)) - -(defun makefile-insert-target (target-name) - "Prepare definition of a new target (dependency line)." - (interactive "sTarget: ") - (if (not (zerop (length target-name))) - (progn - (beginning-of-line) - (insert target-name makefile-target-colon) - (makefile-forward-after-target-colon) - (end-of-line) - (setq makefile-need-target-pickup t) - (makefile-remember-target target-name)))) - -(defun makefile-insert-target-ref (target-name) - "Complete on a list of known targets, then insert target-ref at point." - (interactive - (list - (progn - (makefile-pickup-targets) - (completing-read "Refer to target: " makefile-target-table nil nil nil)))) - (if (not (zerop (length target-name))) - (insert target-name " "))) - -(defun makefile-electric-colon (arg) - "Prompt for name of new target. -Prompting only happens at beginning of line. -Anywhere else just self-inserts." - (interactive "p") - (if (bolp) - (call-interactively 'makefile-insert-target) - (self-insert-command arg))) - - - -;;; ------------------------------------------------------------ -;;; Extracting targets and macros from an existing makefile -;;; ------------------------------------------------------------ - -(defun makefile-pickup-targets () - "Notice names of all target definitions in Makefile." - (interactive) - (if (not makefile-need-target-pickup) - nil - (setq makefile-need-target-pickup nil) - (setq makefile-target-table nil) - (setq makefile-has-prereqs nil) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward makefile-dependency-regex (point-max) t) - (makefile-add-this-line-targets))) - (message "Read targets OK."))) - -(defun makefile-add-this-line-targets () - (save-excursion - (beginning-of-line) - (let ((done-with-line nil) - (line-number (1+ (count-lines (point-min) (point))))) - (while (not done-with-line) - (skip-chars-forward " \t") - (if (not (setq done-with-line (or (eolp) - (char-equal (char-after (point)) ?:)))) - (progn - (let* ((start-of-target-name (point)) - (target-name - (progn - (skip-chars-forward "^ \t:#") - (buffer-substring start-of-target-name (point)))) - (has-prereqs - (not (looking-at ":[ \t]*$")))) - (if (makefile-remember-target target-name has-prereqs) - (message "Picked up target \"%s\" from line %d" - target-name line-number))))))))) - -(defun makefile-pickup-macros () - "Notice names of all macro definitions in Makefile." - (interactive) - (if (not makefile-need-macro-pickup) - nil - (setq makefile-need-macro-pickup nil) - ;; changed the nil in the next line to makefile-runtime-macros-list - ;; so you don't have to confirm on every runtime macro entered... -gk - (setq makefile-macro-table makefile-runtime-macros-list) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward makefile-macroassign-regex (point-max) t) - (makefile-add-this-line-macro) - (forward-line 1))) - (message "Read macros OK."))) - -(defun makefile-add-this-line-macro () - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (if (not (eolp)) - (let* ((start-of-macro-name (point)) - (line-number (1+ (count-lines (point-min) (point)))) - (macro-name (progn - (skip-chars-forward "^ \t:#=*") - (buffer-substring start-of-macro-name (point))))) - (if (makefile-remember-macro macro-name) - (message "Picked up macro \"%s\" from line %d" - macro-name line-number)))))) - -(defun makefile-pickup-everything (arg) - "Notice names of all macros and targets in Makefile. -Prefix arg means force pickups to be redone." - (interactive "P") - (if arg - (progn - (setq makefile-need-target-pickup t) - (setq makefile-need-macro-pickup t))) - (makefile-pickup-macros) - (makefile-pickup-targets) - (if makefile-pickup-everything-picks-up-filenames-p - (makefile-pickup-filenames-as-targets))) - -(defun makefile-pickup-filenames-as-targets () - "Scan the current directory for filenames to use as targets. -Checks each filename against `makefile-ignored-files-in-pickup-regex' -and adds all qualifying names to the list of known targets." - (interactive) - (let* ((dir (file-name-directory (buffer-file-name))) - (raw-filename-list (if dir - (file-name-all-completions "" dir) - (file-name-all-completions "" "")))) - (mapcar '(lambda (name) - (if (and (not (file-directory-p name)) - (not (string-match makefile-ignored-files-in-pickup-regex - name))) - (if (makefile-remember-target name) - (message "Picked up file \"%s\" as target" name)))) - raw-filename-list))) - - - -;;; Completion. - -(defun makefile-complete () - "Perform completion on Makefile construct preceding point. -Can complete variable and target names. -The context determines which are considered." - (interactive) - (let* ((beg (save-excursion - (skip-chars-backward "^$(){}:#= \t\n") - (point))) - (try (buffer-substring beg (point))) - (do-macros nil) - (paren nil)) - - (save-excursion - (goto-char beg) - (let ((pc (preceding-char))) - (cond - ;; Beginning of line means anything. - ((bolp) - ()) - - ;; Preceding "$" means macros only. - ((= pc ?$) - (setq do-macros t)) - - ;; Preceding "$(" or "${" means macros only. - ((and (or (= pc ?{) - (= pc ?\()) - (progn - (setq paren pc) - (backward-char) - (and (not (bolp)) - (= (preceding-char) ?$)))) - (setq do-macros t))))) - - ;; Try completion. - (let* ((table (append (if do-macros - '() - makefile-target-table) - makefile-macro-table)) - (completion (try-completion try table))) - (cond - ;; Exact match, so insert closing paren or colon. - ((eq completion t) - (insert (if do-macros - (if (eq paren ?{) - ?} - ?\)) - (if (save-excursion - (goto-char beg) - (bolp)) - ":" - " ")))) - - ;; No match. - ((null completion) - (message "Can't find completion for \"%s\"" try) - (ding)) - - ;; Partial completion. - ((not (string= try completion)) - ;; FIXME it would be nice to supply the closing paren if an - ;; exact, unambiguous match were found. That is not possible - ;; right now. Ditto closing ":" for targets. - (delete-region beg (point)) - - ;; DO-MACROS means doing macros only. If not that, then check - ;; to see if this completion is a macro. Special insertion - ;; must be done for macros. - (if (or do-macros - (assoc completion makefile-macro-table)) - (let ((makefile-use-curly-braces-for-macros-p - (or (eq paren ?{) - makefile-use-curly-braces-for-macros-p))) - (delete-backward-char 2) - (makefile-do-macro-insertion completion) - (delete-backward-char 1)) - - ;; Just insert targets. - (insert completion))) - - ;; Can't complete any more, so make completion list. FIXME - ;; this doesn't do the right thing when the completion is - ;; actually inserted. I don't think there is an easy way to do - ;; that. - (t - (message "Making completion list...") - (let ((list (all-completions try table))) - (with-output-to-temp-buffer "*Completions*" - (display-completion-list list))) - (message "Making completion list...done")))))) - - - -;; Backslashification. Stolen from cc-mode.el. - -(defun makefile-backslashify-current-line (doit) - (end-of-line) - (if doit - (if (not (save-excursion - (forward-char -1) - (eq (char-after (point)) ?\\ ))) - (progn - (if (>= (current-column) makefile-backslash-column) - (insert " \\") - (while (<= (current-column) makefile-backslash-column) - (insert "\t") - (end-of-line)) - (delete-char -1) - (while (< (current-column) makefile-backslash-column) - (insert " ") - (end-of-line)) - (insert "\\")))) - (if (not (bolp)) - (progn - (forward-char -1) - (if (eq (char-after (point)) ?\\ ) - (let ((saved (save-excursion - (end-of-line) - (point)))) - (skip-chars-backward " \t") - (delete-region (point) saved))))))) - -(defun makefile-backslash-region (beg end arg) - "Insert backslashes at end of every line in region. -Useful for defining multi-line rules. -If called with a prefix argument, trailing backslashes are removed." - (interactive "r\nP") - (save-excursion - (let ((do-lastline-p (progn (goto-char end) (not (bolp))))) - (save-restriction - (narrow-to-region beg end) - (goto-char (point-min)) - (while (not (save-excursion - (forward-line 1) - (eobp))) - (makefile-backslashify-current-line (null arg)) - (forward-line 1))) - (and do-lastline-p - (progn (goto-char end) - (makefile-backslashify-current-line (null arg))))))) - - - -;;; ------------------------------------------------------------ -;;; Browser mode. -;;; ------------------------------------------------------------ - -(defun makefile-browser-format-target-line (target selected) - (format - (concat (make-string makefile-browser-leftmost-column ?\ ) - (if selected - makefile-browser-selected-mark - makefile-browser-unselected-mark) - "%s%s") - target makefile-target-colon)) - -(defun makefile-browser-format-macro-line (macro selected) - (concat (make-string makefile-browser-leftmost-column ?\ ) - (if selected - makefile-browser-selected-mark - makefile-browser-unselected-mark) - (makefile-format-macro-ref macro))) - -(defun makefile-browser-fill (targets macros) - (let ((inhibit-read-only t)) - (goto-char (point-min)) - (erase-buffer) - (mapconcat - (function - (lambda (item) (insert (makefile-browser-format-target-line (car item) nil) "\n"))) - targets - "") - (mapconcat - (function - (lambda (item) (insert (makefile-browser-format-macro-line (car item) nil) "\n"))) - macros - "") - (sort-lines nil (point-min) (point-max)) - (goto-char (1- (point-max))) - (delete-char 1) ; remove unnecessary newline at eob - (goto-char (point-min)) - (forward-char makefile-browser-cursor-column))) - -;;; -;;; Moving up and down in the browser -;;; - -(defun makefile-browser-next-line () - "Move the browser selection cursor to the next line." - (interactive) - (if (not (makefile-last-line-p)) - (progn - (forward-line 1) - (forward-char makefile-browser-cursor-column)))) - -(defun makefile-browser-previous-line () - "Move the browser selection cursor to the previous line." - (interactive) - (if (not (makefile-first-line-p)) - (progn - (forward-line -1) - (forward-char makefile-browser-cursor-column)))) - -;;; -;;; Quitting the browser (returns to client buffer) -;;; - -(defun makefile-browser-quit () - "Leave the browser and return to the makefile buffer." - (interactive) - (let ((my-client makefile-browser-client)) - (setq makefile-browser-client nil) ; we quitted, so NO client! - (set-buffer-modified-p nil) - (kill-buffer (current-buffer)) - (pop-to-buffer my-client))) - -;;; -;;; Toggle state of a browser item -;;; - -(defun makefile-browser-toggle () - "Toggle the selection state of the browser item at the cursor position." - (interactive) - (let ((this-line (count-lines (point-min) (point)))) - (setq this-line (max 1 this-line)) - (makefile-browser-toggle-state-for-line this-line) - (goto-line this-line) - (let ((inhibit-read-only t)) - (beginning-of-line) - (if (makefile-browser-on-macro-line-p) - (let ((macro-name (makefile-browser-this-line-macro-name))) - (delete-region (point) (progn (end-of-line) (point))) - (insert - (makefile-browser-format-macro-line - macro-name - (makefile-browser-get-state-for-line this-line)))) - (let ((target-name (makefile-browser-this-line-target-name))) - (delete-region (point) (progn (end-of-line) (point))) - (insert - (makefile-browser-format-target-line - target-name - (makefile-browser-get-state-for-line this-line)))))) - (beginning-of-line) - (forward-char makefile-browser-cursor-column) - (if makefile-browser-auto-advance-after-selection-p - (makefile-browser-next-line)))) - -;;; -;;; Making insertions into the client buffer -;;; - -(defun makefile-browser-insert-continuation () - "Insert a makefile continuation. -In the makefile buffer, go to (end-of-line), insert a \'\\\' -character, insert a new blank line, go to that line and indent by one TAB. -This is most useful in the process of creating continued lines when copying -large dependencies from the browser to the client buffer. -\(point) advances accordingly in the client buffer." - (interactive) - (save-excursion - (set-buffer makefile-browser-client) - (end-of-line) - (insert "\\\n\t"))) - -(defun makefile-browser-insert-selection () - "Insert all selected targets and/or macros in the makefile buffer. -Insertion takes place at point." - (interactive) - (save-excursion - (goto-line 1) - (let ((current-line 1)) - (while (not (eobp)) - (if (makefile-browser-get-state-for-line current-line) - (makefile-browser-send-this-line-item)) - (forward-line 1) - (setq current-line (1+ current-line)))))) - -(defun makefile-browser-insert-selection-and-quit () - (interactive) - (makefile-browser-insert-selection) - (makefile-browser-quit)) - -(defun makefile-browser-send-this-line-item () - (if (makefile-browser-on-macro-line-p) - (save-excursion - (let ((macro-name (makefile-browser-this-line-macro-name))) - (set-buffer makefile-browser-client) - (insert (makefile-format-macro-ref macro-name) " "))) - (save-excursion - (let ((target-name (makefile-browser-this-line-target-name))) - (set-buffer makefile-browser-client) - (insert target-name " "))))) - -(defun makefile-browser-start-interaction () - (use-local-map makefile-browser-map) - (setq buffer-read-only t)) - -(defun makefile-browse (targets macros) - (if (zerop (+ (length targets) (length macros))) - (progn - (beep) - (message "No macros or targets to browse! Consider running 'makefile-pickup-everything\'")) - (let ((browser-buffer (get-buffer-create makefile-browser-buffer-name))) - (pop-to-buffer browser-buffer) - (make-variable-buffer-local 'makefile-browser-selection-vector) - (makefile-browser-fill targets macros) - (shrink-window-if-larger-than-buffer) - (setq makefile-browser-selection-vector - (make-vector (+ (length targets) (length macros)) nil)) - (makefile-browser-start-interaction)))) - -(defun makefile-switch-to-browser () - (interactive) - (run-hooks 'makefile-browser-hook) - (setq makefile-browser-client (current-buffer)) - (makefile-pickup-targets) - (makefile-pickup-macros) - (makefile-browse makefile-target-table - ;; take out the runtime macros which were added for completion sake -gk - (set-difference makefile-macro-table makefile-runtime-macros-list))) - - - -;;; ------------------------------------------------------------ -;;; Up-to-date overview buffer -;;; ------------------------------------------------------------ - -(defun makefile-create-up-to-date-overview () - "Create a buffer containing an overview of the state of all known targets. -Known targets are targets that are explicitly defined in that makefile; -in other words, all targets that appear on the left hand side of a -dependency in the makefile." - (interactive) - (if (y-or-n-p "Are you sure that the makefile being edited is consistent? ") - ;; - ;; The rest of this function operates on a temporary makefile, created by - ;; writing the current contents of the makefile buffer. - ;; - (let ((saved-target-table makefile-target-table) - (this-buffer (current-buffer)) - (makefile-up-to-date-buffer - (get-buffer-create makefile-up-to-date-buffer-name)) - (filename (makefile-save-temporary)) - ;; - ;; Forget the target table because it may contain picked-up filenames - ;; that are not really targets in the current makefile. - ;; We don't want to query these, so get a new target-table with just the - ;; targets that can be found in the makefile buffer. - ;; The 'old' target table will be restored later. - ;; - (real-targets (progn - (makefile-pickup-targets) - makefile-target-table)) - (prereqs makefile-has-prereqs) - ) - - (set-buffer makefile-up-to-date-buffer) - (setq buffer-read-only nil) - (erase-buffer) - (makefile-query-targets filename real-targets prereqs) - (if (zerop (buffer-size)) ; if it did not get us anything - (progn - (kill-buffer (current-buffer)) - (message "No overview created!"))) - (set-buffer this-buffer) - (setq makefile-target-table saved-target-table) - (if (get-buffer makefile-up-to-date-buffer-name) - (progn - (pop-to-buffer (get-buffer makefile-up-to-date-buffer-name)) - (shrink-window-if-larger-than-buffer) - (sort-lines nil (point-min) (point-max)) - (setq buffer-read-only t)))))) - -(defun makefile-save-temporary () - "Create a temporary file from the current makefile buffer." - (let ((filename (makefile-generate-temporary-filename))) - (write-region (point-min) (point-max) filename nil 0) - filename)) ; return the filename - -(defun makefile-generate-temporary-filename () - "Create a filename suitable for use in `makefile-save-temporary'. -Be careful to allow brain-dead file systems (DOS, SYSV ...) to cope -with the generated name!" - (let ((my-name (user-login-name)) - (my-uid (int-to-string (user-uid)))) - (concat "mktmp" - (if (> (length my-name) 3) - (substring my-name 0 3) - my-name) - "." - (if (> (length my-uid) 3) - (substring my-uid 0 3) - my-uid)))) - -(defun makefile-query-targets (filename target-table prereq-list) - "Fill the up-to-date overview buffer. -Checks each target in TARGET-TABLE using `makefile-query-one-target-method' -and generates the overview, one line per target name." - (insert - (mapconcat - (function (lambda (item) - (let* ((target-name (car item)) - (no-prereqs (not (member target-name prereq-list))) - (needs-rebuild (or no-prereqs - (funcall - makefile-query-one-target-method - target-name - filename)))) - (format "\t%s%s" - target-name - (cond (no-prereqs " .. has no prerequisites") - (needs-rebuild " .. NEEDS REBUILD") - (t " .. is up to date")))) - )) - target-table "\n")) - (goto-char (point-min)) - (delete-file filename)) ; remove the tmpfile - -(defun makefile-query-by-make-minus-q (target &optional filename) - (not (zerop - (call-process makefile-brave-make nil nil nil - "-f" filename "-q" target)))) - - - -;;; ------------------------------------------------------------ -;;; Continuation cleanup -;;; ------------------------------------------------------------ - -(defun makefile-cleanup-continuations () - (if (eq major-mode 'makefile-mode) - (if (and makefile-cleanup-continuations-p - (not buffer-read-only)) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "\\\\[ \t]+$" (point-max) t) - (replace-match "\\" t t)))))) - - -;;; ------------------------------------------------------------ -;;; Warn of suspicious lines -;;; ------------------------------------------------------------ - -(defun makefile-warn-suspicious-lines () - (let ((dont-save nil)) - (if (and (eq major-mode 'makefile-mode) - makefile-warn-suspicious-lines-p) ; -gk - (let ((suspicious - (save-excursion - (goto-char (point-min)) - (re-search-forward - "\\(^[\t]+$\\)\\|\\(^[ ]+[\t]\\)" (point-max) t)))) - (if suspicious - (let ((line-nr (count-lines (point-min) suspicious))) - (setq dont-save - (not (y-or-n-p - (format "Suspicious line %d. Save anyway " - line-nr)))))))) - dont-save)) - - - -;;; ------------------------------------------------------------ -;;; GNU make function support -;;; ------------------------------------------------------------ - -(defun makefile-insert-gmake-function () - "Insert a GNU make function call. -Asks for the name of the function to use (with completion). -Then prompts for all required parameters." - (interactive) - (let* ((gm-function-name (completing-read - "Function: " - makefile-gnumake-functions-alist - nil t nil)) - (gm-function-prompts - (cdr (assoc gm-function-name makefile-gnumake-functions-alist)))) - (if (not (zerop (length gm-function-name))) - (insert (makefile-format-macro-ref - (concat gm-function-name " " - (makefile-prompt-for-gmake-funargs - gm-function-name gm-function-prompts))) - " ")))) - -(defun makefile-prompt-for-gmake-funargs (function-name prompt-list) - (mapconcat - (function (lambda (one-prompt) - (read-string (format "[%s] %s: " function-name one-prompt) - nil))) - prompt-list - ",")) - - - -;;; ------------------------------------------------------------ -;;; Utility functions -;;; ------------------------------------------------------------ - -(defun makefile-do-macro-insertion (macro-name) - "Insert a macro reference." - (if (not (zerop (length macro-name))) - (if (assoc macro-name makefile-runtime-macros-list) - (insert "$" macro-name) - (insert (makefile-format-macro-ref macro-name))))) - -(defun makefile-remember-target (target-name &optional has-prereqs) - "Remember a given target if it is not already remembered for this buffer." - (if (not (zerop (length target-name))) - (progn - (if (not (assoc target-name makefile-target-table)) - (setq makefile-target-table - (cons (list target-name) makefile-target-table))) - (if has-prereqs - (setq makefile-has-prereqs - (cons target-name makefile-has-prereqs)))))) - -(defun makefile-remember-macro (macro-name) - "Remember a given macro if it is not already remembered for this buffer." - (if (not (zerop (length macro-name))) - (if (not (assoc macro-name makefile-macro-table)) - (setq makefile-macro-table - (cons (list macro-name) makefile-macro-table))))) - -(defun makefile-forward-after-target-colon () - "Move point forward after inserting the terminating colon of a target. -This acts according to the value of `makefile-tab-after-target-colon'." - (if makefile-tab-after-target-colon - (insert "\t") - (insert " "))) - -(defun makefile-browser-on-macro-line-p () - "Determine if point is on a macro line in the browser." - (save-excursion - (beginning-of-line) - (re-search-forward "\\$[{(]" (makefile-end-of-line-point) t))) - -(defun makefile-browser-this-line-target-name () - "Extract the target name from a line in the browser." - (save-excursion - (end-of-line) - (skip-chars-backward "^ \t") - (buffer-substring (point) (1- (makefile-end-of-line-point))))) - -(defun makefile-browser-this-line-macro-name () - "Extract the macro name from a line in the browser." - (save-excursion - (beginning-of-line) - (re-search-forward "\\$[{(]" (makefile-end-of-line-point) t) - (let ((macro-start (point))) - (skip-chars-forward "^})") - (buffer-substring macro-start (point))))) - -(defun makefile-format-macro-ref (macro-name) - "Format a macro reference. -Uses `makefile-use-curly-braces-for-macros-p'." - (if (or (char-equal ?\( (string-to-char macro-name)) - (char-equal ?\{ (string-to-char macro-name))) - (format "$%s" macro-name) - (if makefile-use-curly-braces-for-macros-p - (format "${%s}" macro-name) - (format "$(%s)" macro-name)))) - -(defun makefile-browser-get-state-for-line (n) - (aref makefile-browser-selection-vector (1- n))) - -(defun makefile-browser-set-state-for-line (n to-state) - (aset makefile-browser-selection-vector (1- n) to-state)) - -(defun makefile-browser-toggle-state-for-line (n) - (makefile-browser-set-state-for-line n (not (makefile-browser-get-state-for-line n)))) - -(defun makefile-beginning-of-line-point () - (save-excursion - (beginning-of-line) - (point))) - -(defun makefile-end-of-line-point () - (save-excursion - (end-of-line) - (point))) - -(defun makefile-last-line-p () - (= (makefile-end-of-line-point) (point-max))) - -(defun makefile-first-line-p () - (= (makefile-beginning-of-line-point) (point-min))) - - - -;;; Support for other packages, like add-log and imenu. - -(defun makefile-add-log-defun () - "Return name of target or variable assignment that point is in. -If it isn't in one, return nil." - (save-excursion - (let (found) - (beginning-of-line) - ;; Scan back line by line, noticing when we come to a - ;; variable or rule definition, and giving up when we see - ;; a line that is not part of either of those. - (while (not found) - (cond - ((looking-at makefile-macroassign-regex) - (setq found (buffer-substring-no-properties (match-beginning 1) - (match-end 1)))) - ((looking-at makefile-dependency-regex) - (setq found (buffer-substring-no-properties (match-beginning 1) - (match-end 1)))) - ;; Don't keep looking across a blank line or comment. Give up. - ((looking-at "$\\|#") - (setq found 'bobp)) - ((bobp) - (setq found 'bobp))) - (or found - (forward-line -1))) - (if (stringp found) found)))) - -;; FIXME it might be nice to have them separated by macro vs target. -(defun makefile-menu-index-function () - ;; "Generate alist of indices for imenu." - (let (alist - stupid - (re (concat makefile-dependency-regex - "\\|" - makefile-macroassign-regex))) - (imenu-progress-message stupid 0) - (goto-char (point-min)) - (while (re-search-forward re nil t) - (imenu-progress-message stupid) - (let ((n (if (match-beginning 1) 1 5))) - (setq alist (cons - (cons (buffer-substring (match-beginning n) - (match-end n)) - (match-beginning n)) - alist)))) - (imenu-progress-message stupid 100) - (nreverse alist))) - -;;; make-mode.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/modula2.el --- a/lisp/modes/modula2.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,473 +0,0 @@ -;;; modula2.el --- Modula-2 editing support package - -;; Author: Michael Schmidt -;; Tom Perrine -;; Keywords: languages - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34. - -;; The authors distributed this without a copyright notice -;; back in 1988, so it is in the public domain. The original included -;; the following credit: - -;; Author Mick Jordan -;; amended Peter Robinson - -;;; Commentary: - -;; A major mode for editing Modula-2 code. It provides convenient abbrevs -;; for Modula-2 keywords, knows about the standard layout rules, and supports -;; a native compile command. - -;;; Code: - -;;; Added by Tom Perrine (TEP) -(defvar m2-mode-syntax-table nil - "Syntax table in use in Modula-2 buffers.") - -(defvar m2-compile-command "m2c" - "Command to compile Modula-2 programs") - -(defvar m2-link-command "m2l" - "Command to link Modula-2 programs") - -(defvar m2-link-name nil - "Name of the executable.") - - -(if m2-mode-syntax-table - () - (let ((table (make-syntax-table))) - (modify-syntax-entry ?\\ "\\" table) - (modify-syntax-entry ?\( ". 1" table) - (modify-syntax-entry ?\) ". 4" table) - (modify-syntax-entry ?* ". 23" table) - (modify-syntax-entry ?+ "." table) - (modify-syntax-entry ?- "." table) - (modify-syntax-entry ?= "." table) - (modify-syntax-entry ?% "." table) - (modify-syntax-entry ?< "." table) - (modify-syntax-entry ?> "." table) - (modify-syntax-entry ?\' "\"" table) - (setq m2-mode-syntax-table table))) - -;;; Added by TEP -(defvar m2-mode-map nil - "Keymap used in Modula-2 mode.") - -(if m2-mode-map () - (let ((map (make-sparse-keymap))) - (define-key map "\^i" 'm2-tab) - (define-key map "\C-cb" 'm2-begin) - (define-key map "\C-cc" 'm2-case) - (define-key map "\C-cd" 'm2-definition) - (define-key map "\C-ce" 'm2-else) - (define-key map "\C-cf" 'm2-for) - (define-key map "\C-ch" 'm2-header) - (define-key map "\C-ci" 'm2-if) - (define-key map "\C-cm" 'm2-module) - (define-key map "\C-cl" 'm2-loop) - (define-key map "\C-co" 'm2-or) - (define-key map "\C-cp" 'm2-procedure) - (define-key map "\C-c\C-w" 'm2-with) - (define-key map "\C-cr" 'm2-record) - (define-key map "\C-cs" 'm2-stdio) - (define-key map "\C-ct" 'm2-type) - (define-key map "\C-cu" 'm2-until) - (define-key map "\C-cv" 'm2-var) - (define-key map "\C-cw" 'm2-while) - (define-key map "\C-cx" 'm2-export) - (define-key map "\C-cy" 'm2-import) - (define-key map "\C-c{" 'm2-begin-comment) - (define-key map "\C-c}" 'm2-end-comment) - (define-key map "\C-j" 'm2-newline) - (define-key map "\C-c\C-z" 'suspend-emacs) - (define-key map "\C-c\C-v" 'm2-visit) - (define-key map "\C-c\C-t" 'm2-toggle) - (define-key map "\C-c\C-l" 'm2-link) - (define-key map "\C-c\C-c" 'm2-compile) - (setq m2-mode-map map))) - -(defvar m2-indent 5 "*This variable gives the indentation in Modula-2-Mode") - -;;;###autoload -(defun modula-2-mode () - "This is a mode intended to support program development in Modula-2. -All control constructs of Modula-2 can be reached by typing C-c -followed by the first character of the construct. -\\ - \\[m2-begin] begin \\[m2-case] case - \\[m2-definition] definition \\[m2-else] else - \\[m2-for] for \\[m2-header] header - \\[m2-if] if \\[m2-module] module - \\[m2-loop] loop \\[m2-or] or - \\[m2-procedure] procedure Control-c Control-w with - \\[m2-record] record \\[m2-stdio] stdio - \\[m2-type] type \\[m2-until] until - \\[m2-var] var \\[m2-while] while - \\[m2-export] export \\[m2-import] import - \\[m2-begin-comment] begin-comment \\[m2-end-comment] end-comment - \\[suspend-emacs] suspend Emacs \\[m2-toggle] toggle - \\[m2-compile] compile \\[m2-next-error] next-error - \\[m2-link] link - - `m2-indent' controls the number of spaces for each indentation. - `m2-compile-command' holds the command to compile a Modula-2 program. - `m2-link-command' holds the command to link a Modula-2 program." - (interactive) - (kill-all-local-variables) - (use-local-map m2-mode-map) - (setq major-mode 'modula-2-mode) - (setq mode-name "Modula-2") - (make-local-variable 'comment-column) - (setq comment-column 41) - (make-local-variable 'end-comment-column) - (setq end-comment-column 75) - (set-syntax-table m2-mode-syntax-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) -; (make-local-variable 'indent-line-function) -; (setq indent-line-function 'c-indent-line) - (make-local-variable 'require-final-newline) - (setq require-final-newline t) - (make-local-variable 'comment-start) - (setq comment-start "(* ") - (make-local-variable 'comment-end) - (setq comment-end " *)") - (make-local-variable 'comment-column) - (setq comment-column 41) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "/\\*+ *") - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'c-comment-indent) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - (run-hooks 'm2-mode-hook)) - -(defun m2-newline () - "Insert a newline and indent following line like previous line." - (interactive) - (let ((hpos (current-indentation))) - (newline) - (indent-to hpos))) - -(defun m2-tab () - "Indent to next tab stop." - (interactive) - (indent-to (* (1+ (/ (current-indentation) m2-indent)) m2-indent))) - -(defun m2-begin () - "Insert a BEGIN keyword and indent for the next line." - (interactive) - (insert "BEGIN") - (m2-newline) - (m2-tab)) - -(defun m2-case () - "Build skeleton CASE statement, prompting for the ." - (interactive) - (let ((name (read-string "Case-Expression: "))) - (insert "CASE " name " OF") - (m2-newline) - (m2-newline) - (insert "END (* case " name " *);")) - (end-of-line 0) - (m2-tab)) - -(defun m2-definition () - "Build skeleton DEFINITION MODULE, prompting for the ." - (interactive) - (insert "DEFINITION MODULE ") - (let ((name (read-string "Name: "))) - (insert name ";\n\n\n\nEND " name ".\n")) - (previous-line 3)) - -(defun m2-else () - "Insert ELSE keyword and indent for next line." - (interactive) - (m2-newline) - (backward-delete-char-untabify m2-indent ()) - (insert "ELSE") - (m2-newline) - (m2-tab)) - -(defun m2-for () - "Build skeleton FOR loop statement, prompting for the loop parameters." - (interactive) - (insert "FOR ") - (let ((name (read-string "Loop Initialiser: ")) limit by) - (insert name " TO ") - (setq limit (read-string "Limit: ")) - (insert limit) - (setq by (read-string "Step: ")) - (if (not (string-equal by "")) - (insert " BY " by)) - (insert " DO") - (m2-newline) - (m2-newline) - (insert "END (* for " name " to " limit " *);")) - (end-of-line 0) - (m2-tab)) - -(defun m2-header () - "Insert a comment block containing the module title, author, etc." - (interactive) - (insert "(*\n Title: \t") - (insert (read-string "Title: ")) - (insert "\n Created:\t") - (insert (current-time-string)) - (insert "\n Author: \t") - (insert (user-full-name)) - (insert (concat "\n\t\t<" (user-login-name) "@" (system-name) ">\n")) - (insert "*)\n\n")) - -(defun m2-if () - "Insert skeleton IF statement, prompting for ." - (interactive) - (insert "IF ") - (let ((thecondition (read-string ": "))) - (insert thecondition " THEN") - (m2-newline) - (m2-newline) - (insert "END (* if " thecondition " *);")) - (end-of-line 0) - (m2-tab)) - -(defun m2-loop () - "Build skeleton LOOP (with END)." - (interactive) - (insert "LOOP") - (m2-newline) - (m2-newline) - (insert "END (* loop *);") - (end-of-line 0) - (m2-tab)) - -(defun m2-module () - "Build skeleton IMPLEMENTATION MODULE, prompting for ." - (interactive) - (insert "IMPLEMENTATION MODULE ") - (let ((name (read-string "Name: "))) - (insert name ";\n\n\n\nEND " name ".\n") - (previous-line 3) - (m2-header) - (m2-type) - (newline) - (m2-var) - (newline) - (m2-begin) - (m2-begin-comment) - (insert " Module " name " Initialisation Code ")) - (m2-end-comment) - (newline) - (m2-tab)) - -(defun m2-or () - (interactive) - (m2-newline) - (backward-delete-char-untabify m2-indent) - (insert "|") - (m2-newline) - (m2-tab)) - -(defun m2-procedure () - (interactive) - (insert "PROCEDURE ") - (let ((name (read-string "Name: " )) - args) - (insert name " (") - (insert (read-string "Arguments: ") ")") - (setq args (read-string "Result Type: ")) - (if (not (string-equal args "")) - (insert " : " args)) - (insert ";") - (m2-newline) - (insert "BEGIN") - (m2-newline) - (m2-newline) - (insert "END ") - (insert name) - (insert ";") - (end-of-line 0) - (m2-tab))) - -(defun m2-with () - (interactive) - (insert "WITH ") - (let ((name (read-string "Record-Type: "))) - (insert name) - (insert " DO") - (m2-newline) - (m2-newline) - (insert "END (* with " name " *);")) - (end-of-line 0) - (m2-tab)) - -(defun m2-record () - (interactive) - (insert "RECORD") - (m2-newline) - (m2-newline) - (insert "END (* record *);") - (end-of-line 0) - (m2-tab)) - -(defun m2-stdio () - (interactive) - (insert " -FROM TextIO IMPORT - WriteCHAR, ReadCHAR, WriteINTEGER, ReadINTEGER, - WriteCARDINAL, ReadCARDINAL, WriteBOOLEAN, ReadBOOLEAN, - WriteREAL, ReadREAL, WriteBITSET, ReadBITSET, - WriteBasedCARDINAL, ReadBasedCARDINAL, WriteChars, ReadChars, - WriteString, ReadString, WhiteSpace, EndOfLine; - -FROM SysStreams IMPORT sysIn, sysOut, sysErr; - -")) - -(defun m2-type () - (interactive) - (insert "TYPE") - (m2-newline) - (m2-tab)) - -(defun m2-until () - (interactive) - (insert "REPEAT") - (m2-newline) - (m2-newline) - (insert "UNTIL ") - (insert (read-string ": ") ";") - (end-of-line 0) - (m2-tab)) - -(defun m2-var () - (interactive) - (m2-newline) - (insert "VAR") - (m2-newline) - (m2-tab)) - -(defun m2-while () - (interactive) - (insert "WHILE ") - (let ((name (read-string ": "))) - (insert name " DO" ) - (m2-newline) - (m2-newline) - (insert "END (* while " name " *);")) - (end-of-line 0) - (m2-tab)) - -(defun m2-export () - (interactive) - (insert "EXPORT QUALIFIED ")) - -(defun m2-import () - (interactive) - (insert "FROM ") - (insert (read-string "Module: ")) - (insert " IMPORT ")) - -(defun m2-begin-comment () - (interactive) - (if (not (bolp)) - (indent-to comment-column 0)) - (insert "(* ")) - -(defun m2-end-comment () - (interactive) - (if (not (bolp)) - (indent-to end-comment-column)) - (insert "*)")) - -(defun m2-compile () - (interactive) - (setq modulename (buffer-name)) - (compile (concat m2-compile-command " " modulename))) - -(defun m2-link () - (interactive) - (setq modulename (buffer-name)) - (if m2-link-name - (compile (concat m2-link-command " " m2-link-name)) - (compile (concat m2-link-command " " - (setq m2-link-name (read-string "Name of executable: " - modulename)))))) - -(defun m2-execute-monitor-command (command) - (let* ((shell shell-file-name) - (csh (equal (file-name-nondirectory shell) "csh"))) - (call-process shell nil t t "-cf" (concat "exec " command)))) - -(defun m2-visit () - (interactive) - (let ((deffile nil) - (modfile nil) - modulename) - (save-excursion - (setq modulename - (read-string "Module name: ")) - (switch-to-buffer "*Command Execution*") - (m2-execute-monitor-command (concat "m2whereis " modulename)) - (goto-char (point-min)) - (condition-case () - (progn (re-search-forward "\\(.*\\.def\\) *$") - (setq deffile (buffer-substring (match-beginning 1) - (match-end 1)))) - (search-failed ())) - (condition-case () - (progn (re-search-forward "\\(.*\\.mod\\) *$") - (setq modfile (buffer-substring (match-beginning 1) - (match-end 1)))) - (search-failed ())) - (if (not (or deffile modfile)) - (error "I can find neither definition nor implementation of %s" - modulename))) - (cond (deffile - (find-file deffile) - (if modfile - (save-excursion - (find-file modfile)))) - (modfile - (find-file modfile))))) - -(defun m2-toggle () - "Toggle between .mod and .def files for the module." - (interactive) - (cond ((string-equal (substring (buffer-name) -4) ".def") - (find-file-other-window - (concat (substring (buffer-name) 0 -4) ".mod"))) - ((string-equal (substring (buffer-name) -4) ".mod") - (find-file-other-window - (concat (substring (buffer-name) 0 -4) ".def"))) - ((string-equal (substring (buffer-name) -3) ".mi") - (find-file-other-window - (concat (substring (buffer-name) 0 -3) ".md"))) - ((string-equal (substring (buffer-name) -3) ".md") - (find-file-other-window - (concat (substring (buffer-name) 0 -3) ".mi"))))) - -;;; modula2.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/nroff-mode.el --- a/lisp/modes/nroff-mode.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,284 +0,0 @@ -;;; nroff-mode.el --- GNU Emacs major mode for editing nroff source - -;; Copyright (C) 1985, 1986, 1994, 1995 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: wp - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34. - -;;; Commentary: - -;; This package is a major mode for editing nroff source code. It knows -;; about various nroff constructs, ms, mm, and me macros, and will fill -;; and indent paragraphs properly in their presence. It also includes -;; a command to count text lines (excluding nroff constructs), a command -;; to center a line, and movement commands that know how to skip macros. - -;; Paragraph filling and line-counting currently don't respect comments, -;; as they should. - -;;; Code: - -(defvar nroff-mode-abbrev-table nil - "Abbrev table used while in nroff mode.") -(define-abbrev-table 'nroff-mode-abbrev-table ()) - -(defvar nroff-mode-map nil - "Major mode keymap for nroff mode.") -(if (not nroff-mode-map) - (progn - (setq nroff-mode-map (make-sparse-keymap)) - (define-key nroff-mode-map "\t" 'tab-to-tab-stop) - (define-key nroff-mode-map "\es" 'center-line) - (define-key nroff-mode-map "\e?" 'count-text-lines) - (define-key nroff-mode-map "\n" 'electric-nroff-newline) - (define-key nroff-mode-map "\en" 'forward-text-line) - (define-key nroff-mode-map "\ep" 'backward-text-line))) - -(defvar nroff-mode-syntax-table nil - "Syntax table used while in nroff mode.") - -(defvar nroff-font-lock-keywords - (list - ;; Directives are . or ' at start of line, followed by - ;; optional whitespace, then command (which my be longer than - ;; 2 characters in groff). Perhaps the arguments should be - ;; fontified as well. - "^[.']\\s-*\\sw+" - ;; There are numerous groff escapes; the following get things - ;; like \-, \(em (standard troff) and \f[bar] (groff - ;; variants). This won't currently do groff's \A'foo' and - ;; the like properly. One might expect it to highlight an escape's - ;; arguments in common cases, like \f. - (concat "\\\\" ; backslash - "\\(" ; followed by various possibilities - (mapconcat 'identity - '("[f*n]*\\[.+]" ; some groff extensions - "(.." ; two chars after ( - "[^(\"]" ; single char escape - ) "\\|") - "\\)") - ) - "Font-lock highlighting control in nroff-mode.") - -;;;###autoload -(defun nroff-mode () - "Major mode for editing text intended for nroff to format. -\\{nroff-mode-map} -Turning on Nroff mode runs `text-mode-hook', then `nroff-mode-hook'. -Also, try `nroff-electric-mode', for automatically inserting -closing requests for requests that are used in matched pairs." - (interactive) - (kill-all-local-variables) - (use-local-map nroff-mode-map) - (setq mode-name "Nroff") - (setq major-mode 'nroff-mode) - (if nroff-mode-syntax-table - () - (setq nroff-mode-syntax-table (copy-syntax-table text-mode-syntax-table)) - ;; " isn't given string quote syntax in text-mode but it - ;; (arguably) should be for use round nroff arguments (with ` and - ;; ' used otherwise). - (modify-syntax-entry ?\" "\" 2" nroff-mode-syntax-table) - ;; Comments are delimited by \" and newline. - (modify-syntax-entry ?\\ "\\ 1" nroff-mode-syntax-table) - (modify-syntax-entry ?\n "> 1" nroff-mode-syntax-table)) - (set-syntax-table nroff-mode-syntax-table) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(nroff-font-lock-keywords nil t)) - (setq local-abbrev-table nroff-mode-abbrev-table) - (make-local-variable 'nroff-electric-mode) - (setq nroff-electric-mode nil) - (make-local-variable 'outline-regexp) - (setq outline-regexp "\\.H[ ]+[1-7]+ ") - (make-local-variable 'outline-level) - (setq outline-level 'nroff-outline-level) - ;; now define a bunch of variables for use by commands in this mode - (make-local-variable 'page-delimiter) - (setq page-delimiter "^\\.\\(bp\\|SK\\|OP\\)") - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "[.']\\|" paragraph-start)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate (concat "[.']\\|" paragraph-separate)) - ;; comment syntax added by mit-erl!gildea 18 Apr 86 - (make-local-variable 'comment-start) - (setq comment-start "\\\" ") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "\\\\\"[ \t]*") - (make-local-variable 'comment-column) - (setq comment-column 24) - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'nroff-comment-indent) - (run-hooks 'text-mode-hook 'nroff-mode-hook)) - -(defun nroff-outline-level () - (save-excursion - (looking-at outline-regexp) - (skip-chars-forward ".H ") - (string-to-int (buffer-substring (point) (+ 1 (point)))))) - -;;; Compute how much to indent a comment in nroff/troff source. -;;; By mit-erl!gildea April 86 -(defun nroff-comment-indent () - "Compute indent for an nroff/troff comment. -Puts a full-stop before comments on a line by themselves." - (let ((pt (point))) - (unwind-protect - (progn - (skip-chars-backward " \t") - (if (bolp) - (progn - (setq pt (1+ pt)) - (insert ?.) - 1) - (if (save-excursion - (backward-char 1) - (looking-at "^[.']")) - 1 - (max comment-column - (* 8 (/ (+ (current-column) - 9) 8)))))) ; add 9 to ensure at least two blanks - (goto-char pt)))) - -(defun count-text-lines (start end &optional print) - "Count lines in region, except for nroff request lines. -All lines not starting with a period are counted up. -Interactively, print result in echo area. -Noninteractively, return number of non-request lines from START to END." - (interactive "r\np") - (if print - (message "Region has %d text lines" (count-text-lines start end)) - (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char (point-min)) - (- (buffer-size) (forward-text-line (buffer-size))))))) - -(defun forward-text-line (&optional cnt) - "Go forward one nroff text line, skipping lines of nroff requests. -An argument is a repeat count; if negative, move backward." - (interactive "p") - (if (not cnt) (setq cnt 1)) - (while (and (> cnt 0) (not (eobp))) - (forward-line 1) - (while (and (not (eobp)) (looking-at "[.'].")) - (forward-line 1)) - (setq cnt (- cnt 1))) - (while (and (< cnt 0) (not (bobp))) - (forward-line -1) - (while (and (not (bobp)) - (looking-at "[.'].")) - (forward-line -1)) - (setq cnt (+ cnt 1))) - cnt) - -(defun backward-text-line (&optional cnt) - "Go backward one nroff text line, skipping lines of nroff requests. -An argument is a repeat count; negative means move forward." - (interactive "p") - (forward-text-line (- cnt))) - -(defconst nroff-brace-table - '((".(b" . ".)b") - (".(l" . ".)l") - (".(q" . ".)q") - (".(c" . ".)c") - (".(x" . ".)x") - (".(z" . ".)z") - (".(d" . ".)d") - (".(f" . ".)f") - (".LG" . ".NL") - (".SM" . ".NL") - (".LD" . ".DE") - (".CD" . ".DE") - (".BD" . ".DE") - (".DS" . ".DE") - (".DF" . ".DE") - (".FS" . ".FE") - (".KS" . ".KE") - (".KF" . ".KE") - (".LB" . ".LE") - (".AL" . ".LE") - (".BL" . ".LE") - (".DL" . ".LE") - (".ML" . ".LE") - (".RL" . ".LE") - (".VL" . ".LE") - (".RS" . ".RE") - (".TS" . ".TE") - (".EQ" . ".EN") - (".PS" . ".PE") - (".BS" . ".BE") - (".G1" . ".G2") ; grap - (".na" . ".ad b") - (".nf" . ".fi") - (".de" . ".."))) - -(defun electric-nroff-newline (arg) - "Insert newline for nroff mode; special if electric-nroff mode. -In `electric-nroff-mode', if ending a line containing an nroff opening request, -automatically inserts the matching closing request after point." - (interactive "P") - (let ((completion (save-excursion - (beginning-of-line) - (and (null arg) - nroff-electric-mode - (<= (point) (- (point-max) 3)) - (cdr (assoc (buffer-substring (point) - (+ 3 (point))) - nroff-brace-table))))) - (needs-nl (not (looking-at "[ \t]*$")))) - (if (null completion) - (newline (prefix-numeric-value arg)) - (save-excursion - (insert "\n\n" completion) - (if needs-nl (insert "\n"))) - (forward-char 1)))) - -;;;###autoload -(defun electric-nroff-mode (&optional arg) - "Toggle `nroff-electric-newline' minor mode. -`nroff-electric-newline' forces Emacs to check for an nroff request at the -beginning of the line, and insert the matching closing request if necessary. -This command toggles that mode (off->on, on->off), with an argument, -turns it on iff arg is positive, otherwise off." - (interactive "P") - (or (eq major-mode 'nroff-mode) (error "Must be in nroff mode")) - ;; XEmacs: see below. -; (or (assq 'nroff-electric-mode minor-mode-alist) -; (setq minor-mode-alist (append minor-mode-alist -; (list '(nroff-electric-mode -; " Electric"))))) - (setq nroff-electric-mode - (cond ((null arg) (null nroff-electric-mode)) - (t (> (prefix-numeric-value arg) 0))))) - -;;;###autoload -(defvar nroff-electric-mode nil - "Non-nil if in electric-nroff minor mode.") -;; XEmacs: do it right. This must come after the defun of -;; electric-nroff-mode so that add-minor-mode will recognize it as a -;; command. -;; perverse variable name. -;;;###autoload -(add-minor-mode 'nroff-electric-mode " Electric" nil nil 'electric-nroff-mode) - -;;; nroff-mode.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/outl-mouse.el --- a/lisp/modes/outl-mouse.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,676 +0,0 @@ -;;; outl-mouse.el --- outline mode mouse commands for Emacs - -;; Copyright 1994 (C) Andy Piper -;; Keywords: outlines, mouse - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. -;; -;; outl-mouse.el v1.3.8: -;; -;; Defines button one to hide blocks when clicked on outline-up-arrow -;; and expand blocks when clicked on outline-down-arrow. Features are -;; activated when outline-minor-mode or outline-mode are turned -;; on. There is also a menu for each glyph on button 3. -;; -;; To use put: -;; (require 'outl-mouse) -;; in your .emacs file. -;; -;; If you use func-menu all the time and want outl-mouse on all the -;; time as well then put: -;; (setq outline-sync-with-func-menu t) -;; outlining will then be turned on when func-menu is. Note that this -;; requires a patch to func-menu 2.16 (in 19.10) to work: -;; -;RCS file: func-menu.el,v -;retrieving revision 1.1 -;diff -r1.1 func-menu.el -;180a181,183 -;> (defvar fume-found-function-hook nil -;> "*Hook to call after every function match.") -;> -;1137,1138c1140,1142 -;< (if (listp funcname) -;< (setq funclist (cons funcname funclist))) -;--- -;> (cond ((listp funcname) -;> (setq funclist (cons funcname funclist)) -;> (save-excursion (run-hooks 'fume-found-function-hook)))) -;; -;; If you want mac-style outlining then set outline-mac-style to t. -;; If you want the outline arrows on the left then set -;; outline-glyphs-on-left to t. If you have xpm then arrows are much -;; better defined. -;; -;; This package uses func-menu to define outline regexps if they are -;; not already defined. You should no longer need to use out-xtra. -;; -;; You can define the package to do something other than outlining by -;; setting outline-fold-in-function and outline-fold-out-function. -;; -;; You can define the color of outline arrows, but only in your .emacs. -;; -;; Only works in XEmacs 19.10 and onwards. -;; -;; User definable variables. -;; - -(defgroup outl-mouse nil - "Outline mouse mode commands for Emacs" - :prefix "outline-" - :group 'outlines - :group 'mouse) - - -(defcustom outline-mac-style nil - "*If t then outline glyphs will be right and down arrows." - :type 'boolean - :group 'outl-mouse) - -(defcustom outline-glyphs-on-left nil - "*The position of outline glyphs on a line." - :type 'boolean - :group 'outl-mouse) - -(defcustom outline-glyph-colour "Gray75" - "*The colour of outlining arrows." - :type 'color - :group 'outl-mouse) - -(defcustom outline-glyph-shade-colour "Gray40" - "*The shadow colour of outlining arrows." - :type 'color - :group 'outl-mouse) - -(defcustom outline-glyph-lit-colour "Gray90" - "*The lit colour of outlining arrows." - :type 'color - :group 'outl-mouse) - -(defvar outline-fold-in-function 'outline-fold-in - "Function to call for folding in. -The function should take an annotation argument.") -(make-variable-buffer-local 'outline-fold-in-function) - -(defvar outline-fold-out-function 'outline-fold-out - "Function to call for folding out. -The function should take an annotation argument.") -(make-variable-buffer-local 'outline-fold-out-function) - -(defcustom outline-sync-with-func-menu nil - "*If t then outline glyphs are permanently added by func-menu scans. -If outline-minor-mode is turned off then turing it back on will have -no effect. Instead the buffer should be rescanned from the function -menu." - :type 'boolean - :group 'outl-mouse) - -(defcustom outline-move-point-after-click t - "*If t then point is moved to the current heading when clicked." - :type 'boolean - :group 'outl-mouse) - -(defcustom outline-scanning-message "Adding glyphs... (%3d%%)" - "*Progress message during the scanning of the buffer. -Set this to nil to inhibit progress messages." - :type 'string - :group 'outl-mouse) - -;; -;; No user definable variables beyond this point. -;; - -;; I'll bet there's a neat way to do this with specifiers -- a pity the -;; sucks so badly on it. -sb -(defconst outline-up-arrow ; XEmacs - (make-glyph ; an up-arrow - (cond ((featurep 'xpm) (vector 'xpm :data (concat "/* XPM */ -static char * arrow[] = { -\"10 10 5 1\", -\" c none\", -\". c " outline-glyph-lit-colour "\", -\"X c " outline-glyph-shade-colour "\", -\"o c " outline-glyph-colour "\", -\"O c " outline-glyph-shade-colour "\", -\" .X \", -\" .X \", -\" ..XX \", -\" ..XX \", -\" ..ooXX \", -\" ..ooXX \", -\" ..ooooXX \", -\" ..ooooXX \", -\"..OOOOOOXX\", -\"OOOOOOOOOO\"};"))) - ((featurep 'x) - (vector 'xbm - :data - (list 10 10 - (concat "\000\000\000\000\060\000\060\000\150\000" - "\150\000\324\000\324\000\376\001\376\001")))) - (t "^"))) - "Bitmap object for outline up glyph.") - -(defconst outline-up-arrow-mask ; XEmacs - (make-glyph ; an up-arrow - (cond ((featurep 'xpm) (vector 'xpm :data (concat "/* XPM */ -static char * arrow[] = { -\"10 10 5 1\", -\" c none\", -\". c " outline-glyph-shade-colour "\", -\"X c " outline-glyph-lit-colour "\", -\"o c " outline-glyph-colour "\", -\"O c " outline-glyph-lit-colour "\", -\" .X \", -\" .X \", -\" ..XX \", -\" ..XX \", -\" ..ooXX \", -\" ..ooXX \", -\" ..ooooXX \", -\" ..ooooXX \", -\"..OOOOOOXX\", -\"OOOOOOOOOO\"};"))) - ((featurep 'x) - (vector 'xbm - :data - (list 10 10 - (concat "\000\000\000\000\060\000\060\000\130\000" - "\130\000\254\000\274\000\006\001\376\001")))) - (t "+"))) - "Bitmap object for outline depressed up glyph.") - -(defconst outline-down-arrow ; XEmacs - (make-glyph ; a down-arrow - (cond ((featurep 'xpm) (vector 'xpm :data (concat "/* XPM */ -static char * down[] = { -\"10 10 5 1\", -\" c " outline-glyph-lit-colour "\", -\". c " outline-glyph-lit-colour "\", -\"X c " outline-glyph-shade-colour "\", -\"o c none\", -\"O c " outline-glyph-colour "\", -\" \", -\".. XX\", -\"o..OOOOXXo\", -\"o..OOOOXXo\", -\"oo..OOXXoo\", -\"oo..OOXXoo\", -\"ooo..XXooo\", -\"ooo..XXooo\", -\"oooo.Xoooo\", -\"oooo.Xoooo\"};"))) - ((featurep 'x) - (vector 'xbm - :data - (list 10 10 - (concat "\000\000\000\000\376\001\202\001\364\000" - "\324\000\150\000\150\000\060\000\060\000")))) - (t "v"))) - "Bitmap object for outline down glyph.") - -(defconst outline-down-arrow-mask ; XEmacs - (make-glyph ; a down-arrow - (cond ((featurep 'xpm) (vector 'xpm :data (concat "/* XPM */ -static char * down[] = { -\"10 10 5 1\", -\" c " outline-glyph-shade-colour "\", -\". c " outline-glyph-shade-colour "\", -\"X c " outline-glyph-lit-colour "\", -\"o c none\", -\"O c " outline-glyph-colour "\", -\" \", -\".. XX\", -\"o..OOOOXXo\", -\"o..OOOOXXo\", -\"oo..OOXXoo\", -\"oo..OOXXoo\", -\"ooo..XXooo\", -\"ooo..XXooo\", -\"oooo.Xoooo\", -\"oooo.Xoooo\"};"))) - ((featurep 'x) - (vector 'xbm - :data - (list 10 10 - (concat "\000\000\000\000\376\001\376\001\254\000" - "\254\000\130\000\130\000\060\000\060\000")))) - (t "+"))) - "Bitmap object for outline depressed down glyph.") - -(defconst outline-right-arrow - (make-glyph ; a right-arrow - (cond ((featurep 'xpm) (vector 'xpm :data (concat "/* XPM */ -static char * right[] = { -\"10 10 5 1\", -\" c " outline-glyph-lit-colour "\", -\". c " outline-glyph-lit-colour "\", -\"X c none\", -\"o c " outline-glyph-colour "\", -\"O c " outline-glyph-shade-colour "\", -\" .XXXXXXXX\", -\" ...XXXXXX\", -\" ....XXXX\", -\" oo....XX\", -\" oooo....\", -\" ooooOOOO\", -\" ooOOOOXX\", -\" OOOOXXXX\", -\" OOOXXXXXX\", -\" OXXXXXXXX\"};"))) - ((featurep 'x) - (vector 'xbm - :data - (list 10 10 - (concat "\000\000\006\000\032\000\142\000\232\001" - "\352\001\172\000\036\000\006\000\000\000")))) - (t ">"))) - "Bitmap object for outline right glyph.") - -(defconst outline-right-arrow-mask - (make-glyph ; a right-arrow - (cond ((featurep 'xpm) (vector 'xpm :data (concat "/* XPM */ -static char * right[] = { -\"10 10 5 1\", -\" c " outline-glyph-shade-colour "\", -\". c " outline-glyph-shade-colour "\", -\"X c none\", -\"o c " outline-glyph-colour "\", -\"O c " outline-glyph-lit-colour "\", -\" .XXXXXXXX\", -\" ...XXXXXX\", -\" ....XXXX\", -\" oo....XX\", -\" oooo....\", -\" ooooOOOO\", -\" ooOOOOXX\", -\" OOOOXXXX\", -\" OOOXXXXXX\", -\" OXXXXXXXX\"};"))) - ((featurep 'x) - (vector 'xbm - :data - (list 10 10 - (concat "\000\000\006\000\036\000\176\000\346\001" - "\236\001\146\000\036\000\006\000\000\000")))) - (t "+"))) - "Bitmap object for outline depressed right glyph.") - -(defvar outline-glyph-menu - '("Outline Commands" - ["Hide all" hide-body t] - ["Hide all subtrees" hide-subtrees-same-level t] - ["Hide subtree" hide-subtree t] -; ["Hide body" hide-body t] - "---" - ["Show all" show-all t] - ["Show subtree" show-subtree t] - ["Show body" show-entry t] - "---" - ["Update buffer" outline-add-glyphs t] - ["Rescan buffer" outline-rescan-buffer t]) - "Menu of commands for outline glyphs.") - -(set-pixmap-contributes-to-line-height outline-down-arrow nil) -(set-pixmap-contributes-to-line-height outline-up-arrow nil) -(set-pixmap-contributes-to-line-height outline-down-arrow-mask nil) -(set-pixmap-contributes-to-line-height outline-up-arrow-mask nil) -(set-pixmap-contributes-to-line-height outline-right-arrow nil) -(set-pixmap-contributes-to-line-height outline-right-arrow-mask nil) - -(require 'annotations) -(require 'advice) ; help me doctor ! -(require 'outline) -(require 'func-menu) ; for those most excellent regexps. - -(add-hook 'outline-mode-hook 'outline-mouse-hooks) -(add-hook 'outline-minor-mode-hook 'outline-mouse-hooks) -;; I thought this was done already ... -(make-variable-buffer-local 'outline-regexp) -(make-variable-buffer-local 'outline-level) - -(cond (outline-sync-with-func-menu - (add-hook 'fume-found-function-hook 'outline-heading-add-glyph-1) - (setq-default fume-rescan-buffer-hook '(lambda () - (outline-minor-mode 1))))) - -(defadvice fume-set-defaults (after fume-set-defaults-ad activate) - "Advise fume-set-defaults to setup outline regexps." - (if (and (not (assq 'outline-regexp (buffer-local-variables))) - fume-function-name-regexp) - (progn - (setq outline-regexp (if (listp fume-function-name-regexp) - (car fume-function-name-regexp) - fume-function-name-regexp)) - (setq outline-level '(lambda () 1))))) - -(defadvice outline-minor-mode (after outline-mode-mouse activate) - "Advise outline-minor-mode to delete glyphs when switched off." - (if (not outline-minor-mode) - (progn - (outline-delete-glyphs) - (show-all)))) - -;; advise all outline commands so that glyphs are synced after use -(defadvice show-all (after show-all-ad activate) - "Advise show-all to sync headings." - (outline-sync-visible-sub-headings-in-region (point-min) (point-max))) - -(defadvice hide-subtree (after hide-subtree-ad activate) - "Advise hide-subtree to sync headings." - (outline-sync-visible-sub-headings)) - -(defadvice hide-entry (after hide-entry-ad activate) - "Advise hide-entry to sync headings." - (outline-sync-visible-sub-headings)) - -(defadvice hide-body (after hide-body-ad activate) - "Advise hide-body to sync headings." - (outline-sync-visible-sub-headings-in-region (point-min) (point-max))) - -(defadvice show-subtree (after show-subtree-ad activate) - "Advise show-subtree to sync headings." - (outline-sync-visible-sub-headings)) - -(defadvice show-entry (after show-entry-ad activate) - "Advise shown-entry to sync headings." - (outline-sync-visible-sub-headings)) - -;;;###autoload -(defun outl-mouse-mode () - "Calls outline-mode, with outl-mouse extensions" - (interactive) - (outline-mode)) - -;;;###autoload -(defun outl-mouse-minor-mode (&optional arg) - "Toggles outline-minor-mode, with outl-mouse extensions" - (interactive "P") - (outline-minor-mode arg)) - -(defun hide-subtrees-same-level () - "Hide all subtrees below the current level." - (interactive) - (save-excursion - (while (progn - (hide-subtree) - (condition-case nil - (progn - (outline-forward-same-level 1) - t) - (error nil)))))) - -(defun outline-mouse-hooks () - "Hook for installing outlining with the mouse." - ;; use function menu regexps if not set - (fume-set-defaults) - ;; only add glyphs when we're not synced. - (if (not outline-sync-with-func-menu) (outline-add-glyphs)) - ;; add C-a to local keymap - (let ((outline (cond ((keymapp (lookup-key (current-local-map) - outline-minor-mode-prefix)) - (lookup-key (current-local-map) - outline-minor-mode-prefix)) - (t - (define-key (current-local-map) - outline-minor-mode-prefix (make-sparse-keymap)) - (lookup-key (current-local-map) - outline-minor-mode-prefix))))) - (define-key outline "\C-a" 'outline-heading-add-glyph) - (define-key outline-mode-map "\C-c\C-a" 'outline-heading-add-glyph))) - -(defun outline-add-glyphs () - "Add annotations and glyphs to all heading lines that don't have them." - (interactive) - (save-excursion - (and outline-scanning-message (display-message - 'progress - (format outline-scanning-message 0))) - (goto-char (point-min)) - (if (not (outline-on-heading-p)) (outline-next-visible-heading-safe)) - (while - (progn - (outline-heading-add-glyph-1) - (and outline-scanning-message - (display-message - 'progress - (format outline-scanning-message (fume-relative-position)))) - (outline-next-visible-heading-safe))) - (and outline-scanning-message - (display-message - 'progress - (format "%s done" (format outline-scanning-message 100)))))) - -(defun outline-delete-glyphs () - "Remove annotations and glyphs from heading lines." - (save-excursion - (mapcar 'outline-heading-delete-glyph (annotation-list)))) - -(defun outline-rescan-buffer () - "Remove and insert all annotations." - (interactive) - (outline-delete-glyphs) - (outline-add-glyphs) - (save-excursion - (outline-sync-visible-sub-headings-in-region (point-min) (point-max)))) - -(defun outline-heading-delete-glyph (ext) - "Delete annotation and glyph from a heading with annotation EXT." - (if (and - (progn - (goto-char (extent-start-position ext)) - (beginning-of-line) - (outline-on-heading-p)) - (extent-property ext 'outline)) - (delete-annotation ext)) - nil) - -(defun outline-heading-add-glyph () - "Interactive version of outline-heading-add-glyph-1." - (interactive) - (save-excursion - (outline-heading-add-glyph-1))) - -(defun outline-heading-add-glyph-1 () - "Add glyph to the end of heading line which point is on. - Returns nil if point is not on a heading or glyph already exists." - (if (or (not (outline-on-heading-p)) - (outline-heading-has-glyph-p) - (save-excursion (forward-line) (outline-on-heading-p))) - nil - (outline-back-to-heading) - (let ((anot2 - (make-annotation (if outline-mac-style - outline-right-arrow - outline-down-arrow) - (save-excursion (if outline-glyphs-on-left nil - (outline-end-of-heading)) - (point)) - 'text nil t - (if outline-mac-style - outline-right-arrow-mask - outline-down-arrow-mask))) - (anot1 - (make-annotation (if outline-mac-style - outline-down-arrow - outline-up-arrow) - (save-excursion (if outline-glyphs-on-left nil - (outline-end-of-heading)) - (point)) - 'text nil t - (if outline-mac-style - outline-down-arrow-mask - outline-up-arrow-mask)))) - ;; we cunningly make the annotation data point to its twin. - (set-annotation-data anot1 anot2) - (set-extent-property anot1 'outline 'up) - (set-annotation-action anot1 'outline-up-click) - (set-annotation-menu anot1 outline-glyph-menu) - (set-extent-priority anot1 1) - (set-annotation-data anot2 anot1) - (set-extent-property anot2 'outline 'down) - (set-annotation-menu anot2 outline-glyph-menu) - (set-annotation-action anot2 'outline-down-click) - (annotation-hide anot2)) - t)) - -(defun outline-heading-has-glyph-p () - "Return t if heading has an outline glyph." - (catch 'found - (mapcar - '(lambda(a) - (if (extent-property a 'outline) - (throw 'found t))) - (annotations-in-region (save-excursion (outline-back-to-heading) (point)) - (save-excursion (outline-end-of-heading) - (+ 1 (point))) - (current-buffer))) - nil)) - -(defun outline-sync-visible-sub-headings-in-region (pmin pmax) - "Make sure all anotations on headings in region PMIN PMAX are -displayed correctly." - (mapcar '(lambda (x) - (goto-char (extent-start-position x)) - (beginning-of-line) - (cond ((and (eq (extent-property x 'outline) 'down) - ;; skip things we can't see - (not (eq (preceding-char) ?\^M))) - (if (outline-more-to-hide) - ;; reveal my twin - (annotation-reveal (annotation-data x)) - (annotation-hide (annotation-data x))) - (if (not (outline-hidden-p)) - ;; hide my self - (annotation-hide x) - (annotation-reveal x))))) - (annotations-in-region pmin pmax (current-buffer)))) - -(defun outline-sync-visible-sub-headings () - "Make sure all anotations on sub-headings below the one point is on are -displayed correctly." - (outline-sync-visible-sub-headings-in-region - (point) - (progn (outline-end-of-subtree) (point)))) - -(defun outline-fold-out (annotation) - "Fold out the current heading." - (beginning-of-line) -; (if (not (equal (condition-case nil -; (save-excursion (outline-next-visible-heading 1) -; (point)) -; (error nil)) -; (save-excursion (outline-next-heading) -; (if (eobp) nil (point))))) - (if (save-excursion (outline-next-heading) - (eq (preceding-char) ?\^M)) - (progn - (save-excursion (show-children)) - (outline-sync-visible-sub-headings)) - ;; mess with single entry - (if (outline-hidden-p) - (progn - (save-excursion (show-entry)) - ;; reveal my twin and hide me - (annotation-hide annotation) - (annotation-reveal (annotation-data annotation)))))) - -(defun outline-fold-in (annotation) - "Fold in the current heading." - (beginning-of-line) - ;; mess with single entries - (if (not (outline-hidden-p)) - (progn - (save-excursion (hide-entry)) - (if (not (outline-more-to-hide)) - (annotation-hide annotation)) - (annotation-reveal (annotation-data annotation))) - ;; otherwise look for more leaves - (save-excursion - (if (outline-more-to-hide t) - (hide-subtree) - (hide-leaves))) - ;; sync everything - (outline-sync-visible-sub-headings))) - -(defun outline-more-to-hide (&optional arg) - "Return t if there are more visible sub-headings or text. -With ARG return t only if visible sub-headings have no visible text." - (if (not (outline-hidden-p)) - (if arg nil t) - (save-excursion - (and (< (funcall outline-level) (condition-case nil - (progn - (outline-next-visible-heading 1) - (funcall outline-level)) - (error 0))) - (if (and (not (outline-hidden-p)) arg) - nil t))))) - -(defun outline-hidden-p () - "Return t if point is on the header of a hidden subtree." - (save-excursion - (let ((end-of-entry (save-excursion (outline-next-heading)))) - ;; Make sure that the end of the entry really exists. - (if (not end-of-entry) - (setq end-of-entry (point-max))) - (outline-back-to-heading) - ;; If there are ANY ^M's, the entry is hidden. - (search-forward "\^M" end-of-entry t)))) - -(defun outline-next-visible-heading-safe () - "Safely go to the next visible heading. -nil is returned if there is none." - (condition-case nil - (progn - (outline-next-visible-heading 1) - t) - (error nil))) - -(defun outline-up-click (data ev) - "Annotation action for clicking on an up arrow. -DATA is the annotation data. EV is the mouse click event." - (save-excursion - (goto-char (extent-end-position (event-glyph-extent ev))) - (funcall outline-fold-in-function (event-glyph-extent ev))) - (if outline-move-point-after-click - (progn - (goto-char (extent-end-position (event-glyph-extent ev))) - (beginning-of-line)))) -; This line demonstrates a bug in redisplay -(defun outline-down-click (data ev) - "Annotation action for clicking on a down arrow. -DATA is the annotation data. EV is the mouse click event." - (save-excursion - (goto-char (extent-end-position (event-glyph-extent ev))) - (funcall outline-fold-out-function (event-glyph-extent ev))) - (if outline-move-point-after-click - (progn - (goto-char (extent-end-position (event-glyph-extent ev))) - (beginning-of-line)))) - - -(provide 'outl-mouse) -(provide 'outln-18) ; fool auctex - outline is ok now. - -;; Local Variables: -;; outline-regexp: ";;; \\|(def.." -;; End: - - - diff -r 43306a74e31c -r d44af0c54775 lisp/modes/outline.el --- a/lisp/modes/outline.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,645 +0,0 @@ -;;; outline.el --- outline mode commands for Emacs - -;; Copyright (C) 1986, 1993, 1994 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: outlines - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34. - -;;; Commentary: - -;; This package is a major mode for editing outline-format documents. -;; An outline can be `abstracted' to show headers at any given level, -;; with all stuff below hidden. See the Emacs manual for details. - -;;; Code: - -;; Jan '86, Some new features added by Peter Desnoyers and rewritten by RMS. - -(defvar outline-regexp nil - "*Regular expression to match the beginning of a heading. -Any line whose beginning matches this regexp is considered to start a heading. -The recommended way to set this is with a Local Variables: list -in the file it applies to. See also outline-heading-end-regexp.") - -;; Can't initialize this in the defvar above -- some major modes have -;; already assigned a local value to it. -(or (default-value 'outline-regexp) - (setq-default outline-regexp "[*\^L]+")) - -;; XEmacs change -(defvar outline-heading-end-regexp (purecopy "[\n\^M]") - "*Regular expression to match the end of a heading line. -You can assume that point is at the beginning of a heading when this -regexp is searched for. The heading ends at the end of the match. -The recommended way to set this is with a \"Local Variables:\" list -in the file it applies to.") - -;; XEmacs: There is no point in doing this differently now. -sb -(defvar outline-mode-prefix-map nil) - -(if outline-mode-prefix-map - nil - (setq outline-mode-prefix-map (make-sparse-keymap)) - (define-key outline-mode-prefix-map "\C-n" 'outline-next-visible-heading) - (define-key outline-mode-prefix-map "\C-p" 'outline-previous-visible-heading) - (define-key outline-mode-prefix-map "\C-i" 'show-children) - (define-key outline-mode-prefix-map "\C-s" 'show-subtree) - (define-key outline-mode-prefix-map "\C-d" 'hide-subtree) - (define-key outline-mode-prefix-map "\C-u" 'outline-up-heading) - (define-key outline-mode-prefix-map "\C-f" 'outline-forward-same-level) - (define-key outline-mode-prefix-map "\C-b" 'outline-backward-same-level) - (define-key outline-mode-prefix-map "\C-t" 'hide-body) - (define-key outline-mode-prefix-map "\C-a" 'show-all) - (define-key outline-mode-prefix-map "\C-c" 'hide-entry) - (define-key outline-mode-prefix-map "\C-e" 'show-entry) - (define-key outline-mode-prefix-map "\C-l" 'hide-leaves) - (define-key outline-mode-prefix-map "\C-k" 'show-branches) - (define-key outline-mode-prefix-map "\C-q" 'hide-sublevels) - (define-key outline-mode-prefix-map "\C-o" 'hide-other)) - -(defvar outline-mode-menu-bar-map nil) -(if outline-mode-menu-bar-map - nil - (setq outline-mode-menu-bar-map (make-sparse-keymap)) - - (define-key outline-mode-menu-bar-map [hide] - (cons "Hide" (make-sparse-keymap "Hide"))) - - (define-key outline-mode-menu-bar-map [hide hide-other] - '("Hide Other" . hide-other)) - (define-key outline-mode-menu-bar-map [hide hide-sublevels] - '("Hide Sublevels" . hide-sublevels)) - (define-key outline-mode-menu-bar-map [hide hide-subtree] - '("Hide Subtree" . hide-subtree)) - (define-key outline-mode-menu-bar-map [hide hide-entry] - '("Hide Entry" . hide-entry)) - (define-key outline-mode-menu-bar-map [hide hide-body] - '("Hide Body" . hide-body)) - (define-key outline-mode-menu-bar-map [hide hide-leaves] - '("Hide Leaves" . hide-leaves)) - - (define-key outline-mode-menu-bar-map [show] - (cons "Show" (make-sparse-keymap "Show"))) - - (define-key outline-mode-menu-bar-map [show show-subtree] - '("Show Subtree" . show-subtree)) - (define-key outline-mode-menu-bar-map [show show-children] - '("Show Children" . show-children)) - (define-key outline-mode-menu-bar-map [show show-branches] - '("Show Branches" . show-branches)) - (define-key outline-mode-menu-bar-map [show show-entry] - '("Show Entry" . show-entry)) - (define-key outline-mode-menu-bar-map [show show-all] - '("Show All" . show-all)) - - (define-key outline-mode-menu-bar-map [headings] - (cons "Headings" (make-sparse-keymap "Headings"))) - - (define-key outline-mode-menu-bar-map [headings outline-backward-same-level] - '("Previous Same Level" . outline-backward-same-level)) - (define-key outline-mode-menu-bar-map [headings outline-forward-same-level] - '("Next Same Level" . outline-forward-same-level)) - (define-key outline-mode-menu-bar-map [headings outline-previous-visible-heading] - '("Previous" . outline-previous-visible-heading)) - (define-key outline-mode-menu-bar-map [headings outline-next-visible-heading] - '("Next" . outline-next-visible-heading)) - (define-key outline-mode-menu-bar-map [headings outline-up-heading] - '("Up" . outline-up-heading))) - -(defvar outline-mode-map nil "") - -(if outline-mode-map - nil - ;; XEmacs change - ;(setq outline-mode-map (nconc (make-sparse-keymap) text-mode-map)) - (setq outline-mode-map (make-sparse-keymap 'text-mode-map)) - (define-key outline-mode-map "\C-c" outline-mode-prefix-map) - (define-key outline-mode-map [menu-bar] outline-mode-menu-bar-map)) - -;;; #+XEmacs -(defvar outline-mode-menu - ;; This is the RB menu which also makes 3 menus in the menubar (like - ;; FSF rather than because it's good) - '("Outline" - ("Headings" - ["Up" outline-up-heading t] - ["Next" outline-next-visible-heading t] - ["Previous" outline-previous-visible-heading t] - ["Next Same Level" outline-forward-same-level t] - ["Previous Same Level" outline-backward-same-level t]) - ("Show" - ["Show All" show-all t] - ["Show Entry" show-entry t] - ["Show Branches" show-branches t] - ["Show Children" show-children t] - ["Show Subtree" show-subtree t]) - ("Hide" - ["Hide Leaves" hide-leaves t] - ["Hide Body" hide-body t] - ["Hide Entry" hide-entry t] - ["Hide Subtree" hide-subtree t] - ["Hide Other" hide-other t] - ["Hide Sublevels" hide-sublevels t]))) - -;;; #+XEmacs -(defun outline-mode-menu () - (interactive) - (popup-menu outline-mode-menu)) - -;;; #+XEmacs -;;; ?? Is this OK & if so should it be in minor mode too? -(define-key outline-mode-map [button3] 'outline-mode-menu) - -;;; #+XEmacs -(defun outline-install-menubar (&optional remove) - ;; install or remove the outline menus - ;; This is a nop if menubars aren't available - (when (and (featurep 'menubar) ; XEmacs - current-menubar) - (let ((menus (cdr outline-mode-menu)) path) - (and (not remove) - (set-buffer-menubar (copy-sequence current-menubar))) - (while menus - (setq path (list (car (car menus)))) - (if (and remove (find-menu-item current-menubar path)) - (delete-menu-item path) - (or (car (find-menu-item current-menubar path)) - (add-menu nil (car (car menus)) (cdr (car menus)) nil))) - (setq menus (cdr menus)))))) - -;;;###autoload -(defvar outline-minor-mode nil - "Non-nil if using Outline mode as a minor mode of some other mode.") -;;;###autoload -(make-variable-buffer-local 'outline-minor-mode) -;;;###autoload -(put 'outline-minor-mode 'permanent-local t) -;(or (assq 'outline-minor-mode minor-mode-alist) -; (setq minor-mode-alist (append minor-mode-alist -; (list '(outline-minor-mode " Outl"))))) -;; XEmacs: do it right. -;;;###autoload -(add-minor-mode 'outline-minor-mode " Outl") - -(defvar outline-font-lock-keywords - '(;; Highlight headings according to the level. - ("^\\(\\*+\\)[ \t]*\\(.+\\)?[ \t]*$" - (1 font-lock-string-face) - (2 (let ((len (- (match-end 1) (match-beginning 1)))) - (or (cdr (assq len '((1 . font-lock-function-name-face) - (2 . font-lock-keyword-face) - (3 . font-lock-comment-face)))) - font-lock-variable-name-face)) - nil t)) - ;; Highlight citations of the form [1] and [Mar94]. - ("\\[\\([A-Z][A-Za-z]+\\)*[0-9]+\\]" . font-lock-type-face)) - "Additional expressions to highlight in Outline mode.") - -;;;###autoload -(defun outline-mode () - "Set major mode for editing outlines with selective display. -Headings are lines which start with asterisks: one for major headings, -two for subheadings, etc. Lines not starting with asterisks are body lines. - -Body text or subheadings under a heading can be made temporarily -invisible, or visible again. Invisible lines are attached to the end -of the heading, so they move with it, if the line is killed and yanked -back. A heading with text hidden under it is marked with an ellipsis (...). - -Commands:\\ -\\[outline-next-visible-heading] outline-next-visible-heading move by visible headings -\\[outline-previous-visible-heading] outline-previous-visible-heading -\\[outline-forward-same-level] outline-forward-same-level similar but skip subheadings -\\[outline-backward-same-level] outline-backward-same-level -\\[outline-up-heading] outline-up-heading move from subheading to heading - -\\[hide-body] make all text invisible (not headings). -\\[show-all] make everything in buffer visible. - -The remaining commands are used when point is on a heading line. -They apply to some of the body or subheadings of that heading. -\\[hide-subtree] hide-subtree make body and subheadings invisible. -\\[show-subtree] show-subtree make body and subheadings visible. -\\[show-children] show-children make direct subheadings visible. - No effect on body, or subheadings 2 or more levels down. - With arg N, affects subheadings N levels down. -\\[hide-entry] make immediately following body invisible. -\\[show-entry] make it visible. -\\[hide-leaves] make body under heading and under its subheadings invisible. - The subheadings remain visible. -\\[show-branches] make all subheadings at all levels visible. - -The variable `outline-regexp' can be changed to control what is a heading. -A line is a heading if `outline-regexp' matches something at the -beginning of the line. The longer the match, the deeper the level. - -Turning on outline mode calls the value of `text-mode-hook' and then of -`outline-mode-hook', if they are non-nil." - (interactive) - (kill-all-local-variables) - (setq selective-display t) - (use-local-map outline-mode-map) - (setq mode-name "Outline") - (setq major-mode 'outline-mode) - (define-abbrev-table 'text-mode-abbrev-table ()) - (setq local-abbrev-table text-mode-abbrev-table) - (set-syntax-table text-mode-syntax-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat paragraph-start "\\|\\(" - outline-regexp "\\)")) - ;; Inhibit auto-filling of header lines. - (make-local-variable 'auto-fill-inhibit-regexp) - (setq auto-fill-inhibit-regexp outline-regexp) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate (concat paragraph-separate "\\|\\(" - outline-regexp "\\)")) - ;; #+XEmacs - (outline-install-menubar) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(outline-font-lock-keywords t)) - (make-local-variable 'change-major-mode-hook) - (add-hook 'change-major-mode-hook 'show-all) - (run-hooks 'text-mode-hook 'outline-mode-hook)) - -(defvar outline-minor-mode-prefix "\C-c@" - "*Prefix key to use for Outline commands in Outline minor mode. -The value of this variable is checked as part of loading Outline mode. -After that, changing the prefix key requires manipulating keymaps.") - -(defvar outline-minor-mode-map nil) -(if outline-minor-mode-map - nil - (setq outline-minor-mode-map (make-sparse-keymap)) - (define-key outline-minor-mode-map [menu-bar] - outline-mode-menu-bar-map) - (define-key outline-minor-mode-map outline-minor-mode-prefix - outline-mode-prefix-map)) - -(or (assq 'outline-minor-mode minor-mode-map-alist) - (setq minor-mode-map-alist - (cons (cons 'outline-minor-mode outline-minor-mode-map) - minor-mode-map-alist))) - -;;;###autoload -(defun outline-minor-mode (&optional arg) - "Toggle Outline minor mode. -With arg, turn Outline minor mode on if arg is positive, off otherwise. -See the command `outline-mode' for more information on this mode." - (interactive "P") - (setq outline-minor-mode - (if (null arg) (not outline-minor-mode) - (> (prefix-numeric-value arg) 0))) - (if outline-minor-mode - (progn - (setq selective-display t) - ;; #+XEmacs - (outline-install-menubar) - (run-hooks 'outline-minor-mode-hook)) - (setq selective-display nil)) - ;; When turning off outline mode, get rid of any ^M's. - (unless outline-minor-mode - (outline-flag-region (point-min) (point-max) ?\n) - ;; XEmacs change - (set-buffer-modified-p (buffer-modified-p)) - ;; #+XEmacs - (outline-install-menubar 'remove)) - ;; XEmacs change - (redraw-modeline)) - -(defvar outline-level 'outline-level - "Function of no args to compute a header's nesting level in an outline. -It can assume point is at the beginning of a header line.") - -;; This used to count columns rather than characters, but that made ^L -;; appear to be at level 2 instead of 1. Columns would be better for -;; tab handling, but the default regexp doesn't use tabs, and anyone -;; who changes the regexp can also redefine the outline-level variable -;; as appropriate. -(defun outline-level () - "Return the depth to which a statement is nested in the outline. -Point must be at the beginning of a header line. This is actually -the number of characters that `outline-regexp' matches." - (save-excursion - (looking-at outline-regexp) - (- (match-end 0) (match-beginning 0)))) - -(defun outline-next-preface () - "Skip forward to just before the next heading line. -If there's no following heading line, stop before the newline -at the end of the buffer." - (if (re-search-forward (concat "[\n\^M]\\(" outline-regexp "\\)") - nil 'move) - (goto-char (match-beginning 0))) - (if (memq (preceding-char) '(?\n ?\^M)) - (forward-char -1))) - -(defun outline-next-heading () - "Move to the next (possibly invisible) heading line." - (interactive) - (if (re-search-forward (concat "[\n\^M]\\(" outline-regexp "\\)") - nil 'move) - (goto-char (1+ (match-beginning 0))))) - -(defun outline-back-to-heading () - "Move to previous heading line, or beg of this line if it's a heading. -Only visible heading lines are considered." - (beginning-of-line) - (or (outline-on-heading-p) - (re-search-backward (concat "^\\(" outline-regexp "\\)") nil t) - (error "before first heading"))) - -(defun outline-on-heading-p () - "Return t if point is on a (visible) heading line." - (save-excursion - (beginning-of-line) - (and (bolp) - (looking-at outline-regexp)))) - -(defun outline-end-of-heading () - (if (re-search-forward outline-heading-end-regexp nil 'move) - (forward-char -1))) - -(defun outline-next-visible-heading (arg) - "Move to the next visible heading line. -With argument, repeats or can move backward if negative. -A heading line is one that starts with a `*' (or that -`outline-regexp' matches)." - (interactive "p") - (if (< arg 0) - (beginning-of-line) - (end-of-line)) - (or (re-search-forward (concat "^\\(" outline-regexp "\\)") nil t arg) - (error "")) - (beginning-of-line)) - -(defun outline-previous-visible-heading (arg) - "Move to the previous heading line. -With argument, repeats or can move forward if negative. -A heading line is one that starts with a `*' (or that -`outline-regexp' matches)." - (interactive "p") - (outline-next-visible-heading (- arg))) - -(defun outline-flag-region (from to flag) - "Hides or shows lines from FROM to TO, according to FLAG. -If FLAG is `\\n' (newline character) then text is shown, -while if FLAG is `\\^M' (control-M) the text is hidden." - (let (buffer-read-only) - (subst-char-in-region from to - (if (= flag ?\n) ?\^M ?\n) - flag t))) - -(defun hide-entry () - "Hide the body directly following this heading." - (interactive) - (outline-back-to-heading) - (outline-end-of-heading) - (save-excursion - (outline-flag-region (point) (progn (outline-next-preface) (point)) ?\^M))) - -(defun show-entry () - "Show the body directly following this heading." - (interactive) - (save-excursion - (outline-flag-region (point) (progn (outline-next-preface) (point)) ?\n))) - -(defun hide-body () - "Hide all of buffer except headings." - (interactive) - (hide-region-body (point-min) (point-max))) - -(defun hide-region-body (start end) - "Hide all body lines in the region, but not headings." - (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char (point-min)) - (if (outline-on-heading-p) - (outline-end-of-heading)) - (while (not (eobp)) - (outline-flag-region (point) - (progn (outline-next-preface) (point)) ?\^M) - (if (not (eobp)) - (progn - (forward-char - (if (looking-at "[\n\^M][\n\^M]") - 2 1)) - (outline-end-of-heading))))))) - -(defun show-all () - "Show all of the text in the buffer." - (interactive) - (outline-flag-region (point-min) (point-max) ?\n)) - -(defun hide-subtree () - "Hide everything after this heading at deeper levels." - (interactive) - (outline-flag-subtree ?\^M)) - -(defun hide-leaves () - "Hide all body after this heading at deeper levels." - (interactive) - (outline-back-to-heading) - (outline-end-of-heading) - (hide-region-body (point) (progn (outline-end-of-subtree) (point)))) - -(defun show-subtree () - "Show everything after this heading at deeper levels." - (interactive) - (outline-flag-subtree ?\n)) - -(defun hide-sublevels (levels) - "Hide everything but the top LEVELS levels of headers, in whole buffer." - (interactive "p") - (if (< levels 1) - (error "Must keep at least one level of headers")) - (setq levels (1- levels)) - (save-excursion - (goto-char (point-min)) - ;; Keep advancing to the next top-level heading. - (while (or (and (bobp) (outline-on-heading-p)) - (outline-next-heading)) - (let ((end (save-excursion (outline-end-of-subtree) (point)))) - ;; Hide everything under that. - (outline-flag-region (point) end ?\^M) - ;; Show the first LEVELS levels under that. - (if (> levels 0) - (show-children levels)) - ;; Move to the next, since we already found it. - (goto-char end))))) - -(defun hide-other () - "Hide everything except for the current body and the parent headings." - (interactive) - (hide-sublevels 1) - (let ((last (point)) - (pos (point))) - (while (save-excursion - (and (re-search-backward "[\n\r]" nil t) - (eq (following-char) ?\r))) - (save-excursion - (beginning-of-line) - (if (eq last (point)) - (progn - (outline-next-heading) - (outline-flag-region last (point) ?\n)) - (show-children) - (setq last (point))))))) - -(defun outline-flag-subtree (flag) - (save-excursion - (outline-back-to-heading) - (outline-end-of-heading) - (outline-flag-region (point) - (progn (outline-end-of-subtree) (point)) - flag))) - -(defun outline-end-of-subtree () - (outline-back-to-heading) - (let ((opoint (point)) - (first t) - (level (funcall outline-level))) - (while (and (not (eobp)) - (or first (> (funcall outline-level) level))) - (setq first nil) - (outline-next-heading)) - (if (memq (preceding-char) '(?\n ?\^M)) - (progn - ;; Go to end of line before heading - (forward-char -1) - (if (memq (preceding-char) '(?\n ?\^M)) - ;; leave blank line before heading - (forward-char -1)))))) - -(defun show-branches () - "Show all subheadings of this heading, but not their bodies." - (interactive) - (show-children 1000)) - -(defun show-children (&optional level) - "Show all direct subheadings of this heading. -Prefix arg LEVEL is how many levels below the current level should be shown. -Default is enough to cause the following heading to appear." - (interactive "P") - (setq level - (if level (prefix-numeric-value level) - (save-excursion - (outline-back-to-heading) - (let ((start-level (funcall outline-level))) - (outline-next-heading) - (if (eobp) - 1 - (max 1 (- (funcall outline-level) start-level))))))) - (save-excursion - (save-restriction - (outline-back-to-heading) - (setq level (+ level (funcall outline-level))) - (narrow-to-region (point) - (progn (outline-end-of-subtree) - (if (eobp) (point-max) (1+ (point))))) - (goto-char (point-min)) - (while (and (not (eobp)) - (progn - (outline-next-heading) - (not (eobp)))) - (if (<= (funcall outline-level) level) - (save-excursion - (outline-flag-region (save-excursion - (forward-char -1) - (if (memq (preceding-char) '(?\n ?\^M)) - (forward-char -1)) - (point)) - (progn (outline-end-of-heading) (point)) - ?\n))))))) - -(defun outline-up-heading (arg) - "Move to the heading line of which the present line is a subheading. -With argument, move up ARG levels." - (interactive "p") - (outline-back-to-heading) - (if (eq (funcall outline-level) 1) - (error "")) - (while (and (> (funcall outline-level) 1) - (> arg 0) - (not (bobp))) - (let ((present-level (funcall outline-level))) - (while (not (< (funcall outline-level) present-level)) - (outline-previous-visible-heading 1)) - (setq arg (- arg 1))))) - -(defun outline-forward-same-level (arg) - "Move forward to the ARG'th subheading at same level as this one. -Stop at the first and last subheadings of a superior heading." - (interactive "p") - (outline-back-to-heading) - (while (> arg 0) - (let ((point-to-move-to (save-excursion - (outline-get-next-sibling)))) - (if point-to-move-to - (progn - (goto-char point-to-move-to) - (setq arg (1- arg))) - (progn - (setq arg 0) - (error "")))))) - -(defun outline-get-next-sibling () - "Move to next heading of the same level, and return point or nil if none." - (let ((level (funcall outline-level))) - (outline-next-visible-heading 1) - (while (and (> (funcall outline-level) level) - (not (eobp))) - (outline-next-visible-heading 1)) - (if (< (funcall outline-level) level) - nil - (point)))) - -(defun outline-backward-same-level (arg) - "Move backward to the ARG'th subheading at same level as this one. -Stop at the first and last subheadings of a superior heading." - (interactive "p") - (outline-back-to-heading) - (while (> arg 0) - (let ((point-to-move-to (save-excursion - (outline-get-last-sibling)))) - (if point-to-move-to - (progn - (goto-char point-to-move-to) - (setq arg (1- arg))) - (progn - (setq arg 0) - (error "")))))) - -(defun outline-get-last-sibling () - "Move to next heading of the same level, and return point or nil if none." - (let ((level (funcall outline-level))) - (outline-previous-visible-heading 1) - (while (and (> (funcall outline-level) level) - (not (bobp))) - (outline-previous-visible-heading 1)) - (if (< (funcall outline-level) level) - nil - (point)))) - -(provide 'outline) - -;;; outline.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/pascal.el --- a/lisp/modes/pascal.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1594 +0,0 @@ -;;; pascal.el --- major mode for editing pascal source in Emacs - -;; Copyright (C) 1993, 1994, 1995, 1996, 1997 Free Software Foundation, Inc. - -;; Author: Espen Skoglund (espensk@stud.cs.uit.no) -;; Keywords: languages - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: FSF 19.34 - -;;; Commentary: - -;; USAGE -;; ===== - -;; Emacs should enter Pascal mode when you find a Pascal source file. -;; When you have entered Pascal mode, you may get more info by pressing -;; C-h m. You may also get online help describing various functions by: -;; C-h f - -;; If you want to customize Pascal mode to fit you better, you may add -;; these lines (the values of the variables presented here are the defaults): -;; -;; ;; User customization for Pascal mode -;; (setq pascal-indent-level 3 -;; pascal-case-indent 2 -;; pascal-auto-newline nil -;; pascal-tab-always-indent t -;; pascal-auto-endcomments t -;; pascal-auto-lineup '(all) -;; pascal-toggle-completions nil -;; pascal-type-keywords '("array" "file" "packed" "char" -;; "integer" "real" "string" "record") -;; pascal-start-keywords '("begin" "end" "function" "procedure" -;; "repeat" "until" "while" "read" "readln" -;; "reset" "rewrite" "write" "writeln") -;; pascal-separator-keywords '("downto" "else" "mod" "div" "then")) - -;; KNOWN BUGS / BUGREPORTS -;; ======================= -;; As far as I know, there are no bugs in the current version of this -;; package. This may not be true however, since I never use this mode -;; myself and therefore would never notice them anyway. If you do -;; find any bugs, you may submit them to: espensk@stud.cs.uit.no -;; as well as to bug-gnu-emacs@prep.ai.mit.edu. - -;;; Code: - -(defconst pascal-mode-version "2.5" - "Version of `pascal.el'.") - -(defgroup pascal nil - "Major mode for editing Pascal source in Emacs" - :group 'languages) - -(defvar pascal-mode-abbrev-table nil - "Abbrev table in use in Pascal-mode buffers.") -(define-abbrev-table 'pascal-mode-abbrev-table ()) - -(defvar pascal-mode-map () - "Keymap used in Pascal mode.") -(if pascal-mode-map - () - (setq pascal-mode-map (make-sparse-keymap)) - (define-key pascal-mode-map ";" 'electric-pascal-semi-or-dot) - (define-key pascal-mode-map "." 'electric-pascal-semi-or-dot) - (define-key pascal-mode-map ":" 'electric-pascal-colon) - (define-key pascal-mode-map "=" 'electric-pascal-equal) - (define-key pascal-mode-map "#" 'electric-pascal-hash) - (define-key pascal-mode-map "\r" 'electric-pascal-terminate-line) - (define-key pascal-mode-map "\t" 'electric-pascal-tab) - (define-key pascal-mode-map "\M-\t" 'pascal-complete-word) - (define-key pascal-mode-map "\M-?" 'pascal-show-completions) - (define-key pascal-mode-map "\M-\C-h" 'pascal-mark-defun) - (define-key pascal-mode-map "\C-c\C-b" 'pascal-insert-block) - (define-key pascal-mode-map "\M-*" 'pascal-star-comment) - (define-key pascal-mode-map "\C-c\C-c" 'pascal-comment-area) - (define-key pascal-mode-map "\C-c\C-u" 'pascal-uncomment-area) - (define-key pascal-mode-map "\M-\C-a" 'pascal-beg-of-defun) - (define-key pascal-mode-map "\M-\C-e" 'pascal-end-of-defun) - (define-key pascal-mode-map "\C-c\C-d" 'pascal-goto-defun) - (define-key pascal-mode-map "\C-c\C-o" 'pascal-outline) -;;; A command to change the whole buffer won't be used terribly -;;; often, so no need for a key binding. -; (define-key pascal-mode-map "\C-cd" 'pascal-downcase-keywords) -; (define-key pascal-mode-map "\C-cu" 'pascal-upcase-keywords) -; (define-key pascal-mode-map "\C-cc" 'pascal-capitalize-keywords) - ) - -(defvar pascal-imenu-generic-expression - '("^[ \t]*\\(function\\|procedure\\)[ \t\n]+\\([a-zA-Z0-9_.:]+\\)" . (2)) - "Imenu expression for Pascal-mode. See `imenu-generic-expression'.") - -(defvar pascal-keywords - '("and" "array" "begin" "case" "const" "div" "do" "downto" "else" "end" - "file" "for" "function" "goto" "if" "in" "label" "mod" "nil" "not" "of" - "or" "packed" "procedure" "program" "record" "repeat" "set" "then" "to" - "type" "until" "var" "while" "with" - ;; The following are not standard in pascal, but widely used. - "get" "put" "input" "output" "read" "readln" "reset" "rewrite" "write" - "writeln")) - -;;; -;;; Regular expressions used to calculate indent, etc. -;;; -(defconst pascal-symbol-re "\\<[a-zA-Z_][a-zA-Z_0-9.]*\\>") -(defconst pascal-beg-block-re "\\<\\(begin\\|case\\|record\\|repeat\\)\\>") -(defconst pascal-end-block-re "\\<\\(end\\|until\\)\\>") -(defconst pascal-declaration-re "\\<\\(const\\|label\\|type\\|var\\)\\>") -(defconst pascal-defun-re "\\<\\(function\\|procedure\\|program\\)\\>") -(defconst pascal-sub-block-re "\\<\\(if\\|else\\|for\\|while\\|with\\)\\>") -(defconst pascal-noindent-re "\\<\\(begin\\|end\\|until\\|else\\)\\>") -(defconst pascal-nosemi-re "\\<\\(begin\\|repeat\\|then\\|do\\|else\\)\\>") -(defconst pascal-autoindent-lines-re - "\\<\\(label\\|var\\|type\\|const\\|until\\|end\\|begin\\|repeat\\|else\\)\\>") - -;;; Strings used to mark beginning and end of excluded text -(defconst pascal-exclude-str-start "{-----\\/----- EXCLUDED -----\\/-----") -(defconst pascal-exclude-str-end " -----/\\----- EXCLUDED -----/\\-----}") - -(defvar pascal-mode-syntax-table nil - "Syntax table in use in Pascal-mode buffers.") - -(if pascal-mode-syntax-table - () - (setq pascal-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\\ "." pascal-mode-syntax-table) - (modify-syntax-entry ?( "()1" pascal-mode-syntax-table) - (modify-syntax-entry ?) ")(4" pascal-mode-syntax-table) - (modify-syntax-entry ?* ". 23" pascal-mode-syntax-table) - (modify-syntax-entry ?{ "<" pascal-mode-syntax-table) - (modify-syntax-entry ?} ">" pascal-mode-syntax-table) - (modify-syntax-entry ?+ "." pascal-mode-syntax-table) - (modify-syntax-entry ?- "." pascal-mode-syntax-table) - (modify-syntax-entry ?= "." pascal-mode-syntax-table) - (modify-syntax-entry ?% "." pascal-mode-syntax-table) - (modify-syntax-entry ?< "." pascal-mode-syntax-table) - (modify-syntax-entry ?> "." pascal-mode-syntax-table) - (modify-syntax-entry ?& "." pascal-mode-syntax-table) - (modify-syntax-entry ?| "." pascal-mode-syntax-table) - (modify-syntax-entry ?_ "_" pascal-mode-syntax-table) - (modify-syntax-entry ?\' "\"" pascal-mode-syntax-table)) - -(defvar pascal-font-lock-keywords (purecopy - (list - '("^[ \t]*\\(function\\|pro\\(cedure\\|gram\\)\\)\\>[ \t]*\\(\\[a-z]\\)?" - 1 font-lock-keyword-face) - '("^[ \t]*\\(function\\|pro\\(cedure\\|gram\\)\\)\\>[ \t]*\\([a-z][a-z0-9_]*\\)" - 3 font-lock-function-name-face t) -; ("type" "const" "real" "integer" "char" "boolean" "var" -; "record" "array" "file") - (cons (concat "\\<\\(array\\|boolean\\|c\\(har\\|onst\\)\\|file\\|" - "integer\\|re\\(al\\|cord\\)\\|type\\|var\\)\\>") - 'font-lock-type-face) - '("\\<\\(label\\|external\\|forward\\)\\>" . font-lock-reference-face) - '("\\<\\([0-9]+\\)[ \t]*:" 1 font-lock-function-name-face) -; ("of" "to" "for" "if" "then" "else" "case" "while" -; "do" "until" "and" "or" "not" "in" "with" "repeat" "begin" "end") - (concat "\\<\\(" - "and\\|begin\\|case\\|do\\|e\\(lse\\|nd\\)\\|for\\|i[fn]\\|" - "not\\|o[fr]\\|repeat\\|t\\(hen\\|o\\)\\|until\\|w\\(hile\\|ith\\)" - "\\)\\>") - '("\\<\\(goto\\)\\>[ \t]*\\([0-9]+\\)?" - 1 font-lock-keyword-face) - '("\\<\\(goto\\)\\>[ \t]*\\([0-9]+\\)?" - 2 font-lock-keyword-face nil t))) - "Additional expressions to highlight in Pascal mode.") -(put 'pascal-mode 'font-lock-defaults '(pascal-font-lock-keywords nil t)) - -(defcustom pascal-indent-level 3 - "*Indentation of Pascal statements with respect to containing block." - :type 'integer - :group 'pascal) - -(defcustom pascal-case-indent 2 - "*Indentation for case statements." - :type 'integer - :group 'pascal) - -(defcustom pascal-auto-newline nil - "*Non-nil means automatically newline after semicolons and the punctuation -mark after an end." - :type 'boolean - :group 'pascal) - -(defcustom pascal-tab-always-indent t - "*Non-nil means TAB in Pascal mode should always reindent the current line, -regardless of where in the line point is when the TAB command is used." - :type 'boolean - :group 'pascal) - -(defcustom pascal-auto-endcomments t - "*Non-nil means a comment { ... } is set after the ends which ends cases and -functions. The name of the function or case will be set between the braces." - :type 'boolean - :group 'pascal) - -(defcustom pascal-auto-lineup '(all) - "*List of contexts where auto lineup of :'s or ='s should be done. -Elements can be of type: 'paramlist', 'declaration' or 'case', which will -do auto lineup in parameterlist, declarations or case-statements -respectively. The word 'all' will do all lineups. '(case paramlist) for -instance will do lineup in case-statements and parameterlist, while '(all) -will do all lineups." - :type '(repeat (choice (const all) - (const paramlist) - (const declaration) - (const case))) - :group 'pascal) - -(defcustom pascal-toggle-completions nil - "*Non-nil means that repeated use of \ -\\\\[pascal-complete-word] will toggle the possible -completions in the minibuffer. Normally, when there is more than one possible -completion, a buffer will display all completions." - :type 'boolean - :group 'pascal) - -(defcustom pascal-type-keywords - '("array" "file" "packed" "char" "integer" "real" "string" "record") - "*Keywords for types used when completing a word in a declaration or parmlist. -\(eg. integer, real, char.) The types defined within the Pascal program -will be completed runtime, and should not be added to this list." - :type '(repeat (string :tag "Keyword")) - :group 'pascal) - -(defcustom pascal-start-keywords - '("begin" "end" "function" "procedure" "repeat" "until" "while" - "read" "readln" "reset" "rewrite" "write" "writeln") - "*Keywords to complete when standing at the first word of a statement. -\(eg. begin, repeat, until, readln.) -The procedures and variables defined within the Pascal program -will be completed runtime and should not be added to this list." - :type '(repeat (string :tag "Keyword")) - :group 'pascal) - -(defcustom pascal-separator-keywords - '("downto" "else" "mod" "div" "then") - "*Keywords to complete when NOT standing at the first word of a statement. -\(eg. downto, else, mod, then.) -Variables and function names defined within the -Pascal program are completed runtime and should not be added to this list." - :type '(repeat (string :tag "Keyword")) - :group 'pascal) - -;;; -;;; Macros -;;; - -(defsubst pascal-get-beg-of-line (&optional arg) - (save-excursion - (beginning-of-line arg) - (point))) - -(defsubst pascal-get-end-of-line (&optional arg) - (save-excursion - (end-of-line arg) - (point))) - -(defun pascal-declaration-end () - (let ((nest 1)) - (while (and (> nest 0) - (re-search-forward - "[:=]\\|\\(\\\\)\\|\\(\\\\)" - (save-excursion (end-of-line 2) (point)) t)) - (cond ((match-beginning 1) (setq nest (1+ nest))) - ((match-beginning 2) (setq nest (1- nest))) - ((looking-at "[^(\n]+)") (setq nest 0)))))) - - -(defun pascal-declaration-beg () - (let ((nest 1)) - (while (and (> nest 0) - (re-search-backward "[:=]\\|\\<\\(type\\|var\\|label\\|const\\)\\>\\|\\(\\\\)\\|\\(\\\\)" (pascal-get-beg-of-line 0) t)) - (cond ((match-beginning 1) (setq nest 0)) - ((match-beginning 2) (setq nest (1- nest))) - ((match-beginning 3) (setq nest (1+ nest))))) - (= nest 0))) - - -(defsubst pascal-within-string () - (save-excursion - (nth 3 (parse-partial-sexp (pascal-get-beg-of-line) (point))))) - - -;;;###autoload -(defun pascal-mode () - "Major mode for editing Pascal code. \\ -TAB indents for Pascal code. Delete converts tabs to spaces as it moves back. - -\\[pascal-complete-word] completes the word around current point with respect \ -to position in code -\\[pascal-show-completions] shows all possible completions at this point. - -Other useful functions are: - -\\[pascal-mark-defun]\t- Mark function. -\\[pascal-insert-block]\t- insert begin ... end; -\\[pascal-star-comment]\t- insert (* ... *) -\\[pascal-comment-area]\t- Put marked area in a comment, fixing nested comments. -\\[pascal-uncomment-area]\t- Uncomment an area commented with \ -\\[pascal-comment-area]. -\\[pascal-beg-of-defun]\t- Move to beginning of current function. -\\[pascal-end-of-defun]\t- Move to end of current function. -\\[pascal-goto-defun]\t- Goto function prompted for in the minibuffer. -\\[pascal-outline]\t- Enter pascal-outline-mode (see also pascal-outline). - -Variables controlling indentation/edit style: - - pascal-indent-level (default 3) - Indentation of Pascal statements with respect to containing block. - pascal-case-indent (default 2) - Indentation for case statements. - pascal-auto-newline (default nil) - Non-nil means automatically newline after semicolons and the punctuation - mark after an end. - pascal-tab-always-indent (default t) - Non-nil means TAB in Pascal mode should always reindent the current line, - regardless of where in the line point is when the TAB command is used. - pascal-auto-endcomments (default t) - Non-nil means a comment { ... } is set after the ends which ends cases and - functions. The name of the function or case will be set between the braces. - pascal-auto-lineup (default t) - List of contexts where auto lineup of :'s or ='s should be done. - -See also the user variables pascal-type-keywords, pascal-start-keywords and -pascal-separator-keywords. - -Turning on Pascal mode calls the value of the variable pascal-mode-hook with -no args, if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map pascal-mode-map) - (setq major-mode 'pascal-mode) - (setq mode-name "Pascal") - (setq local-abbrev-table pascal-mode-abbrev-table) - (set-syntax-table pascal-mode-syntax-table) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'pascal-indent-line) - (setq comment-indent-function 'pascal-indent-comment) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments nil) - (make-local-variable 'case-fold-search) - (setq case-fold-search t) - (make-local-variable 'comment-start) - (setq comment-start "{") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "(\\*+ *\\|{ *") - (make-local-variable 'comment-end) - (setq comment-end "}") - ;; Font lock support - ;(make-local-variable 'font-lock-defaults) - ;(setq font-lock-defaults '(pascal-font-lock-keywords nil t)) - ;; Imenu support - (make-local-variable 'imenu-generic-expression) - (setq imenu-generic-expression pascal-imenu-generic-expression) - (run-hooks 'pascal-mode-hook)) - - - -;;; -;;; Electric functions -;;; -(defun electric-pascal-terminate-line () - "Terminate line and indent next line." - (interactive) - ;; First, check if current line should be indented - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (if (looking-at pascal-autoindent-lines-re) - (pascal-indent-line))) - (delete-horizontal-space) ; Removes trailing whitespaces - (newline) - ;; Indent next line - (pascal-indent-line) - ;; Maybe we should set some endcomments - (if pascal-auto-endcomments - (pascal-set-auto-comments)) - ;; Check if we shall indent inside comment - (let ((setstar nil)) - (save-excursion - (forward-line -1) - (skip-chars-forward " \t") - (cond ((looking-at "\\*[ \t]+)") - ;; Delete region between `*' and `)' if there is only whitespaces. - (forward-char 1) - (delete-horizontal-space)) - ((and (looking-at "(\\*\\|\\*[^)]") - (not (save-excursion - (search-forward "*)" (pascal-get-end-of-line) t)))) - (setq setstar t)))) - ;; If last line was a star comment line then this one shall be too. - (if (null setstar) - (pascal-indent-line) - (insert "* ")))) - - -(defun electric-pascal-semi-or-dot () - "Insert `;' or `.' character and reindent the line." - (interactive) - (insert last-command-char) - (save-excursion - (beginning-of-line) - (pascal-indent-line)) - (if pascal-auto-newline - (electric-pascal-terminate-line))) - -(defun electric-pascal-colon () - "Insert `:' and do all indentions except line indent on this line." - (interactive) - (insert last-command-char) - ;; Do nothing if within string. - (if (pascal-within-string) - () - (save-excursion - (beginning-of-line) - (pascal-indent-line)) - (let ((pascal-tab-always-indent nil)) - (pascal-indent-command)))) - -(defun electric-pascal-equal () - "Insert `=', and do indention if within type declaration." - (interactive) - (insert last-command-char) - (if (eq (car (pascal-calculate-indent)) 'declaration) - (let ((pascal-tab-always-indent nil)) - (pascal-indent-command)))) - -(defun electric-pascal-hash () - "Insert `#', and indent to column 0 if this is a CPP directive." - (interactive) - (insert last-command-char) - (if (save-excursion (beginning-of-line) (looking-at "^[ \t]*#")) - (save-excursion (beginning-of-line) - (delete-horizontal-space)))) - -(defun electric-pascal-tab () - "Function called when TAB is pressed in Pascal mode." - (interactive) - ;; Do nothing if within a string or in a CPP directive. - (if (or (pascal-within-string) - (and (not (bolp)) - (save-excursion (beginning-of-line) (eq (following-char) ?#)))) - (insert "\t") - ;; If pascal-tab-always-indent, indent the beginning of the line. - (if pascal-tab-always-indent - (save-excursion - (beginning-of-line) - (pascal-indent-line)) - (if (save-excursion - (skip-chars-backward " \t") - (bolp)) - (pascal-indent-line) - (insert "\t"))) - (pascal-indent-command))) - - - -;;; -;;; Interactive functions -;;; -(defun pascal-insert-block () - "Insert Pascal begin ... end; block in the code with right indentation." - (interactive) - (pascal-indent-line) - (insert "begin") - (electric-pascal-terminate-line) - (save-excursion - (electric-pascal-terminate-line) - (insert "end;") - (beginning-of-line) - (pascal-indent-line))) - -(defun pascal-star-comment () - "Insert Pascal star comment at point." - (interactive) - (pascal-indent-line) - (insert "(*") - (electric-pascal-terminate-line) - (save-excursion - (electric-pascal-terminate-line) - (delete-horizontal-space) - (insert ")")) - (insert " ")) - -(defun pascal-mark-defun () - "Mark the current pascal function (or procedure). -This puts the mark at the end, and point at the beginning." - (interactive) - (push-mark (point)) - (pascal-end-of-defun) - (push-mark (point)) - (pascal-beg-of-defun) - (if (fboundp 'zmacs-activate-region) - (zmacs-activate-region))) - -(defun pascal-comment-area (start end) - "Put the region into a Pascal comment. -The comments that are in this area are \"deformed\": -`*)' becomes `!(*' and `}' becomes `!{'. -These deformed comments are returned to normal if you use -\\[pascal-uncomment-area] to undo the commenting. - -The commented area starts with `pascal-exclude-str-start', and ends with -`pascal-include-str-end'. But if you change these variables, -\\[pascal-uncomment-area] won't recognize the comments." - (interactive "r") - (save-excursion - ;; Insert start and endcomments - (goto-char end) - (if (and (save-excursion (skip-chars-forward " \t") (eolp)) - (not (save-excursion (skip-chars-backward " \t") (bolp)))) - (forward-line 1) - (beginning-of-line)) - (insert pascal-exclude-str-end) - (setq end (point)) - (newline) - (goto-char start) - (beginning-of-line) - (insert pascal-exclude-str-start) - (newline) - ;; Replace end-comments within commented area - (goto-char end) - (save-excursion - (while (re-search-backward "\\*)" start t) - (replace-match "!(*" t t))) - (save-excursion - (while (re-search-backward "}" start t) - (replace-match "!{" t t))))) - -(defun pascal-uncomment-area () - "Uncomment a commented area; change deformed comments back to normal. -This command does nothing if the pointer is not in a commented -area. See also `pascal-comment-area'." - (interactive) - (save-excursion - (let ((start (point)) - (end (point))) - ;; Find the boundaries of the comment - (save-excursion - (setq start (progn (search-backward pascal-exclude-str-start nil t) - (point))) - (setq end (progn (search-forward pascal-exclude-str-end nil t) - (point)))) - ;; Check if we're really inside a comment - (if (or (equal start (point)) (<= end (point))) - (message "Not standing within commented area.") - (progn - ;; Remove endcomment - (goto-char end) - (beginning-of-line) - (let ((pos (point))) - (end-of-line) - (delete-region pos (1+ (point)))) - ;; Change comments back to normal - (save-excursion - (while (re-search-backward "!{" start t) - (replace-match "}" t t))) - (save-excursion - (while (re-search-backward "!(\\*" start t) - (replace-match "*)" t t))) - ;; Remove startcomment - (goto-char start) - (beginning-of-line) - (let ((pos (point))) - (end-of-line) - (delete-region pos (1+ (point))))))))) - -(defun pascal-beg-of-defun () - "Move backward to the beginning of the current function or procedure." - (interactive) - (catch 'found - (if (not (looking-at (concat "\\s \\|\\s)\\|" pascal-defun-re))) - (forward-sexp 1)) - (let ((nest 0) (max -1) (func 0) - (reg (concat pascal-beg-block-re "\\|" - pascal-end-block-re "\\|" - pascal-defun-re))) - (while (re-search-backward reg nil 'move) - (cond ((let ((state (save-excursion - (parse-partial-sexp (point-min) (point))))) - (or (nth 3 state) (nth 4 state))) ; Inside string or comment - ()) - ((match-end 1) ; begin|case|record|repeat - (if (and (looking-at "\\") (>= max 0)) - (setq func (1- func))) - (setq nest (1+ nest) - max (max nest max))) - ((match-end 2) ; end|until - (if (and (= nest max) (>= max 0)) - (setq func (1+ func))) - (setq nest (1- nest))) - ((match-end 3) ; function|procedure - (if (= 0 func) - (throw 'found t) - (setq func (1- func))))))) - nil)) - -(defun pascal-end-of-defun () - "Move forward to the end of the current function or procedure." - (interactive) - (if (looking-at "\\s ") - (forward-sexp 1)) - (if (not (looking-at pascal-defun-re)) - (pascal-beg-of-defun)) - (forward-char 1) - (let ((nest 0) (func 1) - (reg (concat pascal-beg-block-re "\\|" - pascal-end-block-re "\\|" - pascal-defun-re))) - (while (and (/= func 0) - (re-search-forward reg nil 'move)) - (cond ((let ((state (save-excursion - (parse-partial-sexp (point-min) (point))))) - (or (nth 3 state) (nth 4 state))) ; Inside string or comment - ()) - ((match-end 1) - (setq nest (1+ nest)) - (if (save-excursion - (goto-char (match-beginning 0)) - (looking-at "\\")) - (setq func (1+ func)))) - ((match-end 2) - (setq nest (1- nest)) - (if (= nest 0) - (setq func (1- func)))) - ((match-end 3) - (setq func (1+ func)))))) - (forward-line 1)) - -(defun pascal-end-of-statement () - "Move forward to end of current statement." - (interactive) - (let ((parse-sexp-ignore-comments t) - (nest 0) pos - (regexp (concat "\\(" pascal-beg-block-re "\\)\\|\\(" - pascal-end-block-re "\\)"))) - (if (not (looking-at "[ \t\n]")) (forward-sexp -1)) - (or (looking-at pascal-beg-block-re) - ;; Skip to end of statement - (setq pos (catch 'found - (while t - (forward-sexp 1) - (cond ((looking-at "[ \t]*;") - (skip-chars-forward "^;") - (forward-char 1) - (throw 'found (point))) - ((save-excursion - (forward-sexp -1) - (looking-at pascal-beg-block-re)) - (goto-char (match-beginning 0)) - (throw 'found nil)) - ((eobp) - (throw 'found (point)))))))) - (if (not pos) - ;; Skip a whole block - (catch 'found - (while t - (re-search-forward regexp nil 'move) - (setq nest (if (match-end 1) - (1+ nest) - (1- nest))) - (cond ((eobp) - (throw 'found (point))) - ((= 0 nest) - (throw 'found (pascal-end-of-statement)))))) - pos))) - -(defun pascal-downcase-keywords () - "Downcase all Pascal keywords in the buffer." - (interactive) - (pascal-change-keywords 'downcase-word)) - -(defun pascal-upcase-keywords () - "Upcase all Pascal keywords in the buffer." - (interactive) - (pascal-change-keywords 'upcase-word)) - -(defun pascal-capitalize-keywords () - "Capitalize all Pascal keywords in the buffer." - (interactive) - (pascal-change-keywords 'capitalize-word)) - -;; Change the keywords according to argument. -(defun pascal-change-keywords (change-word) - (save-excursion - (let ((keyword-re (concat "\\<\\(" - (mapconcat 'identity pascal-keywords "\\|") - "\\)\\>"))) - (goto-char (point-min)) - (while (re-search-forward keyword-re nil t) - (funcall change-word -1))))) - - - -;;; -;;; Other functions -;;; -(defun pascal-set-auto-comments () - "Insert `{ case }' or `{ NAME }' on this line if appropriate. -Insert `{ case }' if there is an `end' on the line which -ends a case block. Insert `{ NAME }' if there is an `end' -on the line which ends a function or procedure named NAME." - (save-excursion - (forward-line -1) - (skip-chars-forward " \t") - (if (and (looking-at "\\")) - (elsed (looking-at "[ \t]*else\\>")) - (type (catch 'nesting - ;; Check if inside a string, comment or parenthesis - (cond ((nth 3 state) (throw 'nesting 'string)) - ((nth 4 state) (throw 'nesting 'comment)) - ((> (car state) 0) - (goto-char (scan-lists (point) -1 (car state))) - (setq par (1+ (current-column)))) - ((save-excursion (beginning-of-line) - (eq (following-char) ?#)) - (throw 'nesting 'cpp))) - ;; Loop until correct indent is found - (while t - (backward-sexp 1) - (cond (;--Escape from case statements - (and (looking-at "[A-Za-z0-9]+[ \t]*:[^=]") - (not complete) - (save-excursion (skip-chars-backward " \t") - (bolp)) - (= (save-excursion - (end-of-line) (backward-sexp) (point)) - (point)) - (> (save-excursion (goto-char oldpos) - (beginning-of-line) - (point)) - (point))) - (throw 'nesting 'caseblock)) - (;--Nest block outwards - (looking-at pascal-beg-block-re) - (if (= nest 0) - (cond ((looking-at "case\\>") - (throw 'nesting 'case)) - ((looking-at "record\\>") - (throw 'nesting 'declaration)) - (t (throw 'nesting 'block))) - (setq nest (1- nest)))) - (;--Nest block inwards - (looking-at pascal-end-block-re) - (if (and (looking-at "end\\s ") - elsed (not complete)) - (throw 'nesting 'block)) - (setq complete t - nest (1+ nest))) - (;--Defun (or parameter list) - (looking-at pascal-defun-re) - (if (= 0 par) - (throw 'nesting 'defun) - (setq par 0) - (let ((n 0)) - (while (re-search-forward - "\\(\\\\)\\|\\" - oldpos t) - (if (match-end 1) - (setq n (1+ n)) (setq n (1- n)))) - (if (> n 0) - (throw 'nesting 'declaration) - (throw 'nesting 'paramlist))))) - (;--Declaration part - (looking-at pascal-declaration-re) - (if (save-excursion - (goto-char oldpos) - (forward-line -1) - (looking-at "^[ \t]*$")) - (throw 'nesting 'unknown) - (throw 'nesting 'declaration))) - (;--If, else or while statement - (and (not complete) - (looking-at pascal-sub-block-re)) - (throw 'nesting 'block)) - (;--Found complete statement - (save-excursion (forward-sexp 1) - (= (following-char) ?\;)) - (setq complete t)) - (;--No known statements - (bobp) - (throw 'nesting 'unknown)) - ))))) - - ;; Return type of block and indent level. - (if (> par 0) ; Unclosed Parenthesis - (list 'contexp par) - (list type (pascal-indent-level)))))) - -(defun pascal-indent-level () - "Return the indent-level the current statement has. -Do not count labels, case-statements or records." - (save-excursion - (beginning-of-line) - (if (looking-at "[ \t]*[0-9a-zA-Z]+[ \t]*:[^=]") - (search-forward ":" nil t) - (if (looking-at ".*=[ \t]*record\\>") - (search-forward "=" nil t))) - (skip-chars-forward " \t") - (current-column))) - -(defun pascal-indent-comment (&optional arg) - "Indent current line as comment. -If optional arg is non-nil, just return the -column number the line should be indented to." - (let* ((stcol (save-excursion - (re-search-backward "(\\*\\|{" nil t) - (1+ (current-column))))) - (if arg stcol - (delete-horizontal-space) - (indent-to stcol)))) - -(defun pascal-indent-case () - "Indent within case statements." - (let ((savepos (point-marker)) - (end (prog2 - (end-of-line) - (point-marker) - (re-search-backward "\\" nil t))) - (beg (point)) oldpos - (ind 0)) - ;; Get right indent - (while (< (point) end) - (if (re-search-forward - "^[ \t]*[^ \t,:]+[ \t]*\\(,[ \t]*[^ \t,:]+[ \t]*\\)*:" - (marker-position end) 'move) - (forward-char -1)) - (if (< (point) end) - (progn - (delete-horizontal-space) - (if (> (current-column) ind) - (setq ind (current-column))) - (pascal-end-of-statement)))) - (goto-char beg) - (setq oldpos (marker-position end)) - ;; Indent all case statements - (while (< (point) end) - (if (re-search-forward - "^[ \t]*[^][ \t,\\.:]+[ \t]*\\(,[ \t]*[^ \t,:]+[ \t]*\\)*:" - (marker-position end) 'move) - (forward-char -1)) - (indent-to (1+ ind)) - (if (/= (following-char) ?:) - () - (forward-char 1) - (delete-horizontal-space) - (insert " ")) - (setq oldpos (point)) - (pascal-end-of-statement)) - (goto-char savepos))) - -(defun pascal-indent-paramlist (&optional arg) - "Indent current line in parameterlist. -If optional arg is non-nil, just return the -indent of the current line in parameterlist." - (save-excursion - (let* ((oldpos (point)) - (stpos (progn (goto-char (scan-lists (point) -1 1)) (point))) - (stcol (1+ (current-column))) - (edpos (progn (pascal-declaration-end) - (search-backward ")" (pascal-get-beg-of-line) t) - (point))) - (usevar (re-search-backward "\\" stpos t))) - (if arg (progn - ;; If arg, just return indent - (goto-char oldpos) - (beginning-of-line) - (if (or (not usevar) (looking-at "[ \t]*var\\>")) - stcol (+ 4 stcol))) - (goto-char stpos) - (forward-char 1) - (delete-horizontal-space) - (if (and usevar (not (looking-at "var\\>"))) - (indent-to (+ 4 stcol))) - (pascal-indent-declaration nil stpos edpos))))) - -(defun pascal-indent-declaration (&optional arg start end) - "Indent current lines as declaration, lining up the `:'s or `='s." - (let ((pos (point-marker))) - (if (and (not (or arg start)) (not (pascal-declaration-beg))) - () - (let ((lineup (if (or (looking-at "\\\\|\\") arg start) - ":" "=")) - (stpos (if start start - (forward-word 2) (backward-word 1) (point))) - (edpos (set-marker (make-marker) - (if end end - (max (progn (pascal-declaration-end) - (point)) - pos)))) - ind) - - (goto-char stpos) - ;; Indent lines in record block - (if arg - (while (<= (point) edpos) - (beginning-of-line) - (delete-horizontal-space) - (if (looking-at "end\\>") - (indent-to arg) - (indent-to (+ arg pascal-indent-level))) - (forward-line 1))) - - ;; Do lineup - (setq ind (pascal-get-lineup-indent stpos edpos lineup)) - (goto-char stpos) - (while (and (<= (point) edpos) (not (eobp))) - (if (search-forward lineup (pascal-get-end-of-line) 'move) - (forward-char -1)) - (delete-horizontal-space) - (indent-to ind) - (if (not (looking-at lineup)) - (forward-line 1) ; No more indent if there is no : or = - (forward-char 1) - (delete-horizontal-space) - (insert " ") - ;; Indent record block - (if (looking-at "record\\>") - (pascal-indent-declaration (current-column))) - (forward-line 1))))) - - ;; If arg - move point - (if arg (forward-line -1) - (goto-char pos)))) - -; "Return the indent level that will line up several lines within the region -;from b to e nicely. The lineup string is str." -(defun pascal-get-lineup-indent (b e str) - (save-excursion - (let ((ind 0) - (reg (concat str "\\|\\(\\\\)"))) - (goto-char b) - ;; Get rightmost position - (while (< (point) e) - (if (re-search-forward reg (min e (pascal-get-end-of-line 2)) 'move) - (progn - ;; Skip record blocks - (if (match-beginning 1) - (pascal-declaration-end) - (progn - (goto-char (match-beginning 0)) - (skip-chars-backward " \t") - (if (> (current-column) ind) - (setq ind (current-column))) - (goto-char (match-end 0)) - (end-of-line) - ))))) - ;; In case no lineup was found - (if (> ind 0) - (1+ ind) - ;; No lineup-string found - (goto-char b) - (end-of-line) - (skip-chars-backward " \t") - (1+ (current-column)))))) - - - -;;; -;;; Completion -;;; -(defvar pascal-str nil) -(defvar pascal-all nil) -(defvar pascal-pred nil) -(defvar pascal-buffer-to-use nil) -(defvar pascal-flag nil) - -(defun pascal-string-diff (str1 str2) - "Return index of first letter where STR1 and STR2 differs." - (catch 'done - (let ((diff 0)) - (while t - (if (or (> (1+ diff) (length str1)) - (> (1+ diff) (length str2))) - (throw 'done diff)) - (or (equal (aref str1 diff) (aref str2 diff)) - (throw 'done diff)) - (setq diff (1+ diff)))))) - -;; Calculate all possible completions for functions if argument is `function', -;; completions for procedures if argument is `procedure' or both functions and -;; procedures otherwise. - -(defun pascal-func-completion (type) - ;; Build regular expression for function/procedure names - (if (string= pascal-str "") - (setq pascal-str "[a-zA-Z_]")) - (let ((pascal-str (concat (cond - ((eq type 'procedure) "\\<\\(procedure\\)\\s +") - ((eq type 'function) "\\<\\(function\\)\\s +") - (t "\\<\\(function\\|procedure\\)\\s +")) - "\\<\\(" pascal-str "[a-zA-Z0-9_.]*\\)\\>")) - match) - - (if (not (looking-at "\\<\\(function\\|procedure\\)\\>")) - (re-search-backward "\\<\\(function\\|procedure\\)\\>" nil t)) - (forward-char 1) - - ;; Search through all reachable functions - (while (pascal-beg-of-defun) - (if (re-search-forward pascal-str (pascal-get-end-of-line) t) - (progn (setq match (buffer-substring (match-beginning 2) - (match-end 2))) - (if (or (null pascal-pred) - (funcall pascal-pred match)) - (setq pascal-all (cons match pascal-all))))) - (goto-char (match-beginning 0))))) - -(defun pascal-get-completion-decl () - ;; Macro for searching through current declaration (var, type or const) - ;; for matches of `str' and adding the occurrence to `all' - (let ((end (save-excursion (pascal-declaration-end) - (point))) - match) - ;; Traverse lines - (while (< (point) end) - (if (re-search-forward "[:=]" (pascal-get-end-of-line) t) - ;; Traverse current line - (while (and (re-search-backward - (concat "\\((\\|\\<\\(var\\|type\\|const\\)\\>\\)\\|" - pascal-symbol-re) - (pascal-get-beg-of-line) t) - (not (match-end 1))) - (setq match (buffer-substring (match-beginning 0) (match-end 0))) - (if (string-match (concat "\\<" pascal-str) match) - (if (or (null pascal-pred) - (funcall pascal-pred match)) - (setq pascal-all (cons match pascal-all)))))) - (if (re-search-forward "\\" (pascal-get-end-of-line) t) - (pascal-declaration-end) - (forward-line 1))))) - -(defun pascal-type-completion () - "Calculate all possible completions for types." - (let ((start (point)) - goon) - ;; Search for all reachable type declarations - (while (or (pascal-beg-of-defun) - (setq goon (not goon))) - (save-excursion - (if (and (< start (prog1 (save-excursion (pascal-end-of-defun) - (point)) - (forward-char 1))) - (re-search-forward - "\\\\|\\<\\(begin\\|function\\|procedure\\)\\>" - start t) - (not (match-end 1))) - ;; Check current type declaration - (pascal-get-completion-decl)))))) - -(defun pascal-var-completion () - "Calculate all possible completions for variables (or constants)." - (let ((start (point)) - goon twice) - ;; Search for all reachable var declarations - (while (or (pascal-beg-of-defun) - (setq goon (not goon))) - (save-excursion - (if (> start (prog1 (save-excursion (pascal-end-of-defun) - (point)))) - () ; Declarations not reachable - (if (search-forward "(" (pascal-get-end-of-line) t) - ;; Check parameterlist - (pascal-get-completion-decl)) - (setq twice 2) - (while (>= (setq twice (1- twice)) 0) - (cond ((and (re-search-forward - (concat "\\<\\(var\\|const\\)\\>\\|" - "\\<\\(begin\\|function\\|procedure\\)\\>") - start t) - (not (match-end 2))) - ;; Check var/const declarations - (pascal-get-completion-decl)) - ((match-end 2) - (setq twice 0))))))))) - - -(defun pascal-keyword-completion (keyword-list) - "Give list of all possible completions of keywords in KEYWORD-LIST." - (mapcar '(lambda (s) - (if (string-match (concat "\\<" pascal-str) s) - (if (or (null pascal-pred) - (funcall pascal-pred s)) - (setq pascal-all (cons s pascal-all))))) - keyword-list)) - -;; Function passed to completing-read, try-completion or -;; all-completions to get completion on STR. If predicate is non-nil, -;; it must be a function to be called for every match to check if this -;; should really be a match. If flag is t, the function returns a list -;; of all possible completions. If it is nil it returns a string, the -;; longest possible completion, or t if STR is an exact match. If flag -;; is 'lambda, the function returns t if STR is an exact match, nil -;; otherwise. - -(defun pascal-completion (pascal-str pascal-pred pascal-flag) - (save-excursion - (let ((pascal-all nil)) - ;; Set buffer to use for searching labels. This should be set - ;; within functions which use pascal-completions - (set-buffer pascal-buffer-to-use) - - ;; Determine what should be completed - (let ((state (car (pascal-calculate-indent)))) - (cond (;--Within a declaration or parameterlist - (or (eq state 'declaration) (eq state 'paramlist) - (and (eq state 'defun) - (save-excursion - (re-search-backward ")[ \t]*:" - (pascal-get-beg-of-line) t)))) - (if (or (eq state 'paramlist) (eq state 'defun)) - (pascal-beg-of-defun)) - (pascal-type-completion) - (pascal-keyword-completion pascal-type-keywords)) - (;--Starting a new statement - (and (not (eq state 'contexp)) - (save-excursion - (skip-chars-backward "a-zA-Z0-9_.") - (backward-sexp 1) - (or (looking-at pascal-nosemi-re) - (progn - (forward-sexp 1) - (looking-at "\\s *\\(;\\|:[^=]\\)"))))) - (save-excursion (pascal-var-completion)) - (pascal-func-completion 'procedure) - (pascal-keyword-completion pascal-start-keywords)) - (t;--Anywhere else - (save-excursion (pascal-var-completion)) - (pascal-func-completion 'function) - (pascal-keyword-completion pascal-separator-keywords)))) - - ;; Now we have built a list of all matches. Give response to caller - (pascal-completion-response)))) - -(defun pascal-completion-response () - (cond ((or (equal pascal-flag 'lambda) (null pascal-flag)) - ;; This was not called by all-completions - (if (null pascal-all) - ;; Return nil if there was no matching label - nil - ;; Get longest string common in the labels - (let* ((elm (cdr pascal-all)) - (match (car pascal-all)) - (min (length match)) - tmp) - (if (string= match pascal-str) - ;; Return t if first match was an exact match - (setq match t) - (while (not (null elm)) - ;; Find longest common string - (if (< (setq tmp (pascal-string-diff match (car elm))) min) - (progn - (setq min tmp) - (setq match (substring match 0 min)))) - ;; Terminate with match=t if this is an exact match - (if (string= (car elm) pascal-str) - (progn - (setq match t) - (setq elm nil)) - (setq elm (cdr elm))))) - ;; If this is a test just for exact match, return nil ot t - (if (and (equal pascal-flag 'lambda) (not (equal match 't))) - nil - match)))) - ;; If flag is t, this was called by all-completions. Return - ;; list of all possible completions - (pascal-flag - pascal-all))) - -(defvar pascal-last-word-numb 0) -(defvar pascal-last-word-shown nil) -(defvar pascal-last-completions nil) - -(defun pascal-complete-word () - "Complete word at current point. -\(See also `pascal-toggle-completions', `pascal-type-keywords', -`pascal-start-keywords' and `pascal-separator-keywords'.)" - (interactive) - (let* ((b (save-excursion (skip-chars-backward "a-zA-Z0-9_") (point))) - (e (save-excursion (skip-chars-forward "a-zA-Z0-9_") (point))) - (pascal-str (buffer-substring b e)) - ;; The following variable is used in pascal-completion - (pascal-buffer-to-use (current-buffer)) - (allcomp (if (and pascal-toggle-completions - (string= pascal-last-word-shown pascal-str)) - pascal-last-completions - (all-completions pascal-str 'pascal-completion))) - (match (if pascal-toggle-completions - "" (try-completion - pascal-str (mapcar '(lambda (elm) - (cons elm 0)) allcomp))))) - ;; Delete old string - (delete-region b e) - - ;; Toggle-completions inserts whole labels - (if pascal-toggle-completions - (progn - ;; Update entry number in list - (setq pascal-last-completions allcomp - pascal-last-word-numb - (if (>= pascal-last-word-numb (1- (length allcomp))) - 0 - (1+ pascal-last-word-numb))) - (setq pascal-last-word-shown (elt allcomp pascal-last-word-numb)) - ;; Display next match or same string if no match was found - (if (not (null allcomp)) - (insert "" pascal-last-word-shown) - (insert "" pascal-str) - (message "(No match)"))) - ;; The other form of completion does not necessarily do that. - - ;; Insert match if found, or the original string if no match - (if (or (null match) (equal match 't)) - (progn (insert "" pascal-str) - (message "(No match)")) - (insert "" match)) - ;; Give message about current status of completion - (cond ((equal match 't) - (if (not (null (cdr allcomp))) - (message "(Complete but not unique)") - (message "(Sole completion)"))) - ;; Display buffer if the current completion didn't help - ;; on completing the label. - ((and (not (null (cdr allcomp))) (= (length pascal-str) - (length match))) - (with-output-to-temp-buffer "*Completions*" - (display-completion-list allcomp)) - ;; Wait for a keypress. Then delete *Completion* window - (momentary-string-display "" (point)) - (delete-window (get-buffer-window (get-buffer "*Completions*"))) - ))))) - -(defun pascal-show-completions () - "Show all possible completions at current point." - (interactive) - (let* ((b (save-excursion (skip-chars-backward "a-zA-Z0-9_") (point))) - (e (save-excursion (skip-chars-forward "a-zA-Z0-9_") (point))) - (pascal-str (buffer-substring b e)) - ;; The following variable is used in pascal-completion - (pascal-buffer-to-use (current-buffer)) - (allcomp (if (and pascal-toggle-completions - (string= pascal-last-word-shown pascal-str)) - pascal-last-completions - (all-completions pascal-str 'pascal-completion)))) - ;; Show possible completions in a temporary buffer. - (with-output-to-temp-buffer "*Completions*" - (display-completion-list allcomp)) - ;; Wait for a keypress. Then delete *Completion* window - (momentary-string-display "" (point)) - (delete-window (get-buffer-window (get-buffer "*Completions*"))))) - - -(defun pascal-get-default-symbol () - "Return symbol around current point as a string." - (save-excursion - (buffer-substring (progn - (skip-chars-backward " \t") - (skip-chars-backward "a-zA-Z0-9_") - (point)) - (progn - (skip-chars-forward "a-zA-Z0-9_") - (point))))) - -(defun pascal-build-defun-re (str &optional arg) - "Return function/procedure starting with STR as regular expression. -With optional second arg non-nil, STR is the complete name of the instruction." - (if arg - (concat "^\\(function\\|procedure\\)[ \t]+\\(" str "\\)\\>") - (concat "^\\(function\\|procedure\\)[ \t]+\\(" str "[a-zA-Z0-9_]*\\)\\>"))) - -;; Function passed to completing-read, try-completion or -;; all-completions to get completion on any function name. If -;; predicate is non-nil, it must be a function to be called for every -;; match to check if this should really be a match. If flag is t, the -;; function returns a list of all possible completions. If it is nil -;; it returns a string, the longest possible completion, or t if STR -;; is an exact match. If flag is 'lambda, the function returns t if -;; STR is an exact match, nil otherwise. - -(defun pascal-comp-defun (pascal-str pascal-pred pascal-flag) - (save-excursion - (let ((pascal-all nil) - match) - - ;; Set buffer to use for searching labels. This should be set - ;; within functions which use pascal-completions - (set-buffer pascal-buffer-to-use) - - (let ((pascal-str pascal-str)) - ;; Build regular expression for functions - (if (string= pascal-str "") - (setq pascal-str (pascal-build-defun-re "[a-zA-Z_]")) - (setq pascal-str (pascal-build-defun-re pascal-str))) - (goto-char (point-min)) - - ;; Build a list of all possible completions - (while (re-search-forward pascal-str nil t) - (setq match (buffer-substring (match-beginning 2) (match-end 2))) - (if (or (null pascal-pred) - (funcall pascal-pred match)) - (setq pascal-all (cons match pascal-all))))) - - ;; Now we have built a list of all matches. Give response to caller - (pascal-completion-response)))) - -(defun pascal-goto-defun () - "Move to specified Pascal function/procedure. -The default is a name found in the buffer around point." - (interactive) - (let* ((default (pascal-get-default-symbol)) - ;; The following variable is used in pascal-comp-function - (pascal-buffer-to-use (current-buffer)) - (default (if (pascal-comp-defun default nil 'lambda) - default "")) - (label (if (not (string= default "")) - ;; Do completion with default - (completing-read (concat "Label: (default " default ") ") - 'pascal-comp-defun nil t "") - ;; There is no default value. Complete without it - (completing-read "Label: " - 'pascal-comp-defun nil t "")))) - ;; If there was no response on prompt, use default value - (if (string= label "") - (setq label default)) - ;; Goto right place in buffer if label is not an empty string - (or (string= label "") - (progn - (goto-char (point-min)) - (re-search-forward (pascal-build-defun-re label t)) - (beginning-of-line))))) - - - -;;; -;;; Pascal-outline-mode -;;; -(defvar pascal-outline-map nil "Keymap used in Pascal Outline mode.") - -(if pascal-outline-map - nil - (if (boundp 'set-keymap-name) - (set-keymap-name pascal-outline-map 'pascal-outline-map)) - (if (not (boundp 'set-keymap-parent)) - (setq pascal-outline-map (copy-keymap pascal-mode-map)) - (setq pascal-outline-map (make-sparse-keymap)) - (set-keymap-parent pascal-outline-map pascal-mode-map)) - (define-key pascal-outline-map "\M-\C-a" 'pascal-outline-prev-defun) - (define-key pascal-outline-map "\M-\C-e" 'pascal-outline-next-defun) - (define-key pascal-outline-map "\C-c\C-d" 'pascal-outline-goto-defun) - (define-key pascal-outline-map "\C-c\C-s" 'pascal-show-all) - (define-key pascal-outline-map "\C-c\C-h" 'pascal-hide-other-defuns)) - -(defvar pascal-outline-mode nil "Non-nil while using Pascal Outline mode.") -(make-variable-buffer-local 'pascal-outline-mode) -(set-default 'pascal-outline-mode nil) -(if (not (assoc 'pascal-outline-mode minor-mode-alist)) - (setq minor-mode-alist (append minor-mode-alist - (list '(pascal-outline-mode " Outl"))))) - -(defun pascal-outline (&optional arg) - "Outline-line minor mode for Pascal mode. -When in Pascal Outline mode, portions -of the text being edited may be made invisible. \\ - -Pascal Outline mode provides some additional commands. - -\\[pascal-outline-prev-defun]\ -\t- Move to previous function/procedure, hiding everything else. -\\[pascal-outline-next-defun]\ -\t- Move to next function/procedure, hiding everything else. -\\[pascal-outline-goto-defun]\ -\t- Goto function/procedure prompted for in minibuffer, -\t hide all other functions. -\\[pascal-show-all]\t- Show the whole buffer. -\\[pascal-hide-other-defuns]\ -\t- Hide everything but the current function (function under the cursor). -\\[pascal-outline]\t- Leave pascal-outline-mode." - (interactive "P") - (setq pascal-outline-mode - (if (null arg) (not pascal-outline-mode) t)) - (if (boundp 'redraw-mode-line) - (redraw-mode-line)) - (if pascal-outline-mode - (progn - (setq selective-display t) - (use-local-map pascal-outline-map)) - (progn - (setq selective-display nil) - (pascal-show-all) - (use-local-map pascal-mode-map)))) - -(defun pascal-outline-change (b e pascal-flag) - (let ((modp (buffer-modified-p))) - (unwind-protect - (subst-char-in-region b e (if (= pascal-flag ?\n) - ?\^M ?\n) pascal-flag) - (set-buffer-modified-p modp)))) - -(defun pascal-show-all () - "Show all of the text in the buffer." - (interactive) - (pascal-outline-change (point-min) (point-max) ?\n)) - -(defun pascal-hide-other-defuns () - "Show only the current defun." - (interactive) - (save-excursion - (let ((beg (progn (if (not (looking-at "\\(function\\|procedure\\)\\>")) - (pascal-beg-of-defun)) - (point))) - (end (progn (pascal-end-of-defun) - (backward-sexp 1) - (search-forward "\n\\|\^M" nil t) - (point))) - (opoint (point-min))) - (goto-char (point-min)) - - ;; Hide all functions before current function - (while (re-search-forward "^\\(function\\|procedure\\)\\>" beg 'move) - (pascal-outline-change opoint (1- (match-beginning 0)) ?\^M) - (setq opoint (point)) - ;; Functions may be nested - (if (> (progn (pascal-end-of-defun) (point)) beg) - (goto-char opoint))) - (if (> beg opoint) - (pascal-outline-change opoint (1- beg) ?\^M)) - - ;; Show current function - (pascal-outline-change beg end ?\n) - ;; Hide nested functions - (forward-char 1) - (while (re-search-forward "^\\(function\\|procedure\\)\\>" end 'move) - (setq opoint (point)) - (pascal-end-of-defun) - (pascal-outline-change opoint (point) ?\^M)) - - (goto-char end) - (setq opoint end) - - ;; Hide all function after current function - (while (re-search-forward "^\\(function\\|procedure\\)\\>" nil 'move) - (pascal-outline-change opoint (1- (match-beginning 0)) ?\^M) - (setq opoint (point)) - (pascal-end-of-defun)) - (pascal-outline-change opoint (point-max) ?\^M) - - ;; Hide main program - (if (< (progn (forward-line -1) (point)) end) - (progn - (goto-char beg) - (pascal-end-of-defun) - (backward-sexp 1) - (pascal-outline-change (point) (point-max) ?\^M)))))) - -(defun pascal-outline-next-defun () - "Move to next function/procedure, hiding all others." - (interactive) - (pascal-end-of-defun) - (pascal-hide-other-defuns)) - -(defun pascal-outline-prev-defun () - "Move to previous function/procedure, hiding all others." - (interactive) - (pascal-beg-of-defun) - (pascal-hide-other-defuns)) - -(defun pascal-outline-goto-defun () - "Move to specified function/procedure, hiding all others." - (interactive) - (pascal-goto-defun) - (pascal-hide-other-defuns)) - -;;; pascal.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/perl-mode.el --- a/lisp/modes/perl-mode.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,712 +0,0 @@ -;;; perl-mode.el --- Perl code editing commands for GNU Emacs - -;; Copyright (C) 1990, 1994 Free Software Foundation, Inc. - -;; Author: William F. Mann -;; Maintainer: FSF -;; Adapted-By: ESR -;; Keywords: languages - -;; Adapted from C code editing commands 'c-mode.el', Copyright 1987 by the -;; Free Software Foundation, under terms of its General Public License. - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: FSF 19.30. - -;;; Commentary: - -;; To enter perl-mode automatically, add (autoload 'perl-mode "perl-mode") -;; to your .emacs file and change the first line of your perl script to: -;; #!/usr/bin/perl -- # -*-Perl-*- -;; With arguments to perl: -;; #!/usr/bin/perl -P- # -*-Perl-*- -;; To handle files included with do 'filename.pl';, add something like -;; (setq auto-mode-alist (append (list (cons "\\.pl\\'" 'perl-mode)) -;; auto-mode-alist)) -;; to your .emacs file; otherwise the .pl suffix defaults to prolog-mode. - -;; This code is based on the 18.53 version c-mode.el, with extensive -;; rewriting. Most of the features of c-mode survived intact. - -;; I added a new feature which adds functionality to TAB; it is controlled -;; by the variable perl-tab-to-comment. With it enabled, TAB does the -;; first thing it can from the following list: change the indentation; -;; move past leading white space; delete an empty comment; reindent a -;; comment; move to end of line; create an empty comment; tell you that -;; the line ends in a quoted string, or has a # which should be a \#. - -;; If your machine is slow, you may want to remove some of the bindings -;; to electric-perl-terminator. I changed the indenting defaults to be -;; what Larry Wall uses in perl/lib, but left in all the options. - -;; I also tuned a few things: comments and labels starting in column -;; zero are left there by indent-perl-exp; perl-beginning-of-function -;; goes back to the first open brace/paren in column zero, the open brace -;; in 'sub ... {', or the equal sign in 'format ... ='; indent-perl-exp -;; (meta-^q) indents from the current line through the close of the next -;; brace/paren, so you don't need to start exactly at a brace or paren. - -;; It may be good style to put a set of redundant braces around your -;; main program. This will let you reindent it with meta-^q. - -;; Known problems (these are all caused by limitations in the Emacs Lisp -;; parsing routine (parse-partial-sexp), which was not designed for such -;; a rich language; writing a more suitable parser would be a big job): -;; 1) Regular expression delimiters do not act as quotes, so special -;; characters such as `'"#:;[](){} may need to be backslashed -;; in regular expressions and in both parts of s/// and tr///. -;; 2) The globbing syntax is not recognized, so special -;; characters in the pattern string must be backslashed. -;; 3) The q, qq, and << quoting operators are not recognized; see below. -;; 4) \ (backslash) always quotes the next character, so '\' is -;; treated as the start of a string. Use "\\" as a work-around. -;; 5) To make variables such a $' and $#array work, perl-mode treats -;; $ just like backslash, so '$' is the same as problem 5. -;; 6) Unfortunately, treating $ like \ makes ${var} be treated as an -;; unmatched }. See below. -;; 7) When ' (quote) is used as a package name separator, perl-mode -;; doesn't understand, and thinks it is seeing a quoted string. - -;; Here are some ugly tricks to bypass some of these problems: the perl -;; expression /`/ (that's a back-tick) usually evaluates harmlessly, -;; but will trick perl-mode into starting a quoted string, which -;; can be ended with another /`/. Assuming you have no embedded -;; back-ticks, this can used to help solve problem 3: -;; -;; /`/; $ugly = q?"'$?; /`/; -;; -;; To solve problem 6, add a /{/; before each use of ${var}: -;; /{/; while (<${glob_me}>) ... -;; -;; Problem 7 is even worse, but this 'fix' does work :-( -;; $DB'stop#' -;; [$DB'line#' -;; ] =~ s/;9$//; - - -;;; Code: - -(defvar perl-mode-abbrev-table nil - "Abbrev table in use in perl-mode buffers.") -(define-abbrev-table 'perl-mode-abbrev-table ()) - -(defvar perl-mode-map () - "Keymap used in Perl mode.") -(if perl-mode-map - () - (setq perl-mode-map (make-sparse-keymap)) - (set-keymap-name perl-mode-map 'perl-mode-map) - (define-key perl-mode-map "{" 'electric-perl-terminator) - (define-key perl-mode-map "}" 'electric-perl-terminator) - (define-key perl-mode-map ";" 'electric-perl-terminator) - (define-key perl-mode-map ":" 'electric-perl-terminator) - (define-key perl-mode-map "\e\C-a" 'perl-beginning-of-function) - (define-key perl-mode-map "\e\C-e" 'perl-end-of-function) - (define-key perl-mode-map "\e\C-h" 'mark-perl-function) - (define-key perl-mode-map "\e\C-q" 'indent-perl-exp) - (define-key perl-mode-map "\t" 'perl-indent-command)) - -(autoload 'c-macro-expand "cmacexp" - "Display the result of expanding all C macros occurring in the region. -The expansion is entirely correct because it uses the C preprocessor." - t) - -(defvar perl-mode-syntax-table nil - "Syntax table in use in perl-mode buffers.") - -(if perl-mode-syntax-table - () - (setq perl-mode-syntax-table (make-syntax-table (standard-syntax-table))) - (modify-syntax-entry ?\n ">" perl-mode-syntax-table) - (modify-syntax-entry ?# "<" perl-mode-syntax-table) - (modify-syntax-entry ?$ "\\" perl-mode-syntax-table) - (modify-syntax-entry ?% "." perl-mode-syntax-table) - (modify-syntax-entry ?& "." perl-mode-syntax-table) - (modify-syntax-entry ?\' "\"" perl-mode-syntax-table) - (modify-syntax-entry ?* "." perl-mode-syntax-table) - (modify-syntax-entry ?+ "." perl-mode-syntax-table) - (modify-syntax-entry ?- "." perl-mode-syntax-table) - (modify-syntax-entry ?/ "." perl-mode-syntax-table) - (modify-syntax-entry ?< "." perl-mode-syntax-table) - (modify-syntax-entry ?= "." perl-mode-syntax-table) - (modify-syntax-entry ?> "." perl-mode-syntax-table) - (modify-syntax-entry ?\\ "\\" perl-mode-syntax-table) - (modify-syntax-entry ?` "\"" perl-mode-syntax-table) - (modify-syntax-entry ?| "." perl-mode-syntax-table) -) - -;(defvar perl-imenu-generic-expression -; '( -; ;; Functions -; (nil "^sub\\s-+\\([-A-Za-z0-9+_:]+\\)\\(\\s-\\|\n\\)*{" 1 ) -; ;;Variables -; ("Variables" "^\\([$@%][-A-Za-z0-9+_:]+\\)\\s-*=" 1 ) -; ) -; "Imenu generic expression for Perl mode. See `imenu-generic-expression'.") - -(defvar perl-font-lock-keywords (purecopy - (list -; ("if" "until" "while" "elsif" "else" "unless" "for" "foreach" "continue" -; "exit" "die" "last" "goto" "next" "redo" "return" "local" "exec") - (concat "\\<\\(" - "continue\\|die\\|e\\(ls\\(e\\|if\\)\\|x\\(ec\\|it\\)\\)\\|" - "for\\(\\|each\\)\\|goto\\|if\\|l\\(ast\\|ocal\\)\\|next\\|" - "re\\(do\\|turn\\)\\|un\\(less\\|til\\)\\|while" - "\\)\\>") -; ("#endif" "#else" "#ifdef" "#ifndef" "#if" "#include" "#define" "#undef") - (cons (concat "#\\(define\\|e\\(lse\\|ndif\\)\\|" - "i\\(f\\(\\|def\\|ndef\\)\\|nclude\\)\\|undef\\)\\>") - 'font-lock-reference-face) - '("^[ \n\t]*sub[ \t]+\\([^ \t{]+\\)[ \t]*[{]" 1 font-lock-function-name-face) - '("[ \n\t{]*\\(eval\\)[ \n\t(;]" 1 font-lock-function-name-face) - '("\\(--- .* ---\\|=== .* ===\\)" . font-lock-string-face) - )) - "Additional expressions to highlight in Perl mode.") - -;A similar version. -;(defconst perl-font-lock-keywords (purecopy -; (list -; (cons (concat "[ \n\t{]*\\(" -; (mapconcat 'identity -; '("if" "until" "while" "elsif" "else" "unless" -; "for" "foreach" "continue" "exit" "die" "last" -; "goto" "next" "redo" "return" "local" "exec") -; "\\|") -; "\\)[ \n\t;(]") -; 1) -; (mapconcat 'identity -; '("#endif" "#else" "#ifdef" "#ifndef" "#if" "#include" -; "#define" "#undef") -; "\\|") -; '("^[ \n\t]*sub[ \t]+\\([^ \t{]+\\)[ \n\t]*\\{" -; 1 font-lock-function-name-face) -; '("[ \n\t{]*\\(eval\\)[ \n\t(;]" -; 1 font-lock-function-name-face) -; ;; '("\\(--- .* ---\\|=== .* ===\\)" 1 font-lock-doc-string-face) -; )) -; "Additional expressions to highlight in Perl mode.") - -(put 'perl-mode 'font-lock-defaults '(perl-font-lock-keywords)) - -(defvar perl-indent-level 4 - "*Indentation of Perl statements with respect to containing block.") -(defvar perl-continued-statement-offset 4 - "*Extra indent for lines not starting new statements.") -(defvar perl-continued-brace-offset -4 - "*Extra indent for substatements that start with open-braces. -This is in addition to `perl-continued-statement-offset'.") -(defvar perl-brace-offset 0 - "*Extra indentation for braces, compared with other text in same context.") -(defvar perl-brace-imaginary-offset 0 - "*Imagined indentation of an open brace that actually follows a statement.") -(defvar perl-label-offset -2 - "*Offset of Perl label lines relative to usual indentation.") - -(defvar perl-tab-always-indent t - "*Non-nil means TAB in Perl mode always indents the current line. -Otherwise it inserts a tab character if you type it past the first -nonwhite character on the line.") - -;; I changed the default to nil for consistency with general Emacs -;; conventions -- rms. -(defvar perl-tab-to-comment nil - "*Non-nil means TAB moves to eol or makes a comment in some cases. -For lines which don't need indenting, TAB either indents an -existing comment, moves to end-of-line, or if at end-of-line already, -create a new comment.") - -(defvar perl-nochange ";?#\\|\f\\|\\s(\\|\\(\\w\\|\\s_\\)+:" - "*Lines starting with this regular expression are not auto-indented.") - -(defvar perl-mode-hook nil - "Invoked on entry to perl-mode.") - - -;;; bluck. ;;;###autoload -(defun perl-mode () - "Major mode for editing Perl code. -Expression and list commands understand all Perl brackets. -Tab indents for Perl code. -Comments are delimited with # ... \\n. -Paragraphs are separated by blank lines only. -Delete converts tabs to spaces as it moves back. -\\{perl-mode-map} -Variables controlling indentation style: - perl-tab-always-indent - Non-nil means TAB in Perl mode should always indent the current line, - regardless of where in the line point is when the TAB command is used. - perl-tab-to-comment - Non-nil means that for lines which don't need indenting, TAB will - either delete an empty comment, indent an existing comment, move - to end-of-line, or if at end-of-line already, create a new comment. - perl-nochange - Lines starting with this regular expression are not auto-indented. - perl-indent-level - Indentation of Perl statements within surrounding block. - The surrounding block's indentation is the indentation - of the line on which the open-brace appears. - perl-continued-statement-offset - Extra indentation given to a substatement, such as the - then-clause of an if or body of a while. - perl-continued-brace-offset - Extra indentation given to a brace that starts a substatement. - This is in addition to `perl-continued-statement-offset'. - perl-brace-offset - Extra indentation for line if it starts with an open brace. - perl-brace-imaginary-offset - An open brace following other text is treated as if it were - this far to the right of the start of its line. - perl-label-offset - Extra indentation for line that is a label. - -Various indentation styles: K&R BSD BLK GNU LW - perl-indent-level 5 8 0 2 4 - perl-continued-statement-offset 5 8 4 2 4 - perl-continued-brace-offset 0 0 0 0 -4 - perl-brace-offset -5 -8 0 0 0 - perl-brace-imaginary-offset 0 0 4 0 0 - perl-label-offset -5 -8 -2 -2 -2 - -Turning on Perl mode runs the normal hook `perl-mode-hook'." - (interactive) - (kill-all-local-variables) - (use-local-map perl-mode-map) - (setq major-mode 'perl-mode) - (setq mode-name "Perl") - (setq local-abbrev-table perl-mode-abbrev-table) - (set-syntax-table perl-mode-syntax-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'perl-indent-line) - (make-local-variable 'require-final-newline) - (setq require-final-newline t) - (make-local-variable 'comment-start) - (setq comment-start "# ") - (make-local-variable 'comment-end) - (setq comment-end "") - (make-local-variable 'comment-column) - (setq comment-column 32) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "\\(^\\|\\s-\\);?#+ *") - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'perl-comment-indent) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - ;; Tell imenu how to handle Perl. -; (make-local-variable 'imenu-generic-expression) -; (setq imenu-generic-expression perl-imenu-generic-expression) - (run-hooks 'perl-mode-hook)) - -;; This is used by indent-for-comment -;; to decide how much to indent a comment in Perl code -;; based on its context. -(defun perl-comment-indent () - (if (and (bolp) (not (eolp))) - 0 ;Existing comment at bol stays there. - (save-excursion - (skip-chars-backward " \t") - (max (if (bolp) ;Else indent at comment column - 0 ; except leave at least one space if - (1+ (current-column))) ; not at beginning of line. - comment-column)))) - -(defun electric-perl-terminator (arg) - "Insert character and adjust indentation. -If at end-of-line, and not in a comment or a quote, correct the's indentation." - (interactive "P") - (let ((insertpos (point))) - (and (not arg) ; decide whether to indent - (eolp) - (save-excursion - (beginning-of-line) - (and (not ; eliminate comments quickly - (re-search-forward comment-start-skip insertpos t)) - (or (/= last-command-char ?:) - ;; Colon is special only after a label .... - (looking-at "\\s-*\\(\\w\\|\\s_\\)+$")) - (let ((pps (parse-partial-sexp - (perl-beginning-of-function) insertpos))) - (not (or (nth 3 pps) (nth 4 pps) (nth 5 pps)))))) - (progn ; must insert, indent, delete - (insert-char last-command-char 1) - (perl-indent-line) - (delete-char -1)))) - (self-insert-command (prefix-numeric-value arg))) - -;; not used anymore, but may be useful someday: -;;(defun perl-inside-parens-p () -;; (condition-case () -;; (save-excursion -;; (save-restriction -;; (narrow-to-region (point) -;; (perl-beginning-of-function)) -;; (goto-char (point-max)) -;; (= (char-after (or (scan-lists (point) -1 1) (point-min))) ?\())) -;; (error nil))) - -(defun perl-indent-command (&optional arg) - "Indent current line as Perl code, or optionally, insert a tab character. - -With an argument, indent the current line, regardless of other options. - -If `perl-tab-always-indent' is nil and point is not in the indentation -area at the beginning of the line, simply insert a tab. - -Otherwise, indent the current line. If point was within the indentation -area it is moved to the end of the indentation area. If the line was -already indented properly and point was not within the indentation area, -and if `perl-tab-to-comment' is non-nil (the default), then do the first -possible action from the following list: - - 1) delete an empty comment - 2) move forward to start of comment, indenting if necessary - 3) move forward to end of line - 4) create an empty comment - 5) move backward to start of comment, indenting if necessary." - (interactive "P") - (if arg ; If arg, just indent this line - (perl-indent-line "\f") - (if (and (not perl-tab-always-indent) - (> (current-column) (current-indentation))) - (insert-tab) - (let (bof lsexp delta (oldpnt (point))) - (beginning-of-line) - (setq lsexp (point)) - (setq bof (perl-beginning-of-function)) - (goto-char oldpnt) - (setq delta (perl-indent-line "\f\\|;?#" bof)) - (and perl-tab-to-comment - (= oldpnt (point)) ; done if point moved - (if (listp delta) ; if line starts in a quoted string - (setq lsexp (or (nth 2 delta) bof)) - (= delta 0)) ; done if indenting occurred - (let (eol state) - (end-of-line) - (setq eol (point)) - (if (= (char-after bof) ?=) - (if (= oldpnt eol) - (message "In a format statement")) - (setq state (parse-partial-sexp lsexp eol)) - (if (nth 3 state) - (if (= oldpnt eol) ; already at eol in a string - (message "In a string which starts with a %c." - (nth 3 state))) - (if (not (nth 4 state)) - (if (= oldpnt eol) ; no comment, create one? - (indent-for-comment)) - (beginning-of-line) - (if (re-search-forward comment-start-skip eol 'move) - (if (eolp) - (progn ; kill existing comment - (goto-char (match-beginning 0)) - (skip-chars-backward " \t") - (kill-region (point) eol)) - (if (or (< oldpnt (point)) (= oldpnt eol)) - (indent-for-comment) ; indent existing comment - (end-of-line))) - (if (/= oldpnt eol) - (end-of-line) - (message "Use backslash to quote # characters.") - (ding t)))))))))))) - -(defun perl-indent-line (&optional nochange parse-start) - "Indent current line as Perl code. -Return the amount the indentation -changed by, or (parse-state) if line starts in a quoted string." - (let ((case-fold-search nil) - (pos (- (point-max) (point))) - (bof (or parse-start (save-excursion (perl-beginning-of-function)))) - beg indent shift-amt) - (beginning-of-line) - (setq beg (point)) - (setq shift-amt - (cond ((= (char-after bof) ?=) 0) - ((listp (setq indent (calculate-perl-indent bof))) indent) - ((looking-at (or nochange perl-nochange)) 0) - (t - (skip-chars-forward " \t\f") - (cond ((looking-at "\\(\\w\\|\\s_\\)+:") - (setq indent (max 1 (+ indent perl-label-offset)))) - ((= (following-char) ?}) - (setq indent (- indent perl-indent-level))) - ((= (following-char) ?{) - (setq indent (+ indent perl-brace-offset)))) - (- indent (current-column))))) - (skip-chars-forward " \t\f") - (if (and (numberp shift-amt) (/= 0 shift-amt)) - (progn (delete-region beg (point)) - (indent-to indent))) - ;; If initial point was within line's indentation, - ;; position after the indentation. Else stay at same point in text. - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos))) - shift-amt)) - -(defun calculate-perl-indent (&optional parse-start) - "Return appropriate indentation for current line as Perl code. -In usual case returns an integer: the column to indent to. -Returns (parse-state) if line starts inside a string." - (save-excursion - (beginning-of-line) - (let ((indent-point (point)) - (case-fold-search nil) - (colon-line-end 0) - state containing-sexp) - (if parse-start ;used to avoid searching - (goto-char parse-start) - (perl-beginning-of-function)) - (while (< (point) indent-point) ;repeat until right sexp - (setq parse-start (point)) - (setq state (parse-partial-sexp (point) indent-point 0)) -; state = (depth_in_parens innermost_containing_list last_complete_sexp -; string_terminator_or_nil inside_commentp following_quotep -; minimum_paren-depth_this_scan) -; Parsing stops if depth in parentheses becomes equal to third arg. - (setq containing-sexp (nth 1 state))) - (cond ((nth 3 state) state) ; In a quoted string? - ((null containing-sexp) ; Line is at top level. - (skip-chars-forward " \t\f") - (if (= (following-char) ?{) - 0 ; move to beginning of line if it starts a function body - ;; indent a little if this is a continuation line - (perl-backward-to-noncomment) - (if (or (bobp) - (memq (preceding-char) '(?\; ?\}))) - 0 perl-continued-statement-offset))) - ((/= (char-after containing-sexp) ?{) - ;; line is expression, not statement: - ;; indent to just after the surrounding open. - (goto-char (1+ containing-sexp)) - (current-column)) - (t - ;; Statement level. Is it a continuation or a new statement? - ;; Find previous non-comment character. - (perl-backward-to-noncomment) - ;; Back up over label lines, since they don't - ;; affect whether our line is a continuation. - (while (or (eq (preceding-char) ?\,) - (and (eq (preceding-char) ?:) - (memq (char-syntax (char-after (- (point) 2))) - '(?w ?_)))) - (if (eq (preceding-char) ?\,) - (perl-backward-to-start-of-continued-exp containing-sexp) - (beginning-of-line)) - (perl-backward-to-noncomment)) - ;; Now we get the answer. - (if (not (memq (preceding-char) '(?\; ?\} ?\{))) - ;; This line is continuation of preceding line's statement; - ;; indent perl-continued-statement-offset more than the - ;; previous line of the statement. - (progn - (perl-backward-to-start-of-continued-exp containing-sexp) - (+ perl-continued-statement-offset (current-column) - (if (save-excursion (goto-char indent-point) - (looking-at "[ \t]*{")) - perl-continued-brace-offset 0))) - ;; This line starts a new statement. - ;; Position at last unclosed open. - (goto-char containing-sexp) - (or - ;; If open paren is in col 0, close brace is special - (and (bolp) - (save-excursion (goto-char indent-point) - (looking-at "[ \t]*}")) - perl-indent-level) - ;; Is line first statement after an open-brace? - ;; If no, find that first statement and indent like it. - (save-excursion - (forward-char 1) - ;; Skip over comments and labels following openbrace. - (while (progn - (skip-chars-forward " \t\f\n") - (cond ((looking-at ";?#") - (forward-line 1) t) - ((looking-at "\\(\\w\\|\\s_\\)+:") - (save-excursion - (end-of-line) - (setq colon-line-end (point))) - (search-forward ":"))))) - ;; The first following code counts - ;; if it is before the line we want to indent. - (and (< (point) indent-point) - (if (> colon-line-end (point)) - (- (current-indentation) perl-label-offset) - (current-column)))) - ;; If no previous statement, - ;; indent it relative to line brace is on. - ;; For open paren in column zero, don't let statement - ;; start there too. If perl-indent-level is zero, - ;; use perl-brace-offset + perl-continued-statement-offset - ;; For open-braces not the first thing in a line, - ;; add in perl-brace-imaginary-offset. - (+ (if (and (bolp) (zerop perl-indent-level)) - (+ perl-brace-offset perl-continued-statement-offset) - perl-indent-level) - ;; Move back over whitespace before the openbrace. - ;; If openbrace is not first nonwhite thing on the line, - ;; add the perl-brace-imaginary-offset. - (progn (skip-chars-backward " \t") - (if (bolp) 0 perl-brace-imaginary-offset)) - ;; If the openbrace is preceded by a parenthesized exp, - ;; move to the beginning of that; - ;; possibly a different line - (progn - (if (eq (preceding-char) ?\)) - (forward-sexp -1)) - ;; Get initial indentation of the line we are on. - (current-indentation)))))))))) - -(defun perl-backward-to-noncomment () - "Move point backward to after the first non-white-space, skipping comments." - (interactive) - (let (opoint stop) - (while (not stop) - (setq opoint (point)) - (beginning-of-line) - (if (re-search-forward comment-start-skip opoint 'move 1) - (progn (goto-char (match-end 1)) - (skip-chars-forward ";"))) - (skip-chars-backward " \t\f") - (setq stop (or (bobp) - (not (bolp)) - (forward-char -1)))))) - -(defun perl-backward-to-start-of-continued-exp (lim) - (if (= (preceding-char) ?\)) - (forward-sexp -1)) - (beginning-of-line) - (if (<= (point) lim) - (goto-char (1+ lim))) - (skip-chars-forward " \t\f")) - -;; note: this may be slower than the c-mode version, but I can understand it. -(defun indent-perl-exp () - "Indent each line of the Perl grouping following point." - (interactive) - (let* ((case-fold-search nil) - (oldpnt (point-marker)) - (bof-mark (save-excursion - (end-of-line 2) - (perl-beginning-of-function) - (point-marker))) - eol last-mark lsexp-mark delta) - (if (= (char-after (marker-position bof-mark)) ?=) - (message "Can't indent a format statement") - (message "Indenting Perl expression...") - (save-excursion (end-of-line) (setq eol (point))) - (save-excursion ; locate matching close paren - (while (and (not (eobp)) (<= (point) eol)) - (parse-partial-sexp (point) (point-max) 0)) - (setq last-mark (point-marker))) - (setq lsexp-mark bof-mark) - (beginning-of-line) - (while (< (point) (marker-position last-mark)) - (setq delta (perl-indent-line nil (marker-position bof-mark))) - (if (numberp delta) ; unquoted start-of-line? - (progn - (if (eolp) - (delete-horizontal-space)) - (setq lsexp-mark (point-marker)))) - (end-of-line) - (setq eol (point)) - (if (nth 4 (parse-partial-sexp (marker-position lsexp-mark) eol)) - (progn ; line ends in a comment - (beginning-of-line) - (if (or (not (looking-at "\\s-*;?#")) - (listp delta) - (and (/= 0 delta) - (= (- (current-indentation) delta) comment-column))) - (if (re-search-forward comment-start-skip eol t) - (indent-for-comment))))) ; indent existing comment - (forward-line 1)) - (goto-char (marker-position oldpnt)) - (message "Indenting Perl expression...done")))) - -(defun perl-beginning-of-function (&optional arg) - "Move backward to next beginning-of-function, or as far as possible. -With argument, repeat that many times; negative args move forward. -Returns new value of point in all cases." - (interactive "p") - (or arg (setq arg 1)) - (if (< arg 0) (forward-char 1)) - (and (/= arg 0) - (re-search-backward "^\\s(\\|^\\s-*sub\\b[^{]+{\\|^\\s-*format\\b[^=]*=\\|^\\." - nil 'move arg) - (goto-char (1- (match-end 0)))) - (point)) - -;; note: this routine is adapted directly from emacs lisp.el, end-of-defun; -;; no bugs have been removed :-) -(defun perl-end-of-function (&optional arg) - "Move forward to next end-of-function. -The end of a function is found by moving forward from the beginning of one. -With argument, repeat that many times; negative args move backward." - (interactive "p") - (or arg (setq arg 1)) - (let ((first t)) - (while (and (> arg 0) (< (point) (point-max))) - (let ((pos (point))) - (while (progn - (if (and first - (progn - (forward-char 1) - (perl-beginning-of-function 1) - (not (bobp)))) - nil - (or (bobp) (forward-char -1)) - (perl-beginning-of-function -1)) - (setq first nil) - (forward-list 1) - (skip-chars-forward " \t") - (if (looking-at "[#\n]") - (forward-line 1)) - (<= (point) pos)))) - (setq arg (1- arg))) - (while (< arg 0) - (let ((pos (point))) - (perl-beginning-of-function 1) - (forward-sexp 1) - (forward-line 1) - (if (>= (point) pos) - (if (progn (perl-beginning-of-function 2) (not (bobp))) - (progn - (forward-list 1) - (skip-chars-forward " \t") - (if (looking-at "[#\n]") - (forward-line 1))) - (goto-char (point-min))))) - (setq arg (1+ arg))))) - -(defun mark-perl-function () - "Put mark at end of Perl function, point at beginning." - (interactive) - (push-mark (point)) - (perl-end-of-function) - (push-mark (point)) - (perl-beginning-of-function) - (backward-paragraph)) - -(provide 'perl-mode) - -;;; perl-mode.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/picture.el --- a/lisp/modes/picture.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,664 +0,0 @@ -;;; picture.el --- "Picture mode" -- editing using quarter-plane screen model. - -;; Copyright (C) 1985, 1994 Free Software Foundation, Inc. - -;; Author: K. Shane Hartman -;; Maintainer: FSF - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: FSF 19.30. - -;; XEmacs changes: -;; -- set zmacs-region-stays -;; -- set mouse-track-rectangle-p -;; -- deleted useless hscroll-point-visible junk. - - -;;; Commentary: - -;; This code provides the picture-mode commands documented in the Emacs -;; manual. The screen is treated as a semi-infinite quarter-plane with -;; support for rectangle operations and `etch-a-sketch' character -;; insertion in any of eight directions. - -;;; Code: - -(defun move-to-column-force (column) - "Move to column COLUMN in current line. -Differs from `move-to-column' in that it creates or modifies whitespace -if necessary to attain exactly the specified column." - (or (natnump column) (setq column 0)) - (move-to-column column) - (let ((col (current-column))) - (if (< col column) - (indent-to column) - (if (and (/= col column) - (= (preceding-char) ?\t)) - (let (indent-tabs-mode) - (delete-char -1) - (indent-to col) - (move-to-column column)))) - (prog1 - ;; XEmacs addition: - (setq zmacs-region-stays t)))) - - -;; Picture Movement Commands - -(defun picture-beginning-of-line (&optional arg) - "Position point at the beginning of the line. -With ARG not nil, move forward ARG - 1 lines first. -If scan reaches end of buffer, stop there without error." - (interactive "P") - (if arg (forward-line (1- (prefix-numeric-value arg)))) - (beginning-of-line) - ) - -(defun picture-end-of-line (&optional arg) - "Position point after last non-blank character on current line. -With ARG not nil, move forward ARG - 1 lines first. -If scan reaches end of buffer, stop there without error." - (interactive "P") - (if arg (forward-line (1- (prefix-numeric-value arg)))) - (beginning-of-line) - (skip-chars-backward " \t" (prog1 (point) (end-of-line))) - ) - -(defun picture-forward-column (arg) - "Move cursor right, making whitespace if necessary. -With argument, move that many columns." - (interactive "p") - (let ((target-column (+ (current-column) arg))) - (move-to-column-force target-column) - ;; Picture mode isn't really suited to multi-column characters, - ;; but we might as well let the user move across them. - (and (< arg 0) - (> (current-column) target-column) - (forward-char -1)))) - -(defun picture-backward-column (arg) - "Move cursor left, making whitespace if necessary. -With argument, move that many columns." - (interactive "p") - (picture-forward-column (- arg))) - -(defun picture-move-down (arg) - "Move vertically down, making whitespace if necessary. -With argument, move that many lines." - (interactive "p") - (let ((col (current-column))) - (picture-newline arg) - (move-to-column-force col))) - -(defconst picture-vertical-step 0 - "Amount to move vertically after text character in Picture mode.") - -(defconst picture-horizontal-step 1 - "Amount to move horizontally after text character in Picture mode.") - -(defun picture-move-up (arg) - "Move vertically up, making whitespace if necessary. -With argument, move that many lines." - (interactive "p") - (picture-move-down (- arg))) - -(defun picture-movement-right () - "Move right after self-inserting character in Picture mode." - (interactive) - (picture-set-motion 0 1)) - -(defun picture-movement-left () - "Move left after self-inserting character in Picture mode." - (interactive) - (picture-set-motion 0 -1)) - -(defun picture-movement-up () - "Move up after self-inserting character in Picture mode." - (interactive) - (picture-set-motion -1 0)) - -(defun picture-movement-down () - "Move down after self-inserting character in Picture mode." - (interactive) - (picture-set-motion 1 0)) - -(defun picture-movement-nw () - "Move up and left after self-inserting character in Picture mode." - (interactive) - (picture-set-motion -1 -1)) - -(defun picture-movement-ne () - "Move up and right after self-inserting character in Picture mode." - (interactive) - (picture-set-motion -1 1)) - -(defun picture-movement-sw () - "Move down and left after self-inserting character in Picture mode." - (interactive) - (picture-set-motion 1 -1)) - -(defun picture-movement-se () - "Move down and right after self-inserting character in Picture mode." - (interactive) - (picture-set-motion 1 1)) - -(defun picture-set-motion (vert horiz) - "Set VERTICAL and HORIZONTAL increments for movement in Picture mode. -The modeline is updated to reflect the current direction." - (setq picture-vertical-step vert - picture-horizontal-step horiz) - (setq mode-name - (format "Picture:%s" - (car (nthcdr (+ 1 (% horiz 2) (* 3 (1+ (% vert 2)))) - '(nw up ne left none right sw down se))))) - (redraw-modeline) - (message nil)) - -(defun picture-move () - "Move in direction of `picture-vertical-step' and `picture-horizontal-step'." - (picture-move-down picture-vertical-step) - (picture-forward-column picture-horizontal-step)) - -(defun picture-motion (arg) - "Move point in direction of current picture motion in Picture mode. -With ARG do it that many times. Useful for delineating rectangles in -conjunction with diagonal picture motion. -Do \\[command-apropos] picture-movement to see commands which control motion." - (interactive "p") - (picture-move-down (* arg picture-vertical-step)) - (picture-forward-column (* arg picture-horizontal-step))) - -(defun picture-motion-reverse (arg) - "Move point in direction opposite of current picture motion in Picture mode. -With ARG do it that many times. Useful for delineating rectangles in -conjunction with diagonal picture motion. -Do \\[command-apropos] `picture-movement' to see commands which control motion." - (interactive "p") - (picture-motion (- arg))) - - -;; Picture insertion and deletion. - -(defun picture-self-insert (arg) - "Insert this character in place of character previously at the cursor. -The cursor then moves in the direction you previously specified -with the commands `picture-movement-right', `picture-movement-up', etc. -Do \\[command-apropos] `picture-movement' to see those commands." - (interactive "p") - (while (> arg 0) - (setq arg (1- arg)) - (move-to-column-force (1+ (current-column))) - (delete-char -1) - ;; FSF changes the following to last-command-event. - (insert last-command-char) - (forward-char -1) - (picture-move) - ;; XEmacs addition: - (setq zmacs-region-stays nil))) - -(defun picture-clear-column (arg) - "Clear out ARG columns after point without moving." - (interactive "p") - (let* ((opoint (point)) - (original-col (current-column)) - (target-col (+ original-col arg))) - (move-to-column-force target-col) - (delete-region opoint (point)) - (save-excursion - (indent-to (max target-col original-col))))) - -(defun picture-backward-clear-column (arg) - "Clear out ARG columns before point, moving back over them." - (interactive "p") - (picture-clear-column (- arg))) - -(defun picture-clear-line (arg) - "Clear out rest of line; if at end of line, advance to next line. -Cleared-out line text goes into the kill ring, as do newlines that are -advanced over. With argument, clear out (and save in kill ring) that -many lines." - (interactive "P") - (if arg - (progn - (setq arg (prefix-numeric-value arg)) - (kill-line arg) - (newline (if (> arg 0) arg (- arg)))) - (if (looking-at "[ \t]*$") - (kill-ring-save (point) (progn (forward-line 1) (point))) - (kill-region (point) (progn (end-of-line) (point)))) - ;; XEmacs addition: - (setq zmacs-region-stays nil))) - -(defun picture-newline (arg) - "Move to the beginning of the following line. -With argument, moves that many lines (up, if negative argument); -always moves to the beginning of a line." - (interactive "p") - (if (< arg 0) - (forward-line arg) - (while (> arg 0) - (end-of-line) - (if (eobp) (newline) (forward-char 1)) - (setq arg (1- arg)))) - ) - -(defun picture-open-line (arg) - "Insert an empty line after the current line. -With positive argument insert that many lines." - (interactive "p") - (save-excursion - (end-of-line) - (open-line arg)) - ) - -(defun picture-duplicate-line () - "Insert a duplicate of the current line, below it." - (interactive) - (save-excursion - (let ((contents - (buffer-substring - (progn (beginning-of-line) (point)) - (progn (picture-newline 1) (point))))) - (forward-line -1) - (insert contents)))) - -;; Like replace-match, but overwrites. -(defun picture-replace-match (newtext fixedcase literal) - (let (ocolumn change pos) - (goto-char (setq pos (match-end 0))) - (setq ocolumn (current-column)) - ;; Make the replacement and undo it, to see how it changes the length. - (let ((buffer-undo-list nil) - list1) - (replace-match newtext fixedcase literal) - (setq change (- (current-column) ocolumn)) - (setq list1 buffer-undo-list) - (while list1 - (setq list1 (primitive-undo 1 list1)))) - (goto-char pos) - (if (> change 0) - (delete-region (point) - (progn - (move-to-column-force (+ change (current-column))) - (point)))) - (replace-match newtext fixedcase literal) - (if (< change 0) - (insert-char ?\ (- change))))) - -;; Picture Tabs - -(defvar picture-tab-chars "!-~" - "*A character set which controls behavior of commands -\\[picture-set-tab-stops] and \\[picture-tab-search]. It is NOT a -regular expression, any regexp special characters will be quoted. -It defines a set of \"interesting characters\" to look for when setting -\(or searching for) tab stops, initially \"!-~\" (all printing characters). -For example, suppose that you are editing a table which is formatted thus: -| foo | bar + baz | 23 * -| bubbles | and + etc | 97 * -and that `picture-tab-chars' is \"|+*\". Then invoking -\\[picture-set-tab-stops] on either of the previous lines would result -in the following tab stops - : : : : -Another example - \"A-Za-z0-9\" would produce the tab stops - : : : : - -Note that if you want the character `-' to be in the set, it must be -included in a range or else appear in a context where it cannot be -taken for indicating a range (e.g. \"-A-Z\" declares the set to be the -letters `A' through `Z' and the character `-'). If you want the -character `\\' in the set it must be preceded by itself: \"\\\\\". - -The command \\[picture-tab-search] is defined to move beneath (or to) a -character belonging to this set independent of the tab stops list.") - -(defun picture-set-tab-stops (&optional arg) - "Set value of `tab-stop-list' according to context of this line. -This controls the behavior of \\[picture-tab]. A tab stop is set at -every column occupied by an \"interesting character\" that is preceded -by whitespace. Interesting characters are defined by the variable -`picture-tab-chars', see its documentation for an example of usage. -With ARG, just (re)set `tab-stop-list' to its default value. The tab -stops computed are displayed in the minibuffer with `:' at each stop." - (interactive "P") - (save-excursion - (let (tabs) - (if arg - (setq tabs (default-value 'tab-stop-list)) - (let ((regexp (concat "[ \t]+[" (regexp-quote picture-tab-chars) "]"))) - (beginning-of-line) - (let ((bol (point))) - (end-of-line) - (while (re-search-backward regexp bol t) - (skip-chars-forward " \t") - (setq tabs (cons (current-column) tabs))) - (if (null tabs) - (error "No characters in set %s on this line." - (regexp-quote picture-tab-chars)))))) - (setq tab-stop-list tabs) - (let ((blurb (make-string (1+ (nth (1- (length tabs)) tabs)) ?\ ))) - (while tabs - (aset blurb (car tabs) ?:) - (setq tabs (cdr tabs))) - (message blurb))))) - -(defun picture-tab-search (&optional arg) - "Move to column beneath next interesting char in previous line. -With ARG move to column occupied by next interesting character in this -line. The character must be preceded by whitespace. -\"interesting characters\" are defined by variable `picture-tab-chars'. -If no such character is found, move to beginning of line." - (interactive "P") - (let ((target (current-column))) - (save-excursion - (if (and (not arg) - (progn - (beginning-of-line) - (skip-chars-backward - (concat "^" (regexp-quote picture-tab-chars)) - (point-min)) - (not (bobp)))) - (move-to-column target)) - (if (re-search-forward - (concat "[ \t]+[" (regexp-quote picture-tab-chars) "]") - (save-excursion (end-of-line) (point)) - 'move) - (setq target (1- (current-column))) - (setq target nil))) - (if target - (move-to-column-force target) - (beginning-of-line)))) - -(defun picture-tab (&optional arg) - "Tab transparently (just move point) to next tab stop. -With prefix arg, overwrite the traversed text with spaces. The tab stop -list can be changed by \\[picture-set-tab-stops] and \\[edit-tab-stops]. -See also documentation for variable `picture-tab-chars'." - (interactive "P") - (let* ((opoint (point))) - (move-to-tab-stop) - (if arg - (let (indent-tabs-mode - (column (current-column))) - (delete-region opoint (point)) - (indent-to column)) - ;; XEmacs addition: - (setq zmacs-region-stays t)))) - -;; Picture Rectangles - -(defconst picture-killed-rectangle nil - "Rectangle killed or copied by \\[picture-clear-rectangle] in Picture mode. -The contents can be retrieved by \\[picture-yank-rectangle]") - -(defun picture-clear-rectangle (start end &optional killp) - "Clear and save rectangle delineated by point and mark. -The rectangle is saved for yanking by \\[picture-yank-rectangle] and replaced -with whitespace. The previously saved rectangle, if any, is lost. With -prefix argument, the rectangle is actually killed, shifting remaining text." - (interactive "r\nP") - (setq picture-killed-rectangle (picture-snarf-rectangle start end killp))) - -(defun picture-clear-rectangle-to-register (start end register &optional killp) - "Clear rectangle delineated by point and mark into REGISTER. -The rectangle is saved in REGISTER and replaced with whitespace. With -prefix argument, the rectangle is actually killed, shifting remaining text." - (interactive "r\ncRectangle to register: \nP") - (set-register register (picture-snarf-rectangle start end killp))) - -(defun picture-snarf-rectangle (start end &optional killp) - (let ((column (current-column)) - (indent-tabs-mode nil)) - (prog1 (save-excursion - (if killp - (delete-extract-rectangle start end) - (prog1 (extract-rectangle start end) - (clear-rectangle start end)))) - (move-to-column-force column) - ;; XEmacs addition: - (setq zmacs-region-stays nil)))) - -(defun picture-yank-rectangle (&optional insertp) - "Overlay rectangle saved by \\[picture-clear-rectangle] -The rectangle is positioned with upper left corner at point, overwriting -existing text. With prefix argument, the rectangle is inserted instead, -shifting existing text. Leaves mark at one corner of rectangle and -point at the other (diagonally opposed) corner." - (interactive "P") - (if (not (consp picture-killed-rectangle)) - (error "No rectangle saved.") - (picture-insert-rectangle picture-killed-rectangle insertp))) - -(defun picture-yank-at-click (click arg) - "Insert the last killed rectangle at the position clicked on. -Also move point to one end of the text thus inserted (normally the end). -Prefix arguments are interpreted as with \\[yank]. -If `mouse-yank-at-point' is non-nil, insert at point -regardless of where you click." - (interactive "e\nP") - (or mouse-yank-at-point (mouse-set-point click)) - (picture-yank-rectangle arg)) - -(defun picture-yank-rectangle-from-register (register &optional insertp) - "Overlay rectangle saved in REGISTER. -The rectangle is positioned with upper left corner at point, overwriting -existing text. With prefix argument, the rectangle is -inserted instead, shifting existing text. Leaves mark at one corner -of rectangle and point at the other (diagonally opposed) corner." - (interactive "cRectangle from register: \nP") - (let ((rectangle (get-register register))) - (if (not (consp rectangle)) - (error "Register %c does not contain a rectangle." register) - (picture-insert-rectangle rectangle insertp)))) - -(defun picture-insert-rectangle (rectangle &optional insertp) - "Overlay RECTANGLE with upper left corner at point. -Optional argument INSERTP, if non-nil causes RECTANGLE to be inserted. -Leaves the region surrounding the rectangle." - (let ((indent-tabs-mode nil)) - (if (not insertp) - (save-excursion - (delete-rectangle (point) - (progn - (picture-forward-column (length (car rectangle))) - (picture-move-down (1- (length rectangle))) - (point))))) - (push-mark) - (insert-rectangle rectangle))) - - -;; Picture Keymap, entry and exit points. - -(defconst picture-mode-map nil) - -(defun picture-substitute (oldfun newfun) - (substitute-key-definition oldfun newfun picture-mode-map global-map)) - -(if (not picture-mode-map) - (progn - (setq picture-mode-map (make-keymap 'picture-mode-map)) - (picture-substitute 'self-insert-command 'picture-self-insert) - (picture-substitute 'forward-char 'picture-forward-column) - (picture-substitute 'backward-char 'picture-backward-column) - (picture-substitute 'delete-char 'picture-clear-column) - ;; There are two possibilities for what is normally on DEL. - (picture-substitute 'backward-delete-char-untabify 'picture-backward-clear-column) - (picture-substitute 'delete-backward-char 'picture-backward-clear-column) - (picture-substitute 'kill-line 'picture-clear-line) - (picture-substitute 'open-line 'picture-open-line) - (picture-substitute 'newline 'picture-newline) - (picture-substitute 'newline-and-indent 'picture-duplicate-line) - (picture-substitute 'next-line 'picture-move-down) - (picture-substitute 'previous-line 'picture-move-up) - (picture-substitute 'beginning-of-line 'picture-beginning-of-line) - (picture-substitute 'end-of-line 'picture-end-of-line) - - (define-key picture-mode-map "\C-c\C-d" 'delete-char) - (define-key picture-mode-map "\e\t" 'picture-toggle-tab-state) - (define-key picture-mode-map "\t" 'picture-tab) - (define-key picture-mode-map "\e\t" 'picture-tab-search) - (define-key picture-mode-map "\C-c\t" 'picture-set-tab-stops) - (define-key picture-mode-map "\C-c\C-k" 'picture-clear-rectangle) - (define-key picture-mode-map "\C-c\C-w" 'picture-clear-rectangle-to-register) - (define-key picture-mode-map "\C-c\C-y" 'picture-yank-rectangle) - (define-key picture-mode-map "\C-c\C-x" 'picture-yank-rectangle-from-register) - (define-key picture-mode-map "\C-c\C-c" 'picture-mode-exit) - (define-key picture-mode-map "\C-c\C-f" 'picture-motion) - (define-key picture-mode-map "\C-c\C-b" 'picture-motion-reverse) - (define-key picture-mode-map "\C-c<" 'picture-movement-left) - (define-key picture-mode-map "\C-c>" 'picture-movement-right) - (define-key picture-mode-map "\C-c^" 'picture-movement-up) - (define-key picture-mode-map "\C-c." 'picture-movement-down) - (define-key picture-mode-map "\C-c`" 'picture-movement-nw) - (define-key picture-mode-map "\C-c'" 'picture-movement-ne) - (define-key picture-mode-map "\C-c/" 'picture-movement-sw) - (define-key picture-mode-map "\C-c\\" 'picture-movement-se))) - -(defvar picture-mode-hook nil - "If non-nil, its value is called on entry to Picture mode. -Picture mode is invoked by the command \\[picture-mode].") - -(defvar picture-mode-old-local-map) -(defvar picture-mode-old-mode-name) -(defvar picture-mode-old-major-mode) -(defvar picture-mode-old-truncate-lines) - -;;;###autoload -(defun picture-mode () - "Switch to Picture mode, in which a quarter-plane screen model is used. -Printing characters replace instead of inserting themselves with motion -afterwards settable by these commands: - C-c < Move left after insertion. - C-c > Move right after insertion. - C-c ^ Move up after insertion. - C-c . Move down after insertion. - C-c ` Move northwest (nw) after insertion. - C-c ' Move northeast (ne) after insertion. - C-c / Move southwest (sw) after insertion. - C-c \\ Move southeast (se) after insertion. -The current direction is displayed in the modeline. The initial -direction is right. Whitespace is inserted and tabs are changed to -spaces when required by movement. You can move around in the buffer -with these commands: - \\[picture-move-down] Move vertically to SAME column in previous line. - \\[picture-move-up] Move vertically to SAME column in next line. - \\[picture-end-of-line] Move to column following last non-whitespace character. - \\[picture-forward-column] Move right inserting spaces if required. - \\[picture-backward-column] Move left changing tabs to spaces if required. - C-c C-f Move in direction of current picture motion. - C-c C-b Move in opposite direction of current picture motion. - Return Move to beginning of next line. -You can edit tabular text with these commands: - M-Tab Move to column beneath (or at) next interesting character. - `Indents' relative to a previous line. - Tab Move to next stop in tab stop list. - C-c Tab Set tab stops according to context of this line. - With ARG resets tab stops to default (global) value. - See also documentation of variable picture-tab-chars - which defines \"interesting character\". You can manually - change the tab stop list with command \\[edit-tab-stops]. -You can manipulate text with these commands: - C-d Clear (replace) ARG columns after point without moving. - C-c C-d Delete char at point - the command normally assigned to C-d. - \\[picture-backward-clear-column] Clear (replace) ARG columns before point, moving back over them. - \\[picture-clear-line] Clear ARG lines, advancing over them. The cleared - text is saved in the kill ring. - \\[picture-open-line] Open blank line(s) beneath current line. -You can manipulate rectangles with these commands: - C-c C-k Clear (or kill) a rectangle and save it. - C-c C-w Like C-c C-k except rectangle is saved in named register. - C-c C-y Overlay (or insert) currently saved rectangle at point. - C-c C-x Like C-c C-y except rectangle is taken from named register. - \\[copy-rectangle-to-register] Copies a rectangle to a register. - \\[advertised-undo] Can undo effects of rectangle overlay commands - commands if invoked soon enough. -You can return to the previous mode with: - C-c C-c Which also strips trailing whitespace from every line. - Stripping is suppressed by supplying an argument. - -Entry to this mode calls the value of picture-mode-hook if non-nil. - -Note that Picture mode commands will work outside of Picture mode, but -they are not defaultly assigned to keys." - (interactive) - (if (eq major-mode 'picture-mode) - (error "You are already editing a picture.") - (make-local-variable 'picture-mode-old-local-map) - (setq picture-mode-old-local-map (current-local-map)) - (use-local-map picture-mode-map) - (make-local-variable 'picture-mode-old-mode-name) - (setq picture-mode-old-mode-name mode-name) - (make-local-variable 'picture-mode-old-major-mode) - (setq picture-mode-old-major-mode major-mode) - (setq major-mode 'picture-mode) - (make-local-variable 'picture-killed-rectangle) - (setq picture-killed-rectangle nil) - (make-local-variable 'tab-stop-list) - (setq tab-stop-list (default-value 'tab-stop-list)) - (make-local-variable 'picture-tab-chars) - (setq picture-tab-chars (default-value 'picture-tab-chars)) - (make-local-variable 'picture-vertical-step) - (make-local-variable 'picture-horizontal-step) - (make-local-variable 'picture-mode-old-truncate-lines) - (setq picture-mode-old-truncate-lines truncate-lines) - (setq truncate-lines t) - - ;; XEmacs addition: - (make-local-variable 'mouse-track-rectangle-p) - (setq mouse-track-rectangle-p t) - - (picture-set-motion 0 1) - - ;; edit-picture-hook is what we used to run, picture-mode-hook is in doc. - (run-hooks 'edit-picture-hook 'picture-mode-hook) - (message - (substitute-command-keys - "Type \\[picture-mode-exit] in this buffer to return it to %s mode.") - picture-mode-old-mode-name))) - -;;;###autoload -(defalias 'edit-picture 'picture-mode) - -(defun picture-mode-exit (&optional nostrip) - "Undo picture-mode and return to previous major mode. -With no argument strips whitespace from end of every line in Picture buffer - otherwise just return to previous mode." - (interactive "P") - (if (not (eq major-mode 'picture-mode)) - (error "You aren't editing a Picture.") - (if (not nostrip) (picture-clean)) - (setq mode-name picture-mode-old-mode-name) - (use-local-map picture-mode-old-local-map) - (setq major-mode picture-mode-old-major-mode) - (kill-local-variable 'tab-stop-list) - (setq truncate-lines picture-mode-old-truncate-lines) - ;; XEmacs change/addition: - (kill-local-variable 'mouse-track-rectangle-p) - (redraw-modeline))) - -(defun picture-clean () - "Eliminate whitespace at ends of lines." - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "[ \t][ \t]*$" nil t) - (delete-region (match-beginning 0) (point))))) - -(provide 'picture) - -;;; picture.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/postscript.el --- a/lisp/modes/postscript.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,354 +0,0 @@ -;;; postscript.el --- major mode for editing PostScript programs - -;; Keywords: langauges - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Not in FSF. - -;; -;; Author: Chris Maio -;; Last edit: 4 Sep 1988 -;; Includes patches from relph@presto.ig.com (John M. Relph) posted to -;; gnu.emacs.sources on 22 Nov 90 04:53:43 GMT. -;; -;; The following two statements, placed in your .emacs file or site-init.el, -;; will cause this file to be autoloaded, and postscript-mode invoked, when -;; visiting .ps or .cps files: -;; -;; (autoload 'postscript-mode "postscript.el" "" t) -;; (setq auto-mode-alist -;; (cons '("\\.c?ps$".postscript-mode) auto-mode-alist)) -;; - -(provide 'postscript) - -(defconst ps-indent-level 2 - "*Indentation to be used inside of PostScript blocks or arrays") - -(defconst ps-tab-width 8 - "*Tab stop width for PostScript mode") - -(defun ps-make-tabs (stop) - (and (< stop 132) (cons stop (ps-make-tabs (+ stop ps-tab-width))))) - -(defconst ps-tab-stop-list (ps-make-tabs ps-tab-width) - "*Tab stop list for PostScript mode") - -(defconst ps-postscript-command '("gs" "-") - "*Command used to invoke with a printer spooler or NeWS server.") - -(defvar ps-mode-map nil - "Keymap used in PostScript mode buffers") - -(defvar ps-mode-syntax-table nil - "PostScript mode syntax table") - -(defvar ps-balanced-string-syntax-p - (let ((b (current-buffer)) - (loser (generate-new-buffer "x"))) - (unwind-protect - (progn - (set-buffer loser) - (set-syntax-table (copy-syntax-table)) - (modify-syntax-entry ?\( "\"\)") - (insert "((") - (let ((v (parse-partial-sexp (point-min) (point-max)))) - (if (elt v 3) - ;; New syntax code think's we're still inside a string - t - nil))) - (set-buffer b) - (kill-buffer loser)))) - -(defconst postscript-font-lock-keywords (purecopy - (list - ;; Proper rule for Postscript strings - '("(\\([^)]\\|\\\\.\\|\\\\\n\\)*)" . font-lock-string-face) - ;; Make any line beginning with a / be a ``keyword'' - '("^/[^\n%]*" . font-lock-keyword-face) - ;; Make brackets of all forms be keywords - '("[][<>{}]+" . font-lock-keyword-face) - ;; Keywords - (list (concat - "[][ \t\f\n\r()<>{}/%]" ;delimiter - "\\(" - (mapconcat 'identity - '("begin" "end" - "save" "restore" "gsave" "grestore" - ;; Any delimited name ending in 'def' - "[a-zA-Z0-9-._]*def" - "[Dd]efine[a-zA-Z0-9-._]*") - "\\|") - "\\)" - "\\([][ \t\f\n\r()<>{}/%]\\|$\\)" ;delimiter - ) - 1 'font-lock-keyword-face))) - "Expressions to highlight in Postscript buffers.") -(put 'postscript-mode 'font-lock-defaults '(postscript-font-lock-keywords)) - -(if ps-mode-syntax-table - nil - (let ((i 0)) - (setq ps-mode-syntax-table (copy-syntax-table nil)) - (while (< i 256) - (or (= (char-syntax i ps-mode-syntax-table) ?w) - (modify-syntax-entry i "_" ps-mode-syntax-table)) - (setq i (1+ i))) - (modify-syntax-entry ?\ " " ps-mode-syntax-table) - (modify-syntax-entry ?\t " " ps-mode-syntax-table) - (modify-syntax-entry ?\f " " ps-mode-syntax-table) - (modify-syntax-entry ?\r " " ps-mode-syntax-table) - (modify-syntax-entry ?\% "<" ps-mode-syntax-table) - (modify-syntax-entry ?\n ">" ps-mode-syntax-table) - (modify-syntax-entry ?\\ "\\" ps-mode-syntax-table) - (modify-syntax-entry ?? "_" ps-mode-syntax-table) - (modify-syntax-entry ?_ "_" ps-mode-syntax-table) - (modify-syntax-entry ?. "_" ps-mode-syntax-table) - (modify-syntax-entry ?/ "'" ps-mode-syntax-table) - (if ps-balanced-string-syntax-p - (progn - (modify-syntax-entry ?\( "\"\)" ps-mode-syntax-table) - (modify-syntax-entry ?\) "\"\(" ps-mode-syntax-table)) - (progn - ;; This isn't correct, but Emacs syntax stuff - ;; has no way to deal with string syntax which uses - ;; different open and close characters. Sigh. - (modify-syntax-entry ?\( "(" ps-mode-syntax-table) - (modify-syntax-entry ?\) ")" ps-mode-syntax-table))) - (modify-syntax-entry ?\[ "(\]" ps-mode-syntax-table) - (modify-syntax-entry ?\] ")\[" ps-mode-syntax-table) - (modify-syntax-entry ?\{ "\(\}" ps-mode-syntax-table) - (modify-syntax-entry ?\} "\)\}" ps-mode-syntax-table) - (modify-syntax-entry ?/ "' p" ps-mode-syntax-table) - )) - - -;;;###autoload -(defun postscript-mode () - "Major mode for editing PostScript files. - -\\[ps-execute-buffer] will send the contents of the buffer to the NeWS -server using psh(1). \\[ps-execute-region] sends the current region. -\\[ps-shell] starts an interactive psh(1) window which will be used for -subsequent \\[ps-execute-buffer] or \\[ps-execute-region] commands. - -In this mode, TAB and \\[indent-region] attempt to indent code -based on the position of {}, [], and begin/end pairs. The variable -ps-indent-level controls the amount of indentation used inside -arrays and begin/end pairs. - -\\{ps-mode-map} - -\\[postscript-mode] calls the value of the variable postscript-mode-hook -with no args, if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map ps-mode-map) - (set-syntax-table ps-mode-syntax-table) - (make-local-variable 'comment-start) - (setq comment-start "% ") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "%+ *") - (make-local-variable 'comment-column) - (setq comment-column 40) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'ps-indent-line) - (make-local-variable 'tab-stop-list) - (setq tab-stop-list ps-tab-stop-list) - (make-local-variable 'page-delimiter) - (setq page-delimiter "^showpage") - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - (setq mode-name "PostScript") - (setq major-mode 'postscript-mode) - (run-hooks 'ps-mode-hook) ; bad name! Kept for compatibility. - (run-hooks 'postscript-mode-hook) - ) - -(defun ps-tab () - "Command assigned to the TAB key in PostScript mode." - (interactive) - (if (save-excursion (skip-chars-backward " \t") (bolp)) - (ps-indent-line) - (save-excursion - (ps-indent-line)))) - -(defun ps-indent-line () - "Indents a line of PostScript code." - (interactive) - (beginning-of-line) - (delete-horizontal-space) - (if (not (or (looking-at "%%") ; "%%" comments stay at left margin - (ps-top-level-p))) - (if (and (< (point) (point-max)) - (eq ?\) (char-syntax (char-after (point))))) - (ps-indent-close) ; indent close-delimiter - (if (looking-at "\\(dict\\|class\\)?end\\|cdef\\|grestore\\|>>") - (ps-indent-end) ; indent end token - (ps-indent-in-block))))) ; indent line after open delimiter - -;(defun ps-open () -; (interactive) -; (insert last-command-char)) - -(defun ps-insert-d-char (arg) - "Awful hack to make \"end\" and \"cdef\" keywords indent themselves." - (interactive "p") - (insert-char last-command-char arg) - (save-excursion - (beginning-of-line) - (if (looking-at "^[ \t]*\\(\\(dict\\|class\\)?end\\|cdef\\|grestore\\)") - (progn - (delete-horizontal-space) - (ps-indent-end))))) - -(defun ps-close () - "Inserts and indents a close delimiter." - (interactive) - (insert last-command-char) - (backward-char 1) - (ps-indent-close) - (forward-char 1) - (blink-matching-open)) - -(defun ps-indent-close () - "Internal function to indent a line containing a an array close delimiter." - (if (save-excursion (skip-chars-backward " \t") (bolp)) - (let (x (oldpoint (point))) - (forward-char) (backward-sexp) ;XXX - (if (and (eq 1 (count-lines (point) oldpoint)) - (> 1 (- oldpoint (point)))) - (goto-char oldpoint) - (beginning-of-line) - (skip-chars-forward " \t") - (setq x (current-column)) - (goto-char oldpoint) - (delete-horizontal-space) - (indent-to x))))) - -(defun ps-indent-end () - "Indent an \"end\" token or array close delimiter." - (let ((goal (ps-block-start))) - (if (not goal) - (indent-relative) - (setq goal (save-excursion - (goto-char goal) (back-to-indentation) (current-column))) - (indent-to goal)))) - -(defun ps-indent-in-block () - "Indent a line which does not open or close a block." - (let ((goal (ps-block-start))) - (setq goal (save-excursion - (goto-char goal) - (back-to-indentation) - (if (bolp) - ps-indent-level - (back-to-indentation) - (+ (current-column) ps-indent-level)))) - (indent-to goal))) - -;;; returns nil if at top-level, or char pos of beginning of current block -(defun ps-block-start () - "Returns the character position of the character following the nearest -enclosing `[' `{' or `begin' keyword." - (save-excursion - (let ((open (condition-case nil - (save-excursion - (backward-up-list 1) - (1+ (point))) - (error nil)))) - (ps-begin-end-hack open)))) - -(defun ps-begin-end-hack (start) - "Search backwards from point to START for enclosing `begin' and returns the -character number of the character following `begin' or START if not found." - (save-excursion - (let ((depth 1)) - (while (and (> depth 0) - (or (re-search-backward "^[ \t]*\\(dict\\|class\\)?\\(end\\|grestore\\|>>\\)\\|\\(begin\\|gsave\\|<<\\)[ \t]*\\(%.*\\)*$" - start t) - (re-search-backward "^[ \t]*cdef.*$" start t))) - (setq depth (if (looking-at "[ \t]*\\(dict\\|class\\)?\\(end\\|grestore\\|>>\\)") - (1+ depth) (1- depth)))) - (if (not (eq 0 depth)) - start - (forward-word 1) - (point))))) - -(defun ps-top-level-p () - "Awful test to see whether we are inside some sort of PostScript block." - (and (condition-case nil - (not (scan-lists (point) -1 1)) - (error t)) - (not (ps-begin-end-hack nil)))) - -;;; initialize the keymap if it doesn't already exist -(if (null ps-mode-map) - (progn - (setq ps-mode-map (make-sparse-keymap)) - (set-keymap-name ps-mode-map 'ps-mode-map) - ;;(define-key ps-mode-map "d" 'ps-insert-d-char) - ;;(define-key ps-mode-map "f" 'ps-insert-d-char) - ;;(define-key ps-mode-map "{" 'ps-open) - ;;(define-key ps-mode-map "}" 'ps-close) - ;;(define-key ps-mode-map "[" 'ps-open) - ;;(define-key ps-mode-map "]" 'ps-close) - (define-key ps-mode-map "\t" 'ps-tab) - (define-key ps-mode-map "\C-c\C-c" 'ps-execute-buffer) - (define-key ps-mode-map "\C-c|" 'ps-execute-region) - ;; make up yout mind! -- the below or the above? - (define-key ps-mode-map "\C-c!" 'ps-shell) - )) - -(defun ps-execute-buffer () - "Send the contents of the buffer to a printer or NeWS server." - (interactive) - (save-excursion - (mark-whole-buffer) - (ps-execute-region (point-min) (point-max)))) - -(defun ps-execute-region (start end) - "Send the region between START and END to a printer or NeWS server. -You should kill any existing *PostScript* buffer unless you want the -PostScript text to be executed in that process." - (interactive "r") - (let ((start (min (point) (mark))) - (end (max (point) (mark)))) - (condition-case nil - (process-send-string "PostScript" (buffer-substring start end)) - (error (shell-command-on-region - start end - (mapconcat 'identity ps-postscript-command " ") - nil))))) - -(defun ps-shell () - "Start a shell communicating with a PostScript printer or NeWS server." - (interactive) - (require 'shell) - (switch-to-buffer-other-window - (apply 'make-comint - "PostScript" - (car ps-postscript-command) - nil - (cdr ps-postscript-command))) - (make-local-variable 'shell-prompt-pattern) -; (setq shell-prompt-pattern "PS>") - (setq shell-prompt-pattern "GS>") -; (process-send-string "PostScript" "executive\n") - ) diff -r 43306a74e31c -r d44af0c54775 lisp/modes/prolog.el --- a/lisp/modes/prolog.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,332 +0,0 @@ -;;; prolog.el --- major mode for editing and running Prolog under Emacs - -;; Copyright (C) 1986, 1987, 1993 Free Software Foundation, Inc. - -;; Author: Masanobu UMEDA -;; Keywords: languages - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Not synched with FSF, we appear to have a newer version - -;;; Commentary: - -;; This package provides a major mode for editing Prolog. It knows -;; about Prolog syntax and comments, and can send regions to an inferior -;; Prolog interpreter process. - -;;; Code: - -(defvar prolog-mode-syntax-table nil) -(defvar prolog-mode-abbrev-table nil) -(defvar prolog-mode-map nil) - -(defgroup prolog nil - "Major mode for editing and running Prolog under Emacs" - :group 'languages) - - -(defcustom prolog-program-name "prolog" - "*Program name for invoking an inferior Prolog with `run-prolog'." - :type 'string - :group 'prolog) - -(defcustom prolog-consult-string "reconsult(user).\n" - "*(Re)Consult mode (for C-Prolog and Quintus Prolog). " - :type 'string - :group 'prolog) - -(defcustom prolog-compile-string "compile(user).\n" - "*Compile mode (for Quintus Prolog)." - :type 'string - :group 'prolog) - -(defcustom prolog-eof-string "end_of_file.\n" - "*String that represents end of file for prolog. -nil means send actual operating system end of file." - :type 'string - :group 'prolog) - -(defcustom prolog-indent-width 4 - "Level of indentation in Prolog buffers." - :type 'integer - :group 'prolog) - -(defconst prolog-font-lock-keywords (purecopy - (list - (cons (concat - "[( \t]\\(" - (mapconcat 'identity - '("write" "writeq" "nl" "is" "call" "read" "get" "get0" - "tell" "told" "open" "close" "format" "put" - "assert" "asserta" "assertz" - "retract" "retractall" "clause" - "record" "recorda" "abolish" - "setof" "bagof" "findall" "sort" "compare" - "var" "nonvar" "integer" "float" "number" "ground" - "atom" "atomic" "simple" "callable" "compound" - "functor" "arg" "copy_term" "numbervars" - "atom_chars" "number_chars" "atom_to_chars" - "length" "unix" "halt" - "op" "dynamic" "meta_predicate" "raise_exception" - "module" "ensure_loaded" "use_module" - "fail" "true" - "module_interface" "begin_module" "define_struct" - "import" "export" "global" "tool" "external" - "define_macro" "local" "library" "from" - ) - "\\|") - "\\)[ .,\t\n()]") - 1) - '("^[a-z][a-zA-Z0-9_]+" 0 font-lock-function-name-face) -; '("[@!$#]" 0 font-lock-function-name-face) - '("!" 0 font-lock-function-name-face) - '("@" 0 font-lock-function-name-face) - '("<=>" 0 font-lock-function-name-face) - '("==>" 0 font-lock-function-name-face) - '(";" 0 font-lock-function-name-face) - '(":-" 0 font-lock-function-name-face) - '("\\[" 0 font-lock-keyword-face) - '("\\]" 0 font-lock-keyword-face) - '("|" 0 font-lock-keyword-face) - )) - "Additional expressions to highlight in Prolog mode.") - -(if prolog-mode-syntax-table - () - (let ((table (make-syntax-table))) - (modify-syntax-entry ?/ ". 14" table) - (modify-syntax-entry ?* ". 23" table) - (modify-syntax-entry ?% "< b" table) - (modify-syntax-entry ?\n "> b" table) - (modify-syntax-entry ?_ "w" table) - (modify-syntax-entry ?\\ "\\" table) - (modify-syntax-entry ?\' "\"" table) - (modify-syntax-entry ?+ "." table) - (modify-syntax-entry ?- "." table) - (modify-syntax-entry ?= "." table) - (modify-syntax-entry ?< "." table) - (modify-syntax-entry ?> "." table) - (setq prolog-mode-syntax-table table))) - -(define-abbrev-table 'prolog-mode-abbrev-table ()) - -(defun prolog-mode-variables () - (set-syntax-table prolog-mode-syntax-table) - (setq local-abbrev-table prolog-mode-abbrev-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "%%\\|$\\|" page-delimiter)) ;'%%..' - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'prolog-indent-line) - (make-local-variable 'comment-start) - (setq comment-start "%") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "%+ *") - (make-local-variable 'comment-column) - (setq comment-column 48) - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'prolog-comment-indent)) - -(defun prolog-mode-commands (map) - (define-key map "\t" 'prolog-indent-line) - (define-key map "\e\C-x" 'prolog-consult-region)) - -(if prolog-mode-map - nil - (setq prolog-mode-map (make-sparse-keymap)) - (prolog-mode-commands prolog-mode-map)) - -;;;###autoload -(defun prolog-mode () - "Major mode for editing Prolog code for Prologs. -Blank lines and `%%...' separate paragraphs. `%'s start comments. -Commands: -\\{prolog-mode-map} -Entry to this mode calls the value of `prolog-mode-hook' -if that value is non-nil." - (interactive) - (kill-all-local-variables) - (use-local-map prolog-mode-map) - (setq major-mode 'prolog-mode) - (setq mode-name "Prolog") - (prolog-mode-variables) - (run-hooks 'prolog-mode-hook)) - -(defun prolog-indent-line (&optional whole-exp) - "Indent current line as Prolog code. -With argument, indent any additional lines of the same clause -rigidly along with this one (not yet)." - (interactive "p") - (let ((indent (prolog-indent-level)) - (pos (- (point-max) (point))) beg) - (beginning-of-line) - (setq beg (point)) - (skip-chars-forward " \t") - (if (zerop (- indent (current-column))) - nil - (delete-region beg (point)) - (indent-to indent)) - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos))) - )) - -(defun prolog-indent-level () - "Compute prolog indentation level." - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (cond - ((looking-at "%%%") 0) ;Large comment starts - ((looking-at "%[^%]") comment-column) ;Small comment starts - ((bobp) 0) ;Beginning of buffer - (t - (let ((empty t) ind more less) - (if (looking-at ")") - (setq less t) ;Find close - (setq less nil)) - ;; See previous indentation - (while empty - (forward-line -1) - (beginning-of-line) - (if (bobp) - (setq empty nil) - (skip-chars-forward " \t") - (if (not (or (looking-at "%[^%]") (looking-at "\n"))) - (setq empty nil)))) - (if (bobp) - (setq ind 0) ;Beginning of buffer - (setq ind (current-column))) ;Beginning of clause - ;; See its beginning - (if (looking-at "%%[^%]") - ind - ;; Real prolog code - (if (looking-at "(") - (setq more t) ;Find open - (setq more nil)) - ;; See its tail - (end-of-prolog-clause) - (or (bobp) (forward-char -1)) - (cond ((looking-at "[,(;>]") - (if (and more (looking-at "[^,]")) - (+ ind prolog-indent-width) ;More indentation - (max tab-width ind))) ;Same indentation - ((looking-at "-") tab-width) ;TAB - ((or less (looking-at "[^.]")) - (max (- ind prolog-indent-width) 0)) ;Less indentation - (t 0)) ;No indentation - ))) - ))) - -(defun end-of-prolog-clause () - "Go to end of clause in this line." - (beginning-of-line 1) - (let* ((eolpos (save-excursion (end-of-line) (point)))) - (if (re-search-forward comment-start-skip eolpos 'move) - (goto-char (match-beginning 0))) - (skip-chars-backward " \t"))) - -(defun prolog-comment-indent () - "Compute prolog comment indentation." - (cond ((looking-at "%%%") 0) - ((looking-at "%%") (prolog-indent-level)) - (t - (save-excursion - (skip-chars-backward " \t") - ;; Insert one space at least, except at left margin. - (max (+ (current-column) (if (bolp) 0 1)) - comment-column))) - )) - - -;;; -;;; Inferior prolog mode -;;; -(defvar inferior-prolog-mode-map nil) - -;;;###autoload -(defun inferior-prolog-mode () - "Major mode for interacting with an inferior Prolog process. - -The following commands are available: -\\{inferior-prolog-mode-map} - -Entry to this mode calls the value of `prolog-mode-hook' with no arguments, -if that value is non-nil. Likewise with the value of `comint-mode-hook'. -`prolog-mode-hook' is called after `comint-mode-hook'. - -You can send text to the inferior Prolog from other buffers -using the commands `send-region', `send-string' and \\[prolog-consult-region]. - -Commands: -Tab indents for Prolog; with argument, shifts rest - of expression rigidly with the current line. -Paragraphs are separated only by blank lines and '%%'. -'%'s start comments. - -Return at end of buffer sends line as input. -Return not at end copies rest of line to end and sends it. -\\[comint-kill-input] and \\[backward-kill-word] are kill commands, imitating normal Unix input editing. -\\[comint-interrupt-subjob] interrupts the shell or its current subjob if any. -\\[comint-stop-subjob] stops. \\[comint-quit-subjob] sends quit signal." - (interactive) - (require 'comint) - (comint-mode) - (setq major-mode 'inferior-prolog-mode - mode-name "Inferior Prolog" - comint-prompt-regexp "^| [ ?][- ] *") - (prolog-mode-variables) - (if inferior-prolog-mode-map nil - (setq inferior-prolog-mode-map (copy-keymap comint-mode-map)) - (prolog-mode-commands inferior-prolog-mode-map)) - (use-local-map inferior-prolog-mode-map) - (run-hooks 'prolog-mode-hook)) - -;;;###autoload -(defun run-prolog () - "Run an inferior Prolog process, input and output via buffer *prolog*." - (interactive) - (require 'comint) - (switch-to-buffer (make-comint "prolog" prolog-program-name)) - (inferior-prolog-mode)) - -(defun prolog-consult-region (compile beg end) - "Send the region to the Prolog process made by \"M-x run-prolog\". -If COMPILE (prefix arg) is not nil, use compile mode rather than consult mode." - (interactive "P\nr") - (save-excursion - (if compile - (send-string "prolog" prolog-compile-string) - (send-string "prolog" prolog-consult-string)) - (send-region "prolog" beg end) - (send-string "prolog" "\n") ;May be unnecessary - (if prolog-eof-string - (send-string "prolog" prolog-eof-string) - (process-send-eof "prolog")))) ;Send eof to prolog process. - -(defun prolog-consult-region-and-go (compile beg end) - "Send the region to the inferior Prolog, and switch to *prolog* buffer. -If COMPILE (prefix arg) is not nil, use compile mode rather than consult mode." - (interactive "P\nr") - (prolog-consult-region compile beg end) - (switch-to-buffer "*prolog*")) - -;;; prolog.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/python-mode.el --- a/lisp/modes/python-mode.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2480 +0,0 @@ -;;; python-mode.el --- Major mode for editing Python programs - -;; Copyright (C) 1992,1993,1994 Tim Peters - -;; Author: 1995-1997 Barry A. Warsaw -;; 1992-1994 Tim Peters -;; Maintainer: python-mode@python.org -;; Created: Feb 1992 -;; Version: 2.90 -;; Last Modified: 1997/02/24 03:37:22 -;; Keywords: python languages oop - -;; This software is provided as-is, without express or implied -;; warranty. Permission to use, copy, modify, distribute or sell this -;; software, without fee, for any purpose and by any individual or -;; organization, is hereby granted, provided that the above copyright -;; notice and this paragraph appear in all copies. - -;;; Commentary: - -;; This is a major mode for editing Python programs. It was developed -;; by Tim Peters after an original idea by Michael A. Guravage. Tim -;; subsequently left the net; in 1995, Barry Warsaw inherited the -;; mode and is the current maintainer. - -;; At some point this mode will undergo a rewrite to bring it more in -;; line with GNU Emacs Lisp coding standards, and to wax all the Emacs -;; 18 support. But all in all, the mode works exceedingly well, and -;; I've simply been tweaking it as I go along. Ain't it wonderful -;; that Python has a much more sane syntax than C? (or C++?! -;; :-). I can say that; I maintain cc-mode! - -;; The following statements, placed in your .emacs file or -;; site-init.el, will cause this file to be autoloaded, and -;; python-mode invoked, when visiting .py files (assuming this file is -;; in your load-path): -;; -;; (autoload 'python-mode "python-mode" "Python editing mode." t) -;; (setq auto-mode-alist -;; (cons '("\\.py$" . python-mode) auto-mode-alist)) -;; -;; If you want font-lock support for Python source code (a.k.a. syntax -;; coloring, highlighting), add this to your .emacs file: -;; -;; (add-hook 'python-mode-hook 'turn-on-font-lock) -;; -;; But you better be sure you're version of Emacs supports -;; font-lock-mode! As of this writing, the latest Emacs and XEmacs -;; 19's do. - -;; Here's a brief list of recent additions/improvements/changes: -;; -;; - Wrapping and indentation within triple quote strings now works. -;; - `Standard' bug reporting mechanism (use C-c C-b) -;; - py-mark-block was moved to C-c C-m -;; - C-c C-v shows you the python-mode version -;; - a basic python-font-lock-keywords has been added for (X)Emacs 19 -;; - proper interaction with pending-del and del-sel modes. -;; - Better support for outdenting: py-electric-colon (:) and -;; py-indent-line (TAB) improvements; one level of outdentation -;; added after a return, raise, break, pass, or continue statement. -;; Defeated by prefixing command with C-u. -;; - New py-electric-colon (:) command for improved outdenting Also -;; py-indent-line (TAB) should handle outdented lines better -;; - improved (I think) C-c > and C-c < -;; - py-(forward|backward)-into-nomenclature, not bound, but useful on -;; M-f and M-b respectively. -;; - integration with imenu by Perry A. Stoll -;; - py-indent-offset now defaults to 4 -;; - new variable py-honor-comment-indentation -;; - comment-region bound to C-c # -;; - py-delete-char obeys numeric arguments -;; - Small modification to rule for "indenting comment lines", such -;; lines must now also be indented less than or equal to the -;; indentation of the previous statement. - -;; Here's a brief to do list: -;; -;; - Better integration with gud-mode for debugging. -;; - Rewrite according to GNU Emacs Lisp standards. -;; - possibly force indent-tabs-mode == nil, and add a -;; write-file-hooks that runs untabify on the whole buffer (to work -;; around potential tab/space mismatch problems). In practice this -;; hasn't been a problem... yet. -;; - have py-execute-region on indented code act as if the region is -;; left justified. Avoids syntax errors. -;; - Add a py-goto-error or some such that would scan an exception in -;; the py-shell buffer, and pop you to that line in the file. - -;; If you can think of more things you'd like to see, drop me a line. -;; If you want to report bugs, use py-submit-bug-report (C-c C-b). -;; -;; Note that I only test things on XEmacs 19 and to some degree on -;; Emacs 19. If you port stuff to FSF Emacs 19, or Emacs 18, please -;; send me your patches. Byte compiler complaints can probably be -;; safely ignored. - -;;; Code: - - -;; user definable variables -;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv - -(defvar py-python-command "python" - "*Shell command used to start Python interpreter.") - -(defvar py-indent-offset 4 - "*Indentation increment. -Note that `\\[py-guess-indent-offset]' can usually guess a good value -when you're editing someone else's Python code.") - -(defvar py-align-multiline-strings-p t - "*Flag describing how multiline triple quoted strings are aligned. -When this flag is non-nil, continuation lines are lined up under the -preceding line's indentation. When this flag is nil, continuation -lines are aligned to column zero.") - -(defvar py-block-comment-prefix "## " - "*String used by \\[comment-region] to comment out a block of code. -This should follow the convention for non-indenting comment lines so -that the indentation commands won't get confused (i.e., the string -should be of the form `#x...' where `x' is not a blank or a tab, and -`...' is arbitrary).") - -(defvar py-honor-comment-indentation t - "*Controls how comment lines influence subsequent indentation. - -When nil, all comment lines are skipped for indentation purposes, and -in Emacs 19, a faster algorithm is used. - -When t, lines that begin with a single `#' are a hint to subsequent -line indentation. If the previous line is such a comment line (as -opposed to one that starts with `py-block-comment-prefix'), then it's -indentation is used as a hint for this line's indentation. Lines that -begin with `py-block-comment-prefix' are ignored for indentation -purposes. - -When not nil or t, comment lines that begin with a `#' are used as -indentation hints, unless the comment character is in column zero.") - -(defvar py-scroll-process-buffer t - "*Scroll Python process buffer as output arrives. -If nil, the Python process buffer acts, with respect to scrolling, like -Shell-mode buffers normally act. This is surprisingly complicated and -so won't be explained here; in fact, you can't get the whole story -without studying the Emacs C code. - -If non-nil, the behavior is different in two respects (which are -slightly inaccurate in the interest of brevity): - - - If the buffer is in a window, and you left point at its end, the - window will scroll as new output arrives, and point will move to the - buffer's end, even if the window is not the selected window (that - being the one the cursor is in). The usual behavior for shell-mode - windows is not to scroll, and to leave point where it was, if the - buffer is in a window other than the selected window. - - - If the buffer is not visible in any window, and you left point at - its end, the buffer will be popped into a window as soon as more - output arrives. This is handy if you have a long-running - computation and don't want to tie up screen area waiting for the - output. The usual behavior for a shell-mode buffer is to stay - invisible until you explicitly visit it. - -Note the `and if you left point at its end' clauses in both of the -above: you can `turn off' the special behaviors while output is in -progress, by visiting the Python buffer and moving point to anywhere -besides the end. Then the buffer won't scroll, point will remain where -you leave it, and if you hide the buffer it will stay hidden until you -visit it again. You can enable and disable the special behaviors as -often as you like, while output is in progress, by (respectively) moving -point to, or away from, the end of the buffer. - -Warning: If you expect a large amount of output, you'll probably be -happier setting this option to nil. - -Obscure: `End of buffer' above should really say `at or beyond the -process mark', but if you know what that means you didn't need to be -told .") - -(defvar py-temp-directory - (let ((ok '(lambda (x) - (and x - (setq x (expand-file-name x)) ; always true - (file-directory-p x) - (file-writable-p x) - x)))) - (or (funcall ok (getenv "TMPDIR")) - (funcall ok "/usr/tmp") - (funcall ok "/tmp") - (funcall ok ".") - (error - "Couldn't find a usable temp directory -- set py-temp-directory"))) - "*Directory used for temp files created by a *Python* process. -By default, the first directory from this list that exists and that you -can write into: the value (if any) of the environment variable TMPDIR, -/usr/tmp, /tmp, or the current directory.") - -(defvar py-beep-if-tab-change t - "*Ring the bell if tab-width is changed. -If a comment of the form - - \t# vi:set tabsize=: - -is found before the first code line when the file is entered, and the -current value of (the general Emacs variable) `tab-width' does not -equal , `tab-width' is set to , a message saying so is -displayed in the echo area, and if `py-beep-if-tab-change' is non-nil -the Emacs bell is also rung as a warning.") - -(defvar python-font-lock-keywords - (let* ((keywords '("and" "break" "class" - "continue" "def" "del" "elif" - "else:" "except" "except:" "exec" - "finally:" "for" "from" "global" - "if" "import" "in" "is" - "lambda" "not" "or" "pass" - "print" "raise" "return" "try:" - "while" - )) - (kwregex (mapconcat 'identity keywords "\\|"))) - (list - ;; keywords not at beginning of line - (cons (concat "\\s-\\(" kwregex "\\)[ \n\t(]") 1) - ;; keywords at beginning of line. i don't think regexps are - ;; powerful enough to handle these two cases in one regexp. - ;; prove me wrong! - (cons (concat "^\\(" kwregex "\\)[ \n\t(]") 1) - ;; classes - '("\\bclass[ \t]+\\([a-zA-Z_]+[a-zA-Z0-9_]*\\)" - 1 font-lock-type-face) - ;; functions - '("\\bdef[ \t]+\\([a-zA-Z_]+[a-zA-Z0-9_]*\\)" - 1 font-lock-function-name-face) - )) - "Additional expressions to highlight in Python mode.") -(put 'python-mode 'font-lock-defaults '(python-font-lock-keywords)) - - -(defvar imenu-example--python-show-method-args-p nil - "*Controls echoing of arguments of functions & methods in the imenu buffer. -When non-nil, arguments are printed.") - - - -;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -;; NO USER DEFINABLE VARIABLES BEYOND THIS POINT - -(make-variable-buffer-local 'py-indent-offset) - -;; Differentiate between Emacs 18, Lucid Emacs, and Emacs 19. This -;; seems to be the standard way of checking this. -;; BAW - This is *not* the right solution. When at all possible, -;; instead of testing for the version of Emacs, use feature tests. - -(setq py-this-is-lucid-emacs-p (string-match "Lucid\\|XEmacs" emacs-version)) -(setq py-this-is-emacs-19-p - (and - (not py-this-is-lucid-emacs-p) - (string-match "^19\\." emacs-version))) - -;; have to bind py-file-queue before installing the kill-emacs hook -(defvar py-file-queue nil - "Queue of Python temp files awaiting execution. -Currently-active file is at the head of the list.") - -;; define a mode-specific abbrev table for those who use such things -(defvar python-mode-abbrev-table nil - "Abbrev table in use in `python-mode' buffers.") -(define-abbrev-table 'python-mode-abbrev-table nil) - -(defvar python-mode-hook nil - "*Hook called by `python-mode'.") - -;; in previous version of python-mode.el, the hook was incorrectly -;; called py-mode-hook, and was not defvar'd. deprecate its use. -(and (fboundp 'make-obsolete-variable) - (make-obsolete-variable 'py-mode-hook 'python-mode-hook)) - -(defvar py-delete-function 'backward-delete-char-untabify - "*Function called by `py-delete-char' when deleting characters.") - -(defvar py-mode-map () - "Keymap used in `python-mode' buffers.") - -(if py-mode-map - () - (setq py-mode-map (make-sparse-keymap)) - - ;; shadow global bindings for newline-and-indent w/ the py- version. - ;; BAW - this is extremely bad form, but I'm not going to change it - ;; for now. - (mapcar (function (lambda (key) - (define-key - py-mode-map key 'py-newline-and-indent))) - (where-is-internal 'newline-and-indent)) - - ;; BAW - you could do it this way, but its not considered proper - ;; major-mode form. - (mapcar (function - (lambda (x) - (define-key py-mode-map (car x) (cdr x)))) - '((":" . py-electric-colon) - ("\C-c\C-c" . py-execute-buffer) - ("\C-c|" . py-execute-region) - ("\C-c!" . py-shell) - ('backspace . py-delete-char) - ("\n" . py-newline-and-indent) - ("\C-c:" . py-guess-indent-offset) - ("\C-c\t" . py-indent-region) - ("\C-c\C-l" . py-shift-region-left) - ("\C-c\C-r" . py-shift-region-right) - ("\C-c<" . py-shift-region-left) - ("\C-c>" . py-shift-region-right) - ("\C-c\C-n" . py-next-statement) - ("\C-c\C-p" . py-previous-statement) - ("\C-c\C-u" . py-goto-block-up) - ("\C-c\C-m" . py-mark-block) - ("\C-c#" . py-comment-region) - ("\C-c?" . py-describe-mode) - ("\C-c\C-hm" . py-describe-mode) - ("\e\C-a" . beginning-of-python-def-or-class) - ("\e\C-e" . end-of-python-def-or-class) - ( "\e\C-h" . mark-python-def-or-class))) - ;; should do all keybindings this way - (define-key py-mode-map "\C-c\C-b" 'py-submit-bug-report) - (define-key py-mode-map "\C-c\C-v" 'py-version) - ) - -(defvar py-mode-syntax-table nil - "Syntax table used in `python-mode' buffers.") - -(if py-mode-syntax-table - () - (setq py-mode-syntax-table (make-syntax-table)) - ;; BAW - again, blech. - (mapcar (function - (lambda (x) (modify-syntax-entry - (car x) (cdr x) py-mode-syntax-table))) - '(( ?\( . "()" ) ( ?\) . ")(" ) - ( ?\[ . "(]" ) ( ?\] . ")[" ) - ( ?\{ . "(}" ) ( ?\} . "){" ) - ;; fix operator symbols misassigned in the std table - ( ?\$ . "." ) ( ?\% . "." ) ( ?\& . "." ) - ( ?\* . "." ) ( ?\+ . "." ) ( ?\- . "." ) - ( ?\/ . "." ) ( ?\< . "." ) ( ?\= . "." ) - ( ?\> . "." ) ( ?\| . "." ) - ;; for historical reasons, underscore is word class - ;; instead of symbol class. it should be symbol class, - ;; but if you're tempted to change it, try binding M-f and - ;; M-b to py-forward-into-nomenclature and - ;; py-backward-into-nomenclature instead. -baw - ( ?\_ . "w" ) ; underscore is legit in words - ( ?\' . "\"") ; single quote is string quote - ( ?\" . "\"" ) ; double quote is string quote too - ( ?\` . "$") ; backquote is open and close paren - ( ?\# . "<") ; hash starts comment - ( ?\n . ">")))) ; newline ends comment - -(defconst py-stringlit-re - (concat - "'\\([^'\n\\]\\|\\\\.\\)*'" ; single-quoted - "\\|" ; or - "\"\\([^\"\n\\]\\|\\\\.\\)*\"") ; double-quoted - "Regexp matching a Python string literal.") - -;; this is tricky because a trailing backslash does not mean -;; continuation if it's in a comment -(defconst py-continued-re - (concat - "\\(" "[^#'\"\n\\]" "\\|" py-stringlit-re "\\)*" - "\\\\$") - "Regexp matching Python lines that are continued via backslash.") - -(defconst py-blank-or-comment-re "[ \t]*\\($\\|#\\)" - "Regexp matching blank or comment lines.") - -(defconst py-outdent-re - (concat "\\(" (mapconcat 'identity - '("else:" - "except\\(\\s +.*\\)?:" - "finally:" - "elif\\s +.*:") - "\\|") - "\\)") - "Regexp matching clauses to be outdented one level.") - -(defconst py-no-outdent-re - (concat "\\(" (mapconcat 'identity - '("try:" - "except\\(\\s +.*\\)?:" - "while\\s +.*:" - "for\\s +.*:" - "if\\s +.*:" - "elif\\s +.*:" - "\\(return\\|break\\|raise\\|continue\\)[ \t\n]" - ) - "\\|") - "\\)") - "Regexp matching lines to not outdent after.") - -(defvar py-defun-start-re - "^\\([ \t]*\\)def[ \t]+\\([a-zA-Z_0-9]+\\)\\|\\(^[a-zA-Z_0-9]+\\)[ \t]*=" - "Regexp matching a function, method or variable assignment. - -If you change this, you probably have to change `py-current-defun' as well. -This is only used by `py-current-defun' to find the name for add-log.el.") - -(defvar py-class-start-re "^class[ \t]*\\([a-zA-Z_0-9]+\\)" - "Regexp for finding a class name. - -If you change this, you probably have to change `py-current-defun' as well. -This is only used by `py-current-defun' to find the name for add-log.el.") - -;; As of 30-Jan-1997, Emacs 19.34 works but XEmacs 19.15b90 and -;; previous does not. It is suspected that Emacsen before 19.34 are -;; also broken. -(defvar py-parse-partial-sexp-works-p - (let ((buf (get-buffer-create " ---*---pps---*---")) - state status) - (save-excursion - (set-buffer buf) - (erase-buffer) - (insert "(line1\n line2)\nline3") - (lisp-mode) - (goto-char (point-min)) - (setq state (parse-partial-sexp (point) (save-excursion - (forward-line 1) - (point)))) - (parse-partial-sexp (point) (point-max) 0 nil state) - (setq status (not (= (point) (point-max)))) - (kill-buffer buf) - status)) - "Does `parse-partial-sexp' work in this Emacs?") - - -;; Menu definitions, only relevent if you have the easymenu.el package -;; (standard in the latest Emacs 19 and XEmacs 19 distributions). -(defvar py-menu nil - "Menu for Python Mode. - -This menu will get created automatically if you have the easymenu -package. Note that the latest XEmacs 19 and Emacs 19 versions contain -this package.") - -(if (condition-case nil - (require 'easymenu) - (error nil)) - (easy-menu-define - py-menu py-mode-map "Python Mode menu" - '("Python" - ["Comment Out Region" py-comment-region (mark)] - ["Uncomment Region" (py-comment-region (point) (mark) '(4)) (mark)] - "-" - ["Mark current block" py-mark-block t] - ["Mark current def" mark-python-def-or-class t] - ["Mark current class" (mark-python-def-or-class t) t] - "-" - ["Shift region left" py-shift-region-left (mark)] - ["Shift region right" py-shift-region-right (mark)] - "-" - ["Execute buffer" py-execute-buffer t] - ["Execute region" py-execute-region (mark)] - ["Start interpreter..." py-shell t] - "-" - ["Go to start of block" py-goto-block-up t] - ["Go to start of class" (beginning-of-python-def-or-class t) t] - ["Move to end of class" (end-of-python-def-or-class t) t] - ["Move to start of def" beginning-of-python-def-or-class t] - ["Move to end of def" end-of-python-def-or-class t] - "-" - ["Describe mode" py-describe-mode t] - ))) - - - -;; imenu definitions, courtesy of Perry A. Stoll -(defvar imenu-example--python-class-regexp - (concat ; <> - "\\(" ; - "^[ \t]*" ; newline and maybe whitespace - "\\(class[ \t]+[a-zA-Z0-9_]+\\)" ; class name - ; possibly multiple superclasses - "\\([ \t]*\\((\\([a-zA-Z0-9_, \t\n]\\)*)\\)?\\)" - "[ \t]*:" ; and the final : - "\\)" ; >>classes<< - ) - "Regexp for Python classes for use with the imenu package." - ) - -(defvar imenu-example--python-method-regexp - (concat ; <> - "\\(" ; - "^[ \t]*" ; new line and maybe whitespace - "\\(def[ \t]+" ; function definitions start with def - "\\([a-zA-Z0-9_]+\\)" ; name is here - ; function arguments... - "[ \t]*(\\([a-zA-Z0-9_=,\* \t\n]*\\))" - "\\)" ; end of def - "[ \t]*:" ; and then the : - "\\)" ; >>methods and functions<< - ) - "Regexp for Python methods/functions for use with the imenu package." - ) - -(defvar imenu-example--python-method-no-arg-parens '(2 8) - "Indicies into groups of the Python regexp for use with imenu. - -Using these values will result in smaller imenu lists, as arguments to -functions are not listed. - -See the variable `imenu-example--python-show-method-args-p' for more -information.") - -(defvar imenu-example--python-method-arg-parens '(2 7) - "Indicies into groups of the Python regexp for use with imenu. -Using these values will result in large imenu lists, as arguments to -functions are listed. - -See the variable `imenu-example--python-show-method-args-p' for more -information.") - -;; Note that in this format, this variable can still be used with the -;; imenu--generic-function. Otherwise, there is no real reason to have -;; it. -(defvar imenu-example--generic-python-expression - (cons - (concat - imenu-example--python-class-regexp - "\\|" ; or... - imenu-example--python-method-regexp - ) - imenu-example--python-method-no-arg-parens) - "Generic Python expression which may be used directly with imenu. -Used by setting the variable `imenu-generic-expression' to this value. -Also, see the function \\[imenu-example--create-python-index] for a -better alternative for finding the index.") - -;; These next two variables are used when searching for the python -;; class/definitions. Just saving some time in accessing the -;; generic-python-expression, really. -(defvar imenu-example--python-generic-regexp nil) -(defvar imenu-example--python-generic-parens nil) - - -;;;###autoload -(eval-when-compile - ;; Imenu isn't used in XEmacs, so just ignore load errors - (condition-case () - (progn - (require 'cl) - (require 'imenu)) - (error nil))) - -(defun imenu-example--create-python-index () - "Python interface function for imenu package. -Finds all python classes and functions/methods. Calls function -\\[imenu-example--create-python-index-engine]. See that function for -the details of how this works." - (setq imenu-example--python-generic-regexp - (car imenu-example--generic-python-expression)) - (setq imenu-example--python-generic-parens - (if imenu-example--python-show-method-args-p - imenu-example--python-method-arg-parens - imenu-example--python-method-no-arg-parens)) - (goto-char (point-min)) - (imenu-example--create-python-index-engine nil)) - -(defun imenu-example--create-python-index-engine (&optional start-indent) - "Function for finding imenu definitions in Python. - -Finds all definitions (classes, methods, or functions) in a Python -file for the imenu package. - -Returns a possibly nested alist of the form - - (INDEX-NAME . INDEX-POSITION) - -The second element of the alist may be an alist, producing a nested -list as in - - (INDEX-NAME . INDEX-ALIST) - -This function should not be called directly, as it calls itself -recursively and requires some setup. Rather this is the engine for -the function \\[imenu-example--create-python-index]. - -It works recursively by looking for all definitions at the current -indention level. When it finds one, it adds it to the alist. If it -finds a definition at a greater indentation level, it removes the -previous definition from the alist. In it's place it adds all -definitions found at the next indentation level. When it finds a -definition that is less indented then the current level, it retuns the -alist it has created thus far. - -The optional argument START-INDENT indicates the starting indentation -at which to continue looking for Python classes, methods, or -functions. If this is not supplied, the function uses the indentation -of the first definition found." - (let ((index-alist '()) - (sub-method-alist '()) - looking-p - def-name prev-name - cur-indent def-pos - (class-paren (first imenu-example--python-generic-parens)) - (def-paren (second imenu-example--python-generic-parens))) - (setq looking-p - (re-search-forward imenu-example--python-generic-regexp - (point-max) t)) - (while looking-p - (save-excursion - ;; used to set def-name to this value but generic-extract-name is - ;; new to imenu-1.14. this way it still works with imenu-1.11 - ;;(imenu--generic-extract-name imenu-example--python-generic-parens)) - (let ((cur-paren (if (match-beginning class-paren) - class-paren def-paren))) - (setq def-name - (buffer-substring (match-beginning cur-paren) - (match-end cur-paren)))) - (beginning-of-line) - (setq cur-indent (current-indentation))) - - ;; HACK: want to go to the next correct definition location. we - ;; explicitly list them here. would be better to have them in a - ;; list. - (setq def-pos - (or (match-beginning class-paren) - (match-beginning def-paren))) - - ;; if we don't have a starting indent level, take this one - (or start-indent - (setq start-indent cur-indent)) - - ;; if we don't have class name yet, take this one - (or prev-name - (setq prev-name def-name)) - - ;; what level is the next definition on? must be same, deeper - ;; or shallower indentation - (cond - ;; at the same indent level, add it to the list... - ((= start-indent cur-indent) - - ;; if we don't have push, use the following... - ;;(setf index-alist (cons (cons def-name def-pos) index-alist)) - (push (cons def-name def-pos) index-alist)) - - ;; deeper indented expression, recur... - ((< start-indent cur-indent) - - ;; the point is currently on the expression we're supposed to - ;; start on, so go back to the last expression. The recursive - ;; call will find this place again and add it to the correct - ;; list - (re-search-backward imenu-example--python-generic-regexp - (point-min) 'move) - (setq sub-method-alist (imenu-example--create-python-index-engine - cur-indent)) - - (if sub-method-alist - ;; we put the last element on the index-alist on the start - ;; of the submethod alist so the user can still get to it. - (let ((save-elmt (pop index-alist))) - (push (cons (imenu-create-submenu-name prev-name) - (cons save-elmt sub-method-alist)) - index-alist)))) - - ;; found less indented expression, we're done. - (t - (setq looking-p nil) - (re-search-backward imenu-example--python-generic-regexp - (point-min) t))) - (setq prev-name def-name) - (and looking-p - (setq looking-p - (re-search-forward imenu-example--python-generic-regexp - (point-max) 'move)))) - (nreverse index-alist))) - - -;;;###autoload -(defun python-mode () - "Major mode for editing Python files. -To submit a problem report, enter `\\[py-submit-bug-report]' from a -`python-mode' buffer. Do `\\[py-describe-mode]' for detailed -documentation. To see what version of `python-mode' you are running, -enter `\\[py-version]'. - -This mode knows about Python indentation, tokens, comments and -continuation lines. Paragraphs are separated by blank lines only. - -COMMANDS -\\{py-mode-map} -VARIABLES - -py-indent-offset\t\tindentation increment -py-block-comment-prefix\t\tcomment string used by comment-region -py-python-command\t\tshell command to invoke Python interpreter -py-scroll-process-buffer\t\talways scroll Python process buffer -py-temp-directory\t\tdirectory used for temp files (if needed) -py-beep-if-tab-change\t\tring the bell if tab-width is changed" - (interactive) - ;; set up local variables - (kill-all-local-variables) - (make-local-variable 'font-lock-defaults) - (make-local-variable 'paragraph-separate) - (make-local-variable 'paragraph-start) - (make-local-variable 'require-final-newline) - (make-local-variable 'comment-start) - (make-local-variable 'comment-end) - (make-local-variable 'comment-start-skip) - (make-local-variable 'comment-column) - (make-local-variable 'indent-region-function) - (make-local-variable 'indent-line-function) - (make-local-variable 'add-log-current-defun-function) - ;; - (set-syntax-table py-mode-syntax-table) - (setq major-mode 'python-mode - mode-name "Python" - local-abbrev-table python-mode-abbrev-table - paragraph-separate "^[ \t]*$" - paragraph-start "^[ \t]*$" - require-final-newline t - comment-start "# " - comment-end "" - comment-start-skip "# *" - comment-column 40 - indent-region-function 'py-indent-region - indent-line-function 'py-indent-line - ;; tell add-log.el how to find the current function/method/variable - add-log-current-defun-function 'py-current-defun - ) - (use-local-map py-mode-map) - ;; add the menu - (if py-menu - (easy-menu-add py-menu)) - ;; Emacs 19 requires this - (if (or py-this-is-lucid-emacs-p py-this-is-emacs-19-p) - (setq comment-multi-line nil)) - ;; hack to allow overriding the tabsize in the file (see tokenizer.c) - ;; - ;; not sure where the magic comment has to be; to save time - ;; searching for a rarity, we give up if it's not found prior to the - ;; first executable statement. - ;; - ;; BAW - on first glance, this seems like complete hackery. Why was - ;; this necessary, and is it still necessary? - (let ((case-fold-search nil) - (start (point)) - new-tab-width) - (if (re-search-forward - "^[ \t]*#[ \t]*vi:set[ \t]+tabsize=\\([0-9]+\\):" - (prog2 (py-next-statement 1) (point) (goto-char 1)) - t) - (progn - (setq new-tab-width - (string-to-int - (buffer-substring (match-beginning 1) (match-end 1)))) - (if (= tab-width new-tab-width) - nil - (setq tab-width new-tab-width) - (message "Caution: tab-width changed to %d" new-tab-width) - (if py-beep-if-tab-change (beep))))) - (goto-char start)) - - ;; install imenu - (setq imenu-create-index-function - (function imenu-example--create-python-index)) - (if (fboundp 'imenu-add-to-menubar) - (imenu-add-to-menubar (format "%s-%s" "IM" mode-name))) - - ;; run the mode hook. py-mode-hook use is deprecated - (if python-mode-hook - (run-hooks 'python-mode-hook) - (run-hooks 'py-mode-hook))) - - -(defun py-keep-region-active () - ;; do whatever is necessary to keep the region active in XEmacs. - ;; Ignore byte-compiler warnings you might see. Also note that - ;; FSF's Emacs 19 does it differently and doesn't its policy doesn't - ;; require us to take explicit action. - (and (boundp 'zmacs-region-stays) - (setq zmacs-region-stays t))) - - -;; electric characters -(defun py-outdent-p () - ;; returns non-nil if the current line should outdent one level - (save-excursion - (and (progn (back-to-indentation) - (looking-at py-outdent-re)) - (progn (backward-to-indentation 1) - (while (or (looking-at py-blank-or-comment-re) - (bobp)) - (backward-to-indentation 1)) - (not (looking-at py-no-outdent-re))) - ))) - - -(defun py-electric-colon (arg) - "Insert a colon. -In certain cases the line is outdented appropriately. If a numeric -argument is provided, that many colons are inserted non-electrically. -Electric behavior is inhibited inside a string or comment." - (interactive "P") - (self-insert-command (prefix-numeric-value arg)) - ;; are we in a string or comment? - (if (save-excursion - (let ((pps (parse-partial-sexp (save-excursion - (beginning-of-python-def-or-class) - (point)) - (point)))) - (not (or (nth 3 pps) (nth 4 pps))))) - (save-excursion - (let ((here (point)) - (outdent 0) - (indent (py-compute-indentation t))) - (if (and (not arg) - (py-outdent-p) - (= indent (save-excursion - (py-next-statement -1) - (py-compute-indentation t))) - ) - (setq outdent py-indent-offset)) - ;; Don't indent, only outdent. This assumes that any lines that - ;; are already outdented relative to py-compute-indentation were - ;; put there on purpose. Its highly annoying to have `:' indent - ;; for you. Use TAB, C-c C-l or C-c C-r to adjust. TBD: Is - ;; there a better way to determine this??? - (if (< (current-indentation) indent) nil - (goto-char here) - (beginning-of-line) - (delete-horizontal-space) - (indent-to (- indent outdent)) - ))))) - - -;;; Functions that execute Python commands in a subprocess -;;;###autoload -(defun py-shell () - "Start an interactive Python interpreter in another window. -This is like Shell mode, except that Python is running in the window -instead of a shell. See the `Interactive Shell' and `Shell Mode' -sections of the Emacs manual for details, especially for the key -bindings active in the `*Python*' buffer. - -See the docs for variable `py-scroll-buffer' for info on scrolling -behavior in the process window. - -Warning: Don't use an interactive Python if you change sys.ps1 or -sys.ps2 from their default values, or if you're running code that -prints `>>> ' or `... ' at the start of a line. `python-mode' can't -distinguish your output from Python's output, and assumes that `>>> ' -at the start of a line is a prompt from Python. Similarly, the Emacs -Shell mode code assumes that both `>>> ' and `... ' at the start of a -line are Python prompts. Bad things can happen if you fool either -mode. - -Warning: If you do any editing *in* the process buffer *while* the -buffer is accepting output from Python, do NOT attempt to `undo' the -changes. Some of the output (nowhere near the parts you changed!) may -be lost if you do. This appears to be an Emacs bug, an unfortunate -interaction between undo and process filters; the same problem exists in -non-Python process buffers using the default (Emacs-supplied) process -filter." - ;; BAW - should undo be disabled in the python process buffer, if - ;; this bug still exists? - (interactive) - (if py-this-is-emacs-19-p - (progn - (require 'comint) - (switch-to-buffer-other-window - (make-comint "Python" py-python-command))) - (progn - (require 'shell) - (switch-to-buffer-other-window - (apply (if (fboundp 'make-shell) 'make-shell 'make-comint) - "Python" py-python-command nil)))) - (make-local-variable 'shell-prompt-pattern) - (setq shell-prompt-pattern "^>>> \\|^\\.\\.\\. ") - (set-process-filter (get-buffer-process (current-buffer)) - 'py-process-filter) - (set-syntax-table py-mode-syntax-table)) - -(defun py-execute-region (start end) - "Send the region between START and END to a Python interpreter. -If there is a *Python* process it is used. - -Hint: If you want to execute part of a Python file several times -\(e.g., perhaps you're developing a function and want to flesh it out -a bit at a time), use `\\[narrow-to-region]' to restrict the buffer to -the region of interest, and send the code to a *Python* process via -`\\[py-execute-buffer]' instead. - -Following are subtleties to note when using a *Python* process: - -If a *Python* process is used, the region is copied into a temporary -file (in directory `py-temp-directory'), and an `execfile' command is -sent to Python naming that file. If you send regions faster than -Python can execute them, `python-mode' will save them into distinct -temp files, and execute the next one in the queue the next time it -sees a `>>> ' prompt from Python. Each time this happens, the process -buffer is popped into a window (if it's not already in some window) so -you can see it, and a comment of the form - - \t## working on region in file ... - -is inserted at the end. - -Caution: No more than 26 regions can be pending at any given time. -This limit is (indirectly) inherited from libc's mktemp(3). -`python-mode' does not try to protect you from exceeding the limit. -It's extremely unlikely that you'll get anywhere close to the limit in -practice, unless you're trying to be a jerk . - -See the `\\[py-shell]' docs for additional warnings." - (interactive "r") - (or (< start end) (error "Region is empty")) - (let ((pyproc (get-process "Python")) - fname) - (if (null pyproc) - (shell-command-on-region start end py-python-command) - ;; else feed it thru a temp file - (setq fname (py-make-temp-name)) - (write-region start end fname nil 'no-msg) - (setq py-file-queue (append py-file-queue (list fname))) - (if (cdr py-file-queue) - (message "File %s queued for execution" fname) - ;; else - (py-execute-file pyproc fname))))) - -(defun py-execute-file (pyproc fname) - (py-append-to-process-buffer - pyproc - (format "## working on region in file %s ...\n" fname)) - (process-send-string pyproc (format "execfile('%s')\n" fname))) - -(defun py-process-filter (pyproc string) - (let ((curbuf (current-buffer)) - (pbuf (process-buffer pyproc)) - (pmark (process-mark pyproc)) - file-finished) - - ;; make sure we switch to a different buffer at least once. if we - ;; *don't* do this, then if the process buffer is in the selected - ;; window, and point is before the end, and lots of output is - ;; coming at a fast pace, then (a) simple cursor-movement commands - ;; like C-p, C-n, C-f, C-b, C-a, C-e take an incredibly long time - ;; to have a visible effect (the window just doesn't get updated, - ;; sometimes for minutes(!)), and (b) it takes about 5x longer to - ;; get all the process output (until the next python prompt). - ;; - ;; #b makes no sense to me at all. #a almost makes sense: unless - ;; we actually change buffers, set_buffer_internal in buffer.c - ;; doesn't set windows_or_buffers_changed to 1, & that in turn - ;; seems to make the Emacs command loop reluctant to update the - ;; display. Perhaps the default process filter in process.c's - ;; read_process_output has update_mode_lines++ for a similar - ;; reason? beats me ... - - (unwind-protect - ;; make sure current buffer is restored - ;; BAW - we want to check to see if this still applies - (progn - ;; mysterious ugly hack - (if (eq curbuf pbuf) - (set-buffer (get-buffer-create "*scratch*"))) - - (set-buffer pbuf) - (let* ((start (point)) - (goback (< start pmark)) - (goend (and (not goback) (= start (point-max)))) - (buffer-read-only nil)) - (goto-char pmark) - (insert string) - (move-marker pmark (point)) - (setq file-finished - (and py-file-queue - (equal ">>> " - (buffer-substring - (prog2 (beginning-of-line) (point) - (goto-char pmark)) - (point))))) - (if goback (goto-char start) - ;; else - (if py-scroll-process-buffer - (let* ((pop-up-windows t) - (pwin (display-buffer pbuf))) - (set-window-point pwin (point))))) - (set-buffer curbuf) - (if file-finished - (progn - (py-delete-file-silently (car py-file-queue)) - (setq py-file-queue (cdr py-file-queue)) - (if py-file-queue - (py-execute-file pyproc (car py-file-queue))))) - (and goend - (progn (set-buffer pbuf) - (goto-char (point-max)))) - )) - (set-buffer curbuf)))) - -(defun py-execute-buffer () - "Send the contents of the buffer to a Python interpreter. -If there is a *Python* process buffer it is used. If a clipping -restriction is in effect, only the accessible portion of the buffer is -sent. A trailing newline will be supplied if needed. - -See the `\\[py-execute-region]' docs for an account of some subtleties." - (interactive) - (py-execute-region (point-min) (point-max))) - - - -;; Functions for Python style indentation -(defun py-delete-char (count) - "Reduce indentation or delete character. - -If point is at the leftmost column, deletes the preceding newline. -Deletion is performed by calling the function in `py-delete-function' -with a single argument (the number of characters to delete). - -Else if point is at the leftmost non-blank character of a line that is -neither a continuation line nor a non-indenting comment line, or if -point is at the end of a blank line, reduces the indentation to match -that of the line that opened the current block of code. The line that -opened the block is displayed in the echo area to help you keep track -of where you are. With numeric count, outdents that many blocks (but -not past column zero). - -Else the preceding character is deleted, converting a tab to spaces if -needed so that only a single column position is deleted. Numeric -argument delets that many characters." - (interactive "*p") - (if (or (/= (current-indentation) (current-column)) - (bolp) - (py-continuation-line-p) - (not py-honor-comment-indentation) - (looking-at "#[^ \t\n]")) ; non-indenting # - (funcall py-delete-function count) - ;; else indent the same as the colon line that opened the block - - ;; force non-blank so py-goto-block-up doesn't ignore it - (insert-char ?* 1) - (backward-char) - (let ((base-indent 0) ; indentation of base line - (base-text "") ; and text of base line - (base-found-p nil)) - (save-excursion - (while (< 0 count) - (condition-case nil ; in case no enclosing block - (progn - (py-goto-block-up 'no-mark) - (setq base-indent (current-indentation) - base-text (py-suck-up-leading-text) - base-found-p t)) - (error nil)) - (setq count (1- count)))) - (delete-char 1) ; toss the dummy character - (delete-horizontal-space) - (indent-to base-indent) - (if base-found-p - (message "Closes block: %s" base-text))))) - -;; required for pending-del and delsel modes -(put 'py-delete-char 'delete-selection 'supersede) -(put 'py-delete-char 'pending-delete 'supersede) - -(defun py-indent-line (&optional arg) - "Fix the indentation of the current line according to Python rules. -With \\[universal-argument], ignore outdenting rules for block -closing statements (e.g. return, raise, break, continue, pass) - -This function is normally bound to `indent-line-function' so -\\[indent-for-tab-command] will call it." - (interactive "P") - (let* ((ci (current-indentation)) - (move-to-indentation-p (<= (current-column) ci)) - (need (py-compute-indentation (not arg)))) - ;; see if we need to outdent - (if (py-outdent-p) - (setq need (- need py-indent-offset))) - (if (/= ci need) - (save-excursion - (beginning-of-line) - (delete-horizontal-space) - (indent-to need))) - (if move-to-indentation-p (back-to-indentation)))) - -(defun py-newline-and-indent () - "Strives to act like the Emacs `newline-and-indent'. -This is just `strives to' because correct indentation can't be computed -from scratch for Python code. In general, deletes the whitespace before -point, inserts a newline, and takes an educated guess as to how you want -the new line indented." - (interactive) - (let ((ci (current-indentation))) - (if (< ci (current-column)) ; if point beyond indentation - (newline-and-indent) - ;; else try to act like newline-and-indent "normally" acts - (beginning-of-line) - (insert-char ?\n 1) - (move-to-column ci)))) - -(defun py-compute-indentation (honor-block-close-p) - ;; implements all the rules for indentation computation. when - ;; honor-block-close-p is non-nil, statements such as return, raise, - ;; break, continue, and pass force one level of outdenting. - (save-excursion - (let ((pps (parse-partial-sexp (save-excursion - (beginning-of-python-def-or-class) - (point)) - (point)))) - (beginning-of-line) - (cond - ;; are we inside a string or comment? - ((or (nth 3 pps) (nth 4 pps)) - (save-excursion - (if (not py-align-multiline-strings-p) 0 - ;; skip back over blank & non-indenting comment lines - ;; note: will skip a blank or non-indenting comment line - ;; that happens to be a continuation line too - (re-search-backward "^[ \t]*\\([^ \t\n#]\\|#[ \t\n]\\)" nil 'move) - (back-to-indentation) - (current-column)))) - ;; are we on a continuation line? - ((py-continuation-line-p) - (let ((startpos (point)) - (open-bracket-pos (py-nesting-level)) - endpos searching found state) - (if open-bracket-pos - (progn - ;; align with first item in list; else a normal - ;; indent beyond the line with the open bracket - (goto-char (1+ open-bracket-pos)) ; just beyond bracket - ;; is the first list item on the same line? - (skip-chars-forward " \t") - (if (null (memq (following-char) '(?\n ?# ?\\))) - ; yes, so line up with it - (current-column) - ;; first list item on another line, or doesn't exist yet - (forward-line 1) - (while (and (< (point) startpos) - (looking-at "[ \t]*[#\n\\\\]")) ; skip noise - (forward-line 1)) - (if (< (point) startpos) - ;; again mimic the first list item - (current-indentation) - ;; else they're about to enter the first item - (goto-char open-bracket-pos) - (+ (current-indentation) py-indent-offset)))) - - ;; else on backslash continuation line - (forward-line -1) - (if (py-continuation-line-p) ; on at least 3rd line in block - (current-indentation) ; so just continue the pattern - ;; else started on 2nd line in block, so indent more. - ;; if base line is an assignment with a start on a RHS, - ;; indent to 2 beyond the leftmost "="; else skip first - ;; chunk of non-whitespace characters on base line, + 1 more - ;; column - (end-of-line) - (setq endpos (point) searching t) - (back-to-indentation) - (setq startpos (point)) - ;; look at all "=" from left to right, stopping at first - ;; one not nested in a list or string - (while searching - (skip-chars-forward "^=" endpos) - (if (= (point) endpos) - (setq searching nil) - (forward-char 1) - (setq state (parse-partial-sexp startpos (point))) - (if (and (zerop (car state)) ; not in a bracket - (null (nth 3 state))) ; & not in a string - (progn - (setq searching nil) ; done searching in any case - (setq found - (not (or - (eq (following-char) ?=) - (memq (char-after (- (point) 2)) - '(?< ?> ?!))))))))) - (if (or (not found) ; not an assignment - (looking-at "[ \t]*\\\\")) ; <=> - (progn - (goto-char startpos) - (skip-chars-forward "^ \t\n"))) - (1+ (current-column)))))) - - ;; not on a continuation line - ((bobp) (current-indentation)) - - ;; Dfn: "Indenting comment line". A line containing only a - ;; comment, but which is treated like a statement for - ;; indentation calculation purposes. Such lines are only - ;; treated specially by the mode; they are not treated - ;; specially by the Python interpreter. - - ;; The rules for indenting comment lines are a line where: - ;; - the first non-whitespace character is `#', and - ;; - the character following the `#' is whitespace, and - ;; - the line is outdented with respect to (i.e. to the left - ;; of) the indentation of the preceding non-blank line. - - ;; The first non-blank line following an indenting comment - ;; line is given the same amount of indentation as the - ;; indenting comment line. - - ;; All other comment-only lines are ignored for indentation - ;; purposes. - - ;; Are we looking at a comment-only line which is *not* an - ;; indenting comment line? If so, we assume that its been - ;; placed at the desired indentation, so leave it alone. - ;; Indenting comment lines are aligned as statements down - ;; below. - ((and (looking-at "[ \t]*#[^ \t\n]") - ;; NOTE: this test will not be performed in older Emacsen - (fboundp 'forward-comment) - (<= (current-indentation) - (save-excursion - (forward-comment (- (point-max))) - (current-indentation)))) - (current-indentation)) - - ;; else indentation based on that of the statement that - ;; precedes us; use the first line of that statement to - ;; establish the base, in case the user forced a non-std - ;; indentation for the continuation lines (if any) - (t - ;; skip back over blank & non-indenting comment lines note: - ;; will skip a blank or non-indenting comment line that - ;; happens to be a continuation line too. use fast Emacs 19 - ;; function if it's there. - (if (and (eq py-honor-comment-indentation nil) - (fboundp 'forward-comment)) - (forward-comment (- (point-max))) - (let (done) - (while (not done) - (re-search-backward "^[ \t]*\\([^ \t\n#]\\|#[ \t\n]\\)" - nil 'move) - (setq done (or (eq py-honor-comment-indentation t) - (bobp) - (/= (following-char) ?#) - (not (zerop (current-column))))) - ))) - ;; if we landed inside a string, go to the beginning of that - ;; string. this handles triple quoted, multi-line spanning - ;; strings. - (py-goto-initial-line) - (+ (current-indentation) - (if (py-statement-opens-block-p) - py-indent-offset - (if (and honor-block-close-p (py-statement-closes-block-p)) - (- py-indent-offset) - 0))) - ))))) - -(defun py-guess-indent-offset (&optional global) - "Guess a good value for, and change, `py-indent-offset'. -By default (without a prefix arg), makes a buffer-local copy of -`py-indent-offset' with the new value. This will not affect any other -Python buffers. With a prefix arg, changes the global value of -`py-indent-offset'. This affects all Python buffers (that don't have -their own buffer-local copy), both those currently existing and those -created later in the Emacs session. - -Some people use a different value for `py-indent-offset' than you use. -There's no excuse for such foolishness, but sometimes you have to deal -with their ugly code anyway. This function examines the file and sets -`py-indent-offset' to what it thinks it was when they created the -mess. - -Specifically, it searches forward from the statement containing point, -looking for a line that opens a block of code. `py-indent-offset' is -set to the difference in indentation between that line and the Python -statement following it. If the search doesn't succeed going forward, -it's tried again going backward." - (interactive "P") ; raw prefix arg - (let (new-value - (start (point)) - restart - (found nil) - colon-indent) - (py-goto-initial-line) - (while (not (or found (eobp))) - (if (re-search-forward ":[ \t]*\\($\\|[#\\]\\)" nil 'move) - (progn - (setq restart (point)) - (py-goto-initial-line) - (if (py-statement-opens-block-p) - (setq found t) - (goto-char restart))))) - (if found - () - (goto-char start) - (py-goto-initial-line) - (while (not (or found (bobp))) - (setq found - (and - (re-search-backward ":[ \t]*\\($\\|[#\\]\\)" nil 'move) - (or (py-goto-initial-line) t) ; always true -- side effect - (py-statement-opens-block-p))))) - (setq colon-indent (current-indentation) - found (and found (zerop (py-next-statement 1))) - new-value (- (current-indentation) colon-indent)) - (goto-char start) - (if found - (progn - (funcall (if global 'kill-local-variable 'make-local-variable) - 'py-indent-offset) - (setq py-indent-offset new-value) - (message "%s value of py-indent-offset set to %d" - (if global "Global" "Local") - py-indent-offset)) - (error "Sorry, couldn't guess a value for py-indent-offset")))) - -(defun py-shift-region (start end count) - (save-excursion - (goto-char end) (beginning-of-line) (setq end (point)) - (goto-char start) (beginning-of-line) (setq start (point)) - (indent-rigidly start end count))) - -(defun py-shift-region-left (start end &optional count) - "Shift region of Python code to the left. -The lines from the line containing the start of the current region up -to (but not including) the line containing the end of the region are -shifted to the left, by `py-indent-offset' columns. - -If a prefix argument is given, the region is instead shifted by that -many columns. With no active region, outdent only the current line. -You cannot outdent the region if any line is already at column zero." - (interactive - (let ((p (point)) - (m (mark)) - (arg current-prefix-arg)) - (if m - (list (min p m) (max p m) arg) - (list p (save-excursion (forward-line 1) (point)) arg)))) - ;; if any line is at column zero, don't shift the region - (save-excursion - (goto-char start) - (while (< (point) end) - (back-to-indentation) - (if (and (zerop (current-column)) - (not (looking-at "\\s *$"))) - (error "Region is at left edge.")) - (forward-line 1))) - (py-shift-region start end (- (prefix-numeric-value - (or count py-indent-offset)))) - (py-keep-region-active)) - -(defun py-shift-region-right (start end &optional count) - "Shift region of Python code to the right. -The lines from the line containing the start of the current region up -to (but not including) the line containing the end of the region are -shifted to the right, by `py-indent-offset' columns. - -If a prefix argument is given, the region is instead shifted by that -many columns. With no active region, indent only the current line." - (interactive - (let ((p (point)) - (m (mark)) - (arg current-prefix-arg)) - (if m - (list (min p m) (max p m) arg) - (list p (save-excursion (forward-line 1) (point)) arg)))) - (py-shift-region start end (prefix-numeric-value - (or count py-indent-offset))) - (py-keep-region-active)) - -(defun py-indent-region (start end &optional indent-offset) - "Reindent a region of Python code. - -The lines from the line containing the start of the current region up -to (but not including) the line containing the end of the region are -reindented. If the first line of the region has a non-whitespace -character in the first column, the first line is left alone and the -rest of the region is reindented with respect to it. Else the entire -region is reindented with respect to the (closest code or indenting -comment) statement immediately preceding the region. - -This is useful when code blocks are moved or yanked, when enclosing -control structures are introduced or removed, or to reformat code -using a new value for the indentation offset. - -If a numeric prefix argument is given, it will be used as the value of -the indentation offset. Else the value of `py-indent-offset' will be -used. - -Warning: The region must be consistently indented before this function -is called! This function does not compute proper indentation from -scratch (that's impossible in Python), it merely adjusts the existing -indentation to be correct in context. - -Warning: This function really has no idea what to do with -non-indenting comment lines, and shifts them as if they were indenting -comment lines. Fixing this appears to require telepathy. - -Special cases: whitespace is deleted from blank lines; continuation -lines are shifted by the same amount their initial line was shifted, -in order to preserve their relative indentation with respect to their -initial line; and comment lines beginning in column 1 are ignored." - (interactive "*r\nP") ; region; raw prefix arg - (save-excursion - (goto-char end) (beginning-of-line) (setq end (point-marker)) - (goto-char start) (beginning-of-line) - (let ((py-indent-offset (prefix-numeric-value - (or indent-offset py-indent-offset))) - (indents '(-1)) ; stack of active indent levels - (target-column 0) ; column to which to indent - (base-shifted-by 0) ; amount last base line was shifted - (indent-base (if (looking-at "[ \t\n]") - (py-compute-indentation t) - 0)) - ci) - (while (< (point) end) - (setq ci (current-indentation)) - ;; figure out appropriate target column - (cond - ((or (eq (following-char) ?#) ; comment in column 1 - (looking-at "[ \t]*$")) ; entirely blank - (setq target-column 0)) - ((py-continuation-line-p) ; shift relative to base line - (setq target-column (+ ci base-shifted-by))) - (t ; new base line - (if (> ci (car indents)) ; going deeper; push it - (setq indents (cons ci indents)) - ;; else we should have seen this indent before - (setq indents (memq ci indents)) ; pop deeper indents - (if (null indents) - (error "Bad indentation in region, at line %d" - (save-restriction - (widen) - (1+ (count-lines 1 (point))))))) - (setq target-column (+ indent-base - (* py-indent-offset - (- (length indents) 2)))) - (setq base-shifted-by (- target-column ci)))) - ;; shift as needed - (if (/= ci target-column) - (progn - (delete-horizontal-space) - (indent-to target-column))) - (forward-line 1)))) - (set-marker end nil)) - -(defun py-comment-region (beg end &optional arg) - "Like `comment-region' but uses double hash (`#') comment starter." - (interactive "r\nP") - (let ((comment-start py-block-comment-prefix)) - (comment-region beg end arg))) - - -;; Functions for moving point -(defun py-previous-statement (count) - "Go to the start of previous Python statement. -If the statement at point is the i'th Python statement, goes to the -start of statement i-COUNT. If there is no such statement, goes to the -first statement. Returns count of statements left to move. -`Statements' do not include blank, comment, or continuation lines." - (interactive "p") ; numeric prefix arg - (if (< count 0) (py-next-statement (- count)) - (py-goto-initial-line) - (let (start) - (while (and - (setq start (point)) ; always true -- side effect - (> count 0) - (zerop (forward-line -1)) - (py-goto-statement-at-or-above)) - (setq count (1- count))) - (if (> count 0) (goto-char start))) - count)) - -(defun py-next-statement (count) - "Go to the start of next Python statement. -If the statement at point is the i'th Python statement, goes to the -start of statement i+COUNT. If there is no such statement, goes to the -last statement. Returns count of statements left to move. `Statements' -do not include blank, comment, or continuation lines." - (interactive "p") ; numeric prefix arg - (if (< count 0) (py-previous-statement (- count)) - (beginning-of-line) - (let (start) - (while (and - (setq start (point)) ; always true -- side effect - (> count 0) - (py-goto-statement-below)) - (setq count (1- count))) - (if (> count 0) (goto-char start))) - count)) - -(defun py-goto-block-up (&optional nomark) - "Move up to start of current block. -Go to the statement that starts the smallest enclosing block; roughly -speaking, this will be the closest preceding statement that ends with a -colon and is indented less than the statement you started on. If -successful, also sets the mark to the starting point. - -`\\[py-mark-block]' can be used afterward to mark the whole code -block, if desired. - -If called from a program, the mark will not be set if optional argument -NOMARK is not nil." - (interactive) - (let ((start (point)) - (found nil) - initial-indent) - (py-goto-initial-line) - ;; if on blank or non-indenting comment line, use the preceding stmt - (if (looking-at "[ \t]*\\($\\|#[^ \t\n]\\)") - (progn - (py-goto-statement-at-or-above) - (setq found (py-statement-opens-block-p)))) - ;; search back for colon line indented less - (setq initial-indent (current-indentation)) - (if (zerop initial-indent) - ;; force fast exit - (goto-char (point-min))) - (while (not (or found (bobp))) - (setq found - (and - (re-search-backward ":[ \t]*\\($\\|[#\\]\\)" nil 'move) - (or (py-goto-initial-line) t) ; always true -- side effect - (< (current-indentation) initial-indent) - (py-statement-opens-block-p)))) - (if found - (progn - (or nomark (push-mark start)) - (back-to-indentation)) - (goto-char start) - (error "Enclosing block not found")))) - -(defun beginning-of-python-def-or-class (&optional class) - "Move point to start of def (or class, with prefix arg). - -Searches back for the closest preceding `def'. If you supply a prefix -arg, looks for a `class' instead. The docs assume the `def' case; -just substitute `class' for `def' for the other case. - -If point is in a def statement already, and after the `d', simply -moves point to the start of the statement. - -Else (point is not in a def statement, or at or before the `d' of a -def statement), searches for the closest preceding def statement, and -leaves point at its start. If no such statement can be found, leaves -point at the start of the buffer. - -Returns t iff a def statement is found by these rules. - -Note that doing this command repeatedly will take you closer to the -start of the buffer each time. - -If you want to mark the current def/class, see -`\\[mark-python-def-or-class]'." - (interactive "P") ; raw prefix arg - (let ((at-or-before-p (<= (current-column) (current-indentation))) - (start-of-line (progn (beginning-of-line) (point))) - (start-of-stmt (progn (py-goto-initial-line) (point)))) - (if (or (/= start-of-stmt start-of-line) - (not at-or-before-p)) - (end-of-line)) ; OK to match on this line - (re-search-backward (if class "^[ \t]*class\\>" "^[ \t]*def\\>") - nil 'move))) - -(defun end-of-python-def-or-class (&optional class) - "Move point beyond end of def (or class, with prefix arg) body. - -By default, looks for an appropriate `def'. If you supply a prefix arg, -looks for a `class' instead. The docs assume the `def' case; just -substitute `class' for `def' for the other case. - -If point is in a def statement already, this is the def we use. - -Else if the def found by `\\[beginning-of-python-def-or-class]' -contains the statement you started on, that's the def we use. - -Else we search forward for the closest following def, and use that. - -If a def can be found by these rules, point is moved to the start of -the line immediately following the def block, and the position of the -start of the def is returned. - -Else point is moved to the end of the buffer, and nil is returned. - -Note that doing this command repeatedly will take you closer to the -end of the buffer each time. - -If you want to mark the current def/class, see -`\\[mark-python-def-or-class]'." - (interactive "P") ; raw prefix arg - (let ((start (progn (py-goto-initial-line) (point))) - (which (if class "class" "def")) - (state 'not-found)) - ;; move point to start of appropriate def/class - (if (looking-at (concat "[ \t]*" which "\\>")) ; already on one - (setq state 'at-beginning) - ;; else see if beginning-of-python-def-or-class hits container - (if (and (beginning-of-python-def-or-class class) - (progn (py-goto-beyond-block) - (> (point) start))) - (setq state 'at-end) - ;; else search forward - (goto-char start) - (if (re-search-forward (concat "^[ \t]*" which "\\>") nil 'move) - (progn (setq state 'at-beginning) - (beginning-of-line))))) - (cond - ((eq state 'at-beginning) (py-goto-beyond-block) t) - ((eq state 'at-end) t) - ((eq state 'not-found) nil) - (t (error "internal error in end-of-python-def-or-class"))))) - - -;; Functions for marking regions -(defun py-mark-block (&optional extend just-move) - "Mark following block of lines. With prefix arg, mark structure. -Easier to use than explain. It sets the region to an `interesting' -block of succeeding lines. If point is on a blank line, it goes down to -the next non-blank line. That will be the start of the region. The end -of the region depends on the kind of line at the start: - - - If a comment, the region will include all succeeding comment lines up - to (but not including) the next non-comment line (if any). - - - Else if a prefix arg is given, and the line begins one of these - structures: - - if elif else try except finally for while def class - - the region will be set to the body of the structure, including - following blocks that `belong' to it, but excluding trailing blank - and comment lines. E.g., if on a `try' statement, the `try' block - and all (if any) of the following `except' and `finally' blocks - that belong to the `try' structure will be in the region. Ditto - for if/elif/else, for/else and while/else structures, and (a bit - degenerate, since they're always one-block structures) def and - class blocks. - - - Else if no prefix argument is given, and the line begins a Python - block (see list above), and the block is not a `one-liner' (i.e., - the statement ends with a colon, not with code), the region will - include all succeeding lines up to (but not including) the next - code statement (if any) that's indented no more than the starting - line, except that trailing blank and comment lines are excluded. - E.g., if the starting line begins a multi-statement `def' - structure, the region will be set to the full function definition, - but without any trailing `noise' lines. - - - Else the region will include all succeeding lines up to (but not - including) the next blank line, or code or indenting-comment line - indented strictly less than the starting line. Trailing indenting - comment lines are included in this case, but not trailing blank - lines. - -A msg identifying the location of the mark is displayed in the echo -area; or do `\\[exchange-point-and-mark]' to flip down to the end. - -If called from a program, optional argument EXTEND plays the role of -the prefix arg, and if optional argument JUST-MOVE is not nil, just -moves to the end of the block (& does not set mark or display a msg)." - (interactive "P") ; raw prefix arg - (py-goto-initial-line) - ;; skip over blank lines - (while (and - (looking-at "[ \t]*$") ; while blank line - (not (eobp))) ; & somewhere to go - (forward-line 1)) - (if (eobp) - (error "Hit end of buffer without finding a non-blank stmt")) - (let ((initial-pos (point)) - (initial-indent (current-indentation)) - last-pos ; position of last stmt in region - (followers - '((if elif else) (elif elif else) (else) - (try except finally) (except except) (finally) - (for else) (while else) - (def) (class) ) ) - first-symbol next-symbol) - - (cond - ;; if comment line, suck up the following comment lines - ((looking-at "[ \t]*#") - (re-search-forward "^[ \t]*[^ \t#]" nil 'move) ; look for non-comment - (re-search-backward "^[ \t]*#") ; and back to last comment in block - (setq last-pos (point))) - - ;; else if line is a block line and EXTEND given, suck up - ;; the whole structure - ((and extend - (setq first-symbol (py-suck-up-first-keyword) ) - (assq first-symbol followers)) - (while (and - (or (py-goto-beyond-block) t) ; side effect - (forward-line -1) ; side effect - (setq last-pos (point)) ; side effect - (py-goto-statement-below) - (= (current-indentation) initial-indent) - (setq next-symbol (py-suck-up-first-keyword)) - (memq next-symbol (cdr (assq first-symbol followers)))) - (setq first-symbol next-symbol))) - - ;; else if line *opens* a block, search for next stmt indented <= - ((py-statement-opens-block-p) - (while (and - (setq last-pos (point)) ; always true -- side effect - (py-goto-statement-below) - (> (current-indentation) initial-indent)) - nil)) - - ;; else plain code line; stop at next blank line, or stmt or - ;; indenting comment line indented < - (t - (while (and - (setq last-pos (point)) ; always true -- side effect - (or (py-goto-beyond-final-line) t) - (not (looking-at "[ \t]*$")) ; stop at blank line - (or - (>= (current-indentation) initial-indent) - (looking-at "[ \t]*#[^ \t\n]"))) ; ignore non-indenting # - nil))) - - ;; skip to end of last stmt - (goto-char last-pos) - (py-goto-beyond-final-line) - - ;; set mark & display - (if just-move - () ; just return - (push-mark (point) 'no-msg) - (forward-line -1) - (message "Mark set after: %s" (py-suck-up-leading-text)) - (goto-char initial-pos)))) - -(defun mark-python-def-or-class (&optional class) - "Set region to body of def (or class, with prefix arg) enclosing point. -Pushes the current mark, then point, on the mark ring (all language -modes do this, but although it's handy it's never documented ...). - -In most Emacs language modes, this function bears at least a -hallucinogenic resemblance to `\\[end-of-python-def-or-class]' and -`\\[beginning-of-python-def-or-class]'. - -And in earlier versions of Python mode, all 3 were tightly connected. -Turned out that was more confusing than useful: the `goto start' and -`goto end' commands are usually used to search through a file, and -people expect them to act a lot like `search backward' and `search -forward' string-search commands. But because Python `def' and `class' -can nest to arbitrary levels, finding the smallest def containing -point cannot be done via a simple backward search: the def containing -point may not be the closest preceding def, or even the closest -preceding def that's indented less. The fancy algorithm required is -appropriate for the usual uses of this `mark' command, but not for the -`goto' variations. - -So the def marked by this command may not be the one either of the -`goto' commands find: If point is on a blank or non-indenting comment -line, moves back to start of the closest preceding code statement or -indenting comment line. If this is a `def' statement, that's the def -we use. Else searches for the smallest enclosing `def' block and uses -that. Else signals an error. - -When an enclosing def is found: The mark is left immediately beyond -the last line of the def block. Point is left at the start of the -def, except that: if the def is preceded by a number of comment lines -followed by (at most) one optional blank line, point is left at the -start of the comments; else if the def is preceded by a blank line, -point is left at its start. - -The intent is to mark the containing def/class and its associated -documentation, to make moving and duplicating functions and classes -pleasant." - (interactive "P") ; raw prefix arg - (let ((start (point)) - (which (if class "class" "def"))) - (push-mark start) - (if (not (py-go-up-tree-to-keyword which)) - (progn (goto-char start) - (error "Enclosing %s not found" which)) - ;; else enclosing def/class found - (setq start (point)) - (py-goto-beyond-block) - (push-mark (point)) - (goto-char start) - (if (zerop (forward-line -1)) ; if there is a preceding line - (progn - (if (looking-at "[ \t]*$") ; it's blank - (setq start (point)) ; so reset start point - (goto-char start)) ; else try again - (if (zerop (forward-line -1)) - (if (looking-at "[ \t]*#") ; a comment - ;; look back for non-comment line - ;; tricky: note that the regexp matches a blank - ;; line, cuz \n is in the 2nd character class - (and - (re-search-backward "^[ \t]*[^ \t#]" nil 'move) - (forward-line 1)) - ;; no comment, so go back - (goto-char start)))))))) - -;; ripped from cc-mode -(defun py-forward-into-nomenclature (&optional arg) - "Move forward to end of a nomenclature section or word. -With arg, to it arg times. - -A `nomenclature' is a fancy way of saying AWordWithMixedCaseNotUnderscores." - (interactive "p") - (let ((case-fold-search nil)) - (if (> arg 0) - (re-search-forward - "\\(\\W\\|[_]\\)*\\([A-Z]*[a-z0-9]*\\)" - (point-max) t arg) - (while (and (< arg 0) - (re-search-backward - "\\(\\W\\|[a-z0-9]\\)[A-Z]+\\|\\(\\W\\|[_]\\)\\w+" - (point-min) 0)) - (forward-char 1) - (setq arg (1+ arg))))) - (py-keep-region-active)) - -(defun py-backward-into-nomenclature (&optional arg) - "Move backward to beginning of a nomenclature section or word. -With optional ARG, move that many times. If ARG is negative, move -forward. - -A `nomenclature' is a fancy way of saying AWordWithMixedCaseNotUnderscores." - (interactive "p") - (py-forward-into-nomenclature (- arg)) - (py-keep-region-active)) - - - -;; Documentation functions - -;; dump the long form of the mode blurb; does the usual doc escapes, -;; plus lines of the form ^[vc]:name$ to suck variable & command docs -;; out of the right places, along with the keys they're on & current -;; values -(defun py-dump-help-string (str) - (with-output-to-temp-buffer "*Help*" - (let ((locals (buffer-local-variables)) - funckind funcname func funcdoc - (start 0) mstart end - keys ) - (while (string-match "^%\\([vc]\\):\\(.+\\)\n" str start) - (setq mstart (match-beginning 0) end (match-end 0) - funckind (substring str (match-beginning 1) (match-end 1)) - funcname (substring str (match-beginning 2) (match-end 2)) - func (intern funcname)) - (princ (substitute-command-keys (substring str start mstart))) - (cond - ((equal funckind "c") ; command - (setq funcdoc (documentation func) - keys (concat - "Key(s): " - (mapconcat 'key-description - (where-is-internal func py-mode-map) - ", ")))) - ((equal funckind "v") ; variable - (setq funcdoc (documentation-property func 'variable-documentation) - keys (if (assq func locals) - (concat - "Local/Global values: " - (prin1-to-string (symbol-value func)) - " / " - (prin1-to-string (default-value func))) - (concat - "Value: " - (prin1-to-string (symbol-value func)))))) - (t ; unexpected - (error "Error in py-dump-help-string, tag `%s'" funckind))) - (princ (format "\n-> %s:\t%s\t%s\n\n" - (if (equal funckind "c") "Command" "Variable") - funcname keys)) - (princ funcdoc) - (terpri) - (setq start end)) - (princ (substitute-command-keys (substring str start)))) - (print-help-return-message))) - -(defun py-describe-mode () - "Dump long form of Python-mode docs." - (interactive) - (py-dump-help-string "Major mode for editing Python files. -Knows about Python indentation, tokens, comments and continuation lines. -Paragraphs are separated by blank lines only. - -Major sections below begin with the string `@'; specific function and -variable docs begin with `->'. - -@EXECUTING PYTHON CODE - -\\[py-execute-buffer]\tsends the entire buffer to the Python interpreter -\\[py-execute-region]\tsends the current region -\\[py-shell]\tstarts a Python interpreter window; this will be used by -\tsubsequent \\[py-execute-buffer] or \\[py-execute-region] commands -%c:py-execute-buffer -%c:py-execute-region -%c:py-shell - -@VARIABLES - -py-indent-offset\tindentation increment -py-block-comment-prefix\tcomment string used by comment-region - -py-python-command\tshell command to invoke Python interpreter -py-scroll-process-buffer\talways scroll Python process buffer -py-temp-directory\tdirectory used for temp files (if needed) - -py-beep-if-tab-change\tring the bell if tab-width is changed -%v:py-indent-offset -%v:py-block-comment-prefix -%v:py-python-command -%v:py-scroll-process-buffer -%v:py-temp-directory -%v:py-beep-if-tab-change - -@KINDS OF LINES - -Each physical line in the file is either a `continuation line' (the -preceding line ends with a backslash that's not part of a comment, or -the paren/bracket/brace nesting level at the start of the line is -non-zero, or both) or an `initial line' (everything else). - -An initial line is in turn a `blank line' (contains nothing except -possibly blanks or tabs), a `comment line' (leftmost non-blank -character is `#'), or a `code line' (everything else). - -Comment Lines - -Although all comment lines are treated alike by Python, Python mode -recognizes two kinds that act differently with respect to indentation. - -An `indenting comment line' is a comment line with a blank, tab or -nothing after the initial `#'. The indentation commands (see below) -treat these exactly as if they were code lines: a line following an -indenting comment line will be indented like the comment line. All -other comment lines (those with a non-whitespace character immediately -following the initial `#') are `non-indenting comment lines', and -their indentation is ignored by the indentation commands. - -Indenting comment lines are by far the usual case, and should be used -whenever possible. Non-indenting comment lines are useful in cases -like these: - -\ta = b # a very wordy single-line comment that ends up being -\t #... continued onto another line - -\tif a == b: -##\t\tprint 'panic!' # old code we've `commented out' -\t\treturn a - -Since the `#...' and `##' comment lines have a non-whitespace -character following the initial `#', Python mode ignores them when -computing the proper indentation for the next line. - -Continuation Lines and Statements - -The Python-mode commands generally work on statements instead of on -individual lines, where a `statement' is a comment or blank line, or a -code line and all of its following continuation lines (if any) -considered as a single logical unit. The commands in this mode -generally (when it makes sense) automatically move to the start of the -statement containing point, even if point happens to be in the middle -of some continuation line. - - -@INDENTATION - -Primarily for entering new code: -\t\\[indent-for-tab-command]\t indent line appropriately -\t\\[py-newline-and-indent]\t insert newline, then indent -\t\\[py-delete-char]\t reduce indentation, or delete single character - -Primarily for reindenting existing code: -\t\\[py-guess-indent-offset]\t guess py-indent-offset from file content; change locally -\t\\[universal-argument] \\[py-guess-indent-offset]\t ditto, but change globally - -\t\\[py-indent-region]\t reindent region to match its context -\t\\[py-shift-region-left]\t shift region left by py-indent-offset -\t\\[py-shift-region-right]\t shift region right by py-indent-offset - -Unlike most programming languages, Python uses indentation, and only -indentation, to specify block structure. Hence the indentation supplied -automatically by Python-mode is just an educated guess: only you know -the block structure you intend, so only you can supply correct -indentation. - -The \\[indent-for-tab-command] and \\[py-newline-and-indent] keys try to suggest plausible indentation, based on -the indentation of preceding statements. E.g., assuming -py-indent-offset is 4, after you enter -\tif a > 0: \\[py-newline-and-indent] -the cursor will be moved to the position of the `_' (_ is not a -character in the file, it's just used here to indicate the location of -the cursor): -\tif a > 0: -\t _ -If you then enter `c = d' \\[py-newline-and-indent], the cursor will move -to -\tif a > 0: -\t c = d -\t _ -Python-mode cannot know whether that's what you intended, or whether -\tif a > 0: -\t c = d -\t_ -was your intent. In general, Python-mode either reproduces the -indentation of the (closest code or indenting-comment) preceding -statement, or adds an extra py-indent-offset blanks if the preceding -statement has `:' as its last significant (non-whitespace and non- -comment) character. If the suggested indentation is too much, use -\\[py-delete-char] to reduce it. - -Continuation lines are given extra indentation. If you don't like the -suggested indentation, change it to something you do like, and Python- -mode will strive to indent later lines of the statement in the same way. - -If a line is a continuation line by virtue of being in an unclosed -paren/bracket/brace structure (`list', for short), the suggested -indentation depends on whether the current line contains the first item -in the list. If it does, it's indented py-indent-offset columns beyond -the indentation of the line containing the open bracket. If you don't -like that, change it by hand. The remaining items in the list will mimic -whatever indentation you give to the first item. - -If a line is a continuation line because the line preceding it ends with -a backslash, the third and following lines of the statement inherit their -indentation from the line preceding them. The indentation of the second -line in the statement depends on the form of the first (base) line: if -the base line is an assignment statement with anything more interesting -than the backslash following the leftmost assigning `=', the second line -is indented two columns beyond that `='. Else it's indented to two -columns beyond the leftmost solid chunk of non-whitespace characters on -the base line. - -Warning: indent-region should not normally be used! It calls \\[indent-for-tab-command] -repeatedly, and as explained above, \\[indent-for-tab-command] can't guess the block -structure you intend. -%c:indent-for-tab-command -%c:py-newline-and-indent -%c:py-delete-char - - -The next function may be handy when editing code you didn't write: -%c:py-guess-indent-offset - - -The remaining `indent' functions apply to a region of Python code. They -assume the block structure (equals indentation, in Python) of the region -is correct, and alter the indentation in various ways while preserving -the block structure: -%c:py-indent-region -%c:py-shift-region-left -%c:py-shift-region-right - -@MARKING & MANIPULATING REGIONS OF CODE - -\\[py-mark-block]\t mark block of lines -\\[mark-python-def-or-class]\t mark smallest enclosing def -\\[universal-argument] \\[mark-python-def-or-class]\t mark smallest enclosing class -\\[comment-region]\t comment out region of code -\\[universal-argument] \\[comment-region]\t uncomment region of code -%c:py-mark-block -%c:mark-python-def-or-class -%c:comment-region - -@MOVING POINT - -\\[py-previous-statement]\t move to statement preceding point -\\[py-next-statement]\t move to statement following point -\\[py-goto-block-up]\t move up to start of current block -\\[beginning-of-python-def-or-class]\t move to start of def -\\[universal-argument] \\[beginning-of-python-def-or-class]\t move to start of class -\\[end-of-python-def-or-class]\t move to end of def -\\[universal-argument] \\[end-of-python-def-or-class]\t move to end of class - -The first two move to one statement beyond the statement that contains -point. A numeric prefix argument tells them to move that many -statements instead. Blank lines, comment lines, and continuation lines -do not count as `statements' for these commands. So, e.g., you can go -to the first code statement in a file by entering -\t\\[beginning-of-buffer]\t to move to the top of the file -\t\\[py-next-statement]\t to skip over initial comments and blank lines -Or do `\\[py-previous-statement]' with a huge prefix argument. -%c:py-previous-statement -%c:py-next-statement -%c:py-goto-block-up -%c:beginning-of-python-def-or-class -%c:end-of-python-def-or-class - -@LITTLE-KNOWN EMACS COMMANDS PARTICULARLY USEFUL IN PYTHON MODE - -`\\[indent-new-comment-line]' is handy for entering a multi-line comment. - -`\\[set-selective-display]' with a `small' prefix arg is ideally suited for viewing the -overall class and def structure of a module. - -`\\[back-to-indentation]' moves point to a line's first non-blank character. - -`\\[indent-relative]' is handy for creating odd indentation. - -@OTHER EMACS HINTS - -If you don't like the default value of a variable, change its value to -whatever you do like by putting a `setq' line in your .emacs file. -E.g., to set the indentation increment to 4, put this line in your -.emacs: -\t(setq py-indent-offset 4) -To see the value of a variable, do `\\[describe-variable]' and enter the variable -name at the prompt. - -When entering a key sequence like `C-c C-n', it is not necessary to -release the CONTROL key after doing the `C-c' part -- it suffices to -press the CONTROL key, press and release `c' (while still holding down -CONTROL), press and release `n' (while still holding down CONTROL), & -then release CONTROL. - -Entering Python mode calls with no arguments the value of the variable -`python-mode-hook', if that value exists and is not nil; for backward -compatibility it also tries `py-mode-hook'; see the `Hooks' section of -the Elisp manual for details. - -Obscure: When python-mode is first loaded, it looks for all bindings -to newline-and-indent in the global keymap, and shadows them with -local bindings to py-newline-and-indent.")) - - -;; Helper functions -(defvar py-parse-state-re - (concat - "^[ \t]*\\(if\\|elif\\|else\\|while\\|def\\|class\\)\\>" - "\\|" - "^[^ #\t\n]")) - -;; returns the parse state at point (see parse-partial-sexp docs) -(defun py-parse-state () - (save-excursion - (let ((here (point)) - pps done ci) - (while (not done) - ;; back up to the first preceding line (if any; else start of - ;; buffer) that begins with a popular Python keyword, or a - ;; non- whitespace and non-comment character. These are good - ;; places to start parsing to see whether where we started is - ;; at a non-zero nesting level. It may be slow for people who - ;; write huge code blocks or huge lists ... tough beans. - (re-search-backward py-parse-state-re nil 'move) - (setq ci (current-indentation)) - (beginning-of-line) - (save-excursion - (setq pps (parse-partial-sexp (point) here))) - ;; make sure we don't land inside a triple-quoted string - (setq done (or (zerop ci) - (not (nth 3 pps)) - (bobp))) - ) - pps))) - -;; if point is at a non-zero nesting level, returns the number of the -;; character that opens the smallest enclosing unclosed list; else -;; returns nil. -(defun py-nesting-level () - (let ((status (py-parse-state)) ) - (if (zerop (car status)) - nil ; not in a nest - (car (cdr status))))) ; char# of open bracket - -;; t iff preceding line ends with backslash that's not in a comment -(defun py-backslash-continuation-line-p () - (save-excursion - (beginning-of-line) - (and - ;; use a cheap test first to avoid the regexp if possible - ;; use 'eq' because char-after may return nil - (eq (char-after (- (point) 2)) ?\\ ) - ;; make sure; since eq test passed, there is a preceding line - (forward-line -1) ; always true -- side effect - (looking-at py-continued-re)))) - -;; t iff current line is a continuation line -(defun py-continuation-line-p () - (save-excursion - (beginning-of-line) - (or (py-backslash-continuation-line-p) - (py-nesting-level)))) - -;; go to initial line of current statement; usually this is the line -;; we're on, but if we're on the 2nd or following lines of a -;; continuation block, we need to go up to the first line of the -;; block. -;; -;; Tricky: We want to avoid quadratic-time behavior for long continued -;; blocks, whether of the backslash or open-bracket varieties, or a -;; mix of the two. The following manages to do that in the usual -;; cases. -(defun py-goto-initial-line () - (let ( open-bracket-pos ) - (while (py-continuation-line-p) - (beginning-of-line) - (if (py-backslash-continuation-line-p) - (while (py-backslash-continuation-line-p) - (forward-line -1)) - ;; else zip out of nested brackets/braces/parens - (while (setq open-bracket-pos (py-nesting-level)) - (goto-char open-bracket-pos))))) - (beginning-of-line)) - -;; go to point right beyond final line of current statement; usually -;; this is the start of the next line, but if this is a multi-line -;; statement we need to skip over the continuation lines. Tricky: -;; Again we need to be clever to avoid quadratic time behavior. -(defun py-goto-beyond-final-line () - (forward-line 1) - (let (state) - (while (and (py-continuation-line-p) - (not (eobp))) - ;; skip over the backslash flavor - (while (and (py-backslash-continuation-line-p) - (not (eobp))) - (forward-line 1)) - ;; if in nest, zip to the end of the nest - (setq state (py-parse-state)) - (if (and (not (zerop (car state))) - (not (eobp))) - (progn - (parse-partial-sexp (point) (point-max) - (if py-parse-partial-sexp-works-p - 0 (- 0 (car state))) - nil state) - (forward-line 1)))))) - -;; t iff statement opens a block == iff it ends with a colon that's -;; not in a comment. point should be at the start of a statement -(defun py-statement-opens-block-p () - (save-excursion - (let ((start (point)) - (finish (progn (py-goto-beyond-final-line) (1- (point)))) - (searching t) - (answer nil) - state) - (goto-char start) - (while searching - ;; look for a colon with nothing after it except whitespace, and - ;; maybe a comment - (if (re-search-forward ":\\([ \t]\\|\\\\\n\\)*\\(#.*\\)?$" - finish t) - (if (eq (point) finish) ; note: no `else' clause; just - ; keep searching if we're not at - ; the end yet - ;; sure looks like it opens a block -- but it might - ;; be in a comment - (progn - (setq searching nil) ; search is done either way - (setq state (parse-partial-sexp start - (match-beginning 0))) - (setq answer (not (nth 4 state))))) - ;; search failed: couldn't find another interesting colon - (setq searching nil))) - answer))) - -(defun py-statement-closes-block-p () - ;; true iff the current statement `closes' a block == the line - ;; starts with `return', `raise', `break', `continue', and `pass'. - ;; doesn't catch embedded statements - (let ((here (point))) - (back-to-indentation) - (prog1 - (looking-at "\\(return\\|raise\\|break\\|continue\\|pass\\)\\>") - (goto-char here)))) - -;; go to point right beyond final line of block begun by the current -;; line. This is the same as where py-goto-beyond-final-line goes -;; unless we're on colon line, in which case we go to the end of the -;; block. assumes point is at bolp -(defun py-goto-beyond-block () - (if (py-statement-opens-block-p) - (py-mark-block nil 'just-move) - (py-goto-beyond-final-line))) - -;; go to start of first statement (not blank or comment or -;; continuation line) at or preceding point. returns t if there is -;; one, else nil -(defun py-goto-statement-at-or-above () - (py-goto-initial-line) - (if (looking-at py-blank-or-comment-re) - ;; skip back over blank & comment lines - ;; note: will skip a blank or comment line that happens to be - ;; a continuation line too - (if (re-search-backward "^[ \t]*[^ \t#\n]" nil t) - (progn (py-goto-initial-line) t) - nil) - t)) - -;; go to start of first statement (not blank or comment or -;; continuation line) following the statement containing point returns -;; t if there is one, else nil -(defun py-goto-statement-below () - (beginning-of-line) - (let ((start (point))) - (py-goto-beyond-final-line) - (while (and - (looking-at py-blank-or-comment-re) - (not (eobp))) - (forward-line 1)) - (if (eobp) - (progn (goto-char start) nil) - t))) - -;; go to start of statement, at or preceding point, starting with -;; keyword KEY. Skips blank lines and non-indenting comments upward -;; first. If that statement starts with KEY, done, else go back to -;; first enclosing block starting with KEY. If successful, leaves -;; point at the start of the KEY line & returns t. Else leaves point -;; at an undefined place & returns nil. -(defun py-go-up-tree-to-keyword (key) - ;; skip blanks and non-indenting # - (py-goto-initial-line) - (while (and - (looking-at "[ \t]*\\($\\|#[^ \t\n]\\)") - (zerop (forward-line -1))) ; go back - nil) - (py-goto-initial-line) - (let* ((re (concat "[ \t]*" key "\\b")) - (case-fold-search nil) ; let* so looking-at sees this - (found (looking-at re)) - (dead nil)) - (while (not (or found dead)) - (condition-case nil ; in case no enclosing block - (py-goto-block-up 'no-mark) - (error (setq dead t))) - (or dead (setq found (looking-at re)))) - (beginning-of-line) - found)) - -;; return string in buffer from start of indentation to end of line; -;; prefix "..." if leading whitespace was skipped -(defun py-suck-up-leading-text () - (save-excursion - (back-to-indentation) - (concat - (if (bolp) "" "...") - (buffer-substring (point) (progn (end-of-line) (point)))))) - -;; assuming point at bolp, return first keyword ([a-z]+) on the line, -;; as a Lisp symbol; return nil if none -(defun py-suck-up-first-keyword () - (let ((case-fold-search nil)) - (if (looking-at "[ \t]*\\([a-z]+\\)\\b") - (intern (buffer-substring (match-beginning 1) (match-end 1))) - nil))) - -(defun py-make-temp-name () - (make-temp-name - (concat (file-name-as-directory py-temp-directory) "python"))) - -(defun py-delete-file-silently (fname) - (condition-case nil - (delete-file fname) - (error nil))) - -(defun py-kill-emacs-hook () - ;; delete our temp files - (while py-file-queue - (py-delete-file-silently (car py-file-queue)) - (setq py-file-queue (cdr py-file-queue))) - (if (not (or py-this-is-lucid-emacs-p py-this-is-emacs-19-p)) - ;; run the hook we inherited, if any - (and py-inherited-kill-emacs-hook - (funcall py-inherited-kill-emacs-hook)))) - -;; make PROCESS's buffer visible, append STRING to it, and force -;; display; also make shell-mode believe the user typed this string, -;; so that kill-output-from-shell and show-output-from-shell work -;; "right" -(defun py-append-to-process-buffer (process string) - (let ((cbuf (current-buffer)) - (pbuf (process-buffer process)) - (py-scroll-process-buffer t)) - (set-buffer pbuf) - (goto-char (point-max)) - (move-marker (process-mark process) (point)) - (if (not (or py-this-is-emacs-19-p - py-this-is-lucid-emacs-p)) - (move-marker last-input-start (point))) ; muck w/ shell-mode - (funcall (process-filter process) process string) - (if (not (or py-this-is-emacs-19-p - py-this-is-lucid-emacs-p)) - (move-marker last-input-end (point))) ; muck w/ shell-mode - (set-buffer cbuf)) - (sit-for 0)) - -;; older Emacsen don't have this function -(if (not (fboundp 'match-string)) - (defun match-string (n) - (let ((beg (match-beginning n)) - (end (match-end n))) - (if (and beg end) - (buffer-substring beg end) - nil)))) - -(defun py-current-defun () - ;; tell add-log.el how to find the current function/method/variable - (save-excursion - (if (re-search-backward py-defun-start-re nil t) - (or (match-string 3) - (let ((method (match-string 2))) - (if (and (not (zerop (length (match-string 1)))) - (re-search-backward py-class-start-re nil t)) - (concat (match-string 1) "." method) - method))) - nil))) - - -(defconst py-version "2.90" - "`python-mode' version number.") -(defconst py-help-address "python-mode@python.org" - "Address accepting submission of bug reports.") - -(defun py-version () - "Echo the current version of `python-mode' in the minibuffer." - (interactive) - (message "Using `python-mode' version %s" py-version) - (py-keep-region-active)) - -;; only works under Emacs 19 -;(eval-when-compile -; (require 'reporter)) - -(defun py-submit-bug-report (enhancement-p) - "Submit via mail a bug report on `python-mode'. -With \\[universal-argument] just submit an enhancement request." - (interactive - (list (not (y-or-n-p - "Is this a bug report? (hit `n' to send other comments) ")))) - (let ((reporter-prompt-for-summary-p (if enhancement-p - "(Very) brief summary: " - t))) - (require 'reporter) - (reporter-submit-bug-report - py-help-address ;address - (concat "python-mode " py-version) ;pkgname - ;; varlist - (if enhancement-p nil - '(py-python-command - py-indent-offset - py-block-comment-prefix - py-scroll-process-buffer - py-temp-directory - py-beep-if-tab-change)) - nil ;pre-hooks - nil ;post-hooks - "Dear Barry,") ;salutation - (if enhancement-p nil - (set-mark (point)) - (insert -"Please replace this text with a sufficiently large code sample\n\ -and an exact recipe so that I can reproduce your problem. Failure\n\ -to do so may mean a greater delay in fixing your bug.\n\n") - (exchange-point-and-mark) - (py-keep-region-active)))) - - -;; arrange to kill temp files when Emacs exists -(if (or py-this-is-emacs-19-p py-this-is-lucid-emacs-p) - (add-hook 'kill-emacs-hook 'py-kill-emacs-hook) - ;; have to trust that other people are as respectful of our hook - ;; fiddling as we are of theirs - (if (boundp 'py-inherited-kill-emacs-hook) - ;; we were loaded before -- trust others not to have screwed us - ;; in the meantime (no choice, really) - nil - ;; else arrange for our hook to run theirs - (setq py-inherited-kill-emacs-hook kill-emacs-hook) - (setq kill-emacs-hook 'py-kill-emacs-hook))) - - - -(provide 'python-mode) -;;; python-mode.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/reftex.el --- a/lisp/modes/reftex.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,5661 +0,0 @@ -;; reftex.el --- Minor mode for doing \label, \ref and \cite in LaTeX -;; Copyright (c) 1997 Free Software Foundation, Inc. - -;; Version: 3.7 -;; Author: Carsten Dominik -;; Keywords: tex - -;; 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., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;--------------------------------------------------------------------------- -;; -;;; Commentary: -;; -;; RefTeX is a minor mode with distinct support for \ref, \label and -;; \cite commands in (multi-file) LaTeX documents. -;; Labels are created semi-automatically. Definition context of labels is -;; provided when creating a reference. Citations are simplified with -;; efficient database lookup. A table of contents buffer provides easy -;; access to any part of a document. -;; -;; To turn RefTeX Minor Mode on and off in a particular buffer, use -;; `M-x reftex-mode'. -;; -;; To turn on RefTeX Minor Mode for all LaTeX files, add one of the -;; following lines to your .emacs file: -;; -;; (add-hook 'LaTeX-mode-hook 'turn-on-reftex) ; with AUCTeX LaTeX mode -;; (add-hook 'latex-mode-hook 'turn-on-reftex) ; with Emacs latex mode -;; -;; For default key bindings, see further down in this documentation. -;; -;;--------------------------------------------------------------------------- -;; -;; CONTENTS -;; -------- -;; -;; Overview............................ All you need to know to get started. -;; -;; Configuration....................... How to configure RefTeX. -;; Configuration Examples........... Tutorial examples. -;; Hooks............................ Available hooks. -;; Configuration Variables.......... Complete listing. -;; Key Bindings........................ A list of default bindings. -;; Multifile Documents................. Documents spread over many files. -;; References to Other Documents....... RefTeX and the LaTeX package `xr'. -;; Optimizations for Large Documents... How to improve speed and memory use. -;; Related Packages.................... Other Emacs packages. -;; Known Bugs and Work-Arounds......... First aid. -;; Author.............................. Who wrote RefTeX and who helped. -;; History............................. What was new in which version. -;;--------------------------------------------------------------------------- -;; -;; OVERVIEW -;; ======== -;; -;; 1. USING \label AND \ref. Labels and references are one of the strong -;; points of LaTeX. But, in documents with hundreds of equations, -;; figures, tables etc. it becomes quickly impossible to find good label -;; names and to actually remember them. Then, also completion of labels -;; is not enough. One actually needs to see the context of the label -;; definition to find the right one. -;; -;; - RefTeX distinguishes labels for different environments. It always -;; knows if a certain label references a figure, table etc.. You can -;; configure RefTeX to recognize any additional labeled environments -;; you have defined yourself. -;; -;; - RefTeX defines automatically unique labels. Type `C-c (' -;; (`reftex-label') to insert a label at point. RefTeX will either -;; - derive a label from context (default for section labels) -;; - insert a simple label consisting of a prefix and a number -;; (default for equations,enumerate items, and footnotes) or -;; - prompt for a label string (figures and tables). -;; Which labels are created how can be controlled with the variable -;; `reftex-insert-label-flags'. -;; -;; - Referencing labels is a snap and I promise you'll love it. In -;; order to make a reference, type `C-c )' (`reftex-reference'). This -;; shows an outline of the document with all labels of a certain type -;; (figure, equation,...) and context of the label definition. -;; Selecting one of the labels inserts a \ref macro into the original -;; buffer. Online help during the selection is available with `?'. -;; -;; 2. CITATIONS. After typing `C-c [' (`reftex-citation'), RefTeX will let -;; you specify a regexp to search in current BibTeX database files (as -;; specified in the \bibliography command) and pull out a formatted list -;; of matches for you to choose from. The list is *formatted* and -;; sorted, thus much easier to read than the raw database entries. The -;; text inserted into the buffer is by default just `\cite{KEY}', but -;; can also contain author names and the year in a configurable way. -;; See documentation of the variable `reftex-cite-format'. -;; -;; 3. TABLE OF CONTENTS. Typing `C-c =' (`reftex-toc') will show a table -;; of contents of the document. From that buffer, you can jump quickly -;; to every part of your document. This is similar to imenu, only it -;; works for entire multifile documents and uses the keyboard rather -;; than the mouse. The initial version of this function was contributed -;; by Stephen Eglen. -;; -;; 4. MULTIFILE DOCUMENTS are fully supported by RefTeX. Such documents -;; consist of a master file and many other files being included via -;; \input or \include. RefTeX will provide cross referencing -;; information from all files which are part of the document. See -;; `RefTeX and Multifile Documents' further down in the documentation -;; for more information on this topic. -;; -;; 5. DOCUMENT PARSING. RefTeX needs to parse the document in order to -;; find labels and other information. It will do it automatically once, -;; when you start working with a document. Re-parsing should not be -;; necessary too often since RefTeX updates its lists internally when -;; you make a new label with `reftex-label'. To enforce reparsing, -;; call any of the functions `reftex-citation', `reftex-label', -;; `reftex-reference', `reftex-toc' with a raw C-u prefix, or press the -;; `r' key in the label menu and table of contents buffer. -;;--------------------------------------------------------------------------- -;; -;; CONFIGURATION -;; ============= -;; -;; RefTeX needs to be configured if you use labels to mark environments -;; defined by yourself (e.g. with `\newenvironment') or in packages not -;; included in the standard LaTeX distribution. RefTeX's default settings -;; make it recognize practically all labeled environments and macros -;; discussed in `The LaTeX Companion' by Goossens, Mittelbach & Samarin, -;; Addison-Wesley 1994. These are: -;; -;; - figure, figure*, table, table*, equation, eqnarray, enumerate, -;; the \footnote macro (this is the LaTeX core stuff) -;; - align, gather, multline, flalign, alignat, xalignat, xxalignat, -;; subequations (from AMS-LaTeX's amsmath.sty package) -;; - the \endnote macro (from endnotes.sty) -;; - Beqnarray (fancybox.sty) -;; - floatingfig (floatfig.sty) -;; - longtable (longtable.sty) -;; - figwindow, tabwindow (picinpar.sty) -;; - sidewaysfigure, sidewaystable (rotating.sty) -;; - subfigure, subfigure*, the \subfigure macro (subfigure.sty) -;; - supertabular (supertab.sty) -;; - wrapfigure (wrapfig.sty) -;; -;; If you want to use any other labeled environments or macros, you need -;; to configure RefTeX. -;; -;; Per Abrahamsens custom.el package provides a simple way to do -;; configuration. To try it out, use `M-x reftex-customize'. -;; -;; CONFIGURATION EXAMPLES -;; ---------------------- -;; -;; Suppose you are working with AMS-LaTeX amsmath package (with its math -;; environments like `align', `multline' etc.). RefTeX is preconfigured to -;; recognize these - so there is nothing you have to do. -;; -;; Suppose you are also using `\newtheorem' in LaTeX in order to define two -;; new environments `theorem' and `axiom' -;; -;; \newtheorem{axiom}{Axiom} -;; \newtheorem{theorem}{Theorem} -;; -;; to be used like this: -;; -;; \begin{axiom} -;; \label{ax:first} -;; .... -;; \end{axiom} -;; -;; So we need to tell RefTeX that `theorem' and `axiom' are new labeled -;; environments which define their own label categories. Here is how: -;; -;; (setq reftex-label-alist -;; '(("axiom" ?a "ax:" "~\\ref{%s}" nil ("Axiom" "Ax.")) -;; ("theorem" ?h "thr:" "~\\ref{%s}" t ("Theorem" "Theor." "Th.")))) -;; -;; The type indicator characters ?a and ?h are used for prompts when RefTeX -;; queries for a label type. Note that `h' was chosen for `theorem' since -;; `t' is already taken by `table'. Note that also `s', `f', `e', `i', `n' -;; are already used for standard environments. -;; The automatic labels for Axioms and Theorems will look like "ax:23" or -;; "thr:24". -;; The "\ref{%s}" is a format string indicating how to insert references to -;; these labels. -;; The next item indicates how to grab context of the label definition. -;; - t means to get it from a default location (from the beginning of a -;; \macro or after the \begin statement). t is *not* a good choice for -;; eqnarray and similar environments. -;; - nil means to use the text right after the label definition. -;; - For more complex ways of getting context, see the docstring of -;; `reftex-label-alist'. -;; The strings at the end of each entry are used to guess the correct label -;; type from the word before point when creating a reference. E.g. if you -;; write: "As we have shown in Theorem" and then press `C-c )', RefTeX will -;; know that you are looking for a theorem label and restrict the menu to -;; only these labels without even asking. -;; -;; Depending on how you would like the label insertion and selection for -;; the new environments to work, you might want to add the letters "a" and -;; "h" to some of the flags in the following variables: -;; -;; reftex-insert-label-flags reftex-label-menu-flags -;; -;; Suppose you want to make figures not directly with the figure -;; environment, but with a macro like -;; -;; \newcommand{\myfig}[5][tbp]{% -;; \begin{figure}[#1] -;; \epsimp[#5]{#2} -;; \caption{#3} -;; \label{#4} -;; \end{figure}} -;; -;; which would be called like -;; -;; \myfig[htp]{filename}{caption text}{label}{1} -;; -;; Now we also need to tell RefTeX that the 4th argument of the \myfig -;; macro is a figure label, and where to find the context. -;; -;; (setq reftex-label-alist -;; '(("axiom" ?a "ax:" "~\\ref{%s}" nil ("Axiom" "Ax.")) -;; ("theorem" ?h "thr:" "~\\ref{%s}" t ("Theorem" "Theor." "Th.")) -;; ("\\myfig[]{}{}{*}{}" ?f nil nil 3))) -;; -;; The empty pairs of brackets indicate the different arguments of the -;; \myfig macro. The `*' marks the label argument. `?f' indicates that -;; this is a figure label which will be listed together with labels from -;; normal figure environments. The nil entries for prefix and reference -;; format mean to use the defaults for figure labels. The `3' for the -;; context method means to grab the 3rd macro argument - the caption. -;; -;; As a side effect of this configuration, `reftex-label' will now insert -;; the required naked label (without the \label macro) when point is -;; directly after the opening parenthesis of a \myfig macro argument. -;; -;; ----- -;; -;; If you are writing in a language different from English you might want -;; to add magic words for that language. Here is a German example: -;; -;; (setq reftex-label-alist -;; '((nil ?s nil nil nil ("Kapitel" "Kap." "Abschnitt" "Teil")) -;; (nil ?e nil nil nil ("Gleichung" "Gl.")) -;; (nil ?t nil nil nil ("Tabelle")) -;; (nil ?f nil nil nil ("Figur" "Abbildung" "Abb.")) -;; (nil ?n nil nil nil ("Anmerkung" "Anm.")) -;; (nil ?i nil nil nil ("Punkt")))) -;; -;; Using nil as first item in each entry makes sure that this entry does -;; not replace the original entry for that label type, but just adds magic -;; words. -;; -;; ----- -;; -;; Normally, RefTeX inserts equation references with parenthesis like -;; "~(\ref{KEY})". If you want to change this to square brackets, use -;; -;; (setq reftex-label-alist '((nil ?e nil "~[\\ref{%s}]" nil nil))) -;; -;; In order to use the AMS-LaTeX \eqref macro instead, either of the -;; following lines does the job. -;; -;; (setq reftex-label-alist '((nil ?e nil "~\\eqref{%s}" nil nil))) -;; (setq reftex-label-alist '(AMSTeX)) -;; -;; ---- -;; -;; By default, citations are inserted simply as \cite{KEY}. You can have -;; more complex citation commands with many available packages, most -;; notably the harvard and natbib packages. RefTeX can be configured to -;; support these and other styles by setting the variable -;; `reftex-cite-format'. E.g., for the natbib package you would use -;; -;; (setq reftex-cite-format 'natbib) -;; -;; This can also be done as a file variable. For the full list of builtin -;; options, try `M-x customize-variable RET reftex-cite-format RET'. -;; -;; HOOKS -;; ----- -;; - Loading reftex.el runs the hook `reftex-load-hook'. -;; - Turning on reftex-mode runs `reftex-mode-hook'. -;; - Files visited literally are processed with -;; `reftex-initialize-temporary-buffers' if that is a list of functions. -;; -;; CONFIGURATION VARIABLES -;; ----------------------- -;; -;; The best way to learn about all configuration variables is via the -;; browser interface of the custom library. For reference, I am giving -;; here a complete list. -;; -;; ;; Defining label environments -;; reftex-default-label-alist-entries -;; reftex-label-alist -;; reftex-section-levels -;; reftex-default-context-regexps -;; reftex-use-text-after-label-as-context -;; ;; Label insertion -;; reftex-insert-label-flags -;; reftex-derive-label-parameters -;; reftex-label-illegal-re -;; reftex-abbrev-parameters -;; ;; Label referencing -;; reftex-label-menu-flags -;; reftex-level-indent -;; reftex-refontify-context -;; reftex-guess-label-type -;; ;; BibteX citation configuration -;; reftex-bibpath-environment-variables -;; reftex-bibfile-ignore-list -;; reftex-sort-bibtex-matches -;; reftex-cite-format -;; reftex-comment-citations -;; reftex-cite-comment-format -;; reftex-cite-punctuation -;; ;; Table of contents configuration -;; reftex-toc-follow-mode -;; ;; Fine-tuning the parser -;; reftex-keep-temporary-buffers -;; reftex-initialize-temporary-buffers -;; reftex-enable-partial-scans -;; reftex-save-parse-info -;; ;; Miscellaneous configurations -;; reftex-extra-bindings -;; reftex-plug-into-AUCTeX -;; reftex-use-fonts -;; reftex-auto-show-entry -;; reftex-load-hook -;; reftex-mode-hook -;;------------------------------------------------------------------------- -;; -;; KEY BINDINGS -;; ============ -;; -;; All RefTeX commands can be reached from its menu, the `Ref' menu on the -;; menu bar. More frequently used commands have key bindings: -;; -;; C-c = reftex-toc -;; C-c ( reftex-label -;; C-c ) reftex-reference -;; C-c [ reftex-citation -;; C-c & reftex-view-crossref -;; -;; These keys are chosen to avoid interfering with AUCTeX's settings. -;; Personally, I also bind some functions in the C-c LETTER map for -;; easier access: -;; -;; C-c t reftex-toc -;; C-c l reftex-label -;; C-c r reftex-reference -;; C-c c reftex-citation -;; C-c v reftex-view-crossref -;; C-c s reftex-search-document -;; C-c g reftex-grep-document -;; -;; If you want to copy those as well, set in your .emacs file: -;; -;; (setq reftex-extra-bindings t) -;; -;; It is possible to bind the function for viewing cross references to a -;; mouse event. Something like the following will do the trick: -;; -;; (add-hook 'reftex-load-hook -;; '(lambda () -;; (define-key reftex-mode-map [(shift mouse-2)] -;; 'reftex-mouse-view-crossref))) -;;------------------------------------------------------------------------- -;; -;; REFTEX AND MULTIFILE DOCUMENTS -;; ============================== -;; -;; The following is relevant when using RefTeX for multi-file documents: -;; -;; o RefTeX has full support for multifile documents. You can edit parts -;; of several (multifile) documents at the same time without conflicts. -;; RefTeX provides functions to run `grep', `search' and `query-replace' -;; on all files which are part of a multifile document. -;; -;; o All files belonging to a multifile document should have a File -;; Variable (`TeX-master' for AUCTeX or `tex-main-file' for the standard -;; Emacs LaTeX mode) set to the name of the master file. See the -;; documentation of your (La)TeX mode and the Emacs documentation on -;; file variables: [Emacs/Customization/Variables/File Variables]. -;; -;; o The context of a label definition must be found in the same file as -;; the label itself in order to be processed correctly by RefTeX. The -;; only exception is that section labels referring to a section statement -;; outside the current file can still use that section title as context. -;;------------------------------------------------------------------------- -;; -;; REFERENCES TO OTHER DOCUMENTS -;; ============================= -;; -;; RefTeX supports the LaTeX package `xr', which makes it possible to -;; reference labels defined in another document. See the documentation on -;; `xr' for details. -;; When the document is set up to work with `xr', you can use the `x' key -;; in the reference label menu to switch to the label menu of an external -;; document and select any labels from there. In the *toc* buffer, the -;; `x' key can be used to switch to the table of contents of an external -;; document. -;; -;; For this kind of inter-document cross references, saving of parsing -;; information can mean a large speed-up. -;; -;; (setq reftex-save-parse-info t) -;; -;;------------------------------------------------------------------------- -;; -;; OPTIMIZATIONS FOR LARGE DOCUMENTS -;; ================================= -;; -;; The default settings of RefTeX ensure a safe ride for beginners and -;; casual users. However, when using RefTeX for a large project and/or on -;; a small computer, there are ways to improve speed or memory usage. -;; -;; o RefTeX will load other parts of a multifile document as well as BibTeX -;; database files for lookup purposes. These buffers are kept, so that -;; subsequent use of the same files is fast. If you can't afford keeping -;; these buffers around, and if you can live with a speed penalty, try -;; -;; (setq reftex-keep-temporary-buffers nil) -;; -;; o The `C-u' prefix on the major RefTeX commands `reftex-label', -;; `reftex-reference', `reftex-citation' and `reftex-toc' initiates -;; re-parsing of the entire document in order to update the parsing -;; information. For a large document this can be unnecessary, in -;; particular if only one file has changed. RefTeX can be configured to -;; do partial scans instead of full ones. `C-u' re-parsing then does -;; apply only to the current buffer and files included from it. -;; Likewise, the `r' key in both the label menu and the table-of-contents -;; buffer will only prompt scanning of the file in which the label or -;; section macro near the cursor was defined. Re-parsing of the entire -;; document is still available by using `C-u C-u' as a prefix, or the -;; capital `R' key in the menus. To use this feature, try -;; -;; (setq reftex-enable-partial-scans t) -;; -;; o Even with partial scans enabled, RefTeX still has to make one full -;; scan, when you start working with a document. To avoid this, parsing -;; information can stored in a file. The file `MASTER.rel' is used for -;; storing information about a document with master file `MASTER.tex'. -;; It is written each time RefTeX parses (part of) the document, and -;; restored when you begin working with a document in a new editing -;; session. To use this feature, put into .emacs: -;; -;; (setq reftex-save-parse-info t) -;;---------------------------------------------------------------------------- -;; -;; RELATED PACKAGES -;; ================ -;; -;; AUCTeX -;; ------ -;; If you are writing TeX or LaTeX documents with Emacs, you should have -;; a look at AUCTeX, the definitive package to work with TeX and LaTeX. -;; Information on AUCTeX can be found here: -;; -;; http://www.sunsite.auc.dk/auctex/ -;; -;; Instead of using the RefTeX functions described above directly, you can -;; also use them indirectly, through AUCTeX (version 9.8a or later). -;; RefTeX provides several interface functions which can be used as -;; replacement for corresponding AUCTeX functions dealing with labels and -;; citations. In this way you can work normally with AUCTeX and use RefTeX -;; internals to create and complete labels and citation keys. -;; -;; `reftex-label' can be used as the `LaTeX-label-function' which does -;; label insertion when new environments are created with `C-c C-e'. -;; -;; `reftex-arg-label', `reftex-arg-ref' and `reftex-arg-cite' can replace -;; the corresponding `TeX-arg-...' functions. E.g. when you insert a label -;; macro with `C-c RET label RET', RefTeX will be transparently used to -;; create the label. -;; -;; In order to plug all 4 functions into AUCTeX, use: -;; -;; (setq reftex-plug-into-AUCTeX t) -;; -;; You may also choose to plug in only some of these functions. See the -;; docstring of `reftex-plug-into-AUCTeX'. -;; -;; AUCTeX can support RefTeX via style files. A style file may contain -;; calls to `reftex-add-to-label-alist' which defines additions to -;; `reftex-label-alist'. The argument taken by this function must have the -;; same format as `reftex-label-alist'. The `amsmath.el' style file of -;; AUCTeX (>9.7p) for example contains the following: -;; -;; (TeX-add-style-hook "amsmath" -;; (function -;; (lambda () -;; (if (featurep 'reftex) -;; (reftex-add-to-label-alist '(AMSTeX)))))) -;; -;; while a package `myprop' defining a proposition environment with -;; \newtheorem might use -;; -;; (TeX-add-style-hook "myprop" -;; (function -;; (lambda () -;; (if (featurep 'reftex) -;; (reftex-add-to-label-alist -;; '(("proposition" ?p "prop:" "~\\ref{%s}" t -;; ("Proposition" "Prop.")))))))) -;; -;; Bib-cite.el -;; ----------- -;; Once you have written a document with labels, refs and citations, it can -;; be nice to read such a file like a hypertext document. RefTeX has some -;; support for that (`reftex-view-crossref', `reftex-search-document'). A -;; more elegant interface with mouse support and links into Hyperbole is -;; provided (among other things) by Peter S. Galbraith's `bib-cite.el'. -;; There is some overlap in the functionalities of Bib-cite and RefTeX. -;; Bib-cite.el comes bundled with AUCTeX. You can also get the latest -;; version from -;; -;; ftp://ftp.phys.ocean.dal.ca/users/rhogee/elisp/bib-cite.el -;;--------------------------------------------------------------------------- -;; -;; KNOWN BUGS AND WORK-AROUNDS -;; =========================== -;; -;; o \input, \include, \bibliography and \section (etc.) statements have -;; to be first on a line (except for white space). -;; -;; o RefTeX sees also labels in regions commented out and will refuse to -;; make duplicates of such a label. This is considered to be a feature. -;; -;; o When using partial scans (`reftex-enable-partial-scans'), the section -;; numbers in the table of contents may eventually become wrong. A full -;; scan will fix this. -;; -;; o RefTeX keeps only a global copy of the configuration variables. -;; Also, any additions from style files go into a global variable. -;; Practically, this should not be a problem. Theoretically, it could -;; give conflicts if two documents used environments with identical -;; names, but different associated label types. -;; -;; o When using packages which make the buffer representation of a file -;; different from its disk representation (e.g. x-symbol, isotex, -;; iso-cvt) you may find that RefTeX's parsing information sometimes -;; reflects the disk state of a file. This happens only in *unvisited* -;; parts of a multifile document, because RefTeX visits these files -;; literally for speed reasons. Then both short context and section -;; headings may look different from what you usually see on your screen. -;; In rare cases `reftex-toc' may have problems to jump to an affected -;; section heading. There are three possible ways to deal with this: -;; -;; - (setq reftex-keep-temporary-buffers t) -;; This implies that RefTeX will load all parts of a multifile -;; document into Emacs (i.e. there will be no temporary buffers). -;; - (setq reftex-initialize-temporary-buffers t) -;; This means full initialization of temporary buffers. It involves -;; a penalty when the same file is used for lookup often. -;; - Set `reftex-initialize-temporary-buffers' to a list of hook -;; functions doing a minimal initialization. -;; -;; You might also want to check the variable `reftex-refontify-context'. -;; -;; o Some nasty :-# packages use an additional argument to a \begin macro -;; to specify a label. E.g. Lamport's "pf.sty" uses both -;; -;; \step{LABEL}{CLAIM} and \begin{step+}{LABEL} -;; CLAIM -;; \end{step+} -;; -;; We need to trick RefTeX into swallowing this: -;; -;; ;; Configuration for Lamport's pf.sty -;; (setq reftex-label-alist -;; '(("\\step{*}{}" ?p "st:" "~\\stepref{%s}" 2 ("Step" "St.")) -;; ("\\begin{step+}{*}" ?p "st:" "~\\stepref{%s}" 1000))) -;; -;; The first line is just a normal configuration for a macro. For the -;; `step+' environment we actually tell RefTeX to look for the *macro* -;; "\begin{step+}" and interprete the *first* argument (which in reality -;; is a second argument to the macro \begin) as a label of type ?p. -;; Argument count for this macro starts only after the {step+}, also -;; when specifying how to get context. -;; -;; o In XEmacs 19.15, the overlay library has a bug. RefTeX does not -;; suffer from it, but since it loads the library, other packages like -;; GNUS will switch from extents to overlays and hit the bug. Upgrade -;; to XEmacs 20, or fix the overlay library (in line 180 of overlay.el, -;; change `(list before after)' to `(cons before after)'). -;;--------------------------------------------------------------------------- -;; -;; AUTHOR -;; ====== -;; -;; Carsten Dominik -;; -;; with contributions from Stephen Eglen -;; -;; The newest version of RefTeX can be found at -;; -;; http://www.strw.leidenuniv.nl/~dominik/Tools/ -;; ftp://strw.leidenuniv.nl/pub/dominik/ -;; -;; THANKS TO: -;; --------- -;; At least the following people have invested time to test and bug-fix -;; reftex.el. Some have send patches for fixes or new features, or came -;; up with useful ideas. -;; -;; Stephen Eglen -;; F.E. Burstall -;; Karl Eichwalder -;; Laurent Mugnier -;; Rory Molinari -;; Soren Dayton -;; Daniel Polani -;; Allan Strand -;; Adrian Lanz -;; Jan Vroonhof -;; Alastair Burt -;; Dieter Kraft -;; Robin S. Socha -;; -;; The view crossref feature was inspired by the similar function in -;; Peter S. Galbraith's bib-cite.el. -;; -;; Finally thanks to Uwe Bolick who first -;; got me (some years ago) into supporting LaTeX labels and references -;; with an Editor (which was MicroEmacs at the time). -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; HISTORY -;; ======= -;; -;; Here are the more important changes made to RefTeX since initial release. -;; Minor bug fixes are not mentioned. -;; -;; Version 1.00 -;; - released on 7 Jan 1997. -;; Version 1.04 -;; - Macros as wrappers, AMSTeX support, delayed context parsing for -;; new labels. -;; Version 1.05 -;; - XEmacs port. -;; Version 1.07 -;; - RefTeX gets its own menu. -;; Version 1.09 -;; - Support for tex-main-file, an analogue for TeX-master. -;; - MS-DOS support. -;; Version 2.00 -;; - Labels can be derived from context (default for sections). -;; - Configuration of label insertion and label referencing revised. -;; - Crossref fields in BibTeX database entries. -;; - `reftex-toc' introduced (thanks to Stephen Eglen). -;; Version 2.03 -;; - Figure*, table*, Sidewaysfigure/table added to default environments. -;; - `reftex-bibfile-ignore-list' introduced (thanks to Rory Molinari). -;; - New functions `reftex-arg-label', `reftex-arg-ref', `reftex-arg-cite'. -;; - Emacs/XEmacs compatibility reworked. XEmacs 19.15 now is required. -;; - `reftex-add-to-label-alist' (to be called from AUCTeX style files). -;; - Finding context with a hook function. -;; - Sorting BibTeX entries (new variable: `reftex-sort-bibtex-matches'). -;; Version 2.05 -;; - Support for `custom.el'. -;; - New function `reftex-grep-document' (thanks to Stephen Eglen). -;; Version 2.07 -;; - New functions `reftex-search-document', `reftex-query-replace-document' -;; Version 2.11 -;; - Submitted for inclusion to Emacs and XEmacs. -;; Version 2.14 -;; - Variable `reftex-plug-into-AUCTeX' simplifies cooperation with AUCTeX. -;; Version 2.17 -;; - Label prefix expands % escapes with current file name and other stuff. -;; - Citation format now with % escapes. This is not backward compatible! -;; - TEXINPUTS variable recognized when looking for input files. -;; - Context can be the nth argument of a macro. -;; - Searching in the select buffer is now possible (C-s and C-r). -;; - Display and derive-label can use two different context methods. -;; - AMSmath xalignat and xxalignat added. -;; - THIS IS THE VERSION DISTRIBUTED WITH EMACS 20.1 and 20.2 -;; Version 3.00 -;; - RefTeX should work better for very large projects: -;; - The new parser works without creating a master buffer. -;; - Rescanning can be limited to a part of a multifile document. -;; - Information from the parser can be stored in a file. -;; - RefTeX can deal with macros having a naked label as an argument. -;; - Macros may have white space and newlines between arguments. -;; - Multiple identical section headings no longer confuse `reftex-toc'. -;; - RefTeX should work correctly in combination with buffer-altering -;; packages like outline, folding, x-symbol, iso-cvt, isotex, etc. -;; - All labeled environments discussed in `The LaTeX Companion' by -;; Goossens, Mittelbach & Samarin, Addison-Wesley 1994) are part of -;; RefTeX's defaults. -;; Version 3.03 -;; - Support for the LaTeX package `xr', for inter-document references. -;; - A few (minor) Mule-related changes. -;; - Fixed bug which could cause HUGE .rel files. -;; - Search for input and .bib files with recursive path definitions. -;; Version 3.04 -;; - Fixed BUG in the `xr' support. -;; Version 3.05 -;; - Compatibility code now first checks for XEmacs feature. -;; Version 3.07 -;; - `Ref' menu improved. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;;;;; - -;;; Code: - -(eval-when-compile (require 'cl)) - -;; Stuff that needs to be there when we use defcustom -;; -------------------------------------------------- - -(require 'custom) - -(defvar reftex-tables-dirty t - "Flag showing if tables need to be re-computed.") - -(eval-and-compile - (defun reftex-set-dirty (symbol value) - (setq reftex-tables-dirty t) - (set symbol value))) - -(eval-and-compile - (defmacro reftex-fp (n) - (if (fboundp 'forward-point) - (list 'forward-point n) - (list '+ '(point) n)))) - -;;; Begin of Configuration Section ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Define the two constants which are needed during compilation - -(eval-and-compile -(defconst reftex-label-alist-builtin - '( - ;; Some aliases, mostly for backward compatibility - (Sideways "Alias for -->rotating" (rotating)) - (AMSTeX "amsmath with eqref macro" - ((nil ?e nil "~\\eqref{%s}") - amsmath)) - - ;; Individual package defaults - (amsmath "AMS-LaTeX math environments" - (("align" ?e nil nil eqnarray-like) - ("gather" ?e nil nil eqnarray-like) - ("multline" ?e nil nil t) - ("flalign" ?e nil nil eqnarray-like) - ("alignat" ?e nil nil alignat-like) - ("xalignat" ?e nil nil alignat-like) - ("xxalignat" ?e nil nil alignat-like) - ("subequations" ?e nil nil t))) - - (endnotes "The \\endnote macro" - (("\\endnote[]{}" ?n nil nil 2 ("Endnote")))) - - (fancybox "The Beqnarray environment" - (("Beqnarray" ?e nil nil eqnarray-like))) - - (floatfig "The floatingfigure environment" - (("floatingfigure" ?f nil nil caption))) - - (longtable "The longtable environment" - (("longtable" ?t nil nil caption))) - - (picinpar "The figwindow and tabwindow environments" - (("figwindow" ?f nil nil 1) - ("tabwindow" ?f nil nil 1))) - - (rotating "Sidewaysfigure and table" - (("sidewaysfigure" ?f nil nil caption) - ("sidewaystable" ?t nil nil caption))) - - (subfigure "Subfigure environments/macro" - (("subfigure" ?f nil nil caption) - ("subfigure*" ?f nil nil caption) - ("\\subfigure[]{}" ?f nil nil 1))) - - (supertab "Supertabular environment" - (("supertabular" ?t nil nil "\\tablecaption{"))) - - (wrapfig "The wrapfigure environment" - (("wrapfigure" ?f nil nil caption))) - - ;; The LaTeX core stuff - (LaTeX "LaTeX default environments" - (("section" ?s "sec:" "~\\ref{%s}" (nil . t) - ("Part" "Chapter" "Chap." "Section" "Sec." "Sect." "Paragraph" "Par." - "\\S" "Teil" "Kapitel" "Kap." "Abschnitt" )) - - ("enumerate" ?i "item:" "~\\ref{%s}" item - ("Item" "Punkt")) - - ("equation" ?e "eq:" "~(\\ref{%s})" t - ("Equation" "Eq." "Eqn." "Gleichung" "Gl.")) - ("eqnarray" ?e "eq:" nil eqnarray-like) - - ("figure" ?f "fig:" "~\\ref{%s}" caption - ("Figure" "Fig." "Abbildung" "Abb.")) - ("figure*" ?f nil nil caption) - - ("table" ?t "tab:" "~\\ref{%s}" caption - ("Table" "Tab." "Tabelle")) - ("table*" ?t nil nil caption) - - ("\\footnote[]{}" ?n "note:" "~\\ref{%s}" 2 - ("Footnote" "Note")) - - ("any" ?\ " " "\\ref{%s}" nil))) - - ) - "The default label environment descriptions. -Lower-case symbols correspond to a style file of the same name in the LaTeX -distribution. Mixed-case symbols are convenience aliases.") - -(defconst reftex-cite-format-builtin - '( - (default "Default macro \\cite{%l}" - "\\cite{%l}") - (natbib "The Natbib package" - ((?\C-m . "\\cite{%l}") - (?t . "\\citet{%l}") - (?T . "\\citet*{%l}") - (?p . "\\citep{%l}") - (?P . "\\citep*{%l}") - (?e . "\\citep[e.g.][]{%l}") - (?a . "\\citeauthor{%l}") - (?y . "\\citeyear{%l}"))) - (harvard "The Harvard package" - ((?\C-m . "\\cite{%l}") - (?p . "\\cite{%l}") - (?t . "\\citeasnoun{%l}") - (?n . "\\citeasnoun{%l}") - (?s . "\\possessivecite{%l}") - (?e . "\\citeaffixed{%l}{?}") - (?y . "\\citeyear{%l}") - (?a . "\\citename{%l}"))) - (chicago "The Chicago package" - ((?\C-m . "\\cite{%l}") - (?t . "\\citeN{%l}") - (?T . "\\shortciteN{%l}") - (?p . "\\cite{%l}") - (?P . "\\shortcite{%l}") - (?a . "\\citeA{%l}") - (?A . "\\shortciteA{%l}") - (?y . "\\citeyear{key}"))) - (astron "The Astron package" - ((?\C-m . "\\cite{%l}") - (?p . "\\cite{%l}" ) - (?t . "%2a (\\cite{%l})"))) - (author-year "Do-it-yourself Author-year" - ((?\C-m . "\\cite{%l}") - (?t . "%2a (%y)\\nocite{%l}") - (?p . "(%2a %y\\nocite{%l})"))) - (locally "Full info in parenthesis" - "(%2a %y, %j %v, %P, %e: %b, %u, %s %<)") - ;; undocumented feature: `%<' kills white space and punctuation locally. - ) - "Builtin versions of for the citation format. -The following conventions are valid for all alist entries: -`?\C-m' should always point to a straight \\cite{%l} macro. -`?t' should point to a textual citation (citation as a noun). -`?p' should point to a parenthetical citation.") -) - -;; Configuration Variables and User Options for RefTeX ------------------ - -(defgroup reftex nil - "LaTeX label and citation support." - :tag "RefTeX" - :link '(url-link :tag "Home Page" - "http://strw.leidenuniv.nl/~dominik/Tools/") - :link '(emacs-commentary-link :tag "Commentary in reftex.el" "reftex.el") - :prefix "reftex-" - :group 'tex) - -(defun reftex-customize () - "Call the customize function with reftex as argument." - (interactive) - ;; Depending on the customize version we can call different functions. - (cond - ((fboundp 'customize-browse) - (customize-browse 'reftex)) - ((fboundp 'customize-group) - (customize-group 'reftex)) - ((fboundp 'customize) - (customize 'reftex)) - (t (error "Custom.el not available")))) - -(defun reftex-show-commentary () - "Use the finder to view the file documentation from `reftex.el'." - (interactive) - (require 'finder) - (finder-commentary "reftex.el")) - -;; Support for \label and \ref -------------------------------------- - -(defgroup reftex-label-support nil - "Support for creation, insertion and referencing of labels in LaTeX." - :group 'reftex) - -(defgroup reftex-defining-label-environments nil - "Definition of environments and macros to do with label." - :group 'reftex-label-support) - -;; Make a constant for the customization stuff -(eval-and-compile - (defconst reftex-tmp - '((const :tag "Default position" t) - (const :tag "After label" nil) - (number :tag "Macro arg nr" 1) - (regexp :tag "Regexp" "") - (const :tag "Caption in float" caption) - (const :tag "Item in list" item) - (const :tag "Eqnarray-like" eqnarray-like) - (const :tag "Alignat-like" alignat-like) - (symbol :tag "Function" my-func)))) - -(defcustom reftex-default-label-alist-entries - '(amsmath endnotes fancybox floatfig longtable picinpar - rotating subfigure supertab wrapfig LaTeX) - "Default label alist specifications. LaTeX should be the last entry. -This list describes the default label environments RefTeX should always use. -It is probably a mistake to remove the LaTeX symbol from this list. - -The options include: -LaTeX The standard LaTeX environments. -Sideways The sidewaysfigure and sidewaystable environments. -AMSTeX The math environments in the AMS-LaTeX amsmath package. - -For the full list of options, try - -M-x customize-variable RET reftex-default-label-alist-entries RET." - :group 'reftex-defining-label-environments - :set 'reftex-set-dirty - :type `(set - :indent 4 - :inline t - :greedy t - ,@(mapcar - (function - (lambda (x) - (list 'const ':tag (concat (symbol-name (nth 0 x)) - ": " (nth 1 x)) - (nth 0 x)))) - reftex-label-alist-builtin))) - -(defcustom reftex-label-alist nil - "Alist with information on environments for \\label-\\ref use. - -This docstring is easier to understand after reading the configuration -examples in `reftex.el'. Looking at the builtin defaults in the constant -`reftex-label-alist-builtin' may also be instructive. - -Set this variable to define additions and changes to the default. The only -things you MUST NOT change is that `?s' is the type indicator for section -labels, and SPC for the `any' label type. These are hard-coded at other -places in the code. - -Each list entry describes either an environment carrying a counter for use -with \\label and \\ref, or a LaTeX macro defining a label as (or inside) -one of its arguments. The elements of each list entry are: - -0. Name of the environment (like \"table\") or macro (like \"\\\\myfig\"). - For macros, indicate the macro arguments for best results, as in - \"\\\\myfig[]{}{}{*}{}\". Use square brackets for optional arguments, - a star to mark the label argument, if any. The macro does not have to - have a label argument - you could also use \\label{..} inside one of - its arguments. - Special names: `section' for section labels, `any' to define a group - which contains all labels. - This may also be nil if the entry is only meant to change some settings - associated with the type indicator character (see below). - -1. Type indicator character, like `?t', must be a printable ASCII character. - The type indicator is a single character which defines a label type. - Any label inside the environment or macro is assumed to belong to this - type. The same character may occur several times in this list, to cover - cases in which different environments carry the same label type (like - `equation' and `eqnarray'). - -2. Label prefix string, like \"tab:\". - The prefix is a short string used as the start of a label. It may be the - empty string. The prefix may contain the following `%' escapes: - %f Current file name with directory and extension stripped. - %F Current file name relative to directory of master file. - %u User login name, on systems which support this. - - Example: In a file `intro.tex', \"eq:%f:\" will become \"eq:intro:\"). - -3. Format string for reference insert in buffer. `%s' will be replaced by - the label. - When the format starts with `~', whitespace before point will be removed - so that the reference cannot be separated from the word before it. - -4. Indication on how to find the short context. - - If nil, use the text following the \\label{...} macro. - - If t, use - - the section heading for section labels. - - text following the \\begin{...} statement of environments. - (not a good choice for environments like eqnarray or enumerate, - where one has several labels in a single environment). - - text after the macro name (stearting with the first arg) for macros. - - If an integer, use the nth argument of the macro. As a special case, - 1000 means to get text after the last macro argument. - - If a string, use as regexp to search *backward* from the label. Context - is then the text following the end of the match. E.g. putting this to - \"\\\\\\\\caption[[{]\" will use the caption in a figure or table - environment. - \"\\\\\\\\begin{eqnarray}\\\\|\\\\\\\\\\\\\\\\\" works for eqnarrays. - - If any of `caption', `item', `eqnarray-like', `alignat-like', this - symbol will internally be translated into an appropriate regexp - (see also the variable `reftex-default-context-regexps'). - - If a function, call this function with the name of the environment/macro - as argument. On call, point will be just after the \\label macro. The - function is expected to return a suitable context string. It should - throw an exception (error) when failing to find context. - As an example, here is a function returning the 10 chars following - the label macro as context: - - (defun my-context-function (env-or-mac) - (if (> (point-max) (+ 10 (point))) - (buffer-substring (point) (+ 10 (point))) - (error \"Buffer too small\"))) - - Label context is used in two ways by RefTeX: For display in the label - menu, and to derive a label string. If you want to use a different - method for each of these, specify them as a dotted pair. - E.g. `(nil . t)' uses the text after the label (nil) for display, and - text from the default position (t) to derive a label string. This is - actually used for section labels. - - Setting the variable `reftex-use-text-after-label-as-context' to t - overrides the setting here. - -5. List of magic words which identify a reference to be of this type. - If the word before point is equal to one of these words when calling - `reftex-reference', the label list offered will be automatically - restricted to labels of the correct type. - -If the type indicator characters of two or more entries are the same, RefTeX -will use - - the first non-nil format and prefix - - the magic words of all involved entries. - -Any list entry may also be a symbol. If that has an association in -`reftex-label-alist-builtin', the cdr of that association is spliced into the -list. However, builtin defaults should normally be set here but with the -variable `reftex-default-label-alist-entries." - :group 'reftex-defining-label-environments - :set 'reftex-set-dirty - :type - `(repeat - (choice - :value ("" ?a nil nil nil nil) - (list :tag "Detailed label alist entry" - :value ("" ?a nil nil nil nil) - (choice :tag "Environment or \\macro " - (const :tag "Ignore, just use typekey" nil) - (string "")) - (character :tag "Typekey character " ?a) - (choice :tag "Label prefix string " - (const :tag "Default" nil) - (string :tag "String" "lab:")) - (choice :tag "Label reference format" - (const :tag "Default" nil) - (string :tag "String" "~\\ref{%s}")) - (choice :tag "Context" - (choice - :tag "1 method" - ,@reftex-tmp) - (cons :tag "Split methods" - (choice - :tag " Display context " - ,@reftex-tmp) - (choice - :tag " Derive label context" - ,@reftex-tmp))) - (repeat :tag "List of Magic Words" (string))) - (choice - :tag "Package" - :value AMSTeX - ,@(mapcar - (function - (lambda (x) - (list 'const ':tag (concat (symbol-name (nth 0 x))); ": " (nth 1 x)) - (nth 0 x)))) - reftex-label-alist-builtin))))) - -;; LaTeX section commands and level numbers -(defcustom reftex-section-levels - '( - ("part" . 0) - ("chapter" . 1) - ("section" . 2) - ("subsection" . 3) - ("subsubsection" . 4) - ("paragraph" . 5) - ("subparagraph" . 6) - ("subsubparagraph" . 7) - ) - "Commands and levels used for defining sections in the document. -The car of each cons cell is the name of the section macro. The cdr is a -number indicating its level." - :group 'reftex-defining-label-environments - :set 'reftex-set-dirty - :type '(repeat - (cons (string :tag "sectioning macro" "") - (number :tag "level " 0)))) - -(defcustom reftex-default-context-regexps - '((caption . "\\\\\\(rot\\)?caption\\*?[[{]") - (item . "\\\\item\\(\\[[^]]*\\]\\)?") - (eqnarray-like . "\\\\begin{%s}\\|\\\\\\\\") - (alignat-like . "\\\\begin{%s}{[0-9]*}\\|\\\\\\\\")) -"Alist with default regular expressions for finding context. -The form (format regexp (regexp-quote environment)) is used to calculate -the final regular expression - so %s will be replaced with the environment -or macro." - :group 'reftex-defining-label-environments - :type '(repeat (cons (symbol) (regexp)))) - -(defcustom reftex-use-text-after-label-as-context nil - "*t means, grab context from directly after the \\label{..} macro. -This is the fastest method for obtaining context of the label definition, but -requires discipline when placing labels. Setting this variable to t takes -precedence over the individual settings in `reftex-label-alist'. -This variable may be set to t, nil, or a string of label type letters -indicating the label types for which it should be true." - :group 'reftex-defining-label-environments - :set 'reftex-set-dirty - :type '(choice - (const :tag "on" t) (const :tag "off" nil) - (string :tag "Selected label types"))) - -;; Label insertion - -(defgroup reftex-making-and-inserting-labels nil - "Options on how to create new labels." - :group 'reftex-label-support) - -(defcustom reftex-insert-label-flags '("s" "sft") - "Flags governing label insertion. First flag DERIVE, second flag PROMPT. - -If DERIVE is t, RefTeX will try to derive a sensible label from context. -A section label for example will be derived from the section heading. -The conversion of the context to a legal label is governed by the -specifications given in `reftex-derive-label-parameters'. -If RefTeX fails to derive a label, it will prompt the user. -If DERIVE is nil, the label generated will consist of the prefix and a -unique number, like `eq:23'. - -If PROMPT is t, the user will be prompted for a label string. The prompt will -already contain the prefix, and (if DERIVE is t) a default label derived from -context. When PROMPT is nil, the default label will be inserted without -query. - -So the combination of DERIVE and PROMPT controls label insertion. Here is a -table describing all four possibilities: - -DERIVE PROMPT ACTION -------------------------------------------------------------------------- - nil nil Insert simple label, like eq:22 or sec:13. No query. - nil t Prompt for label. - t nil Derive a label from context and insert without query. - t t Derive a label from context and prompt for confirmation. - -Each flag may be set to t, nil, or a string of label type letters -indicating the label types for which it should be true. -Thus, the combination may be set differently for each label type. The -default settings \"s\" and \"sft\" mean: Derive section labels from headings -(with confirmation). Prompt for figure and table labels. Use simple labels -without confirmation for everything else." - :group 'reftex-making-and-inserting-labels - :type '(list (choice :tag "Derive label from context" - (const :tag "always" t) - (const :tag "never" nil) - (string :tag "selected label types" "")) - (choice :tag "Prompt for label string " - :entry-format " %b %v" - (const :tag "always" t) - (const :tag "never" nil) - (string :tag "selected label types" "")))) - -(defcustom reftex-derive-label-parameters '(3 20 t 1 "-" - ("the" "on" "in" "off" "a" "for" "by" "of" "and" "is")) - "Parameters for converting a string into a label. -NWORDS Number of words to use. -MAXCHAR Maximum number of characters in a label string. -ILLEGAL nil: Throw away any words containing characters illegal in labels. - t: Throw away only the illegal characters, not the whole word. -ABBREV nil: Never abbreviate words. - t: Always abbreviate words (see `reftex-abbrev-parameters'). - not t and not nil: Abbreviate words if necessary to shorten - label string below MAXCHAR. -SEPARATOR String separating different words in the label. -IGNOREWORDS List of words which should not be part of labels." - :group 'reftex-making-and-inserting-labels - :type '(list (integer :tag "Number of words " 3) - (integer :tag "Maximum label length " 20) - (choice :tag "Illegal characters in words" - (const :tag "throw away entire word" nil) - (const :tag "throw away single chars" t)) - (choice :tag "Abbreviate words " - (const :tag "never" nil) - (const :tag "always" t) - (const :tag "when label is too long" 1)) - (string :tag "Separator between words " "-") - (repeat :tag "Ignore words" - :entry-format " %i %d %v" - (string :tag "")))) - -(defcustom reftex-label-illegal-re "[\000-\040\177-\377\\\\#$%&~^_{}]" - "Regexp matching characters not legal in labels. -For historic reasons, this character class comes *with* the [] brackets." - :group 'reftex-making-and-inserting-labels - :type '(regexp :tag "Character class")) - -(defcustom reftex-abbrev-parameters '(4 2 "^saeiou" "aeiou") - "Parameters for abbreviation of words. -MIN-CHARS Minimum number of characters remaining after abbreviation. -MIN-KILL Minimum number of characters to remove when abbreviating words. -BEFORE Character class before abbrev point in word. -AFTER Character class after abbrev point in word." - :group 'reftex-making-and-inserting-labels - :type '(list - (integer :tag "Minimum chars per word" 4) - (integer :tag "Shorten by at least " 2) - (string :tag "cut before char class " "^saeiou") - (string :tag "cut after char class " "aeiou"))) - -;; Label referencing - -(defgroup reftex-referencing-labels nil - "Options on how to reference labels." - :group 'reftex-label-support) - -(eval-and-compile - (defconst reftex-tmp - '((const :tag "on" t) - (const :tag "off" nil) - (string :tag "Selected label types")))) - -(defcustom reftex-label-menu-flags '(t t nil nil nil nil t nil) - "List of flags governing the label menu makeup. -The flags are: - -TABLE-OF-CONTENTS Show the labels embedded in a table of context. -SECTION-NUMBERS Include section numbers (like 4.1.3) in table of contents. -COUNTERS Show counters. This just numbers the labels in the menu. -NO-CONTEXT Non-nil means do NOT show the short context. -FOLLOW Follow full context in other window. -SHOW-COMMENTED Show labels from regions which are commented out. -MATCH-IN-TOC Searches in label menu will also match in toc lines. -SHOW FILES Show Begin and end of included files. - -Each of these flags can be set to t or nil, or to a string of type letters -indicating the label types for which it should be true. These strings work -like character classes in regular expressions. Thus, setting one of the -flags to \"sf\" makes the flag true for section and figure labels, nil -for everything else. Setting it to \"^ft\" makes it the other way round. - -Most options can also be switched from the label menu itself - so if you -decide here to not have a table of contents in the label menu, you can still -get one interactively during selection from the label menu." - :group 'reftex-referencing-labels - :type - `(list - (choice :tag "Embed in table of contents " ,@reftex-tmp) - (choice :tag "Show section numbers " ,@reftex-tmp) - (choice :tag "Show individual counters " ,@reftex-tmp) - (choice :tag "Hide short context " ,@reftex-tmp) - (choice :tag "Follow context in other window " ,@reftex-tmp) - (choice :tag "Show commented labels " ,@reftex-tmp) - (choice :tag "Searches match in toc lines " ,@reftex-tmp) - (choice :tag "Show begin/end of included files" ,@reftex-tmp))) - -(defcustom reftex-level-indent 2 - "*Number of spaces to be used for indentation per section level." - :group 'reftex-referencing-labels - :type '(integer)) - -(defcustom reftex-refontify-context 1 - "*Non-nil means, re-fontify the context in the label menu with font-lock. -This slightly slows down the creation of the label menu. It is only necessay -when you definitely want the context fontified. - -This option may have 3 different values: -nil Never refontify. -t Always refontify. -1 Refontify when absolutly necessary, e.g. when with the x-symbol package. -The option is ignored when `reftex-use-fonts' is nil." - :group 'reftex-referencing-labels - :type '(choice - (const :tag "Never" nil) - (const :tag "Always" t) - (const :tag "When necessary" 1))) - -(defcustom reftex-guess-label-type t - "*Non-nil means, `reftex-reference' will try to guess the label type. -To do that, RefTeX will look at the word before the cursor and compare it with -the words given in `reftex-label-alist'. When it finds a match, RefTeX will -immediately offer the correct label menu - otherwise it will prompt you for -a label type. If you set this variable to nil, RefTeX will always prompt." - :group 'reftex-referencing-labels - :type '(boolean)) - -;; BibteX citation configuration ---------------------------------------- - -(defgroup reftex-citation-support nil - "Support for referencing bibliographic data with BibTeX." - :group 'reftex) - -(defcustom reftex-bibpath-environment-variables '("BIBINPUTS" "TEXBIB") - "*List of env vars which might contain the path to BibTeX database files." - :group 'reftex-citation-support - :set 'reftex-set-dirty - :type '(repeat (string :tag "Environment variable"))) - -(defcustom reftex-bibfile-ignore-list nil - "*List of files in \\bibliography{..} RefTeX should *not* parse. -The file names have to be in the exact same form as in the bibliography -macro - i.e. without the `.bib' extension. -Intended for files which contain only `@string' macro definitions and the -like, which are ignored by RefTeX anyway." - :group 'reftex-citation-support - :set 'reftex-set-dirty - :type '(repeat (string :tag "File name"))) - -(defcustom reftex-sort-bibtex-matches 'reverse-year - "*Sorting of the entries found in BibTeX databases by reftex-citation. -Possible values: -nil Do not sort entries. -'author Sort entries by author name. -'year Sort entries by increasing year. -'reverse-year Sort entries by decreasing year." - :group 'reftex-citation-support - :type '(choice (const :tag "not" nil) - (const :tag "by author" author) - (const :tag "by year" year) - (const :tag "by year, reversed" reverse-year))) - -(defcustom reftex-cite-format 'default - "*The format of citations to be inserted into the buffer. -It can be a string or an alist. In the simplest case this is just -the string \"\\cite{%l}\", which is also the default. See the -definition of `reftex-cite-format-builtin' for more complex examples. - -If `reftex-cite-format' is a string, it will be used as the format. -In the format, the following percent escapes will be expanded. - -%l The BibTeX label of the citation. -%a List of author names, see also `reftex-cite-punctuation. -%2a Like %a, but abbreviate more than 2 authors like Jones et al. -%A First author name only. -%e Works like %a, but on list of editor names. (%2e and %E work a well) - -It is also possible to access all other BibTeX database fields: -%b booktitle %c chapter %d edition %h howpublished -%i institution %j journal %k key %m month -%n number %o organization %p pages %P first page -%r address %s school %u publisher %t title -%v volume %y year - -Usually, only %l is needed. Try, however, (setq reftex-comment-citations t). - -If `reftex-cite-format' is an alist of characters and strings, the user -will be prompted for a character to select one of the possible format -strings. - In order to configure this variable, you can either set -`reftex-cite-format' directly yourself or set it to the SYMBOL of one of -the predefined styles (see `reftex-cite-format-builtin'). E.g.: -(setq reftex-cite-format 'harvard)" - :group 'reftex-citation-support - :type - `(choice - :format "%{%t%}: \n%[Value Menu%] %v" - (radio :tag "Symbolic Builtins" - :indent 4 - :value default - ,@(mapcar - (function - (lambda (x) - (list 'const ':tag (concat (symbol-name (nth 0 x)) - ": " (nth 1 x)) - (nth 0 x)))) - reftex-cite-format-builtin)) - (string :tag "format string" "\\cite{%l}") - (repeat :tag "key-ed format strings" - :value ((?\r . "\\cite{%l}") - (?t . "\\cite{%l}") (?p . "\\cite{%l}")) - (cons (character :tag "Key character" ?\r) - (string :tag "Format string" ""))))) - -(defcustom reftex-comment-citations nil - "*Non-nil means add a comment for each citation describing the full entry. -The comment is formatted according to `reftex-cite-comment-format'." - :group 'reftex-citation-support - :type '(boolean)) - -(defcustom reftex-cite-comment-format - "%% %2a %y, %j %v, %P, %e: %b, %u, %s %<\n" - "Citation format used for commented citations. Must NOT contain %l." - :group 'reftex-citation-support - :type '(string)) - -(defcustom reftex-cite-punctuation '(", " " \\& " " {\\it et al.}") - "Punctuation for formatting of name lists in citations. -This is a list of 3 strings. -1. normal names separator, like \", \" in Jones, Brown and Miller -2. final names separator, like \" and \" in Jones, Brown and Miller -3. The \"et al\" string, like \" {...}\" in Jones {\\it et al.}" - :group 'reftex-citation-support - :type '(list - (string :tag "Separator for names ") - (string :tag "Separator for last name in list") - (string :tag "string used as et al. "))) - -;; Table of contents configuration -------------------------------------- - -(defgroup reftex-table-of-contents-browser nil - "A multifile table of contents browser." - :group 'reftex) - -(defcustom reftex-toc-follow-mode nil - "*Non-nil means, point in *toc* buffer will cause other window to follow. -The other window will show the corresponding part of the document. -This flag can be toggled from within the *toc* buffer with the `f' key." - :group 'reftex-table-of-contents-browser - :type '(boolean)) - -;; Tuning the parser ---------------------------------------------------- - -(defgroup reftex-optimizations-for-large-documents nil - "Configuration of parser speed and memory usage." - :group 'reftex) - -(defcustom reftex-keep-temporary-buffers 1 - "*Non-nil means, keep buffers created for parsing and lookup. -RefTeX sometimes needs to visit files related to the current document. -We distinguish files visited for -PARSING: Parts of a multifile document loaded when (re)-parsing the document. -LOOKUP: BibTeX database files and TeX files loaded to find a reference, - to display label context, etc. -The created buffers can be kept for later use, or be thrown away immediately -after use, depending on the value of this variable: - -nil Throw away as much as possible. -t Keep everything. -1 Throw away buffers created for parsing, but keep the ones created - for lookup. - -If a buffer is to be kept, the file is visited normally (which is potentially -slow but will happen only once). -If a buffer is to be thrown away, the initialization of the buffer depends -upon the variable `reftex-initialize-temporary-buffers'." - :group 'reftex-miscellaneous-configurations - :type '(choice - (const :tag "Throw away everything" nil) - (const :tag "Keep everything" t) - (const :tag "Keep lookup buffers only" 1))) - -(defcustom reftex-initialize-temporary-buffers nil - "*Non-nil means do initializations even when visiting file temporarily. -When nil, RefTeX may turn off find-file hooks and other stuff to briefly -visit a file. -When t, the full default initializations are done (find-file-hook etc.). -Instead of t or nil, this variable may also be a list of hook functions to -do a minimal initialization." - :group 'reftex-miscellaneous-configurations - :type '(choice - (const :tag "Read files literally" nil) - (const :tag "Fully initialize buffers" t) - (repeat :tag "Hook functions" :value (nil) - (function-item)))) - -(defcustom reftex-enable-partial-scans nil - "*Non-nil means, re-parse only 1 file when asked to re-parse. -Re-parsing is normally requested with a `C-u' prefix to many RefTeX commands, -or with the `r' key in menus. When this option is t in a multifile document, -we will only parse the current buffer, or the file associated with the label -or section heading near point in a menu. Requesting re-parsing of an entire -multifile document then requires a `C-u C-u' prefix or the capital `R' key -in menus." - :group 'reftex-optimizations-for-large-documents - :type 'boolean) - -(defcustom reftex-save-parse-info nil - "*Non-nil means, save information gathered with parsing in a file. -The file MASTER.rel in the same directory as MASTER.tex is used to save the -information. When this variable is t, -- accessing the parsing information for the first time in an editing session - will read that file (if available) instead of parsing the document. -- each time (part of) the document is rescanned, a new version of the file - is written." - :group 'reftex-optimizations-for-large-documents - :type 'boolean) - -;; Miscellaneous configurations ----------------------------------------- - -(defgroup reftex-miscellaneous-configurations nil - "Collection of further configurations." - :group 'reftex) - -(defcustom reftex-extra-bindings nil - "Non-nil means, make additional key bindings on startup. -These extra bindings are located in the users `C-c letter' map." - :group 'reftex-miscellaneous-configurations - :type '(boolean)) - -(defcustom reftex-plug-into-AUCTeX nil - "*Plug-in flags for AUCTeX interface. -This variable is a list of 4 boolean flags. When a flag is non-nil, it -means: - - Flag 1: use `reftex-label' as `LaTeX-label-function'. - Flag 2: use `reftex-arg-label' as `TeX-arg-label' - Flag 3: use `reftex-arg-ref' as `TeX-arg-ref' - Flag 4: use `reftex-arg-cite' as `TeX-arg-cite' - -You may also set the variable itself to t or nil in order to turn all -plug-ins on or off, respectively. -\\`LaTeX-label-function' is the function used for label insertion when you -enter a new environment in AUCTeX with \\[LaTeX-environment]. -The `TeX-arg-label' etc. functions are for entering macro arguments during -macro insertion with \\[TeX-insert-macro]. -See the AUCTeX documentation for more information. -RefTeX uses `fset' to take over the function calls. Changing the variable -may require a restart of Emacs in order to become effective." - :group 'reftex-miscellaneous-configurations - :type '(choice (const :tag "No plug-ins" nil) - (const :tag "All possible plug-ins" t) - (list - :tag "Individual choice" - :value (nil nil nil nil) - (boolean :tag "Use reftex-label as LaTeX-label-function") - (boolean :tag "Use reftex-arg-label as TeX-arg-label ") - (boolean :tag "Use reftex-arg-ref as TeX-arg-ref ") - (boolean :tag "Use reftex-arg-cite as TeX-arg-cite ") - ))) - -(defcustom reftex-use-fonts t - "*Non-nil means, use fonts in label menu and on-the-fly help. -Font-lock must be loaded as well to actually get fontified display." - :group 'reftex-miscellaneous-configurations - :type '(boolean)) - -(defcustom reftex-auto-show-entry 'copy - "*Non-nil means, do something when context in other window is hidden. -Some modes like `outline-mode' or `folding-mode' hide parts of buffers. -When RefTeX is asked to show context for a label definition, and the context -is invisible, it can unhide that section permanently (value t), or copy the -context to a temporary buffer (value 'copy)." - :group 'reftex-miscellaneous-configurations - :type '(radio :value copy - :indent 4 - (const :tag "Do nothing" nil) - (const :tag "Unhide section permanently" t) - (const :tag "Copy context to show" copy))) - -(defcustom reftex-load-hook nil - "Hook which is being run when loading reftex.el." - :group 'reftex-miscellaneous-configurations - :type 'hook) - -(defcustom reftex-mode-hook nil - "Hook which is being run when turning on RefTeX mode." - :group 'reftex-miscellaneous-configurations - :type 'hook) - -;;; End of Configuration Section ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;;=========================================================================== -;;; -;;; Define the formal stuff for a minor mode named RefTeX. -;;; - -(defconst reftex-version "RefTeX version 3.7" - "Version string for RefTeX.") - -(defvar reftex-mode nil - "Determines if RefTeX minor mode is active.") -(make-variable-buffer-local 'reftex-mode) - -(defvar reftex-mode-map (make-sparse-keymap) - "Keymap for RefTeX minor mode.") - -(defvar reftex-mode-menu nil) - -;;;###autoload -(defun turn-on-reftex () - "Turn on RefTeX minor mode." - (reftex-mode t)) - -;;;###autoload -(defun reftex-mode (&optional arg) - "Minor mode with distinct support for \\label, \\ref and \\cite in LaTeX. - -Labels can be created with `\\[reftex-label]' and referenced with `\\[reftex-reference]'. -When referencing, you get a menu with all labels of a given type and -context of the label definition. The selected label is inserted as a -\\ref macro. - -Citations can be made with `\\[reftex-citation]' which will use a regular expression -to pull out a *formatted* list of articles from your BibTeX -database. The selected citation is inserted as a \\cite macro. - -A Table of Contents of the entire (multifile) document with browsing -capabilities is available with `\\[reftex-toc]'. - -Most command have help available on the fly. This help is accessed by -pressing `?' to any prompt mentioning this feature. - -Extensive documentation about RefTeX is in the file header of `reftex.el'. -You can view this information with `\\[reftex-show-commentary]'. - -\\{reftex-mode-map} -Under X, these and other functions will also be available as `Ref' menu -on the menu bar. - -------------------------------------------------------------------------------" - - (interactive "P") - (setq reftex-mode (not (or (and (null arg) reftex-mode) - (<= (prefix-numeric-value arg) 0)))) - - ; Add or remove the menu, and run the hook - (if reftex-mode - (progn - (easy-menu-add reftex-mode-menu) - (reftex-plug-into-AUCTeX) - (run-hooks 'reftex-mode-hook)) - (easy-menu-remove reftex-mode-menu))) - -(or (assoc 'reftex-mode minor-mode-alist) - (push '(reftex-mode " Ref") minor-mode-alist)) - -(or (assoc 'reftex-mode minor-mode-map-alist) - (push (cons 'reftex-mode reftex-mode-map) minor-mode-map-alist)) - -;;; =========================================================================== -;;; -;;; Silence warnings about variables in other packages. -(defvar TeX-master) -(defvar LaTeX-label-function) -(defvar tex-main-file) -(defvar outline-minor-mode) - -;;; =========================================================================== -;;; -;;; Interfaces for other packages -;;; ----------------------------- -;;; -;;; AUCTeX -;;; ------ - -(defun reftex-arg-label (optional &optional prompt definition) - "Use `reftex-label' to create label. Insert it with `TeX-argument-insert'. -This function is intended for AUCTeX macro support." - (let ((label (reftex-label nil t))) - (if (and definition (not (string-equal "" label))) - (LaTeX-add-labels label)) - (TeX-argument-insert label optional optional))) - -(defun reftex-arg-ref (optional &optional prompt definition) - "Use `reftex-reference' to select label. Insert with `TeX-argument-insert'. -This function is intended for AUCTeX macro support." - (let ((label (reftex-reference nil t))) - (if (and definition (not (string-equal "" label))) - (LaTeX-add-labels label)) - (TeX-argument-insert label optional optional))) - -(defun reftex-arg-cite (optional &optional prompt definition) - "Use reftex-citation to select a key. Insert with `TeX-argument-insert'. -This function is intended for AUCTeX macro support." - (let ((key (reftex-citation t))) - (TeX-argument-insert (or key "") optional optional))) - -(defun reftex-plug-into-AUCTeX () - ;; Replace AucTeX functions with RefTeX functions. - ;; Which functions are replaced is controlled by the variable - ;; `reftex-plug-into-AUCTeX'. - (let ((flags - (cond ((eq reftex-plug-into-AUCTeX t) '(t t t t)) - ((eq reftex-plug-into-AUCTeX nil) '(nil nil nil nil)) - (t reftex-plug-into-AUCTeX)))) - - (and (nth 0 flags) - (boundp 'LaTeX-label-function) - (setq LaTeX-label-function 'reftex-label)) - - (and (nth 1 flags) - (fboundp 'TeX-arg-label) - (fset 'TeX-arg-label 'reftex-arg-label)) - - (and (nth 2 flags) - (fboundp 'TeX-arg-ref) - (fset 'TeX-arg-ref 'reftex-arg-ref)) - - (and (nth 3 flags) - (fboundp 'TeX-arg-cite) - (fset 'TeX-arg-cite 'reftex-arg-cite)))) - - -(defvar reftex-label-alist-external-add-ons nil - "List of label alist entries added with reftex-add-to-label-alist.") - -(defun reftex-add-to-label-alist (entry-list) - "Add label environment descriptions to `reftex-label-alist-external-add-ons'. -The format of ENTRY-LIST is exactly like `reftex-label-alist'. See there -for details. -This function makes it possible to support RefTeX from AUCTeX style files. -The entries in ENTRY-LIST will be processed after the user settings in -`reftex-label-alist', and before the defaults (specified in -`reftex-default-label-alist-entries'). Any changes made to -`reftex-label-alist-external-add-ons' will raise a flag to the effect that a -mode reset is done on the next occasion." - (let (entry) - (while entry-list - (setq entry (car entry-list) - entry-list (cdr entry-list)) - (unless (member entry reftex-label-alist-external-add-ons) - (setq reftex-tables-dirty t) - (push entry reftex-label-alist-external-add-ons))))) - -;;; =========================================================================== -;;; -;;; Multifile support -;;; -;;; Technical notes: Multifile works as follows: We keep just one list -;;; of labels for each master file - this can save a lot of memory. -;;; `reftex-master-index-list' is an alist which connects the true file name -;;; of each master file with the symbols holding the information on that -;;; document. Each buffer has local variables which point to these symbols. - -;; List of variables which handle the multifile stuff. -;; This list is used to tie, untie, and reset these symbols. -(defconst reftex-multifile-symbols - '(reftex-docstruct-symbol)) - -;; Alist connecting master file names with the corresponding lisp symbols. -(defvar reftex-master-index-list nil) - -;; Last index used for a master file. -(defvar reftex-multifile-index 0) - -;; Variable holding the symbol with the label list of the document. -(defvar reftex-docstruct-symbol nil) -(make-variable-buffer-local 'reftex-docstruct-symbol) - -(defun reftex-next-multifile-index () - ;; Return the next free index for multifile symbols. - (incf reftex-multifile-index)) - -(defun reftex-tie-multifile-symbols () - ;; Tie the buffer-local symbols to globals connected with the master file. - ;; If the symbols for the current master file do not exist, they are created. - - (let* ((master (file-truename (reftex-TeX-master-file))) - (index (assoc master reftex-master-index-list)) - (symlist reftex-multifile-symbols) - (symbol nil) - (symname nil) - (newflag nil)) - ;; Find the correct index. - (if index - ;; symbols do exist - (setq index (cdr index)) - ;; Get a new index and add info to the alist. - (setq index (reftex-next-multifile-index) - newflag t) - (push (cons master index) reftex-master-index-list)) - - ;; Get/create symbols and tie them. - (while symlist - (setq symbol (car symlist) - symlist (cdr symlist) - symname (symbol-name symbol)) - (set symbol (intern (concat symname "-" (int-to-string index)))) - ;; Initialize if new symbols. - (if newflag (set (symbol-value symbol) nil))) - - ;; Return t if the symbols did already exist, nil when we've made them. - (not newflag))) - -(defun reftex-untie-multifile-symbols () - ;; Remove ties from multifile symbols, so that next use makes new ones. - (let ((symlist reftex-multifile-symbols) - (symbol nil)) - (while symlist - (setq symbol (car symlist) - symlist (cdr symlist)) - (set symbol nil)))) - -(defun reftex-TeX-master-file () - ;; Return the name of the master file associated with the current buffer. - ;; When AUCTeX is loaded, we will use it's more sophisticated method. - ;; We also support the default TeX and LaTeX modes by checking for a - ;; variable tex-main-file. - - (let - ((master - (cond - ((fboundp 'TeX-master-file) ; AUCTeX is loaded. Use its mechanism. - (TeX-master-file t)) - ((boundp 'TeX-master) ; The variable is defined - lets use it. - (cond - ((eq TeX-master t) - (buffer-file-name)) - ((eq TeX-master 'shared) - (setq TeX-master (read-file-name "Master file: " - nil nil t nil))) - (TeX-master) - (t - (setq TeX-master (read-file-name "Master file: " - nil nil t nil))))) - ((boundp 'tex-main-file) - ;; This is the variable from the default TeX modes. - (cond - ((stringp tex-main-file) - ;; ok, this must be it - tex-main-file) - (t - ;; In this case, the buffer is its own master. - (buffer-file-name)))) - (t - ;; Know nothing about master file. Assume this is a master file. - (buffer-file-name))))) - (cond - ((null master) - (error "Need a filename for this buffer. Please save it first.")) - ((or (file-exists-p master) - (reftex-get-buffer-visiting master)) - ;; We either see the file, or have a buffer on it. OK. - ) - ((or (file-exists-p (concat master ".tex")) - (reftex-get-buffer-visiting (concat master ".tex"))) - ;; Ahh, an extra .tex was missing... - (setq master (concat master ".tex"))) - (t - ;; Something is wrong here. Throw an exception. - (error "No such master file %s" master))) - (expand-file-name master))) - -(defun reftex-parse-one () - "Re-parse this file." - (interactive) - (let ((reftex-enable-partial-scans t)) - (reftex-access-scan-info '(4)))) - -(defun reftex-parse-all () - "Re-parse entire document." - (interactive) - (reftex-access-scan-info '(16))) - -(defun reftex-all-document-files (&optional relative) - ;; Return a list of all files belonging to the current document. - ;; When RELATIVE is non-nil, give file names relative to directory - ;; of master file. - (let* ((all (symbol-value reftex-docstruct-symbol)) - (master-dir (file-name-directory (reftex-TeX-master-file))) - (re (concat "\\`" (regexp-quote master-dir))) - file-list tmp file) - (while (setq tmp (assoc 'bof all)) - (setq file (nth 1 tmp) - all (cdr (memq tmp all))) - (and relative - (string-match re file) - (setq file (substring file (match-end 0)))) - (push file file-list)) - (nreverse file-list))) - -(defun reftex-create-tags-file () - "Create TAGS file by running `etags' on the current document. -The TAGS file is also immediately visited with `visit-tags-table'." - (interactive) - (reftex-access-scan-info current-prefix-arg) - (let* ((master (reftex-TeX-master-file)) - (files (reftex-all-document-files)) - (cmd (format "etags %s" (mapconcat 'identity files " ")))) - (save-excursion - (set-buffer (reftex-get-buffer-visiting master)) - (message "Running etags to create TAGS file...") - (shell-command cmd) - (visit-tags-table "TAGS")))) - -;; History of grep commands. -(defvar reftex-grep-history nil) -(defvar reftex-grep-command "grep -n " - "Last grep command used in \\[reftex-grep-document]; default for next grep.") - -(defun reftex-grep-document (grep-cmd) - "Run grep query through all files related to this document. -With prefix arg, force to rescan document. -This works also without an active TAGS table." - - (interactive - (list (read-from-minibuffer "Run grep on document (like this): " - reftex-grep-command nil nil - 'reftex-grep-history))) - (reftex-access-scan-info current-prefix-arg) - (let* ((files (reftex-all-document-files t)) - (cmd (format - "%s %s" grep-cmd - (mapconcat 'identity files " ")))) - (grep cmd))) - -(defun reftex-search-document (&optional regexp) - "Regexp search through all files of the current TeX document. -Starts always in the master file. Stops when a match is found. -To continue searching for next match, use command \\[tags-loop-continue]. -This works also without an active TAGS table." - (interactive) - (let ((default (reftex-this-word))) - (unless regexp - (setq regexp (read-string (format "Search regexp in document [%s]: " - default)))) - (if (string= regexp "") (setq regexp (regexp-quote default))) - - (reftex-access-scan-info current-prefix-arg) - (tags-search regexp (list 'reftex-all-document-files)))) - -(defun reftex-query-replace-document (&optional from to delimited) - "Run a query-replace-regexp of FROM with TO over the entire TeX document. -Third arg DELIMITED (prefix arg) means replace only word-delimited matches. -If you exit (\\[keyboard-quit] or ESC), you can resume the query replace -with the command \\[tags-loop-continue]. -This works also without an active TAGS table." - (interactive) - (let ((default (reftex-this-word))) - (unless from - (setq from (read-string (format "Replace regexp in document [%s]: " - default))) - (if (string= from "") (setq from (regexp-quote default)))) - (unless to - (setq to (read-string (format "Replace regexp %s with: " from)))) - (reftex-access-scan-info current-prefix-arg) - (tags-query-replace from to (or delimited current-prefix-arg) - (list 'reftex-all-document-files)))) - -(defun reftex-change-label (&optional from to) - "Query replace FROM with TO in all \\label and \\ref commands. -Works on the entire multifile document. -If you exit (\\[keyboard-quit] or ESC), you can resume the query replace -with the command \\[tags-loop-continue]. -This works also without an active TAGS table." - (interactive) - (let ((default (reftex-this-word "-a-zA-Z0-9_*.:"))) - (unless from - (setq from (read-string (format "Replace label globally [%s]: " - default)))) - (if (string= from "") (setq from default)) - (unless to - (setq to (read-string (format "Replace label %s with: " - from)))) - (reftex-query-replace-document - (concat "\\\\\\(label\\|[a-z]*ref\\){" (regexp-quote from) "}") - (format "\\\\\\1{%s}" to)))) - -;;; =========================================================================== -;;; -;;; Functions to create and reference automatic labels. - -;; The following constants are derived from `reftex-label-alist'. - -;; Prompt used for label type querys directed to the user. -(defconst reftex-type-query-prompt nil) - -;; Help string for label type querys. -(defconst reftex-type-query-help nil) - -;; Alist relating label type to reference format. -(defconst reftex-typekey-to-format-alist nil) - -;; Alist relating label type to label affix. -(defconst reftex-typekey-to-prefix-alist nil) - -;; Alist relating environments or macros to label type and context regexp. -(defconst reftex-env-or-mac-alist nil) - -;; List of macros carrying a label. -(defconst reftex-label-mac-list nil) - -;; List of environments carrying a label. -(defconst reftex-label-env-list nil) - -;; List of all typekey letters in use. -(defconst reftex-typekey-list nil) - -;; Alist relating magic words to a label type. -(defconst reftex-words-to-typekey-alist nil) - -;; The last list-of-labels entry used in a reference. -(defvar reftex-last-used-reference (list nil nil nil nil)) - -;; The regular expression used to abbreviate words. -(defconst reftex-abbrev-regexp - (concat - "\\`\\(" - (make-string (nth 0 reftex-abbrev-parameters) ?.) - "[" (nth 2 reftex-abbrev-parameters) "]*" - "\\)" - "[" (nth 3 reftex-abbrev-parameters) "]" - (make-string (1- (nth 1 reftex-abbrev-parameters)) ?.))) - -;; Global variables used for communication between functions. -(defvar reftex-default-context-position nil) -(defvar reftex-location-start nil) -(defvar reftex-call-back-to-this-buffer nil) -(defvar reftex-active-toc nil) -(defvar reftex-tex-path nil) -(defvar reftex-bib-path nil) - -;; Internal list with index numbers of labels in the selection menu -(defvar reftex-label-index-list) - -;; List of buffers created temporarily for lookup, which should be killed. -(defvar reftex-buffers-to-kill nil) - -;; Regexp to find section statements. Computed from reftex-section-levels. -(defvar reftex-section-regexp nil) -(defvar reftex-section-or-include-regexp nil) -(defvar reftex-everything-regexp nil) -(defvar reftex-find-label-regexp-format nil) -(defvar reftex-find-label-regexp-format2 nil) - -;; The parser functions ---------------------------------- - -(defvar reftex-memory nil - "Memorizes old variable values to indicate changes in these variables.") - -(defun reftex-access-scan-info (&optional rescan file) - ;; Access the scanning info. When the multifile symbols are not yet tied, - ;; tie them. When they are empty or RESCAN is non-nil, scan the document. - - ;; Reset the mode if we had changes to important variables. - (when (or reftex-tables-dirty - (not (eq reftex-label-alist (nth 0 reftex-memory))) - (not (eq reftex-label-alist-external-add-ons - (nth 1 reftex-memory))) - (not (eq reftex-default-label-alist-entries - (nth 2 reftex-memory)))) - (reftex-reset-mode)) - - (if (eq reftex-docstruct-symbol nil) - ;; Symbols are not yet tied: Tie them. - (reftex-tie-multifile-symbols)) - - (if (and (null (symbol-value reftex-docstruct-symbol)) - reftex-save-parse-info) - ;; Try to read the stuff from a file - (reftex-access-parse-file 'read)) - - (cond - ((not (symbol-value reftex-docstruct-symbol)) - (reftex-do-parse 1 file)) - ((member rescan '(t 1 (4) (16))) - (reftex-do-parse rescan file)))) - -(defun reftex-do-parse (rescan &optional file) - ;; Access the scanning info. When the multifile symbols are not yet tied, - ;; tie them. When they are have to be created, do a buffer scan to - ;; fill them. - - ;; If RESCAN is non-nil, enforce document scanning - - ;; Normalize the rescan argument - (setq rescan (cond ((eq rescan t) t) - ((eq rescan 1) 1) - ((equal rescan '(4)) t) - ((equal rescan '(16)) 1) - (t 1))) - - ;; Partial scans only when allowed - (unless reftex-enable-partial-scans - (setq rescan 1)) - - ;; Do the scanning. - - (let* ((old-list (symbol-value reftex-docstruct-symbol)) - (master (reftex-TeX-master-file)) - (master-dir (file-name-as-directory (file-name-directory master))) - (file (or file (buffer-file-name))) - from-file - docstruct tmp) - - ;; Make sure replacement is really an option here - (when (and (eq rescan t) - (not (and (member (list 'bof file) old-list) - (member (list 'eof file) old-list)))) - (message "Scanning whole document (no file section %s)" file) - (setq rescan 1)) - (when (string= file master) - (message "Scanning whole document (%s is master)" file) - (setq rescan 1)) - - ;; From which file do we start? - (setq from-file - (cond ((eq rescan t) (or file master)) - ((eq rescan 1) master) - (t (error "horrible!!")))) - - ;; Find active toc entry and initialize section-numbers - (setq reftex-active-toc - (reftex-last-assoc-before-elt - 'toc (list 'bof from-file) old-list)) - (reftex-init-section-numbers reftex-active-toc) - - (if (eq rescan 1) - (message "Scanning entire document...") - (message "Scanning document from %s..." from-file)) - - (save-window-excursion - (save-excursion - (unwind-protect - (setq docstruct - (reftex-parse-from-file - from-file docstruct master-dir)) - (reftex-kill-temporary-buffers)))) - - (message "Scanning document... done") - - ;; Turn the list around. - (setq docstruct (nreverse docstruct)) - - ;; Set or insert - (setq docstruct (reftex-replace-label-list-segment - old-list docstruct (eq rescan 1))) - - ;; Add all missing information - (unless (assq 'label-numbers docstruct) - (push (cons 'label-numbers nil) docstruct)) - (unless (assq 'master-dir docstruct) - (push (cons 'master-dir master-dir) docstruct)) - (let* ((bof1 (memq (assq 'bof docstruct) docstruct)) - (bof2 (assq 'bof (cdr bof1))) - (is-multi (not (not (and bof1 bof2)))) - (entry (or (assq 'is-multi docstruct) - (car (push (list 'is-multi is-multi) docstruct))))) - (setcdr entry (cons is-multi nil))) - (unless (assq 'xr docstruct) - (let* ((allxr (reftex-all-assq 'xr-doc docstruct)) - (alist (mapcar - '(lambda (x) - (if (setq tmp (reftex-find-tex-file (nth 2 x) - master-dir)) - (cons (nth 1 x) tmp) - (message "Can't find external document %s" - (nth 2 x)) - nil)) - allxr)) - (alist (delete nil alist)) - (allprefix (delete nil (mapcar 'car alist))) - (regexp (concat "\\`\\(" (mapconcat 'identity allprefix "\\|") - "\\)"))) - (push (list 'xr alist regexp) docstruct))) - - (set reftex-docstruct-symbol docstruct) - - ;; Save the parsing informtion into a file? - (if reftex-save-parse-info - (reftex-access-parse-file 'write)))) - -(defun reftex-is-multi () - ;; Tell if this is a multifile document. When not sure, say yes. - (let ((entry (assq 'is-multi (symbol-value reftex-docstruct-symbol)))) - (if entry - (nth 1 entry) - t))) - -(defun reftex-parse-from-file (file docstruct master-dir) - ;; Scan the buffer for labels and save them in a list. - (let ((regexp reftex-everything-regexp) - (bound 0) - file-found tmp - (level 1) - (highest-level 100) - toc-entry next-buf) - - (catch 'exit - (setq file-found (reftex-find-tex-file file master-dir)) - (unless file-found - (push (list 'file-error file) docstruct) - (throw 'exit nil)) - - (save-excursion - - (message "Scanning file %s" file) - (set-buffer - (setq next-buf - (reftex-get-file-buffer-force - file-found - (not (eq t reftex-keep-temporary-buffers))))) - - ;; Begin of file mark - (setq file (buffer-file-name)) - (push (list 'bof file) docstruct) - - (save-excursion - (save-restriction - (widen) - (goto-char 1) - - (while (re-search-forward regexp nil t) - - (cond - - ((match-end 1) - ;; It is a label - (push (reftex-label-info (reftex-match-string 1) file bound) - docstruct)) - - ((match-end 3) - ;; It is a section - (setq bound (point)) - - ;; Insert in List - (setq toc-entry (reftex-section-info file)) - (setq level (nth 5 toc-entry)) - (setq highest-level (min highest-level level)) - (if (= level highest-level) - (message - "Scanning %s %s ..." - (car (nth level reftex-section-levels)) - (nth 6 toc-entry))) - - (push toc-entry docstruct) - (setq reftex-active-toc toc-entry)) - - ((match-end 7) - ;; It's an include or input - (setq docstruct - (reftex-parse-from-file - (reftex-match-string 7) - docstruct master-dir))) - - ((match-end 8) - ;; A macro with label - (save-excursion - (let* ((mac (reftex-match-string 8)) - (label (progn (goto-char (match-end 8)) - (save-match-data - (reftex-no-props - (reftex-nth-arg-wrapper - mac))))) - (entry (progn (goto-char (match-end 0)) - (reftex-label-info - label file bound mac)))) - (push entry docstruct)))) - (t (error "This should not happen (reftex-parse-from-file)"))) - ) - - - ;; Find bibliography statement - (when (setq tmp (reftex-locate-bibliography-files master-dir)) - (push (cons 'bib tmp) docstruct)) - - ;; Find external document specifications - (goto-char 1) - (while (re-search-forward "[\n\r][ \t]*\\\\externaldocument\\(\\[\\([^]]*\\)\\]\\)?{\\([^}]+\\)}" nil t) - (push (list 'xr-doc (reftex-match-string 2) - (reftex-match-string 3)) - docstruct)) - - ;; End of file mark - (push (list 'eof file) docstruct)))) - - ;; Kill the scanned buffer - (reftex-kill-temporary-buffers next-buf)) - - ;; Return the list - docstruct)) - -(defun reftex-locate-bibliography-files (master-dir) - ;; Scan buffer for bibliography macro and return file list. - (let (file-list) - (save-excursion - (goto-char (point-min)) - (if (re-search-forward - "\\(\\`\\|[\n\r]\\)[ \t]*\\\\bibliography{[ \t]*\\([^}]+\\)" nil t) - (setq file-list - (mapcar '(lambda (x) (concat x ".bib")) - (reftex-delete-list - reftex-bibfile-ignore-list - (split-string - (reftex-match-string 2) - "[ \t\n\r]*,[ \t\n\r]*"))))) - (delete nil - (mapcar - (function - (lambda (file) (reftex-find-bib-file file master-dir))) - file-list))))) - -(defun reftex-last-assoc-before-elt (key elt list) - ;; Find the last association of KEY in LIST before or at ELT - ;; ELT is found in LIST with equal, not eq. - ;; Returns nil when either KEY or elt are not found in LIST. - ;; On success, returns the association. - (let* ((elt (car (member elt list))) ass last-ass) - - (while (and (setq ass (assoc key list)) - (setq list (memq ass list)) - (memq elt list)) - (setq last-ass ass - list (cdr list))) - last-ass)) - -(defun reftex-replace-label-list-segment (old insert &optional entirely) - ;; Replace the segment in OLD which corresponds to INSERT. - ;; Works with side effects, directly changes old. - ;; If entirely is t, just return INSERT. - ;; This function also makes sure the old toc markers do not point anywhere. - - (cond - (entirely - (reftex-silence-toc-markers old (length old)) - insert) - (t (let* ((new old) - (file (nth 1 (car insert))) - (eof-list (member (list 'eof file) old)) - (bof-list (member (list 'bof file) old)) - n) - (if (not (and bof-list eof-list)) - (error "Cannot splice") - ;; Splice - (reftex-silence-toc-markers bof-list (- (length bof-list) - (length eof-list))) - (setq n (- (length old) (length bof-list))) - (setcdr (nthcdr n new) (cdr insert)) - (setcdr (nthcdr (1- (length new)) new) (cdr eof-list))) - new)))) - -(defun reftex-silence-toc-markers (list n) - ;; Set all markers in list to nil - (while (and list (> (decf n) -1)) - (and (eq (car (car list)) 'toc) - (markerp (nth 4 (car list))) - (set-marker (nth 4 (car list)) nil)) - (pop list))) - -(defun reftex-access-parse-file (action) - (let* ((list (symbol-value reftex-docstruct-symbol)) - (master (reftex-TeX-master-file)) - (enable-local-variables nil) - (file (if (string-match "\\.[a-zA-Z]+\\'" master) - (concat (substring master 0 (match-beginning 0)) ".rel") - (concat master ".rel")))) - (cond - ((eq action 'readable) - (file-readable-p file)) - ((eq action 'restore) - (if (eq reftex-docstruct-symbol nil) - ;; Symbols are not yet tied: Tie them. - (reftex-tie-multifile-symbols)) - (if (file-exists-p file) - ;; load the file and return t for success - (progn (load-file file) t) - ;; return nil for failure - nil)) - ((eq action 'read) - (if (file-exists-p file) - ;; load the file and return t for success - (progn (load-file file) t) - ;; return nil for failure - nil)) - (t - (save-excursion - (if (file-writable-p file) - (progn - (message "Writing parse file %s" (abbreviate-file-name file)) - (find-file file) - (erase-buffer) - (insert (format ";; RefTeX parse info file\n")) - (insert (format ";; File: %s\n" master)) - (insert (format ";; Date: %s\n" - (format-time-string "%D %T" - (current-time)))) - (insert (format ";; User: %s (%s)\n\n" - (user-login-name) (user-full-name))) - (insert "(set reftex-docstruct-symbol '(\n\n") - (let ((standard-output (current-buffer))) - (mapcar - (function - (lambda (x) - (cond ((eq (car x) 'toc) - ;; A toc entry. Do not save the marker. - ;; Save the markers position at position 8 - (print (list 'toc "toc" (nth 2 x) (nth 3 x) - nil (nth 5 x) (nth 6 x) (nth 7 x) - (or (and (markerp (nth 4 x)) - (marker-position (nth 4 x))) - (nth 8 x))))) - (t (print x))))) - list)) - (insert "))") - (save-buffer 0) - (kill-buffer (current-buffer))) - (error "Cannot write to file %s" file))) - t)))) - -;; Creating labels -------------- - -(defun reftex-label (&optional environment no-insert) - "Insert a unique label. Return the label. -If ENVIRONMENT is given, don't bother to find out yourself. -If NO-INSERT is non-nil, do not insert label into buffer. -With prefix arg, force to rescan document first. -The label is also inserted into the label list. -This function is controlled by the settings of reftex-insert-label-flags." - - (interactive) - - ;; Ensure access to scanning info and rescan buffer if prefix are is '(4). - (reftex-access-scan-info current-prefix-arg) - - ;; Find out what kind of environment this is and abort if necessary. - (if (or (not environment) - (not (assoc environment reftex-env-or-mac-alist))) - (setq environment (reftex-label-location))) - (unless environment - (error "Can't figure out what kind of label should be inserted")) - - ;; Ok, go ahead. - (let* ((entry (assoc environment reftex-env-or-mac-alist)) - (typekey (nth 1 entry)) - (format (nth 3 entry)) - label prefix valid default force-prompt) - (when (and (eq (string-to-char environment) ?\\) - (nth 4 entry) - (memq (preceding-char) '(?\[ ?\{))) - (setq format "%s")) - - (setq prefix (or (cdr (assoc typekey reftex-typekey-to-prefix-alist)) - (concat typekey "-"))) - ;; Replace any escapes in the prefix - (setq prefix (reftex-replace-prefix-escapes prefix)) - - ;; Make a default label. - (cond - - ((reftex-typekey-check typekey (nth 0 reftex-insert-label-flags)) - ;; Derive a label from context. - (setq reftex-active-toc (reftex-last-assoc-before-elt - 'toc (car (reftex-where-am-I)) - (symbol-value reftex-docstruct-symbol))) - (setq default (reftex-no-props - (nth 2 (reftex-label-info " " nil nil t)))) - ;; Catch the cases where the is actually no context available. - (if (or (string-match "NO MATCH FOR CONTEXT REGEXP" default) - (string-match "ILLEGAL VALUE OF PARSE" default) - (string-match "SECTION HEADING NOT FOUND" default) - (string-match "HOOK ERROR" default) - (string-match "^[ \t]*$" default)) - (setq default prefix - force-prompt t) ; need to prompt - (setq default (concat prefix (reftex-string-to-label default))) - - ;; Make it unique. - (setq default (reftex-uniquify-label default nil "-")))) - - ((reftex-typekey-check typekey (nth 1 reftex-insert-label-flags)) ; prompt - ;; Minimal default: the user will be prompted. - (setq default prefix)) - - (t - ;; Make an automatic label. - (setq default (reftex-uniquify-label prefix t)))) - - ;; Should we ask the user? - (if (or (reftex-typekey-check typekey - (nth 1 reftex-insert-label-flags)) ; prompt - force-prompt) - - (while (not valid) - ;; iterate until we get a legal label - - (setq label (read-string - (if (string= format "%s") "Naked Label: " "Label: ") - default)) - - ;; Lets make sure that this is a legal label - (cond - - ;; Test if label contains strange characters - ((string-match reftex-label-illegal-re label) - (message "Label \"%s\" contains illegal characters" label) - (ding) - (sit-for 2)) - - ;; Look it up in the label list - ((setq entry (assoc label - (symbol-value reftex-docstruct-symbol))) - (message "Label \"%s\" exists in file %s" label (nth 3 entry)) - (ding) - (sit-for 2)) - - ;; Label is ok - (t - (setq valid t)))) - (setq label default)) - - ;; Insert the label into the label list - (let* ((here-I-am-info (reftex-where-am-I)) - (here-I-am (car here-I-am-info)) - (note (if (cdr here-I-am-info) - "" - "POSITION UNCERTAIN. RESCAN TO FIX.")) - (file (buffer-file-name)) - (text nil) - (tail (memq here-I-am (symbol-value reftex-docstruct-symbol)))) - - (if tail - (setcdr tail (cons (list label typekey text file note) - (cdr tail))))) - - ;; Insert the label into the buffer - (unless no-insert - (insert (format format label))) - - ;; return value of the function is the label - label)) - -(defun reftex-string-to-label (string) - ;; Convert a string (a sentence) to a label. - ;; - ;; Uses reftex-derive-label-parameters and reftex-abbrev-parameters - ;; - - (let* ((words0 (split-string string "[- \t\n\r]+")) - (ignore-words (nth 5 reftex-derive-label-parameters)) - words word) - - ;; remove words from the ignore list or with funny characters - (while (setq word (pop words0)) - (cond - ((member (downcase word) ignore-words)) - ((string-match reftex-label-illegal-re word) - (when (nth 2 reftex-derive-label-parameters) - (while (string-match reftex-label-illegal-re word) - (setq word (replace-match "" nil nil word))) - (push word words))) - (t - (push word words)))) - (setq words (nreverse words)) - - ;; restrict number of words - (if (> (length words) (nth 0 reftex-derive-label-parameters)) - (setcdr (nthcdr (1- (nth 0 reftex-derive-label-parameters)) words) nil)) - - ;; First, try to use all words - (setq string (mapconcat '(lambda(w) w) words - (nth 4 reftex-derive-label-parameters))) - - ;; Abbreviate words if enforced by user settings or string length - (if (or (eq t (nth 3 reftex-derive-label-parameters)) - (and (nth 3 reftex-derive-label-parameters) - (> (length string) (nth 1 reftex-derive-label-parameters)))) - (setq words - (mapcar - '(lambda (w) (if (string-match reftex-abbrev-regexp w) - (match-string 1 w) - w)) - words) - string (mapconcat '(lambda(w) w) words - (nth 4 reftex-derive-label-parameters)))) - - ;; Shorten if still to long - (setq string - (if (> (length string) (nth 1 reftex-derive-label-parameters)) - (substring string 0 (nth 1 reftex-derive-label-parameters)) - string)) - - ;; Delete the final punctuation, if any - (if (string-match "[^a-zA-Z0-9]+\\'" string) - (setq string (replace-match "" nil nil string))) - string)) - -(defun reftex-replace-prefix-escapes (prefix) - ;; Replace %escapes in a label prefix - (save-match-data - (let (letter (num 0) replace) - (while (string-match "\\%\\([a-zA-Z]\\)" prefix num) - (setq letter (match-string 1 prefix)) - (setq replace - (cond - ((equal letter "f") - (file-name-sans-extension - (file-name-nondirectory (buffer-file-name)))) - ((equal letter "F") - (let ((masterdir (file-name-directory (reftex-TeX-master-file))) - (file (file-name-sans-extension (buffer-file-name)))) - (if (string-match (concat "\\`" (regexp-quote masterdir)) - file) - (substring file (length masterdir)) - file))) - ((equal letter "u") - (or (user-login-name) "")) - (t ""))) - (setq num (1- (+ (match-beginning 1) (length replace))) - prefix (replace-match replace nil nil prefix))) - prefix))) - -(defun reftex-label-location (&optional bound) - ;; Return the environment or macro which determines the label type at point. - ;; If optional BOUND is an integer, limit backward searches to that point. - - (let* ((loc1 (reftex-what-macro reftex-label-mac-list bound)) - (loc2 (reftex-what-environment reftex-label-env-list bound)) - (p1 (or (cdr loc1) 0)) - (p2 (or (cdr loc2) 0))) - - (setq reftex-location-start (max p1 p2)) - (if (>= p1 p2) - (progn - (setq reftex-default-context-position (+ p1 (length (car loc1)))) - (or (car loc1) "section")) - (setq reftex-default-context-position (+ p2 8 (length (car loc2)))) - (or (car loc2) "section")))) - -(defun reftex-uniquify-label (label &optional force separator) - ;; Make label unique by appending a number. - ;; Optional FORCE means, force appending a number, even if label is unique. - ;; Optional SEPARATOR is a string to stick between label and number. - - ;; Ensure access to scanning info - (reftex-access-scan-info) - - (cond - ((and (not force) - (not (assoc label (symbol-value reftex-docstruct-symbol)))) - label) - (t - (let* ((label-numbers (assq 'label-numbers - (symbol-value reftex-docstruct-symbol))) - (label-numbers-alist (cdr label-numbers)) - (cell (or (assoc label label-numbers-alist) - (car (setcdr label-numbers - (cons (cons label 0) - label-numbers-alist))))) - (num (1+ (cdr cell))) - (sep (or separator ""))) - (while (assoc (concat label sep (int-to-string num)) - (symbol-value reftex-docstruct-symbol)) - (incf num)) - (setcdr cell num) - (concat label sep (int-to-string num)))))) - -;; Help string for the reference label menu -(defconst reftex-select-label-prompt - "Select: [n]ext [p]revious [r]escan [ ]context e[x]tern [q]uit RET [?]HELP+more") - -(defconst reftex-select-label-help - " AVAILABLE KEYS IN REFERENCE LABEL MENU - -------------------------------------- - n / p Go to next/previous label (Cursor motion works as well) - C-s / C-r Search forward/backward. Use repeated C-s/C-r as in isearch. - r / s Reparse document / Switch label type - x Switch to label menu of external document (with LaTeX package `xr') - t i c # % Toggle: [i]ncl. file borders, [t]able of contents, [c]ontext - [#] label counters, [%] labels in comments - SPC Show full context for current label in other window - f Toggle follow mode: other window will follow context - l / q Reuse last referenced label / Quit without accepting label - e Recursive Edit into other window - RET Accept current label") - -(defun reftex-reference (&optional type no-insert) - "Make a LaTeX reference. Look only for labels of a certain TYPE. -With prefix arg, force to rescan buffer for labels. This should only be -necessary if you have recently entered labels yourself without using -reftex-label. Rescanning of the buffer can also be requested from the -label selection menu. -The function returns the selected label or nil. -If NO-INSERT is non-nil, do not insert \\ref command, just return label. -When called with 2 C-u prefix args, disable magic word recognition." - - (interactive) - - ;; check for active recursive edits - (reftex-check-recursive-edit) - - ;; Ensure access to scanning info and rescan buffer if prefix are is '(4) - (reftex-access-scan-info current-prefix-arg) - - (unless type - ;; guess type from context - (if (and reftex-guess-label-type - (setq type (assoc (downcase (reftex-word-before-point)) - reftex-words-to-typekey-alist))) - (setq type (cdr type)) - (setq type (reftex-query-label-type)))) - - (let (label pair - (form (or (cdr (assoc type reftex-typekey-to-format-alist)) - "\\ref{%s}"))) - - ;; Have the user select a label - (setq pair (reftex-offer-label-menu type)) - (setq label (car pair)) - - (if (and label - (not no-insert)) - (progn - ;; do we need to remove spaces? - (if (string= "~" (substring form 0 1)) - (while (or (= (preceding-char) ?\ ) - (= (preceding-char) ?\C-i)) - (backward-delete-char 1))) - ;; ok, insert the reference - (insert (format form label label)) - (message "")) - (message "Quit")) - ;; return the label - label)) - -(defun reftex-offer-label-menu (typekey) - ;; Offer a menu with the appropriate labels. Return (label . file). - (let* ((buf (current-buffer)) - (xr-data (assq 'xr (symbol-value reftex-docstruct-symbol))) - (xr-alist (cons (cons "" (buffer-file-name)) (nth 1 xr-data))) - (xr-index 0) - (here-I-am (car (reftex-where-am-I))) - (toc (reftex-typekey-check typekey reftex-label-menu-flags 0)) - (files (reftex-typekey-check typekey reftex-label-menu-flags 7)) - (context (not (reftex-typekey-check - typekey reftex-label-menu-flags 3))) - (counter (reftex-typekey-check - typekey reftex-label-menu-flags 2)) - (follow (reftex-typekey-check - typekey reftex-label-menu-flags 4)) - (commented (nth 5 reftex-label-menu-flags)) - (match-everywhere (reftex-typekey-check - typekey reftex-label-menu-flags 6)) - (prefix "") - offset rtn key cnt last-cnt entry) - - (setq entry (cons nil nil)) - - ;; The following unwind-protect kills temporary buffers after use - (unwind-protect - (catch 'exit - (while t - (save-window-excursion - (setq reftex-call-back-to-this-buffer buf) - (switch-to-buffer-other-window "*RefTeX Select*") - (erase-buffer) - (setq truncate-lines t) - (setq mode-line-format - (list "---- " 'mode-line-buffer-identification - " " (abbreviate-file-name - (buffer-file-name buf)) - " -%-")) - - (setq reftex-label-index-list - (reftex-make-and-insert-label-list - typekey buf toc files context counter commented - here-I-am prefix)) - (setq here-I-am nil) ; turn off determination of offset - ;; use only when searched - (setq offset (or (car reftex-label-index-list) offset)) - ;; only this is the true list - (pop reftex-label-index-list) - (setq rtn - (reftex-select-item - reftex-select-label-prompt - "^>" - 2 - reftex-select-label-help - '(?r ?R ?g ?c ?t ?s ?# ?i ?l ?% ?x) - offset - 'reftex-select-label-callback follow - match-everywhere)) - (setq key (car rtn) - cnt (nth 1 rtn) - last-cnt (nth 2 rtn) - offset (1+ (or cnt last-cnt 0))) - (unless key (throw 'exit nil)) - (cond - ((or (eq key ?r) - (eq key ?R) - (eq key ?g)) - ;; rescan buffer - (reftex-parse-document buf (or cnt last-cnt) key)) - ((eq key ?c) - ;; toggle context mode - (setq context (not context))) - ((eq key ?s) - ;; switch type - (setq typekey (reftex-query-label-type))) - ((eq key ?t) - ;; toggle tabel of contents display - (setq toc (not toc))) - ((eq key ?i) - ;; toggle display of included file borders - (setq files (not files))) - ((eq key ?#) - ;; toggle counter display - (setq counter (not counter))) - ((eq key ?%) - ;; toggle display of commented labels - (setq commented (not commented))) - ((eq key ?l) - ;; reuse the last referenced label again - (setq entry reftex-last-used-reference) - (throw 'exit t)) - ((eq key ?x) - ;; select an external document - (setq xr-index (reftex-select-external-document - xr-alist xr-index)) - (setq buf (or (reftex-get-file-buffer-force - (cdr (nth xr-index xr-alist))) - (error "Cannot switch document")) - prefix (or (car (nth xr-index xr-alist)) "") - offset nil)) - (t - (set-buffer buf) - (if cnt - (progn - (setq entry (nth (nth cnt reftex-label-index-list) - (symbol-value reftex-docstruct-symbol))) - (setq reftex-last-used-reference entry)) - (setq entry nil)) - (throw 'exit t)))))) - (kill-buffer "*RefTeX Select*") - (and (get-buffer "*RefTeX Context Copy*") - (kill-buffer "*RefTeX Context Copy*")) - (reftex-kill-temporary-buffers)) - (cons (if (nth 0 entry) (concat prefix (nth 0 entry)) nil) - (nth 3 entry)))) - -(defun reftex-select-external-document (xr-alist xr-index) - ;; Return index of an external document. - (cond - ((= (length xr-alist) 1) - (message "No external douments available") - (ding) 0) - ((= (length xr-alist) 2) - (- 1 xr-index)) - (t - (save-window-excursion - (let* ((fmt " [%c] %-5s %s\n") (n (1- ?0)) key) - (with-output-to-temp-buffer "*RefTeX Select*" - (princ - (concat "Select a document by pressing a number key:\n KEY PREFIX DOCUMENT\n----------------------\n" - (mapconcat '(lambda (x) - (format fmt (incf n) (or (car x) "") - (abbreviate-file-name (cdr x)))) - xr-alist "")))) - (setq key (read-char)) - (if (< (- key ?1) (length xr-alist)) - (- key ?0) - (error "Illegal document selection [%c]" key))))))) - -(defun reftex-make-and-insert-label-list - (typekey0 buf toc files context counter show-commented here-I-am xr-prefix) - ;; Insert a menu of all labels in buffer BUF into current buffer. - ;; Return the list of labels, with the index of HERE-I-AM as extra car. - (let* ((font (reftex-use-fonts)) - (refont (reftex-refontify)) - (cnt 0) - (index -1) - (toc-indent " ") - (label-indent - (concat "> " - (if toc (make-string (* 7 reftex-level-indent) ?\ ) ""))) - (context-indent - (concat ". " - (if toc (make-string (* 7 reftex-level-indent) ?\ ) ""))) - all cell text label typekey note comment master-dir-re - index-list offset docstruct-symbol from from1 to) - - ;; Pop to buffer buf to get the correct buffer-local variables - (save-excursion - (set-buffer buf) - - ;; Ensure access to scanning info - (reftex-access-scan-info) - - (setq docstruct-symbol reftex-docstruct-symbol - all (symbol-value reftex-docstruct-symbol) - reftex-active-toc nil - master-dir-re - (concat "\\`" (regexp-quote - (file-name-directory (reftex-TeX-master-file)))))) - - (when refont - ;; Calculate font-lock-defaults as in LaTeX mode. - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults nil) - (let ((major-mode 'latex-mode)) - (font-lock-set-defaults)) - ;; The following is only needed for XEmacs, but does not hurt Emacs. - (setq font-lock-mode nil)) - - ;; Walk the docstruct and insert the appropriate stuff - - (while (setq cell (pop all)) - - (incf index) - (setq from (point)) - - (if (eq cell here-I-am) (setq offset (1+ cnt))) - - (cond - - ((memq (car cell) '(bib label-numbers master-dir is-multi - xr xr-doc))) - ;; These are currently ignored - - ((memq (car cell) '(bof eof file-error)) - ;; Beginning or end of a file - (when files - (insert - " " (if (string-match master-dir-re (nth 1 cell)) - (substring (nth 1 cell) (match-end 0)) - (nth 1 cell)) - (cond ((eq (car cell) 'bof) " starts here\n") - ((eq (car cell) 'eof) " ends here\n") - ((eq (car cell) 'file-error) " was not found\n"))) - (when font - (put-text-property from (point) - 'face 'font-lock-function-name-face)))) - - ((eq (car cell) 'toc) - ;; a table of contents entry - (when toc - (setq reftex-active-toc cell) - (insert (concat toc-indent (nth 2 cell) "\n")))) - - ((stringp (car cell)) - ;; a label - (when (null (nth 2 cell)) - ;; No context yet. Quick update. - (setq cell (reftex-label-info-update cell)) - (setcar (nthcdr index (symbol-value docstruct-symbol)) - cell)) - - (setq label (car cell) - typekey (nth 1 cell) - text (nth 2 cell) - note (nth 4 cell) - comment (get-text-property 0 'in-comment text)) - - (when (and (or (string= typekey typekey0) (string= typekey0 " ")) - (or show-commented (null comment))) - - ;; Yes we want this one - (incf cnt) - (push index index-list) - - (setq label (concat xr-prefix label)) - (when comment (setq label (concat "% " label))) - (insert label-indent label) - (when font - (put-text-property - (- (point) (length label)) (point) - 'face (if comment - 'font-lock-comment-face - 'font-lock-reference-face))) - - (insert (if counter (format " (%d) " cnt) "") - (if comment " LABEL IS COMMENTED OUT " "") - (if note (concat " " note) "") - "\n") - (setq to (point)) - - (when context - (setq from1 to) - (insert context-indent text "\n") - (setq to (point)) - (when refont - (font-lock-fontify-region from1 to) - (goto-char to))) - (put-text-property from to 'cnt (1- cnt)) - (goto-char to))))) - - ;; Return the index list - (cons offset (nreverse index-list)))) - -(defun reftex-parse-document (&optional buffer cnt key) - "Rescan the document." - (interactive) - (save-window-excursion - (save-excursion - (if buffer - (if (not (bufferp buffer)) - (error "No such buffer %s" (buffer-name buffer)) - (set-buffer buffer))) - (let ((arg (if (eq key ?R) '(16) '(4))) - (file (if cnt - (nth 3 - (nth (nth cnt reftex-label-index-list) - (symbol-value reftex-docstruct-symbol)))))) - (reftex-access-scan-info arg file))))) - -(defun reftex-query-label-type () - ;; Ask for label type - (message reftex-type-query-prompt) - (let ((key (read-char))) - (when (eq key ?\?) - (save-window-excursion - (with-output-to-temp-buffer "*RefTeX Help*" - (princ reftex-type-query-help)) - (setq key (read-char)) - (kill-buffer "*RefTeX Help*"))) - (unless (member (char-to-string key) reftex-typekey-list) - (error "No such label type: %s" (char-to-string key))) - (char-to-string key))) - -;; Variable holding the vector with section numbers -(defvar reftex-section-numbers [0 0 0 0 0 0 0 0]) - -(defun reftex-section-info (file) - ;; Return a section entry for the current match. - ;; Carefull: This function expects the match-data to be still in place! - (let* ((marker (set-marker (make-marker) (1- (match-beginning 3)))) - (macro (reftex-match-string 3)) - (star (= ?* (char-after (match-end 3)))) - (level (cdr (assoc macro reftex-section-levels))) - (section-number (reftex-section-number - reftex-section-numbers level star)) - (text1 (save-match-data (save-excursion (reftex-context-substring)))) - (literal (buffer-substring-no-properties - (1- (match-beginning 3)) - (min (point-max) (+ (match-end 0) (length text1) 1)))) - ;; Literal can be too short since text1 too short. No big problem. - (text (reftex-nicify-text text1))) - - ;; Add section number and indentation - (setq text - (concat - (make-string (* reftex-level-indent level) ?\ ) - (if (nth 1 reftex-label-menu-flags) ; section number flag - (concat section-number " ")) - text)) - ;; Fontify - (if (reftex-use-fonts) - (put-text-property 0 (length text) - 'face 'font-lock-comment-face text)) - (list 'toc "toc" text file marker level section-number - literal (marker-position marker)))) - -(defun reftex-label-info-update (cell) - ;; Update information about just one label in a different file. - ;; CELL contains the old info list - (let* ((label (nth 0 cell)) - (typekey (nth 1 cell)) - ;; (text (nth 2 cell)) - (file (nth 3 cell)) - (note (nth 4 cell)) - (buf (reftex-get-file-buffer-force - file (not (eq t reftex-keep-temporary-buffers))))) - (if (not buf) - (list label typekey "" file "LOST LABEL. RESCAN TO FIX.") - (save-excursion - (set-buffer buf) - (save-restriction - (widen) - (goto-char 1) - - (if (or (re-search-forward - (format reftex-find-label-regexp-format - (regexp-quote label)) nil t) - (re-search-forward - (format reftex-find-label-regexp-format2 - (regexp-quote label)) nil t)) - - (progn - (backward-char 1) - (append (reftex-label-info label file) (list note))) - (list label typekey "" file "LOST LABEL. RESCAN TO FIX."))))))) - -(defun reftex-label-info (label &optional file bound derive env-or-mac) - ;; Return info list on LABEL at point. - (let* ((env-or-mac (or env-or-mac (reftex-label-location bound))) - (typekey (nth 1 (assoc env-or-mac reftex-env-or-mac-alist))) - (file (or file (buffer-file-name))) - (parse (if (reftex-typekey-check - typekey reftex-use-text-after-label-as-context) - nil - (nth 2 (assoc env-or-mac reftex-env-or-mac-alist)))) - (text (reftex-short-context env-or-mac parse reftex-location-start - derive))) - (if (reftex-in-comment) - (put-text-property 0 1 'in-comment t text)) - (list label typekey text file))) - -(defun reftex-in-comment () - (save-excursion - (skip-chars-backward "^%\n\r") - (eq (preceding-char) ?%))) - -(defun reftex-short-context (env parse &optional bound derive) - ;; Get about one line of useful context for the label definition at point. - - (if (consp parse) - (setq parse (if derive (cdr parse) (car parse)))) - - (reftex-nicify-text - - (cond - - ((null parse) - (save-excursion - (reftex-context-substring))) - - ((eq parse t) - (if (string= env "section") - ;; special treatment for section labels - (save-excursion - (if (and (re-search-backward reftex-section-or-include-regexp - (point-min) t) - (match-end 2)) - (progn - (goto-char (match-end 0)) - (reftex-context-substring)) - (if reftex-active-toc - (progn - (string-match "{\\([^}]*\\)" (nth 7 reftex-active-toc)) - (match-string 1 (nth 7 reftex-active-toc))) - "SECTION HEADING NOT FOUND"))) - (save-excursion - (goto-char reftex-default-context-position) - (unless (eq (string-to-char env) ?\\) - (reftex-move-over-touching-args)) - (reftex-context-substring)))) - - ((stringp parse) - (save-excursion - (if (re-search-backward parse bound t) - (progn - (goto-char (match-end 0)) - (reftex-context-substring)) - "NO MATCH FOR CONTEXT REGEXP"))) - - ((integerp parse) - (or (save-excursion - (goto-char reftex-default-context-position) - (reftex-nth-arg - parse - (nth 6 (assoc env reftex-env-or-mac-alist)))) - "")) - - ((fboundp parse) - ;; A hook function. Call it. - (save-excursion - (condition-case error-var - (funcall parse env) - (error (format "HOOK ERROR: %s" (cdr error-var)))))) - (t - "ILLEGAL VALUE OF PARSE")))) - -(defun reftex-where-am-I () - ;; Return the docstruct entry above point. Actually returns a cons - ;; cell in which the cdr is a flag indicating if the information is - ;; exact (t) or approximate (nil). - (interactive) - - (let ((docstruct (symbol-value reftex-docstruct-symbol)) - (cnt 0) rtn - found) - (save-excursion - (while (not rtn) - (incf cnt) - (setq found (re-search-backward reftex-everything-regexp nil t)) - (setq rtn - (cond - ((not found) - ;; no match - (or - (car (member (list 'bof (buffer-file-name)) docstruct)) - (not (setq cnt 2)) - (assq 'bof docstruct) ;; for safety reasons - 'corrupted)) - ((match-end 1) - ;; Label - (assoc (reftex-match-string 1) - (symbol-value reftex-docstruct-symbol))) - ((match-end 3) - ;; Section - (goto-char (1- (match-beginning 3))) - (let* ((list (member (list 'bof (buffer-file-name)) - docstruct)) - (endelt (car (member (list 'eof (buffer-file-name)) - list))) - rtn1) - (while (and list (not (eq endelt (car list)))) - (if (and (eq (car (car list)) 'toc) - (string= (buffer-file-name) - (nth 3 (car list)))) - (cond - ((equal (point) - (or (and (markerp (nth 4 (car list))) - (marker-position (nth 4 (car list)))) - (nth 8 (car list)))) - ;; Fits with marker position or recorded position - (setq rtn1 (car list) list nil)) - ((looking-at (reftex-make-regexp-allow-for-ctrl-m - (nth 7 (car list)))) - ;; Same title - (setq rtn1 (car list) list nil cnt 2)))) - (pop list)) - rtn1)) - ((match-end 7) - ;; Input or include... - (car - (member (list 'eof (reftex-find-tex-file - (reftex-match-string 7) - (cons - (cdr (assq 'master-dir docstruct)) - reftex-tex-path))) - docstruct))) - ((match-end 8) - (save-excursion - (goto-char (match-end 8)) - (assoc (reftex-no-props - (reftex-nth-arg-wrapper - (reftex-match-string 8))) - (symbol-value reftex-docstruct-symbol)))) - (t - (error "This should not happen (reftex-where-am-I)")))))) - (cons rtn (eq cnt 1)))) - -(defun reftex-parse-args (macro) - ;; Return a list of macro name, nargs, arg-nr which is label and a list of - ;; optional argument indices. - (if (string-match "[[{]\\*?[]}]" macro) - (progn - (let ((must-match (substring macro 0 (match-beginning 0))) - (args (substring macro (match-beginning 0))) - opt-list nlabel (cnt 0)) - (while (string-match "\\`[[{]\\(\\*\\)?[]}]" args) - (incf cnt) - (when (eq ?\[ (string-to-char args)) - (push cnt opt-list)) - (when (and (match-end 1) - (not nlabel)) - (setq nlabel cnt)) - (setq args (substring args (match-end 0)))) - (list must-match cnt nlabel opt-list))) - nil)) - -(defsubst reftex-move-to-next-arg (&optional ignore) - ;; Assuming that we are at the end of a macro name or a macro argument, - ;; move forward to the opening parenthesis of the next argument. - ;; This function understands the splitting of macros over several lines - ;; in TeX. - (cond - ;; Just to be quick: - ((memq (following-char) '(?\[ ?\{))) - ;; Do a search - ((looking-at "[ \t]*[\n\r]?\\([ \t]*%[^\n\r]*[\n\r]\\)*[ \t]*[[{]") - (goto-char (1- (match-end 0))) - t) - (t nil))) - -(defsubst reftex-move-to-previous-arg (&optional bound) - ;; Assuming that we are in front of a macro argument, - ;; move backward to the closing parenthesis of the previous argument. - ;; This function understands the splitting of macros over several lines - ;; in TeX. - (cond - ;; Just to be quick: - ((memq (preceding-char) '(?\] ?\}))) - ;; Do a search - ((re-search-backward - "[]}][ \t]*[\n\r]?\\([ \t]*%[^\n\r]*[\n\r]\\)*[ \t]*\\=" bound t) - (goto-char (1+ (match-beginning 0))) - t) - (t nil))) - -(defun reftex-nth-arg-wrapper (key) - (let ((entry (assoc key reftex-env-or-mac-alist))) - (reftex-nth-arg (nth 5 entry) (nth 6 entry)))) - -(defun reftex-nth-arg (n &optional opt-args) - ;; Return the nth following {} or [] parentheses content. - ;; OPT-ARGS is a list of argument numbers which are optional. - - ;; If we are sitting at a macro start, skip to end of macro name. - (and (eq (following-char) ?\\) (skip-chars-forward "a-zA-Z*\\\\")) - - (if (= n 1000) - ;; Special case: Skip all touching arguments - (progn - (reftex-move-over-touching-args) - (reftex-context-substring)) - - ;; Do the real thing. - (let ((cnt 1)) - - (when (reftex-move-to-next-arg) - - (while (< cnt n) - (while (and (member cnt opt-args) - (eq (following-char) ?\{)) - (incf cnt)) - (when (< cnt n) - (unless (and (condition-case nil - (or (forward-list 1) t) - (error nil)) - (reftex-move-to-next-arg) - (incf cnt)) - (setq cnt 1000)))) - - (while (and (memq cnt opt-args) - (eq (following-char) ?\{)) - (incf cnt))) - (if (and (= n cnt) - (> (skip-chars-forward "{\\[") 0)) - (reftex-context-substring) - nil)))) - -(defun reftex-move-over-touching-args () - (condition-case nil - (while (memq (following-char) '(?\[ ?\{)) - (forward-list 1)) - (error nil))) - -(defun reftex-context-substring () - ;; Return up to 100 chars from point - ;; When point is just after a { or [, limit string to matching parenthesis - (cond - ((or (= (preceding-char) ?\{) - (= (preceding-char) ?\[)) - ;; Inside a list - get only the list. - (buffer-substring-no-properties - (point) - (min (reftex-fp 150) - (point-max) - (condition-case nil - (progn - (up-list 1) - (1- (point))) - (error (point-max)))))) - (t - ;; no list - just grab 100 characters - (buffer-substring-no-properties (point) (min (reftex-fp 150) (point-max)))))) - -(defun reftex-init-section-numbers (&optional toc-entry) - ;; Initialize the section numbers with zeros or with what is found - ;; in the toc entry. - (let* ((level (or (nth 5 toc-entry) -1)) - (numbers (nreverse (split-string (or (nth 6 toc-entry) "") "\\."))) - (depth (1- (length reftex-section-numbers))) - (i depth)) - (while (>= i 0) - (if (> i level) - (aset reftex-section-numbers i 0) - (aset reftex-section-numbers i (string-to-int (or (car numbers) "0"))) - (pop numbers)) - (decf i)))) - -(defun reftex-section-number (section-numbers &optional level star) - ;; Return a string with the current section number. - ;; When LEVEL is non-nil, increase section numbers on that level. - (let* ((depth (1- (length section-numbers))) idx n (string "")) - (when level - (when (and (> level -1) (not star)) - (aset section-numbers level (1+ (aref section-numbers level)))) - (setq idx (1+ level)) - (while (<= idx depth) - (aset section-numbers idx 0) - (incf idx))) - (setq idx 0) - (while (<= idx depth) - (setq n (aref section-numbers idx)) - (setq string (concat string (if (not (string= string "")) "." "") - (int-to-string n))) - (incf idx)) - (save-match-data - (if (string-match "\\`\\(0\\.\\)+" string) - (setq string (replace-match "" nil nil string))) - (if (string-match "\\(\\.0\\)+\\'" string) - (setq string (replace-match "" nil nil string)))) - (if star - (concat (make-string (1- (length string)) ?\ ) "*") - string))) - -;; A variable to remember the index of the last label context shown -(defvar reftex-last-cnt 0) - -(defun reftex-select-label-callback (cnt) - ;; Callback function called from the label selection in order to - ;; show context in another window - (let* ((this-window (selected-window)) - index entry label file buffer re) - ;; pop to original buffer in order to get correct variables - (catch 'exit - (save-excursion - (set-buffer reftex-call-back-to-this-buffer) - (setq index (nth (or cnt 1) reftex-label-index-list) - entry (nth index (symbol-value reftex-docstruct-symbol)) - label (nth 0 entry) - file (nth 3 entry))) - - ;; goto the file in another window - (setq buffer (reftex-get-file-buffer-force - file (not reftex-keep-temporary-buffers))) - (if buffer - ;; good - the file is available - (switch-to-buffer-other-window buffer) - ;; we have got a problem here. The file does not exist. - ;; Let' get out of here.. - (ding) - (throw 'exit nil)) - - - ;; search for that label - (setq re (format reftex-find-label-regexp-format (regexp-quote label))) - (unless (and (integerp cnt) - (integerp reftex-last-cnt) - (if (> cnt reftex-last-cnt) - (re-search-forward re nil t) - (re-search-backward re nil t))) - (goto-char (point-min)) - (unless (re-search-forward re nil t) - ;; Ooops. Must be in a macro with distributed args. - (re-search-forward (format reftex-find-label-regexp-format2 - (regexp-quote label)) nil t))) - (when (match-end 3) - (reftex-highlight 0 (match-beginning 3) (match-end 3)) - (reftex-show-entry (- (point) (match-beginning 3)) - (- (point) (match-end 3))) - (recenter (/ (window-height) 2))) - (select-window this-window)))) - -(defun reftex-pop-to-label (label file-list &optional mark-to-kill highlight) - ;; Find LABEL in any file in FILE-LIST in another window. - ;; If mark-to-kill is non-nil, mark new buffer for killing. - ;; If HIGHLIGHT is non-nil, highlight the label definition. - (let* ((re1 (format reftex-find-label-regexp-format (regexp-quote label))) - (re2 (format reftex-find-label-regexp-format2 (regexp-quote label))) - (re-list (list re1 re2)) re - (file-list-1 file-list) - file buf) - (catch 'exit - (while (setq re (pop re-list)) - (setq file-list file-list-1) - (while (setq file (pop file-list)) - (unless (setq buf (reftex-get-file-buffer-force file mark-to-kill)) - (error "No such file %s" file)) - (set-buffer buf) - (widen) - (goto-char (point-min)) - (when (re-search-forward re nil t) - (switch-to-buffer-other-window buf) - (goto-char (match-beginning 0)) - (recenter (/ (window-height) 2)) - (if highlight - (reftex-highlight 0 (match-beginning 3) (match-end 3))) - (throw 'exit (selected-window))))) - (error "Label %s not found" label)))) - -(defun reftex-find-duplicate-labels () - "Produce a list of all duplicate labels in the document." - - (interactive) - - ;; Rescan the document to make sure - (reftex-access-scan-info t) - - (let ((master (reftex-TeX-master-file)) - (cnt 0) - (dlist - (mapcar - '(lambda(x) - (let (x1) - (cond - ((memq (car x) - '(toc bof eof bib label-numbers xr xr-doc - master-dir file-error is-multi)) - nil) - (t - (setq x1 (reftex-all-assoc-string - (car x) (symbol-value reftex-docstruct-symbol))) - (if (< 1 (length x1)) - (append (list (car x)) - (mapcar '(lambda(x) - (abbreviate-file-name (nth 3 x))) x1)) - (list nil)))))) - (reftex-uniquify (symbol-value reftex-docstruct-symbol))))) - - (setq dlist (reftex-uniquify dlist)) - (if (null dlist) (error "No duplicate labels in document")) - (switch-to-buffer-other-window "*Duplicate Labels*") - (make-local-variable 'TeX-master) - (setq TeX-master master) - (erase-buffer) - (insert " MULTIPLE LABELS IN CURRENT DOCUMENT:\n") - (insert - " Move point to label and type `r' to run a query-replace on the label\n" - " and its references. Type `q' to exit this buffer.\n\n") - (insert " LABEL FILE\n") - (insert " -------------------------------------------------------------\n") - (use-local-map (make-sparse-keymap)) - (local-set-key [?q] '(lambda () (interactive) - (kill-buffer (current-buffer)) (delete-window))) - (local-set-key [?r] 'reftex-change-label) - (while dlist - (when (and (car (car dlist)) - (cdr (car dlist))) - (incf cnt) - (insert (mapconcat '(lambda(x) x) (car dlist) "\n ") "\n")) - (pop dlist)) - (goto-char (point-min)) - (when (= cnt 0) - (kill-buffer (current-buffer)) - (delete-window) - (message "Document does not contain duplicate labels.")))) - -(defun reftex-all-assq (key list) - ;; Return a list of all associations of KEY in LIST. Comparison with string= - (let (rtn) - (while (setq list (memq (assq key list) list)) - (push (car list) rtn) - (pop list)) - (nreverse rtn))) - -(defun reftex-all-assoc-string (key list) - ;; Return a list of all associations of KEY in LIST. Comparison with string= - (let (rtn) - (while list - (if (string= (car (car list)) key) - (push (car list) rtn)) - (pop list)) - (nreverse rtn))) - -(defun reftex-kill-temporary-buffers (&optional buffer) - ;; Kill all buffers in the list reftex-kill-temporary-buffers. - (cond - (buffer - (when (member buffer reftex-buffers-to-kill) - (kill-buffer buffer) - (setq reftex-buffers-to-kill - (delete buffer reftex-buffers-to-kill)))) - (t - (while (setq buffer (pop reftex-buffers-to-kill)) - (when (bufferp buffer) - (and (buffer-modified-p buffer) - (y-or-n-p (format "Save file %s? " - (buffer-file-name buffer))) - (save-excursion - (set-buffer buffer) - (save-buffer))) - (kill-buffer buffer)) - (pop reftex-buffers-to-kill))))) - -(defun reftex-show-entry (beg-hlt end-hlt) - ;; Show entry if point is hidden by outline mode - (let* ((pos (point)) - (n (/ (window-height) 2)) - (beg (save-excursion - (re-search-backward "[\n\r]" nil 1 n) (point))) - (end (save-excursion - (re-search-forward "[\n\r]" nil 1 n) (point)))) - (if (and reftex-auto-show-entry - (string-match - "\r" (buffer-substring beg end))) - (cond - ((eq t reftex-auto-show-entry) - (subst-char-in-region - (save-excursion (search-backward "\n" nil t) (point)) - (save-excursion (search-forward "\n" nil t) (point)) - ?\r ?\n t)) - ((eq reftex-auto-show-entry 'copy) - (let ((string (buffer-substring beg end))) - (switch-to-buffer "*RefTeX Context Copy*") - (setq buffer-read-only nil) - (erase-buffer) - (insert string) - (subst-char-in-region (point-min) (point-max) ?\r ?\n t) - (goto-char (- pos beg)) - (reftex-highlight 0 (1+ (- (point) beg-hlt)) - (1+ (- (point) end-hlt))) - (when (reftex-refontify) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults nil) - (let ((major-mode 'latex-mode)) - (font-lock-set-defaults) - (font-lock-fontify-buffer))) - (setq buffer-read-only t))) - )))) - -(defun reftex-nicify-text (text) - ;; Make TEXT nice for inclusion as context into label menu - (while (string-match "[\n\r\t]\\|[ \t][ \t]+" text) ; remove extra whitespace - (setq text (replace-match " " nil t text))) - (if (string-match "\\\\end{.*" text) ; nothing beyond \end{ - (setq text (replace-match "" nil t text))) - (if (string-match "\\\\label{[^}]*}" text) ; kill the label - (setq text (replace-match "" nil t text))) - (if (string-match "\\`[ }]+" text) ; leading whitespace, `}' - (setq text (replace-match "" nil t text))) - (cond - ((> (length text) 100) (substring text 0 100)) - ((= (length text) 0) " ") - (t text))) - -(defun reftex-typekey-check (typekey conf-variable &optional n) - ;; Check if CONF-VARIABLE is true or contains TYPEKEY - (and n (setq conf-variable (nth n conf-variable))) - (or (eq conf-variable t) - (and (stringp conf-variable) - (string-match (concat "[" conf-variable "]") typekey)))) - -;;; =========================================================================== -;;; -;;; Table of contents - -;; We keep at most one *toc* buffer - it is easy to make them - -(defvar reftex-last-toc-master nil - "Stores the name of the tex file that `reftex-toc' was last run on.") - -(defvar reftex-last-toc-file nil - "Stores the file name from which `reftex-toc' was called. For redo command.") - -(defvar reftex-last-window-height nil) - -(defvar reftex-toc-return-marker (make-marker) - "Marker which makes it possible to return from toc to old position.") - -(defconst reftex-toc-help -" AVAILABLE KEYS IN TOC BUFFER - ============================ -SPC Show the corresponding section of the LaTeX document. -TAB Goto the section. -RET Goto the section and hide the *toc* buffer (also on mouse-2). -q / Q Hide/Kill *toc* buffer, return to position of last reftex-toc command. -f Toggle follow mode on and off. -r / g Reparse the LaTeX document. -x Switch to TOC of external document (with LaTeX package `xr').") - -(defun reftex-toc () - "Show the table of contents for the current document. -When called with a raw C-u prefix, rescan the document first." - - (interactive) - - (if (or (not (string= reftex-last-toc-master (reftex-TeX-master-file))) - current-prefix-arg) - (reftex-empty-toc-buffer)) - - (setq reftex-last-toc-file (buffer-file-name)) - (setq reftex-last-toc-master (reftex-TeX-master-file)) - - (set-marker reftex-toc-return-marker (point)) - - ;; If follow mode is active, arrange to delay it one command - (if reftex-toc-follow-mode - (setq reftex-toc-follow-mode 1)) - - ;; Ensure access to scanning info and rescan buffer if prefix are is '(4) - (reftex-access-scan-info current-prefix-arg) - - (let* ((all (symbol-value reftex-docstruct-symbol)) - (xr-data (assq 'xr all)) - (xr-alist (cons (cons "" (buffer-file-name)) (nth 1 xr-data))) - (where (reftex-nearest-section)) - toc1 cell startpos) - - (if (get-buffer-window "*toc*") - (select-window (get-buffer-window "*toc*")) - (setq reftex-last-window-height (window-height)) ; remember - (split-window-vertically) - (switch-to-buffer (get-buffer-create "*toc*"))) - - (cond - ;; buffer is empty - fill it with the table of contents - ((= (buffer-size) 0) - - (local-set-key "?" 'reftex-toc-show-help) - (local-set-key " " 'reftex-toc-view-line) - (local-set-key "\C-m" 'reftex-toc-goto-line-and-hide) - (local-set-key "\C-i" 'reftex-toc-goto-line) - (local-set-key "r" 'reftex-toc-redo) - (local-set-key "R" 'reftex-toc-Redo) - (local-set-key "g" 'revert-buffer) - (local-set-key "q" 'reftex-toc-quit) - (local-set-key "Q" 'reftex-toc-quit-and-kill) - (local-set-key "f" 'reftex-toc-toggle-follow) - (local-set-key "x" 'reftex-toc-external) - (local-set-key [(mouse-2)] 'reftex-toc-mouse-goto-line-and-hide); Emacs - (local-set-key [(button2)] 'reftex-toc-mouse-goto-line-and-hide); XEmacs - (make-local-variable 'revert-buffer-function) - (setq revert-buffer-function 'reftex-toc-redo) - (setq truncate-lines t) - (make-local-hook 'post-command-hook) - (make-local-hook 'pre-command-hook) - (setq post-command-hook '(reftex-toc-post-command-hook)) - (setq pre-command-hook '(reftex-toc-pre-command-hook)) - - (insert (format -"TABLE-OF-CONTENTS on %s -SPC=view TAB=goto RET=goto+hide [q]uit [r]escan [f]ollow-mode e[x]tern [?]Help -------------------------------------------------------------------------------- -" (abbreviate-file-name reftex-last-toc-master))) - (setq startpos (point)) - - (if (reftex-use-fonts) - (put-text-property 1 (point) 'face 'font-lock-keyword-face)) - (put-text-property 1 (point) 'intangible t) - (put-text-property 1 2 'xr-alist xr-alist) - - (while all - (setq cell (car all) - all (cdr all)) - (when (eq (car cell) 'toc) - (setq toc1 (concat (nth 2 cell) "\n")) - (put-text-property 0 (length toc1) 'toc cell toc1) - (insert toc1))) - - (backward-delete-char 1) - - (setq buffer-read-only t)) - (t - (goto-line 3) - (beginning-of-line) - (setq startpos (point)))) - - ;; Find the correct section - (goto-char (point-max)) - (beginning-of-line) - (while (and (> (point) startpos) - (not (eq (get-text-property (point) 'toc) where))) - (beginning-of-line 0)))) - -(defun reftex-nearest-section () - ;; Return (file . find) of nearest section command - (let* ((here-I-am (car (reftex-where-am-I)))) - (reftex-last-assoc-before-elt - 'toc here-I-am (symbol-value reftex-docstruct-symbol)))) - -(defun reftex-toc-pre-command-hook () - ;; used as pre command hook in *toc* buffer - (reftex-unhighlight 0) - (reftex-unhighlight 1)) - -(defun reftex-toc-post-command-hook () - ;; used in the post-command-hook for the *toc* buffer - (and (> (point) 1) - (save-excursion - (reftex-highlight 1 - (progn (beginning-of-line) (point)) - (progn (end-of-line) (point))))) - (cond - ((integerp reftex-toc-follow-mode) - ;; remove delayed action - (setq reftex-toc-follow-mode t)) - (reftex-toc-follow-mode - ;; show context in other window - (condition-case nil - (reftex-toc-visit-line) - (error (ding) t))))) - -(defun reftex-empty-toc-buffer () - (if (get-buffer "*toc*") - (save-excursion - (set-buffer "*toc*") - (setq buffer-read-only nil) - (erase-buffer)))) - -(defun reftex-re-enlarge () - (enlarge-window - (max 0 (- (or reftex-last-window-height (window-height)) - (window-height))))) - -(defun reftex-toc-show-help () - (interactive) - (with-output-to-temp-buffer "*RefTeX Help*" - (princ reftex-toc-help)) - ;; If follow mode is active, arrange to delay it one command - (if reftex-toc-follow-mode - (setq reftex-toc-follow-mode 1))) - -(defun reftex-toc-toggle-follow () - "Toggle toc-follow mode. -(It is not really a mode, just a flag)." - (interactive) - (setq reftex-toc-follow-mode (not reftex-toc-follow-mode))) -(defun reftex-toc-view-line () - "View document location in other window." - (interactive) - (reftex-toc-visit-line)) -(defun reftex-toc-goto-line-and-hide () - "Go to document location in other window. Hide the *toc* window." - (interactive) - (reftex-toc-visit-line 'hide)) -(defun reftex-toc-goto-line () - "Go to document location in other window. Hide the *toc* window." - (interactive) - (reftex-toc-visit-line t)) -(defun reftex-toc-mouse-goto-line-and-hide (ev) - "Go to document location in other window. Hide the *toc* window." - (interactive "e") - (mouse-set-point ev) - (reftex-toc-visit-line 'hide)) -(defun reftex-toc-quit () - "Hide the *toc* window and do not move point." - (interactive) - (or (one-window-p) (delete-window)) - (switch-to-buffer (marker-buffer reftex-toc-return-marker)) - (reftex-re-enlarge) - (goto-char (or (marker-position reftex-toc-return-marker) (point)))) -(defun reftex-toc-quit-and-kill () - "Kill the *toc* buffer." - (interactive) - (kill-buffer "*toc*") - (or (one-window-p) (delete-window)) - (switch-to-buffer (marker-buffer reftex-toc-return-marker)) - (reftex-re-enlarge) - (goto-char (marker-position reftex-toc-return-marker))) -(defun reftex-toc-redo (&rest ignore) - "Regenerate the *toc* buffer by reparsing file of last reftex-toc command." - (interactive) - (if reftex-enable-partial-scans - (let ((file (nth 3 (get-text-property (point) 'toc)))) - (if (not file) - (error "Don't know which file to rescan. Try `R'.") - (switch-to-buffer-other-window - (reftex-get-file-buffer-force file)) - (setq current-prefix-arg '(4)) - (reftex-toc))) - (reftex-toc-Redo)) - (reftex-kill-temporary-buffers)) -(defun reftex-toc-Redo (&rest ignore) - "Regenerate the *toc* buffer by reparsing the entire document." - (interactive) - (switch-to-buffer-other-window - (reftex-get-file-buffer-force reftex-last-toc-file)) - (setq current-prefix-arg '(16)) - (reftex-toc)) -(defun reftex-toc-external (&rest ignore) - "Switch to table of contents of an external document." - (interactive) - (let* ((xr-alist (get-text-property 1 'xr-alist)) - (xr-index (reftex-select-external-document - xr-alist 0))) - (switch-to-buffer-other-window (or (reftex-get-file-buffer-force - (cdr (nth xr-index xr-alist))) - (error "Cannot switch document"))) - (reftex-toc))) - -(defun reftex-toc-visit-line (&optional final) - ;; Visit the tex file corresponding to the toc entry on the current line. - ;; If FINAL is t, stay there - ;; If FINAL is 'hide, hide the *toc* window. - ;; Otherwise, move cursor back into *toc* window. - ;; This function is pretty clever about finding back a section heading, - ;; even if the buffer is not live, or things like outline, x-symbol etc. - ;; have been active. - - (let* ((toc (get-text-property (point) 'toc)) - (file (nth 3 toc)) - (marker (nth 4 toc)) - (level (nth 5 toc)) - (literal (nth 7 toc)) - (emergency-point (nth 8 toc)) - (toc-window (selected-window)) - show-window show-buffer match) - - (unless toc (error "Don't know which toc line to visit")) - - (setq match - (cond - ((and (markerp marker) (marker-buffer marker)) - ;; Buffer is still live and we have the marker. Should be easy. - (switch-to-buffer-other-window (marker-buffer marker)) - (goto-char (marker-position marker)) - (or (looking-at (regexp-quote literal)) - (looking-at (reftex-make-regexp-allow-for-ctrl-m literal)) - (looking-at (reftex-make-desparate-section-regexp literal)) - (looking-at (concat "\\\\" - (regexp-quote - (car (rassq level reftex-section-levels))) - "[[{]")))) - (t - ;; Marker is lost. Use the backup method. - (switch-to-buffer-other-window - (reftex-get-file-buffer-force file nil)) - (goto-char (or emergency-point (point-min))) - (or (looking-at (regexp-quote literal)) - (let ((pos (point))) - (re-search-backward "\\`\\|[\r\n][ \t]*[\r\n]" nil t) - (or (reftex-nearest-match (regexp-quote literal) pos) - (reftex-nearest-match - (reftex-make-regexp-allow-for-ctrl-m literal) pos) - (reftex-nearest-match - (reftex-make-desparate-section-regexp literal) pos))))) - )) - - (setq show-window (selected-window) - show-buffer (current-buffer)) - - (unless match - (select-window toc-window) - (error "Cannot find line")) - - (goto-char (match-beginning 0)) - (recenter 1) - (reftex-highlight 0 (match-beginning 0) (match-end 0) (current-buffer)) - - (select-window toc-window) - - ;; use the `final' parameter to decide what to do next - (cond - ((eq final t) - (reftex-unhighlight 0) - (select-window show-window)) - ((eq final 'hide) - (reftex-unhighlight 0) - (or (one-window-p) (delete-window)) - (switch-to-buffer show-buffer) - (reftex-re-enlarge)) - (t nil)))) - -;;; =========================================================================== -;;; -;;; BibTeX citations. - -;; Variables and constants - -;; Define variable to silence compiler warnings -(defvar reftex-found-list) -(defvar reftex-cite-format-builtin) - -;; The history list of regular expressions used for citations -(defvar reftex-cite-regexp-hist nil) - -;; Prompt and help string for citation selection -(defconst reftex-citation-prompt - "Select: [n]ext [p]revious [r]estrict [ ]full_entry [q]uit RET [?]Help+more") - -(defconst reftex-citation-help - "AVAILABLE KEYS IN MAKE CITATION MENU ---------------------------------------- - n / p Go to next/previous entry (Cursor motion works as well). - C-s / C-r Search forward/backward. Use repeated C-s/C-r as in isearch. - g / r Start over with new regexp / Restrict with additional regexp. - SPC Show full database entry in other window. - f Toggle follow mode: Other window will follow with full db entry. - q Quit without inserting \\cite macro into buffer. - e Recursive edit into other window. - RET / a Accept current entry / Accept all entries.") - -;; Find bibtex files - -(defun reftex-get-bibfile-list () - ;; Return list of bibfiles for current document. - ;; When using the chapterbib or bibunits package you should either - ;; use the same database files everywhere, or separate parts using - ;; different databases into different files (included into the mater file). - ;; Then this function will return the applicable database files. - - ;; Ensure access to scanning info - (reftex-access-scan-info) - (or - ;; Try inside this file (and its includes) - (cdr (reftex-last-assoc-before-elt - 'bib (list 'eof (buffer-file-name)) - (member (list 'bof (buffer-file-name)) - (symbol-value reftex-docstruct-symbol)))) - ;; Try after the beginning of this file - (cdr (assq 'bib (member (list 'bof (buffer-file-name)) - (symbol-value reftex-docstruct-symbol)))) - ;; Anywhere in the entire document - (cdr (assq 'bib (symbol-value reftex-docstruct-symbol))) - (error "\\bibliography statment missing or .bib files not found."))) - -(defun reftex-find-tex-file (file master-dir &optional die) - ;; Find FILE in MASTER-DIR or on reftex-tex-path. - ;; FILE may be given without the .tex extension. - (reftex-access-search-path "tex") - (let* ((path (cons master-dir reftex-tex-path)) - file1) - (setq file1 - (or (reftex-find-file-on-path (concat file ".tex") path) - (reftex-find-file-on-path file path))) - (unless file1 - (reftex-access-search-path "tex" t file) - (setq path (cons master-dir reftex-tex-path)) - (setq file1 - (or (reftex-find-file-on-path (concat file ".tex") path) - (reftex-find-file-on-path file path)))) - (cond (file1 file1) - (die (error "No such file: %s" file) nil) - (t (message "No such file: %s (ignored)" file) nil)))) - -(defun reftex-find-bib-file (file master-dir &optional die) - ;; Find FILE in MASTER-DIR or on reftex-bib-path - (reftex-access-search-path "bib") - (let ((file1 (reftex-find-file-on-path - file (cons master-dir reftex-bib-path)))) - (unless file1 - (reftex-access-search-path "bib" t file) - (setq file1 (reftex-find-file-on-path - file (cons master-dir reftex-bib-path)))) - (cond (file1 file1) - (die (error "No such file: %s" file) nil) - (t (message "No such file: %s (ignored)" file) nil)))) - -;; Find a certain reference in any of the BibTeX files. - -(defun reftex-pop-to-bibtex-entry (key file-list - &optional mark-to-kill highlight) - ;; Find BibTeX KEY in any file in FILE-LIST in another window. - ;; If mark-to-kill is non-nil, mark new buffer to kill." - - (let* ((re (concat "@[a-zA-Z]+[ \t\n\r]*[{(][ \t\n\r]*" (regexp-quote key) "[ \t\n\r,]")) - (window-conf (current-window-configuration)) - file buf) - (catch 'exit - (switch-to-buffer-other-window (current-buffer)) - (while file-list - (setq file (car file-list) - file-list (cdr file-list)) - (unless (setq buf (reftex-get-file-buffer-force file mark-to-kill)) - (error "No such file %s" file)) - (switch-to-buffer buf) - (widen) - (goto-char (point-min)) - (when (re-search-forward re nil t) - (goto-char (match-beginning 0)) - (recenter 0) - (if highlight - (reftex-highlight 0 (match-beginning 0) (match-end 0))) - (throw 'exit (selected-window)))) - (set-window-configuration window-conf) - (beep) - (message "No BibTeX entry with citation key %s" key)))) - -;; Parse bibtex buffers - -(defun reftex-extract-bib-entries (buffers &optional get-word) - ;; Extract bib entries which match regexps from BUFFERS. - ;; BUFFERS is a list of buffers or file names. - ;; Return list with entries." - (let* (re-list first-re rest-re - (buffer-list (if (listp buffers) buffers (list buffers))) - found-list entry buffer1 buffer alist - key-point start-point end-point) - - (setq re-list (split-string - (read-string "RegExp [ && RegExp...]: " - nil 'reftex-cite-regexp-hist) - "[ \t]*&&[ \t]*")) - - (setq first-re (car re-list) ; We'll use the first re to find things, - rest-re (cdr re-list)) ; the other to narrow down. - (if (string-match "\\`[ \t]*\\'" first-re) - (error "Empty regular expression")) - - (save-excursion - (save-window-excursion - - ;; Walk through all bibtex files - (while buffer-list - (setq buffer (car buffer-list) - buffer-list (cdr buffer-list)) - (if (and (bufferp buffer) - (buffer-live-p buffer)) - (setq buffer1 buffer) - (setq buffer1 (reftex-get-file-buffer-force - buffer (not reftex-keep-temporary-buffers)))) - (if (not buffer1) - (error "Cannot find BibTeX file %s" buffer) - (message "Scanning bibliography database %s" buffer1)) - - (set-buffer buffer1) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward first-re nil t) - (catch 'search-again - (setq key-point (point)) - (unless (re-search-backward - "\\(\\`\\|[\n\r]\\)[ \t]*@\\([a-zA-Z]+\\)[ \t\n\r]*[{(]" nil t) - (throw 'search-again nil)) - (setq start-point (point)) - (goto-char (match-end 0)) - (condition-case nil - (up-list 1) - (error (goto-char key-point) - (throw 'search-again nil))) - (setq end-point (point)) - - ;; Ignore @string, @comment and @c entries or things - ;; outside entries - (when (or (string= (downcase (match-string 2)) "string") - (string= (downcase (match-string 2)) "comment") - (string= (downcase (match-string 2)) "c") - (< (point) key-point)) ; this means match not in {} - (goto-char key-point) - (throw 'search-again nil)) - - ;; Well, we have got a match - (setq entry (concat - (buffer-substring start-point (point)) "\n")) - - ;; Check if other regexp match as well - (setq re-list rest-re) - (while re-list - (unless (string-match (car re-list) entry) - ;; nope - move on - (throw 'search-again nil)) - (pop re-list)) - - (setq alist (reftex-parse-bibtex-entry - nil start-point end-point)) - (push (cons "&entry" entry) alist) - - ;; check for crossref entries - (if (assoc "crossref" alist) - (setq alist - (append - alist (reftex-get-crossref-alist alist)))) - - ;; format the entry - (push (cons "&formatted" (reftex-format-bib-entry alist)) - alist) - - ;; add it to the list - (push alist found-list)))) - (reftex-kill-temporary-buffers)))) - (setq found-list (nreverse found-list)) - - ;; Sorting - (cond - ((eq 'author reftex-sort-bibtex-matches) - (sort found-list 'reftex-bib-sort-author)) - ((eq 'year reftex-sort-bibtex-matches) - (sort found-list 'reftex-bib-sort-year)) - ((eq 'reverse-year reftex-sort-bibtex-matches) - (sort found-list 'reftex-bib-sort-year-reverse)) - (t found-list)))) - -(defun reftex-bib-sort-author (e1 e2) - (let ((al1 (reftex-get-bib-names "author" e1)) - (al2 (reftex-get-bib-names "author" e2))) - (while (and al1 al2 (string= (car al1) (car al2))) - (pop al1) - (pop al2)) - (if (and (stringp (car al1)) - (stringp (car al2))) - (string< (car al1) (car al2)) - (not (stringp (car al1)))))) - -(defun reftex-bib-sort-year (e1 e2) - (< (string-to-int (cdr (assoc "year" e1))) - (string-to-int (cdr (assoc "year" e2))))) - -(defun reftex-bib-sort-year-reverse (e1 e2) - (> (string-to-int (or (cdr (assoc "year" e1)) "0")) - (string-to-int (or (cdr (assoc "year" e2)) "0")))) - -(defun reftex-get-crossref-alist (entry) - ;; return the alist from a crossref entry - (let ((crkey (cdr (assoc "crossref" entry))) - start) - (save-excursion - (save-restriction - (widen) - (if (re-search-forward - (concat "@\\w+[{(][ \t\n\r]*" (regexp-quote crkey) - "[ \t\n\r]*,") nil t) - (progn - (setq start (match-beginning 0)) - (condition-case nil - (up-list 1) - (error nil)) - (reftex-parse-bibtex-entry nil start (point))) - nil))))) - -;; Parse and format individual entries - -(defun reftex-get-bib-names (field entry) - ;; Return a list with the author or editor anmes in ENTRY - (let ((names (reftex-get-bib-field field entry))) - (if (equal "" names) - (setq names (reftex-get-bib-field "editor" entry))) - (while (string-match "\\band\\b[ \t]*" names) - (setq names (replace-match "\n" nil t names))) - (while (string-match "[\\.a-zA-Z\\-]+\\.[ \t]*\\|,.*\\|[{}]+" names) - (setq names (replace-match "" nil t names))) - (while (string-match "^[ \t]+\\|[ \t]+$" names) - (setq names (replace-match "" nil t names))) - (while (string-match "[ \t][ \t]+" names) - (setq names (replace-match " " nil t names))) - (split-string names "\n"))) - -(defun reftex-parse-bibtex-entry (entry &optional from to) - (let (alist key start field) - (save-excursion - (save-restriction - (if entry - (progn - (switch-to-buffer "*RefTeX-scratch*") - (fundamental-mode) - (erase-buffer) - (insert entry)) - (widen) - (narrow-to-region from to)) - (goto-char (point-min)) - - (if (re-search-forward - "@\\(\\w+\\)[ \t\n\r]*[{(][ \t\n\r]*\\([^ \t\n\r,]+\\)" nil t) - (setq alist - (list - (cons "&type" (downcase (reftex-match-string 1))) - (cons "&key" (reftex-match-string 2))))) - (while (re-search-forward "\\(\\w+\\)[ \t\n\r]*=[ \t\n\r]*" nil t) - (setq key (downcase (reftex-match-string 1))) - (cond - ((= (following-char) ?{) - (forward-char 1) - (setq start (point)) - (condition-case nil - (up-list 1) - (error nil))) - ((= (following-char) ?\") - (forward-char 1) - (setq start (point)) - (while (and (search-forward "\"" nil t) - (= ?\\ (char-after (- (point) 2)))))) - (t - (setq start (point)) - (re-search-forward "[ \t\n\r,}]" nil 1))) - (setq field (buffer-substring-no-properties start (1- (point)))) - ;; remove extra whitesp - (while (string-match "[\n\t\r]\\|[ \t][ \t]+" field) - (setq field (replace-match " " nil t field))) - ;; remove leading garbage - (if (string-match "^[ \t{]+" field) - (setq field (replace-match "" nil t field))) - ;; remove trailing garbage - (if (string-match "[ \t}]+$" field) - (setq field (replace-match "" nil t field))) - (push (cons key field) alist)))) - alist)) - -(defun reftex-get-bib-field (fieldname entry) - ;; Extract the field FIELDNAME from an ENTRY - (or (cdr (assoc fieldname entry)) - "")) - -(defun reftex-format-bib-entry (entry) - ;; Format a BibTeX ENTRY so that it is nice to look at - (let* - ((auth-list (reftex-get-bib-names "author" entry)) - (authors (mapconcat '(lambda (x) x) auth-list ", ")) - (year (reftex-get-bib-field "year" entry)) - (title (reftex-get-bib-field "title" entry)) - (type (reftex-get-bib-field "&type" entry)) - (key (reftex-get-bib-field "&key" entry)) - (extra - (cond - ((equal type "article") - (concat (reftex-get-bib-field "journal" entry) " " - (reftex-get-bib-field "volume" entry) ", " - (reftex-get-bib-field "pages" entry))) - ((equal type "book") - (concat "book (" (reftex-get-bib-field "publisher" entry) ")")) - ((equal type "phdthesis") - (concat "PhD: " (reftex-get-bib-field "school" entry))) - ((equal type "mastersthesis") - (concat "Master: " (reftex-get-bib-field "school" entry))) - ((equal type "inbook") - (concat "Chap: " (reftex-get-bib-field "chapter" entry) - ", pp. " (reftex-get-bib-field "pages" entry))) - ((or (equal type "conference") - (equal type "incollection") - (equal type "inproceedings")) - (concat "in: " (reftex-get-bib-field "booktitle" entry))) - (t "")))) - (setq authors (reftex-truncate authors 30 t t)) - (when (reftex-use-fonts) - (put-text-property 0 (length authors) 'face 'font-lock-keyword-face - authors) - (put-text-property 0 (length title) 'face 'font-lock-comment-face - title) - (put-text-property 0 (length extra) 'face 'font-lock-reference-face - extra)) - (concat key "\n " authors " " year " " extra "\n " title "\n\n"))) - -;; Make a citation - -(defun reftex-citation (&optional no-insert) - "Make a citation using BibTeX database files. -After asking for a Regular Expression, it scans the buffers with -bibtex entries (taken from the \\bibliography command) and offers the -matching entries for selection. The selected entry is formated according -to `reftex-cite-format' and inserted into the buffer. -If NO-INSERT is non-nil, nothing is inserted, only the selected key returned. -The regular expression uses an expanded syntax: && is interpreted as `and'. -Thus, `aaaa&&bbb' matches entries which contain both `aaaa' and `bbb'. -When this function is called with point inside the braces of a \\cite -command, it will add another key, ignoring the value of `reftex-cite-format'. -When called with a numeric prefix, that many citations will be made and all -put into the same \\cite command. -When called with just C-u as prefix, enforces rescan of buffer for -bibliography statement (e.g. if it was changed)." - - (interactive) - - ;; check for recursive edit - (reftex-check-recursive-edit) - - ;; if there is just 1 C-u prefix arg, force to rescan buffer - (reftex-access-scan-info current-prefix-arg) - - ;; Call reftex-do-citation, but protected - (unwind-protect - (reftex-do-citation current-prefix-arg no-insert) - (reftex-kill-temporary-buffers))) - -(defun reftex-do-citation (&optional arg no-insert) - ;; This really does the work of reftex-citation. - - ;; Check if there is already a cite command at point and change cite format - ;; in order to only add another reference in the same cite command. - (let (key format (macro (car (car (reftex-what-macro t))))) - (if (and (stringp macro) - (string-match "\\`\\\\cite\\|cite\\'" macro)) - (progn - (cond - ((or (not arg) - (not (listp arg))) - (setq format - (concat - (if (not (or (= (preceding-char) ?{) - (= (preceding-char) ?,))) - "," - "") - "%l" - (if (not (or (= (following-char) ?}) - (= (following-char) ?,))) - "," - "")))) - (t - (setq format "%l")))) - ;; else: figure out the correct format - (setq format - (cond - ((stringp reftex-cite-format) reftex-cite-format) - ((and (symbolp reftex-cite-format) - (assq reftex-cite-format reftex-cite-format-builtin)) - (nth 2 (assq reftex-cite-format reftex-cite-format-builtin))) - (t reftex-cite-format))) - (if (listp format) - (save-window-excursion - (with-output-to-temp-buffer "*RefTeX Select*" - (princ "SELECT A CITATION FORMAT\n\n") - (princ - (mapconcat - (function (lambda (x) - (format "[%c] %s %s" (car x) - (if (> (car x) 31) " " "") - (cdr x)))) - format "\n"))) - (setq key (read-char)) - (if (assq key format) - (setq format (cdr (assq key format))) - (error "No citation format associated with key `%c'" key))))) - - (let* (entry cnt rtn ins-string re-list re - ;; scan bibtex files - (reftex-found-list (reftex-extract-bib-entries - (reftex-get-bibfile-list))) - (found-list-r nil)) - (unless reftex-found-list - (error "Sorry, no matches found")) - - ;; remember where we came from - (setq reftex-call-back-to-this-buffer (current-buffer)) - - ;; offer selection - (save-window-excursion - (switch-to-buffer-other-window "*RefTeX Select*") - (erase-buffer) - (reftex-insert-bib-matches reftex-found-list) - (if (= 0 (buffer-size)) - (error "Sorry, no matches found")) - (setq truncate-lines t) - (goto-char 1) - (if (catch 'exit - (while t - (setq rtn - (reftex-select-item - reftex-citation-prompt - "^[^ \t\n\r]" - 4 - reftex-citation-help - '(?r ?a ?g ?\C-m) - nil - 'reftex-bibtex-selection-callback nil)) - (setq key (car rtn) - cnt (nth 1 rtn)) - (unless key (throw 'exit nil)) - (cond - ((eq key ?g) - (setq reftex-found-list - (save-excursion - (set-buffer reftex-call-back-to-this-buffer) - (reftex-extract-bib-entries - (reftex-get-bibfile-list)))) - (erase-buffer) - (reftex-insert-bib-matches reftex-found-list) - (if (= 0 (buffer-size)) - (error "Sorry, no matches found")) - (goto-char 1)) - - ((eq key ?r) - ;; restrict with new regular expression - (setq re-list - (split-string (read-string - "RegExp [ && RegExp...]: " - nil 'reftex-cite-regexp-hist) - "[ \t]*&&[ \t]*")) - (while re-list - (setq re (car re-list) - re-list (cdr re-list)) - (setq found-list-r - (delete "" - (mapcar - '(lambda (x) - (if (string-match - re (cdr (assoc "&entry" x))) - x - "")) - reftex-found-list)))) - (if found-list-r - (setq reftex-found-list found-list-r) - (ding)) - (erase-buffer) - (reftex-insert-bib-matches reftex-found-list) - (goto-char 1)) - ((eq key ?a) - (setq entry 'all) - (throw 'exit t)) - ((or (eq key ?\C-m) - (eq key 'return)) - (if cnt - (setq entry (nth cnt reftex-found-list)) - (setq entry nil)) - (throw 'exit t)) - (t - (ding))))) - (progn - ;; format the entry - (if (eq entry 'all) - (setq ins-string - (mapconcat - '(lambda (entry) - (reftex-format-citation entry format)) - reftex-found-list "\n")) - (setq ins-string (reftex-format-citation entry format)))) - (setq ins-string "") - (message "Quit"))) - (kill-buffer "*RefTeX Select*") - - (unless no-insert - (insert ins-string) - (when (string-match "\\?" ins-string) - (search-backward "?") - (delete-char 1))) - (message "") - - ;; Check if the prefix arg was numeric, and call recursively - (when (and (integerp arg) - (> arg 1) - (re-search-backward - "\\\\\\([a-zA-Z]*cite\\|cite[a-zA-Z]*\\)\\**\\(\\[[^]]*\\]\\)*{\\([^}]*\\)" nil t)) - (goto-char (match-end 0)) - (decf arg) - (reftex-do-citation arg)) - - ;; Return the citation key - (or (eq entry 'all) - (reftex-get-bib-field "&key" entry))))) - -(defun reftex-insert-bib-matches (list) - ;; Insert the bib matches and number them correctly - (let ((cnt -1) tmp) - (mapcar '(lambda (x) - (setq tmp (cdr (assoc "&formatted" x))) - (incf cnt) - (put-text-property 0 (length tmp) 'cnt cnt tmp) - (insert tmp)) - list))) - -(defun reftex-format-names (namelist n) - (interactive) - (let (last (len (length namelist))) - (cond - ((= 1 len) (car namelist)) - ((> len n) (concat (car namelist) (nth 2 reftex-cite-punctuation))) - (t - (setq n (min len n) - last (nth (1- n) namelist)) - (setcdr (nthcdr (- n 2) namelist) nil) - (concat - (mapconcat 'identity namelist (nth 0 reftex-cite-punctuation)) - (nth 1 reftex-cite-punctuation) - last))))) - -(defun reftex-format-citation (entry format) - ;; Format a citation from the info in the BibTeX ENTRY - - (unless (stringp format) (setq format "\\cite{%l}")) - - (if (and reftex-comment-citations - (string-match "%l" reftex-cite-comment-format)) - (error "reftex-cite-comment-format contains illeagal %%l")) - - (while (string-match - "\\(\\`\\|[^%]\\)\\(\\(%\\([0-9]*\\)\\([a-zA-Z]\\)\\)[.,;: ]*\\)" - format) - (let ((n (string-to-int (match-string 4 format))) - (l (string-to-char (match-string 5 format))) - rpl b e) - (save-match-data - (setq rpl - (cond - ((= l ?l) (concat - (reftex-get-bib-field "&key" entry) - (if reftex-comment-citations - reftex-cite-comment-format - ""))) - ((= l ?a) (reftex-format-names - (reftex-get-bib-names "author" entry) - (or n 2))) - ((= l ?A) (car (reftex-get-bib-names "author" entry))) - ((= l ?b) (reftex-get-bib-field "booktitle" entry)) - ((= l ?c) (reftex-get-bib-field "chapter" entry)) - ((= l ?d) (reftex-get-bib-field "edition" entry)) - ((= l ?e) (reftex-format-names - (reftex-get-bib-names "editor" entry) - (or n 2))) - ((= l ?E) (car (reftex-get-bib-names "editor" entry))) - ((= l ?h) (reftex-get-bib-field "howpublished" entry)) - ((= l ?i) (reftex-get-bib-field "institution" entry)) - ((= l ?j) (reftex-get-bib-field "journal" entry)) - ((= l ?k) (reftex-get-bib-field "key" entry)) - ((= l ?m) (reftex-get-bib-field "month" entry)) - ((= l ?n) (reftex-get-bib-field "number" entry)) - ((= l ?o) (reftex-get-bib-field "organization" entry)) - ((= l ?p) (reftex-get-bib-field "pages" entry)) - ((= l ?P) (car (split-string - (reftex-get-bib-field "pages" entry) - "[- .]+"))) - ((= l ?s) (reftex-get-bib-field "school" entry)) - ((= l ?u) (reftex-get-bib-field "publisher" entry)) - ((= l ?r) (reftex-get-bib-field "address" entry)) - ((= l ?t) (reftex-get-bib-field "title" entry)) - ((= l ?v) (reftex-get-bib-field "volume" entry)) - ((= l ?y) (reftex-get-bib-field "year" entry))))) - - (if (string= rpl "") - (setq b (match-beginning 2) e (match-end 2)) - (setq b (match-beginning 3) e (match-end 3))) - (setq format (concat (substring format 0 b) rpl (substring format e))))) - (while (string-match "%%" format) - (setq format (replace-match "%" t t format))) - (while (string-match "[ ,.;:]*%<" format) - (setq format (replace-match "" t t format))) - format) - -;; This is slow and not recommended for follow mode -(defun reftex-bibtex-selection-callback (cnt) - ;; Callback function to be called from the BibTeX selection, in - ;; order to display context. This function is relatively slow and not - ;; recommended for follow mode, just for individual lookups. - (let ((win (selected-window)) - (key (reftex-get-bib-field "&key" (nth cnt reftex-found-list))) - (bibfile-list (save-excursion - (set-buffer reftex-call-back-to-this-buffer) - (reftex-get-bibfile-list)))) - (reftex-pop-to-bibtex-entry key bibfile-list - (not reftex-keep-temporary-buffers) t) - (select-window win))) - -;;; =========================================================================== -;;; -;;; Here is the routine used for selection - -;; Marker for return point from recursive edit -(defvar reftex-recursive-edit-marker (make-marker)) - -(defun reftex-check-recursive-edit () - ;; Check if we are already in a recursive edit. Abort with helpful - ;; message if so. - (if (marker-position reftex-recursive-edit-marker) - (error - (substitute-command-keys - "In unfinished recursive edit. Finish (\\[exit-recursive-edit]) or abort (\\[abort-recursive-edit]).")))) - -(defun reftex-select-item (prompt next-re size help-string - event-list &optional offset - call-back cb-flag match-everywhere) -;; Select an item. Show PROMPT to user, find next item with NEXT-RE -;; regular expression, return on any of the events listed in -;; EVENT-LIST. The function returns the event along with an integer -;; indicating which item was selected. When OFFSET is specified, -;; starts at that item in the list. When CALL-BACK is given, it is a -;; function which is called with the index of the element. - - (let* (key key-sq b e ev cnt last-cnt cmd skip-callback - (search-str "") tmp search-start matched forward mini-map last-key - (offset1 (or offset 1)) win1 win2) - - ;; Set up a minibuffer keymap for the search stuff - (setq mini-map (copy-keymap minibuffer-local-map)) - (define-key mini-map "\C-s" - '(lambda () (interactive) (setq forward t) (exit-minibuffer))) - (define-key mini-map "\C-r" - '(lambda () (interactive) (setq forward nil) (exit-minibuffer))) - (define-key mini-map "\C-m" 'exit-minibuffer) - - (setq ev - (catch 'exit - (save-window-excursion - (setq truncate-lines t) - (goto-char 1) - (unless (re-search-forward next-re nil t offset1) - ;; in case the offset is illegal - (setq offset1 1) - (re-search-forward next-re nil t offset1)) - (beginning-of-line 1) - (while t - (setq last-cnt (or cnt last-cnt)) - (setq cnt (get-text-property (point) 'cnt)) - (if (and cnt cb-flag call-back (not skip-callback)) - (funcall call-back cnt)) - (setq skip-callback nil) - (if cnt - (setq b (or (previous-single-property-change - (1+ (point)) 'cnt) - (point-min)) - e (or (next-single-property-change - (point) 'cnt) - (point-max))) - (setq b (point) e (point))) - (reftex-highlight 1 b e) - (if (or (not (pos-visible-in-window-p b)) - (not (pos-visible-in-window-p e))) - (recenter (/ (window-height) 2))) - (setq key-sq (read-key-sequence prompt)) - (setq last-key key) - (setq key (car - (cond - ((fboundp 'event-to-character) ; XEmacs - (mapcar 'event-to-character key-sq)) - ((fboundp 'listify-key-sequence) ; Emacs - (listify-key-sequence key-sq)) - (t (error "Please report this problem to dominik@strw.leidenuniv.nl"))))) - - (setq cmd (key-binding key-sq)) - - (reftex-unhighlight 2) - (reftex-unhighlight 0) - - (cond - - ;; Single line motions - ((or (eq key ?n) - (eq key ?\C-i) - (eq cmd 'next-line)) - (or (eobp) (forward-char 1)) - (re-search-forward next-re nil t 1) - (beginning-of-line 1)) - ((or (eq key ?p) - (eq cmd 'previous-line)) - (re-search-backward next-re nil t)) - - ;; Page motions - ((eq cmd 'scroll-up) - (while (and (pos-visible-in-window-p) - (re-search-forward next-re nil t))) - (beginning-of-line 1) - (recenter 1)) - ((eq cmd 'scroll-down) - (while (and (pos-visible-in-window-p) - (re-search-backward next-re nil t))) - (recenter (- (window-height) size 2))) - - ;; Begin and end of buffer - ((eq cmd 'beginning-of-buffer) - (goto-char (point-min)) - (re-search-forward next-re nil t) - (beginning-of-line 1)) - ((eq cmd 'end-of-buffer) - (goto-char (point-max)) - (re-search-backward next-re nil t)) - - ;; Exit - ((eq key ?q) - (throw 'exit nil)) - ((eq key ?\C-g) - (if (or (eq last-key ?\C-s) (eq last-key ?\C-r)) - (ding) - (bury-buffer) - (error "Abort"))) - ((or (eq key ?\C-m) - (eq key 'return) - (eq cmd 'newline)) - (throw 'exit 'return)) - ((memq key event-list) - (throw 'exit key)) - - ;; Callback - ((or (eq key ?C) ; backward compatibility - (eq key ?f)) - (setq cb-flag (not cb-flag))) - ((eq key ?\ ) - (if cnt (funcall call-back cnt) (ding))) - - ;; Help - ((eq key ?\?) - (with-output-to-temp-buffer "*RefTeX Help*" - (princ help-string)) - (setq win1 (selected-window) - win2 (get-buffer-window "*RefTeX Help*" t)) - (select-window win2) - (unless (and (pos-visible-in-window-p 1) - (pos-visible-in-window-p (point-max))) - (enlarge-window (1+ (- (count-lines 1 (point-max)) - (window-height))))) - (select-window win1) - (setq skip-callback t)) - - ;; Searching - ((or (setq forward (eq key ?\C-s)) (eq key ?\C-r)) - (if (or (and (not (eq last-key ?\C-s)) - (not (eq last-key ?\C-r))) - (string= search-str "")) - (setq tmp ; get a new string - (read-from-minibuffer - (if (string= search-str "") - "Search: " - (format "Search [%s]:" search-str)) - nil mini-map) - search-str (if (string= tmp "") - search-str tmp))) - (setq search-start (point)) - (and (not (string= search-str "")) - (progn - (while - (and (setq matched - (if forward - (search-forward search-str nil 1) - (search-backward search-str nil 1))) - (or (>= (save-excursion - (goto-char (match-beginning 0)) - (current-column)) - (window-width)) - (not (or (get-text-property (point) 'cnt) - match-everywhere))))) - (if matched - (reftex-highlight 2 (match-beginning 0) - (match-end 0)) - (ding) - (goto-char search-start))))) - - ;; Recursive edit - ((eq key ?e) - (set-marker reftex-recursive-edit-marker (point)) - (unwind-protect - (progn - (save-window-excursion - (save-excursion - (other-window 1) - (message - (substitute-command-keys - "Recursive edit. Return to selection with \\[exit-recursive-edit]")) - (recursive-edit))) - (unless (equal (marker-buffer - reftex-recursive-edit-marker) - (current-buffer)) - (error "Cannot continue RefTeX from this buffer.")) - (goto-char reftex-recursive-edit-marker)) - (set-marker reftex-recursive-edit-marker nil))) - - (t - (ding))))))) - (and (get-buffer "*RefTeX Help*") (kill-buffer "*RefTeX Help*")) - (message "") - (list ev cnt last-cnt))) - -;;; =========================================================================== -;;; -;;; View cross references - -(defun reftex-view-crossref (&optional arg) - "View cross reference of \\ref or \\cite macro at point. -If the macro at point is a \\ref, show the corresponding label definition. -If it is a \\cite, show the BibTeX database entry. -If there is no such macro at point, search forward to find one. -When you call this function several times in direct successtion, point will -move to view subsequent cross references further down in the buffer. -To cope with the plethora of variations in packages, this function -assumes any macro either starting with ending in `ref' or `cite' to contain -cross references. -With argument, actually select the window showing the cross reference." - - (interactive "P") - - ;; See where we are. - (let* ((re "\\\\\\([a-z]*\\(cite\\|ref\\)\\|\\(cite\\|ref\\)[a-z]*\\)\\**\\(\\[[^{}]*\\]\\)?{") - (macro (car (car (reftex-what-macro t)))) - (this-word (reftex-this-word "*a-zA-Z\\\\")) - (my-window (selected-window)) - pop-window cmd args point) - - (if (and macro - (string-match "\\`\\\\cite\\|\\`\\\\ref\\|cite\\'\\|ref\\'" - macro)) - (and (setq macro (match-string 0 macro)) - (string-match "\\`\\\\" macro) - (setq macro (substring macro 1))) - (setq macro nil)) - - (if (and macro (eq last-command this-command)) - (if (string= macro "cite") - (progn - (skip-chars-forward "^},%") - (while (and (eq (following-char) ?%) - (or (beginning-of-line 2) t) - (skip-chars-forward " \t\n\r"))) - (skip-chars-forward ",") - (if (eq (following-char) ?}) - (setq macro nil))) - (setq macro nil))) - - (if (and (not macro) - (or (not (string-match "\\`\\\\" this-word)) - (eq (following-char) ?\\) - (search-backward "\\" nil t) - t)) - (if (interactive-p) - ;; Only move far if this function was called directly - (and (re-search-forward re nil t) - (setq macro (or (match-string 2) (match-string 3)))) - ;; The macro needs to be at point - (and (looking-at re) - (setq macro (or (match-string 2) (match-string 3))) - (goto-char (match-end 0))))) - - - (unless macro - (error "No cross reference to display")) - - ;; Ensure access to scanning info - (reftex-access-scan-info) - - (cond - ((string= macro "cite") - (setq cmd 'reftex-pop-to-bibtex-entry - args (list - (reftex-this-word "^{},%\n\r") - (reftex-get-bibfile-list) nil t))) - ((string= macro "ref") - (let* ((label (reftex-this-word "^{}%\n\r")) - (xr-data (assoc 'xr (symbol-value reftex-docstruct-symbol))) - (xr-re (nth 2 xr-data)) - (entry (assoc label (symbol-value reftex-docstruct-symbol)))) - (if (and (not entry) (string-match xr-re label)) - ;; Label is defined in external document - (save-excursion - (save-match-data - (set-buffer - (or (reftex-get-file-buffer-force - (cdr (assoc (match-string 1 label) (nth 1 xr-data)))) - (error "Problem with external label %s" label)))) - (setq label (substring label (match-end 1))) - (reftex-access-scan-info) - (setq entry - (assoc label (symbol-value reftex-docstruct-symbol))))) - (if entry - (setq cmd 'reftex-pop-to-label - args (list label (list (nth 3 entry)) nil t)) - (error "Label %s not known - reparse document might help" label)))) - (t (error "This should not happen (reftex-view-crossref)"))) - (setq point (point)) - (apply cmd args) - (setq pop-window (selected-window)) - (add-hook 'pre-command-hook 'reftex-highlight-shall-die) - (select-window my-window) - (goto-char point) - (and arg (select-window pop-window)))) - -(defun reftex-mouse-view-crossref (ev) - "View cross reference of \\ref or \\cite macro where you click. -If the macro at point is a \\ref, show the corresponding label definition. -If it is a \\cite, show the BibTeX database entry. -If there is no such macro at point, search forward to find one. -With argument, actually select the window showing the cross reference." - (interactive "e") - (mouse-set-point ev) - (setq last-command 'self-insert-command) ;; make sure we do not move! - (reftex-view-crossref current-prefix-arg)) - -;;; =========================================================================== -;;; -;;; Functions that check out the surroundings - -(defun reftex-what-macro (which &optional bound) - ;; Find out if point is within the arguments of any TeX-macro. - ;; The return value is either ("\\macro" . (point)) or a list of them. - - ;; If WHICH is nil, immediately return nil. - ;; If WHICH is t, return list of all macros enclosing point. - ;; If WHICH is a list of macros, look only for those macros and return the - ;; name of the first macro in this list found to enclose point. - ;; If the optional BOUND is an integer, bound backwards directed - ;; searches to this point. If it is nil, limit to nearest \section - - ;; like statement. - - ;; This function is pretty stable, but can be fooled if the text contains - ;; things like \macro{aa}{bb} where \macro is defined to take only one - ;; argument. As RefTeX cannot know this, the string "bb" would still be - ;; considered an argument of macro \macro. - - (catch 'exit - (if (null which) (throw 'exit nil)) - (let ((bound (or bound (save-excursion (re-search-backward - reftex-section-regexp nil 1) - (point)))) - pos cmd-list cmd cnt cnt-opt entry) - (save-restriction - (save-excursion - (narrow-to-region (max 1 bound) (point-max)) - ;; move back out of the current parenthesis - (while (condition-case nil - (progn (up-list -1) t) - (error nil)) - (setq cnt 1 cnt-opt 0) - ;; move back over any touching sexps - (while (and (reftex-move-to-previous-arg bound) - (condition-case nil - (progn (backward-sexp) t) - (error nil))) - (if (eq (following-char) ?\[) (incf cnt-opt)) - (incf cnt)) - (setq pos (point)) - (when (and (or (= (following-char) ?\[) - (= (following-char) ?\{)) - (re-search-backward "\\\\[*a-zA-Z]+\\=" nil t)) - (setq cmd (reftex-match-string 0)) - (when (looking-at "\\\\begin{[^}]*}") - (setq cmd (reftex-match-string 0) - cnt (1- cnt))) - ;; This does ignore optional arguments. Very hard to fix. - (when (setq entry (assoc cmd reftex-env-or-mac-alist)) - (if (> cnt (or (nth 4 entry) 100)) - (setq cmd nil))) - (cond - ((null cmd)) - ((eq t which) - (push (cons cmd (point)) cmd-list)) - ((member cmd which) - (throw 'exit (cons cmd (point)))))) - (goto-char pos))) - (nreverse cmd-list))))) - -(defun reftex-what-environment (which &optional bound) - ;; Find out if point is inside a LaTeX environment. - ;; The return value is (e.g.) either ("equation" . (point)) or a list of - ;; them. - - ;; If WHICH is nil, immediately return nil. - ;; If WHICH is t, return list of all environments enclosing point. - ;; If WHICH is a list of environments, look only for those environments and - ;; return the name of the first environment in this list found to enclose - ;; point. - - ;; If the optional BOUND is an integer, bound backwards directed searches to - ;; this point. If it is nil, limit to nearest \section - like statement. - - (catch 'exit - (save-excursion - (if (null which) (throw 'exit nil)) - (let ((bound (or bound (save-excursion (re-search-backward - reftex-section-regexp nil 1) - (point)))) - env-list end-list env) - (while (re-search-backward "\\\\\\(begin\\|end\\){\\([^}]+\\)}" - bound t) - (setq env (buffer-substring-no-properties - (match-beginning 2) (match-end 2))) - (cond - ((string= (match-string 1) "end") - (add-to-list 'end-list env)) - ((member env end-list) - (setq end-list (delete env end-list))) - ((eq t which) - (push (cons env (point)) env-list)) - ((member env which) - (throw 'exit (cons env (point)))))) - (nreverse env-list))))) - -(defun reftex-word-before-point () - ;; Return the word before point. Word means here: - ;; Consists of [a-zA-Z0-9.:] and ends at point or whitespace. - (let ((pos (point))) - (save-excursion - (re-search-backward "[^ \t\n\r]" (point-min) 1) - (setq pos (min (1+ (point)) (point-max))) - (if (re-search-backward "[^a-zA-Z0-9\\\.:]" (point-min) 1) - (forward-char 1)) - (buffer-substring-no-properties (point) pos)))) - -;; ============================================================================ -;; -;; Some generally useful functions - -(defun reftex-no-props (string) - ;; Return STRING with all text properties removed - (and (stringp string) - (set-text-properties 0 (length string) nil string)) - string) - -(defun reftex-match-string (n) - ;; Match string without properties - (when (match-beginning n) - (buffer-substring-no-properties (match-beginning n) (match-end n)))) - -(defun reftex-this-word (&optional class) - ;; Grab the word around point. - (setq class (or class "-a-zA-Z0-9:_/.*;|")) - (save-excursion - (buffer-substring-no-properties - (progn (skip-chars-backward class) (point)) - (progn (skip-chars-forward class) (point))))) - -(defvar enable-multibyte-characters) -(defun reftex-truncate (string ncols &optional ellipses padding) - ;; Truncate a string to NCHAR characters. - ;; Works fast with ASCII and correctly with Mule characters. - ;; When ELLIPSES is non-nil, put three dots at the end of the string. - (setq string - (cond - ((and (boundp 'enable-multibyte-characters) - enable-multibyte-characters) - (if (<= (string-width string) ncols) - string - (if ellipses - (concat (truncate-string-to-width string (- ncols 3)) "...") - (truncate-string-to-width string ncols)))) - (t - (if (<= (length string) ncols) - string - (if ellipses - (concat (substring string 0 (- ncols 3)) "...") - (substring string 0 ncols)))))) - (if padding - (format (format "%%-%ds" ncols) string) - string)) - -(defun reftex-nearest-match (regexp &optional pos) - ;; Find the nearest match of REGEXP. Set the match data. - ;; If POS is given, calculate distances relative to it. - ;; Return nil if there is no match. - (let ((start (point)) (pos (or pos (point))) match1 match2 match) - (goto-char start) - (when (re-search-backward regexp nil t) - (setq match1 (match-data))) - (goto-char start) - (when (re-search-forward regexp nil t) - (setq match2 (match-data))) - (goto-char start) - (setq match - (cond - ((not match1) match2) - ((not match2) match1) - ((< (abs (- pos (car match1))) (abs (- pos (car match2)))) match1) - (t match2))) - (if match (progn (store-match-data match) t) nil))) - -(defun reftex-auto-mode-alist () - ;; Return an `auto-mode-alist' with only the .gz (etc) thingies. - ;; Stolen from gnus nnheader. - (let ((alist auto-mode-alist) - out) - (while alist - (when (listp (cdr (car alist))) - (push (car alist) out)) - (pop alist)) - (nreverse out))) - -(defun reftex-access-search-path (which &optional recurse file) - ;; Access path from environment variables. WHICH is either "tex" or "bib". - ;; When RECURSE is t, expand recursive paths, ending in double slash - ;; FILE is just for the message. - (let* ((pathvar (intern (concat "reftex-" which "-path"))) - (status (get pathvar 'status))) - (cond - ((eq status 'recursed)) - ((and status (null recurse))) - ((null status) - (let ((env-vars (if (equal which "tex") (list "TEXINPUTS") - reftex-bibpath-environment-variables))) - (set pathvar (reftex-parse-colon-path - (mapconcat '(lambda(x) (or (getenv x) "")) - env-vars path-separator)))) - (put pathvar 'status 'split)) - ((and (eq 'split status) recurse) - (message "Expanding search path to find %s file: %s ..." which file) - (set pathvar (reftex-expand-path (symbol-value pathvar))) - (put pathvar 'status 'recursed))))) - -(defun reftex-find-file-on-path (file path) - ;; Find FILE along the directory list PATH. - (catch 'exit - (when (file-name-absolute-p file) - (if (file-exists-p file) - (throw 'exit file) - (throw 'exit nil))) - (let* ((thepath path) file1 dir - (doubleslash (concat "/" "/"))) - (while (setq dir (pop thepath)) - (when (string= (substring dir -2) doubleslash) - (setq dir (substring dir 0 -1))) - (setq file1 (expand-file-name file dir)) - (if (file-exists-p file1) - (throw 'exit file1))) - ;; No such file - nil))) - -(defun reftex-parse-colon-path (path) - ;; Like parse-colon-parse, but // or /~ have no effects. - (mapcar 'file-name-as-directory - (delete "" (split-string path (concat path-separator "+"))))) - -(defun reftex-expand-path (path) - ;; Expand parts of path ending in a double slash - (let (path1 dir dirs (doubleslash (concat "/" "/"))) - (while (setq dir (pop path)) - (if (string= (substring dir -2) doubleslash) - (progn - (setq dir (substring dir 0 -1)) - (setq dirs (reftex-recursive-directory-list dir)) - (setq path1 (append dirs path1))) - (push dir path1))) - (nreverse path1))) - -(defun reftex-recursive-directory-list (dir) - (let ((path (list dir)) dirs path1) - (while (setq dir (pop path)) - (setq dirs - (delete nil - (mapcar (function - (lambda (x) - (if (and (file-directory-p x) - (not (string-match "/\\.+\\'" x))) - (file-name-as-directory x) - nil))) - (directory-files dir t)))) - (setq path (append dirs path)) - (push dir path1)) - path1)) - -(defun reftex-make-regexp-allow-for-ctrl-m (string) - ;; convert STRING into a regexp, allowing ^M for \n and vice versa - (let ((start -2)) - (setq string (regexp-quote string)) - (while (setq start (string-match "[\n\r]" string (+ 3 start))) - (setq string (replace-match "[\n\r]" nil t string))) - string)) - -(defun reftex-make-desparate-section-regexp (old) - ;; Return a regexp which will still match a section statement even if - ;; x-symbol or isotex or the like have been at work in the mean time. - (let* ((n (1+ (string-match "[[{]" old))) - (new (regexp-quote (substring old 0 (1+ (string-match "[[{]" old))))) - (old (substring old n))) - (while (string-match - "\\([\r\n]\\)\\|\\(\\`\\|[ \t\n\r]\\)\\([a-zA-Z0-9]+\\)\\([ \t\n\r]\\|}\\'\\)" - old) - (if (match-beginning 1) - (setq new (concat new "[^\n\r]*[\n\r]")) - (setq new (concat new "[^\n\r]*" (match-string 3 old)))) - (setq old (substring old (match-end 0)))) - new)) - -(defun reftex-delete-list (elt-list list) - ;; like delete, but with a list of things to delete - ;; (original code from Rory Molinari) - (while elt-list - (setq list (delete (car elt-list) list) - elt-list (cdr elt-list))) - list) - -(defun reftex-get-buffer-visiting (file) - ;; return a buffer visiting FILE - (cond - ((boundp 'find-file-compare-truenames) ; XEmacs - (let ((find-file-compare-truenames t)) - (get-file-buffer file))) - ((fboundp 'find-buffer-visiting) ; Emacs - (find-buffer-visiting file)) - (t (error "Please report this problem to dominik@strw.leidenuniv.nl")))) - -(defun reftex-get-file-buffer-force (file &optional mark-to-kill) - ;; Return a buffer visiting file. Make one, if necessary. - ;; If neither such a buffer nor the file exist, return nil. - ;; If MARK-TO-KILL is t and there is no live buffer, load the file with - ;; initializations according to `reftex-initialize-temporary-buffers', - ;; and mark the buffer to be killed after use. - - (let ((buf (reftex-get-buffer-visiting file))) - - (cond (buf - ;; We have it already as a buffer - just return it - buf) - - ((file-readable-p file) - ;; At least there is such a file and we can read it. - - (if (or (not mark-to-kill) - (eq t reftex-initialize-temporary-buffers)) - - ;; Visit the file with full magic - (setq buf (find-file-noselect file)) - - ;; Else: Visit the file just briefly, without or - ;; with limited Magic - - ;; The magic goes away - (let ((format-alist nil) - (auto-mode-alist (reftex-auto-mode-alist)) - (default-major-mode 'fundamental-mode) - (after-insert-file-functions nil)) - (setq buf (find-file-noselect file))) - - ;; Is there a hook to run? - (when (listp reftex-initialize-temporary-buffers) - (save-excursion - (set-buffer buf) - (run-hooks 'reftex-initialize-temporary-buffers)))) - - ;; Lets see if we got a license to kill :-| - (and mark-to-kill - (add-to-list 'reftex-buffers-to-kill buf)) - - ;; Return the new buffer - buf) - - ;; If no such file exists, return nil - (t nil)))) - -(defun reftex-splice-symbols-into-list (list alist) - ;; Splice the association in ALIST of any symbols in LIST into the list. - ;; Return new list. - (let (rtn tmp) - (while list - (while (and (not (null (car list))) ;; keep list elements nil - (symbolp (car list))) - (setq tmp (car list)) - (cond - ((assoc tmp alist) - (setq list (append (nth 2 (assoc tmp alist)) (cdr list)))) - (t - (error "Cannot treat symbol %s in reftex-label-alist" - (symbol-name tmp))))) - (push (pop list) rtn)) - (nreverse rtn))) - -(defun reftex-uniquify (alist &optional keep-list) - ;; Return a list of all elements in ALIST, but each car only once. - ;; Elements of KEEP-LIST are not removed even if duplicate. - (let (new elm) - (while alist - (setq elm (pop alist)) - (if (or (member (car elm) keep-list) - (not (assoc (car elm) new))) - (push elm new))) - (nreverse new))) - -(defun reftex-use-fonts () - ;; Return t if we can and want to use fonts. - (and window-system - reftex-use-fonts - (featurep 'font-lock))) - -(defun reftex-refontify () - ;; Return t if we need to refontify context - (and (reftex-use-fonts) - (or (eq t reftex-refontify-context) - (and (eq 1 reftex-refontify-context) - (or (featurep 'x-symbol)))))) - -;; Highlighting uses overlays. If this is for XEmacs, we need to load -;; the overlay library, available in version 19.15 -(and (not (fboundp 'make-overlay)) - (condition-case nil - (require 'overlay) - (error - (error "RefTeX needs overlay emulation (available in XEmacs 19.15)")))) - -;; We keep a vector with several different overlays to do our highlighting. -(defvar reftex-highlight-overlays [nil nil nil]) - -;; Initialize the overlays -(aset reftex-highlight-overlays 0 (make-overlay 1 1)) -(overlay-put (aref reftex-highlight-overlays 0) 'face 'highlight) -(aset reftex-highlight-overlays 1 (make-overlay 1 1)) -(overlay-put (aref reftex-highlight-overlays 1) 'face 'highlight) -(aset reftex-highlight-overlays 2 (make-overlay 1 1)) -(overlay-put (aref reftex-highlight-overlays 2) 'face - (if (string-match "XEmacs" emacs-version) 'zmacs-region 'region)) - -;; Two functions for activating and deactivation highlight overlays -(defun reftex-highlight (index begin end &optional buffer) - "Highlight a region with overlay INDEX." - (move-overlay (aref reftex-highlight-overlays index) - begin end (or buffer (current-buffer)))) -(defun reftex-unhighlight (index) - "Detatch overlay INDEX." - (delete-overlay (aref reftex-highlight-overlays index))) - -(defun reftex-highlight-shall-die () - ;; Function used in pre-command-hook to remove highlights. - (remove-hook 'pre-command-hook 'reftex-highlight-shall-die) - (reftex-unhighlight 0)) - -;;; --------------------------------------------------------------------------- -;;; -;;; Functions to compile the tables, reset the mode etc. - -(defun reftex-reset-mode () - "Reset RefTeX Mode. Required to implement changes to some list variables. -This function will compile the information in `reftex-label-alist' and similar -variables. It is called when RefTeX is first used, and after changes to -these variables." - (interactive) - - ;; Record that we have done this - (setq reftex-tables-dirty nil) - (setq reftex-memory - (list reftex-label-alist reftex-label-alist-external-add-ons - reftex-default-label-alist-entries)) - - ;; Reset the file search path variables - (put 'reftex-tex-path 'status nil) - (put 'reftex-bib-path 'status nil) - - ;; Kill temporary buffers associated with RefTeX - just in case they - ;; were not cleaned up properly - (let ((buffer-list '("*RefTeX Master*" "*RefTeX Help*" "*RefTeX Select*" - "*Duplicate Labels*" "*toc*" "*RefTeX-scratch*")) - buf) - (while (setq buf (pop buffer-list)) - (if (get-buffer buf) - (kill-buffer buf)))) - - ;; Make sure the current document will be rescanned soon. - (reftex-reset-scanning-information) - - ;; Plug functions into AUCTeX if the user option says so. - (reftex-plug-into-AUCTeX) - - (message "updating internal tables...") - (reftex-compute-ref-cite-tables) - (message "updating internal tables... done")) - -(defun reftex-reset-scanning-information () - "Reset the symbols containing information from buffer scanning. -This enforces rescanning the buffer on next use." - (if (string= reftex-last-toc-master (reftex-TeX-master-file)) - (reftex-empty-toc-buffer)) - (let ((symlist reftex-multifile-symbols) - symbol) - (while symlist - (setq symbol (car symlist) - symlist (cdr symlist)) - (if (and (symbolp (symbol-value symbol)) - (not (null (symbol-value symbol)))) - (set (symbol-value symbol) nil))))) - -(defun reftex-compute-ref-cite-tables () - ;; Update ref and cite tables - - (interactive) - - ;; Compile information in reftex-label-alist - (let ((tmp (reftex-uniquify (reftex-splice-symbols-into-list - (append - reftex-label-alist - reftex-label-alist-external-add-ons - reftex-default-label-alist-entries) - reftex-label-alist-builtin) - '(nil))) - entry env-or-mac typekeychar typekey prefix context word - fmt reffmt labelfmt wordlist qh-list macros-with-labels - nargs nlabel opt-args cell sum) - - (setq reftex-words-to-typekey-alist nil - reftex-typekey-list nil - reftex-typekey-to-format-alist nil - reftex-typekey-to-prefix-alist nil - reftex-env-or-mac-alist nil - reftex-label-env-list nil - reftex-label-mac-list nil) - (while tmp - (catch 'next-entry - (setq entry (car tmp) - env-or-mac (car entry) - entry (cdr entry) - tmp (cdr tmp)) - (if (null env-or-mac) - (setq env-or-mac "")) - (if (stringp (car entry)) - ;; This is before version 2.00 - convert entry to new format - ;; This is just to keep old users happy - (setq entry (cons (string-to-char (car entry)) - (cons (concat (car entry) ":") - (cdr entry))))) - (setq typekeychar (nth 0 entry) - typekey (char-to-string typekeychar) - prefix (nth 1 entry) - fmt (nth 2 entry) - context (nth 3 entry) - wordlist (nth 4 entry)) - (if (stringp wordlist) - ;; This is before version 2.04 - convert to new format - (setq wordlist (nthcdr 4 entry))) - - (if (and (stringp fmt) - (string-match "@" fmt)) - ;; special syntax for specifying a label format - (setq fmt (split-string fmt "@+")) - (setq fmt (list "\\label{%s}" fmt))) - (setq labelfmt (car fmt) - reffmt (nth 1 fmt)) - (if typekey - (add-to-list 'reftex-typekey-list typekey)) - (if (and typekey prefix - (not (assoc typekey reftex-typekey-to-prefix-alist))) - (add-to-list 'reftex-typekey-to-prefix-alist - (cons typekey prefix))) - (cond - ((string-match "\\`\\\\" env-or-mac) - ;; It's a macro - (let ((result (reftex-parse-args env-or-mac))) - (setq env-or-mac (or (first result) env-or-mac) - nargs (second result) - nlabel (third result) - opt-args (fourth result)) - (if nlabel (add-to-list 'macros-with-labels env-or-mac))) - (add-to-list 'reftex-label-mac-list env-or-mac)) - (t - (setq nargs nil nlabel nil opt-args nil) - (cond ((string= env-or-mac "any")) - ((string= env-or-mac "")) - ((string= env-or-mac "section")) - (t - (add-to-list 'reftex-label-env-list env-or-mac) - ;; Translate some special context cases - (when (assq context reftex-default-context-regexps) - (setq context - (format - (cdr (assq context reftex-default-context-regexps)) - (regexp-quote env-or-mac)))))))) - (and reffmt - (not (assoc typekey reftex-typekey-to-format-alist)) - (push (cons typekey reffmt) reftex-typekey-to-format-alist)) - (and (not (string= env-or-mac "any")) - (not (string= env-or-mac "")) - (not (assoc env-or-mac reftex-env-or-mac-alist)) - (push (list env-or-mac typekey context labelfmt - nargs nlabel opt-args) - reftex-env-or-mac-alist)) - (while (and (setq word (pop wordlist)) - (stringp word)) - (setq word (downcase word)) - (or (assoc word reftex-words-to-typekey-alist) - (push (cons word typekey) reftex-words-to-typekey-alist))) - (cond - ((string= "" env-or-mac) nil) - ((setq cell (assoc typekey qh-list)) - (push env-or-mac (cdr cell))) - (t - (push (list typekey env-or-mac) qh-list))))) - - (setq qh-list (sort qh-list '(lambda (x1 x2) (string< (car x1) (car x2))))) - (setq reftex-typekey-to-prefix-alist - (nreverse reftex-typekey-to-prefix-alist)) - (setq reftex-type-query-prompt - (concat "Label type: " - (mapconcat '(lambda(x) - (format "[%s]" (car x))) - qh-list " ") - " (?=Help)")) - (setq reftex-type-query-help - (concat "SELECT A LABEL TYPE:\n--------------------\n" - (mapconcat - '(lambda(x) - (setq sum 0) - (format " [%s] %s" - (car x) - (mapconcat - '(lambda(x) - (setq sum (+ sum (length x))) - (if (< sum 60) - x - (setq sum 0) - (concat "\n " x))) - (cdr x) " "))) - qh-list "\n"))) - - ;; Calculate the regular expressions - (let ((label-re "\\\\label{\\([^}]*\\)}") - (include-re "\\(\\`\\|[\n\r]\\)[ \t]*\\\\\\(include\\|input\\)[{ \t]+\\([^} \t\n\r]+\\)") - (section-re - (concat "\\(\\`\\|[\n\r]\\)[ \t]*\\\\\\(" - (mapconcat 'car reftex-section-levels "\\|") - "\\)\\*?\\(\\[[^]]*\\]\\)?{")) - (macro-re - (if macros-with-labels - (concat "\\(" - (mapconcat 'regexp-quote macros-with-labels "\\|") - "\\)[[{]") - "")) - (find-label-re-format - (concat "\\(" - (mapconcat 'regexp-quote (append '("\\label") - macros-with-labels) "\\|") - "\\)\\([[{][^]}]*[]}]\\)*[[{]\\(%s\\)[]}]"))) - (setq reftex-section-regexp section-re - reftex-section-or-include-regexp - (concat section-re "\\|" include-re) - reftex-everything-regexp - (concat label-re "\\|" section-re "\\|" include-re - (if macros-with-labels "\\|" "") macro-re) - reftex-find-label-regexp-format find-label-re-format - reftex-find-label-regexp-format2 - "\\([]} \t\n\r]\\)\\([[{]\\)\\(%s\\)[]}]")))) - -;;; Keybindings -------------------------------------------------------------- - -(define-key reftex-mode-map "\C-c=" 'reftex-toc) -(define-key reftex-mode-map "\C-c(" 'reftex-label) -(define-key reftex-mode-map "\C-c)" 'reftex-reference) -(define-key reftex-mode-map "\C-c[" 'reftex-citation) -(define-key reftex-mode-map "\C-c&" 'reftex-view-crossref) - -;; If the user requests so, she can have a few more bindings: -(cond - (reftex-extra-bindings - (define-key reftex-mode-map "\C-ct" 'reftex-toc) - (define-key reftex-mode-map "\C-cl" 'reftex-label) - (define-key reftex-mode-map "\C-cr" 'reftex-reference) - (define-key reftex-mode-map "\C-cc" 'reftex-citation) - (define-key reftex-mode-map "\C-cv" 'reftex-view-crossref) - (define-key reftex-mode-map "\C-cg" 'reftex-grep-document) - (define-key reftex-mode-map "\C-cs" 'reftex-search-document))) - -;;; Menus -------------------------------------------------------------------- - -;; Define a menu for the menu bar if Emacs is running under X - -(require 'easymenu) - -(easy-menu-define - reftex-mode-menu reftex-mode-map - "Menu used in RefTeX mode" - `("Ref" - ["Table of Contents" reftex-toc t] - "----" - ["\\label" reftex-label t] - ["\\ref" reftex-reference t] - ["\\cite" reftex-citation t] - ["View Crossref" reftex-view-crossref t] - "----" - ("Parse Document" - ["Only this File" reftex-parse-one t] - ["Entire Document" reftex-parse-all (reftex-is-multi)] - ["Save to File" (reftex-access-parse-file 'write) - (> (length (symbol-value reftex-docstruct-symbol)) 0)] - ["Restore from File" (reftex-access-parse-file 'restore) - (reftex-access-parse-file 'readable)] - "----" - ["Enable Partial Scans" - (setq reftex-enable-partial-scans (not reftex-enable-partial-scans)) - :style toggle :selected reftex-enable-partial-scans] - ["Auto-Save Parse Info" - (setq reftex-save-parse-info (not reftex-save-parse-info)) - :style toggle :selected reftex-save-parse-info] - "---" - ["Reset RefTeX Mode" reftex-reset-mode t]) - ("Multifile" - ["Search Whole Document" reftex-search-document t] - ["Replace in Document" reftex-query-replace-document t] - ["Grep on Document" reftex-grep-document t] - "----" - ["Create TAGS File" reftex-create-tags-file t] - "----" - ["Find Duplicate Labels" reftex-find-duplicate-labels t] - ["Change Label and Refs" reftex-change-label t]) - ("Citation Options" - "Citation Style" - ,@(mapcar - (function - (lambda (x) - (vector - (symbol-name (car x)) - (list 'setq 'reftex-cite-format (list 'quote (car x))) - :style 'radio :selected - (list 'eq 'reftex-cite-format (list 'quote (car x)))))) - reftex-cite-format-builtin) - "----" - "Bibinfo in Comments" - ["Attach Comments" - (setq reftex-comment-citations (not reftex-comment-citations)) - :style toggle :selected reftex-comment-citations] - "---" - "Sort Database Matches" - ["by Author" (setq reftex-sort-bibtex-matches 'author) - :style radio :selected (eq reftex-sort-bibtex-matches 'author)] - ["by Year" (setq reftex-sort-bibtex-matches 'year) - :style radio :selected (eq reftex-sort-bibtex-matches 'year)] - ["by Year, reversed" (setq reftex-sort-bibtex-matches 'reverse-year) - :style radio :selected (eq reftex-sort-bibtex-matches 'reverse-year)] - ["Not" (setq reftex-sort-bibtex-matches nil) - :style radio :selected (eq reftex-sort-bibtex-matches nil)]) - "----" - ["Customize RefTeX" reftex-customize t] - "----" - ["Show Documentation" reftex-show-commentary t])) - -;;; Run Hook ------------------------------------------------------------------ - -(run-hooks 'reftex-load-hook) - -;;; That's it! ---------------------------------------------------------------- - -(provide 'reftex) - -; Make sure tabels are compiled -(message "updating internal tables...") -(reftex-compute-ref-cite-tables) -(message "updating internal tables...done") -(setq reftex-tables-dirty nil) - -;;;============================================================================ - -;;; reftex.el ends here - diff -r 43306a74e31c -r d44af0c54775 lisp/modes/rexx-mode.el --- a/lisp/modes/rexx-mode.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,617 +0,0 @@ -;;; rexx-mode.el --- major mode for editing REXX program files -;; Keywords: languages - -;; Copyright (C) 1993 by Anders Lindgren. - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Not in FSF. - -;;; AUTHOR -;;; Anders Lindgren, d91ali@csd.uu.se -;;; -;;; Abbreviation table due to: -;;; Johan Bergkvist, nv91-jbe@nada.kth.se -;;; -;;; USAGE -;;; This file contains code for a GNU Emacs major mode for -;;; editing REXX program files. -;;; -;;; Type C-h m in Emacs for information on how to configurate -;;; the rexx-mode, or see rexx-mode.doc. -;;; -;;; Put the following lines into your .emacs and rexx-mode -;;; will be automatically loaded when editing a REXX program. -;;; If rexx-mode shall be used for files with other extensions -;;; you can create more (cons ...) lines with these extensions. -;;; -;;; (autoload 'rexx-mode "rexx-mode" "REXX mode" nil t) -;;; (setq auto-mode-alist -;;; (append -;;; (list (cons "\\.rexx$" 'rexx-mode) -;;; (cons "\\.elx$" 'rexx-mode) -;;; (cons "\\.ncomm$" 'rexx-mode) -;;; (cons "\\.cpr$" 'rexx-mode) -;;; ) -;;; auto-mode-alist)) -;;; -;;; HISTORY -;;; 93-01-07 V0.1 ALi Works for the first time. -;;; 92-01-11 V0.2 ALi rexx-calc-indent totally rewritten. -;;; 93-03-08 V0.3 JB rexx-indent-and-newline-and-indent added. -;;; Abbrev-table containing 173 entries created. -;;; rexx-check-expansion added. -;;; rexx-mode enables use of abbrev-table. -;;; 93-03-15 V0.4 ALi abbrev-mode removed, better to call -;;; (abbrev-mode 1) from the hook. -;;; case-fold-search set to t to recognize capital -;;; letters in keywords. -;;; Old (setq case-fold-search nil) removed which -;;; prevented the recognition of END. -;;; rexx-indent-and-newline-and-indent renamed to -;;; rexx-indent-newline-indent. -;;; rexx-i-n-i now only expands abbrevs when -;;; buffer is in abbrev-mode. -;;; New rexx-newline-and-indent added. -;;; 93-03-20 ALi A serious bug in the routine for checking -;;; strings and comments found and fixed. -;;; V1.0 Relesed! -;;; - - -(provide 'rexx-mode) - -(defgroup rexx nil - "Major mode for editing REXX program files" - :group 'languages) - - -(defcustom rexx-indent 8 - "*This variable contains the indentation in rexx-mode." - :type 'integer - :group 'rexx) - -(defcustom rexx-end-indent 0 - "*This variable indicates the relative position of the \"end\" in REXX mode." - :type 'integer - :group 'rexx) - -(defcustom rexx-cont-indent 8 - "*This variable indicates how far a continued line shall be intended." - :type 'integer - :group 'rexx) - -(defcustom rexx-comment-col 32 - "*This variable gives the desired comment column -for comments to the right of text." - :type 'integer - :group 'rexx) - -(defcustom rexx-tab-always-indent t - "*Non-nil means TAB in REXX mode should always reindent the current line, -regardless of where in the line point is when the TAB command is used." - :type 'boolean - :group 'rexx) - -(defcustom rexx-special-regexp - ".*\\(,\\|then\\|else\\)[ \t]*\\(/\\*.*\\*/\\)?[ \t]*$" - "*Regular expression for parsing lines which shall be followed by -a extra indention" - :type 'regexp - :group 'rexx) - -(defconst rexx-font-lock-keywords - (purecopy - (list - (cons (concat "\\<\\(" - (mapconcat 'identity - '("address" "arg" "break" "call" "do" "drop" "echo" "else" "end" - "exit" "if" "interpret" "iterate" "leave" "nop" "numeric" - "options" "otherwise" "parse" "procedure" "pull" "push" "queue" - "return" "say" "select" "shell" "signal" "then" "trace" "upper" - "when" "value" "to" "by" "for" "forever" "while" "until" "form" - "digits" "fuzz" "scientific" "engineering" "failat" "prompt" - "results" "upper" "external" "source" "with" "command" - "function" "var" "version" "expose" "on" "off") - "\\|") "\\)\\>") 'font-lock-keyword-face) - '("\\(\\sw+\\):" 1 font-lock-function-name-face))) - "Additional expressions to highlight in Rexx mode.") -(put 'rexx-mode 'font-lock-defaults '(rexx-font-lock-keywords)) - -(defvar rexx-mode-map nil - "Keymap for rexx-mode.") -(if rexx-mode-map - nil - (setq rexx-mode-map (make-sparse-keymap)) - (define-key rexx-mode-map "\t" 'rexx-indent-command) - (define-key rexx-mode-map "\C-m" 'rexx-indent-and-newline) - (define-key rexx-mode-map 'backspace 'backward-delete-char-untabify) - (define-key rexx-mode-map "\C-c\C-p" 'rexx-find-matching-do) - (define-key rexx-mode-map "\C-c\C-c" 'rexx-debug) - ) - -(defvar rexx-mode-syntax-table nil - "Syntax table in use in REXX-mode buffers.") - -(if rexx-mode-syntax-table - () - (setq rexx-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\\ "\\" rexx-mode-syntax-table) - (modify-syntax-entry ?/ ". 14" rexx-mode-syntax-table) - (modify-syntax-entry ?* ". 23" rexx-mode-syntax-table) - (modify-syntax-entry ?+ "." rexx-mode-syntax-table) - (modify-syntax-entry ?- "." rexx-mode-syntax-table) - (modify-syntax-entry ?= "." rexx-mode-syntax-table) - (modify-syntax-entry ?% "." rexx-mode-syntax-table) - (modify-syntax-entry ?< "." rexx-mode-syntax-table) - (modify-syntax-entry ?> "." rexx-mode-syntax-table) - (modify-syntax-entry ?& "." rexx-mode-syntax-table) - (modify-syntax-entry ?| "." rexx-mode-syntax-table) - (modify-syntax-entry ?. "_" rexx-mode-syntax-table) - (modify-syntax-entry ?\' "\"" rexx-mode-syntax-table)) - -(defvar rexx-mode-abbrev-table nil - "*Abbrev table in use in rexx-mode buffers.") - -(if rexx-mode-abbrev-table - nil - (define-abbrev-table 'rexx-mode-abbrev-table '( - ("address" "ADDRESS" rexx-check-expansion 0) - ("arg" "ARG" rexx-check-expansion 0) - ("break" "BREAK" rexx-check-expansion 0) - ("call" "CALL" rexx-check-expansion 0) - ("do" "DO" rexx-check-expansion 0) - ("drop" "DROP" rexx-check-expansion 0) - ("echo" "ECHO" rexx-check-expansion 0) - ("else" "ELSE" rexx-check-expansion 0) - ("end" "END" rexx-check-expansion 0) - ("exit" "EXIT" rexx-check-expansion 0) - ("if" "IF" rexx-check-expansion 0) - ("interpret" "INTERPRET" rexx-check-expansion 0) - ("iterate" "ITERATE" rexx-check-expansion 0) - ("leave" "LEAVE" rexx-check-expansion 0) - ("nop" "NOP" rexx-check-expansion 0) - ("numeric" "NUMERIC" rexx-check-expansion 0) - ("options" "OPTIONS" rexx-check-expansion 0) - ("otherwise" "OTHERWISE" rexx-check-expansion 0) - ("parse" "PARSE" rexx-check-expansion 0) - ("procedure" "PROCEDURE" rexx-check-expansion 0) - ("pull" "PULL" rexx-check-expansion 0) - ("push" "PUSH" rexx-check-expansion 0) - ("queue" "QUEUE" rexx-check-expansion 0) - ("return" "RETURN" rexx-check-expansion 0) - ("say" "SAY" rexx-check-expansion 0) - ("select" "SELECT" rexx-check-expansion 0) - ("shell" "SHELL" rexx-check-expansion 0) - ("signal" "SIGNAL" rexx-check-expansion 0) - ("then" "THEN" rexx-check-expansion 0) - ("trace" "TRACE" rexx-check-expansion 0) - ("upper" "UPPER" rexx-check-expansion 0) - ("when" "WHEN" rexx-check-expansion 0) - ("value" "VALUE" rexx-check-expansion 0) - ("to" "TO" rexx-check-expansion 0) - ("by" "BY" rexx-check-expansion 0) - ("for" "FOR" rexx-check-expansion 0) - ("forever" "FOREVER" rexx-check-expansion 0) - ("while" "WHILE" rexx-check-expansion 0) - ("until" "UNTIL" rexx-check-expansion 0) - ("form" "FORM" rexx-check-expansion 0) - ("digits" "DIGITS" rexx-check-expansion 0) - ("fuzz" "FUZZ" rexx-check-expansion 0) - ("scientific" "SCIENTIFIC" rexx-check-expansion 0) - ("engineering" "ENGINEERING" rexx-check-expansion 0) - ("failat" "FAILAT" rexx-check-expansion 0) - ("prompt" "PROMPT" rexx-check-expansion 0) - ("results" "RESULTS" rexx-check-expansion 0) - ("upper" "UPPER" rexx-check-expansion 0) - ("external" "EXTERNAL" rexx-check-expansion 0) - ("source" "SOURCE" rexx-check-expansion 0) - ("with" "WITH" rexx-check-expansion 0) - ("command" "COMMAND" rexx-check-expansion 0) - ("function" "FUNCTION" rexx-check-expansion 0) - ("var" "VAR" rexx-check-expansion 0) - ("version" "VERSION" rexx-check-expansion 0) - ("expose" "EXPOSE" rexx-check-expansion 0) - ("on" "ON" rexx-check-expansion 0) - ("off" "OFF" rexx-check-expansion 0) - ("abbrev" "ABBREV" rexx-check-expansion 0) - ("abs" "ABS" rexx-check-expansion 0) - ("addlib" "ADDLIB" rexx-check-expansion 0) - ("b2c" "B2C" rexx-check-expansion 0) - ("bitand" "BITAND" rexx-check-expansion 0) - ("bitchg" "BITCHG" rexx-check-expansion 0) - ("bitclr" "BITCLR" rexx-check-expansion 0) - ("bitcomp" "BITCOMP" rexx-check-expansion 0) - ("bitor" "BITOR" rexx-check-expansion 0) - ("bittst" "BITTST" rexx-check-expansion 0) - ("bitset" "BITSET" rexx-check-expansion 0) - ("c2b" "C2B" rexx-check-expansion 0) - ("c2d" "C2D" rexx-check-expansion 0) - ("c2x" "C2X" rexx-check-expansion 0) - ("center" "CENTER" rexx-check-expansion 0) - ("centre" "CENTRE" rexx-check-expansion 0) - ("close" "CLOSE" rexx-check-expansion 0) - ("compress" "COMPRESS" rexx-check-expansion 0) - ("compare" "COMPARE" rexx-check-expansion 0) - ("copies" "COPIES" rexx-check-expansion 0) - ("d2c" "D2C" rexx-check-expansion 0) - ("datatype" "DATATYPE" rexx-check-expansion 0) - ("delstr" "DELSTR" rexx-check-expansion 0) - ("delword" "DELWORD" rexx-check-expansion 0) - ("eof" "EOF" rexx-check-expansion 0) - ("errortext" "ERRORTEXT" rexx-check-expansion 0) - ("exists" "EXISTS" rexx-check-expansion 0) - ("export" "EXPORT" rexx-check-expansion 0) - ("freespace" "FREESPACE" rexx-check-expansion 0) - ("getclip" "GETCLIP" rexx-check-expansion 0) - ("getspace" "GETSPACE" rexx-check-expansion 0) - ("hash" "HASH" rexx-check-expansion 0) - ("import" "IMPORT" rexx-check-expansion 0) - ("index" "INDEX" rexx-check-expansion 0) - ("insert" "INSERT" rexx-check-expansion 0) - ("lastpos" "LASTPOS" rexx-check-expansion 0) - ("left" "LEFT" rexx-check-expansion 0) - ("length" "LENGTH" rexx-check-expansion 0) - ("max" "MAX" rexx-check-expansion 0) - ("min" "MIN" rexx-check-expansion 0) - ("open" "OPEN" rexx-check-expansion 0) - ("overlay" "OVERLAY" rexx-check-expansion 0) - ("pos" "POS" rexx-check-expansion 0) - ("pragma" "PRAGMA" rexx-check-expansion 0) - ("random" "RANDOM" rexx-check-expansion 0) - ("randu" "RANDU" rexx-check-expansion 0) - ("readch" "READCH" rexx-check-expansion 0) - ("readln" "READLN" rexx-check-expansion 0) - ("remlib" "REMLIB" rexx-check-expansion 0) - ("reverse" "REVERSE" rexx-check-expansion 0) - ("right" "RIGHT" rexx-check-expansion 0) - ("seek" "SEEK" rexx-check-expansion 0) - ("setclip" "SETCLIP" rexx-check-expansion 0) - ("show" "SHOW" rexx-check-expansion 0) - ("sign" "SIGN" rexx-check-expansion 0) - ("space" "SPACE" rexx-check-expansion 0) - ("storage" "STORAGE" rexx-check-expansion 0) - ("strip" "STRIP" rexx-check-expansion 0) - ("substr" "SUBSTR" rexx-check-expansion 0) - ("subword" "SUBWORD" rexx-check-expansion 0) - ("symbol" "SYMBOL" rexx-check-expansion 0) - ("time" "TIME" rexx-check-expansion 0) - ("trace" "TRACE" rexx-check-expansion 0) - ("translate" "TRANSLATE" rexx-check-expansion 0) - ("trim" "TRIM" rexx-check-expansion 0) - ("verify" "VERIFY" rexx-check-expansion 0) - ("word" "WORD" rexx-check-expansion 0) - ("wordindex" "WORDINDEX" rexx-check-expansion 0) - ("wordlength" "WORDLENGTH" rexx-check-expansion 0) - ("words" "WORDS" rexx-check-expansion 0) - ("writech" "WRITECH" rexx-check-expansion 0) - ("writeln" "WRITELN" rexx-check-expansion 0) - ("x2c" "X2C" rexx-check-expansion 0) - ("xrange" "XRANGE" rexx-check-expansion 0) - ("allocmem" "ALLOCMEM" rexx-check-expansion 0) - ("baddr" "BADDR" rexx-check-expansion 0) - ("bitxor" "BITXOR" rexx-check-expansion 0) - ("break_c" "BREAK_C" rexx-check-expansion 0) - ("break_d" "BREAK_D" rexx-check-expansion 0) - ("break_e" "BREAK_E" rexx-check-expansion 0) - ("break_f" "BREAK_F" rexx-check-expansion 0) - ("cache" "CACHE" rexx-check-expansion 0) - ("closeport" "CLOSEPORT" rexx-check-expansion 0) - ("d2x" "D2X" rexx-check-expansion 0) - ("date" "DATA" rexx-check-expansion 0) - ("delay" "DELAY" rexx-check-expansion 0) - ("delete" "DELETE" rexx-check-expansion 0) - ("error" "ERROR" rexx-check-expansion 0) - ("failure" "FAILURE" rexx-check-expansion 0) - ("find" "FIND" rexx-check-expansion 0) - ("forbid" "FORBID" rexx-check-expansion 0) - ("freemem" "FREEMEM" rexx-check-expansion 0) - ("getarg" "GETARG" rexx-check-expansion 0) - ("getpkt" "GETPKT" rexx-check-expansion 0) - ("halt" "HALT" rexx-check-expansion 0) - ("ioerr" "IOERR" rexx-check-expansion 0) - ("lines" "LINES" rexx-check-expansion 0) - ("makedir" "MAKEDIR" rexx-check-expansion 0) - ("next" "NEXT" rexx-check-expansion 0) - ("novalue" "NOVALUE" rexx-check-expansion 0) - ("null" "NULL" rexx-check-expansion 0) - ("offset" "OFFSET" rexx-check-expansion 0) - ("openport" "OPENPORT" rexx-check-expansion 0) - ("permit" "PERMIT" rexx-check-expansion 0) - ("rename" "RENAME" rexx-check-expansion 0) - ("reply" "REPLY" rexx-check-expansion 0) - ("showdir" "SHOWDIR" rexx-check-expansion 0) - ("showlist" "SHOWLIST" rexx-check-expansion 0) - ("sourceline" "SOURCELINE" rexx-check-expansion 0) - ("statef" "STATEF" rexx-check-expansion 0) - ("syntax" "SYNTAX" rexx-check-expansion 0) - ("trunc" "TRUNC" rexx-check-expansion 0) - ("typepkt" "TYPEPKT" rexx-check-expansion 0) - ("waitpkt" "WAITPKT" rexx-check-expansion 0) - ("x2d" "X2D" rexx-check-expansion 0)))) - -;;;###autoload -(defun rexx-mode () -"Major mode for editing REXX code. -\\{rexx-mode-map} - -Variables controlling indentation style: - rexx-indent - The basic indentation for do-blocks. - rexx-end-indent - The relative offset of the \"end\" statement. 0 places it in the - same column as the statements of the block. Setting it to the same - value as rexx-indent places the \"end\" under the do-line. - rexx-cont-indent - The indention for lines following \"then\", \"else\" and \",\" - (continued) lines. - rexx-tab-always-indent - Non-nil means TAB in REXX mode should always reindent the current - line, regardless of where in the line the point is when the TAB - command is used. - -If you have set rexx-end-indent to a nonzero value, you probably want to -remap RETURN to rexx-indent-newline-indent. It makes sure that lines -indents correctly when you press RETURN. - -An extensive abbreviation table consisting of all the keywords of REXX are -supplied. Expanded keywords are converted into upper case making it -easier to distinguish them. To use this feature the buffer must be in -abbrev-mode. (See example below.) - -Turning on REXX mode calls the value of the variable rexx-mode-hook with -no args, if that value is non-nil. - -For example: -(setq rexx-mode-hook '(lambda () - (setq rexx-indent 4) - (setq rexx-end-indent 4) - (setq rexx-cont-indent 4) - (local-set-key \"\\C-m\" 'rexx-indent-newline-indent) - (abbrev-mode 1) - )) - -will make the END aligned with the DO/SELECT. It will indent blocks and -IF-statements four steps and make sure that the END jumps into the -correct position when RETURN is pressed. Finally it will use the abbrev -table to convert all REXX keywords into upper case." - (interactive) - (kill-all-local-variables) - (use-local-map rexx-mode-map) - (set-syntax-table rexx-mode-syntax-table) - (setq major-mode 'rexx-mode) - (setq mode-name "REXX") - (setq local-abbrev-table rexx-mode-abbrev-table) - (make-local-variable 'case-fold-search) - (setq case-fold-search t) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "^$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'rexx-indent-command) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - (make-local-variable 'comment-start) - (setq comment-start "/* ") - (make-local-variable 'comment-end) - (setq comment-end " */") - (make-local-variable 'comment-column) - (setq comment-column 32) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "/\\*+ *") - (make-local-variable 'comment-indent-hook) - (setq comment-indent-hook 'rexx-comment-indent) - (run-hooks 'rexx-mode-hook)) - - -(defun rexx-indent-command (&optional whole-exp) - "Indent the current line as REXX code." - (interactive "P") - (if whole-exp - (let ((shift-amt (rexx-indent-line)) - beg - end) - (save-excursion - (if rexx-tab-always-indent - (beginning-of-line)) - (setq beg (point)) - (forward-sexp 1) - (setq end (point)) - (goto-char beg) - (forward-line 1) - (setq beg (point))) - (if (> end beg) - (indent-code-rigidly beg end shift-amt))) - (if (and (not rexx-tab-always-indent) - (save-excursion - (skip-chars-backward " \t") - (not (bolp)))) - (insert-tab) - (rexx-indent-line)))) - -(defun rexx-indent-line () - "Indent the current line as REXX code. -Return the amount the indentation changed by." - (let ((indent (rexx-calc-indent)) - beg - shift-amt - (pos (- (point-max) (point)))) - (beginning-of-line) - (setq beg (point)) - (cond ((eq indent nil) (setq indent (current-indentation))) - ((eq indent t) (setq indent (rexx-calculate-indent-within-comment))) - ((looking-at "[ \t]*#") (setq indent 0)) - (t (skip-chars-forward " \t") - (if (listp indent) (setq indent (car indent))) - ;; /* Sprekspecifik kod! */ - (if (looking-at "end") (setq indent (- indent rexx-end-indent))))) - (skip-chars-forward " \t") - (setq shift-amt (- indent (current-column))) - (if (zerop shift-amt) - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos))) - (delete-region beg (point)) - (indent-to indent) - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos)))) - shift-amt)) - -(defun rexx-calc-indent () - "Return the appropriate indentation for this line as an int." - (save-excursion - (beginning-of-line) - (let ((block (rexx-find-environment)) - beg - state - indent) - (save-excursion (setq state (rexx-inside-comment-or-string))) - (cond ((or (nth 3 state) (nth 4 state)) - (nth 4 state)) ;; Inside a comment or string - (t - ;; Find line to indent current line after. - (rexx-backup-to-noncomment 1) - (beginning-of-line) - (setq beg (rexx-find-environment)) - (while (> beg block) - (goto-char beg) - (beginning-of-line) - (setq beg (rexx-find-environment))) - - (if (> (point) block) - ;; Check to see if we shall make a special indention - (if (looking-at rexx-special-regexp) - (+ (current-indentation) rexx-cont-indent) - ;; If not, find the basic indention by stepping - ;; by all special indented lines. - (progn - (setq indent (current-indentation)) - (rexx-backup-to-noncomment 1) - (beginning-of-line) - (while (looking-at rexx-special-regexp) - (setq indent (current-indentation)) - (rexx-backup-to-noncomment 1) - (beginning-of-line)) - indent)) - (if (= 1 block) - 0 - ;; Indent after the do-line. - (progn - (goto-char block) - (+ (current-indentation) rexx-indent))))))))) - -(defun rexx-backup-to-noncomment (lim) - "Backup the point to the previous noncomment REXX line." - (let (stop) - (while (not stop) - (skip-chars-backward " \t\n\f" lim) - (if (and (>= (point) (+ 2 lim)) - (save-excursion - (forward-char -2) - (looking-at "\\*/"))) - (search-backward "/*" lim 'move) - (setq stop t))) - (>= (point) lim))) - -(defun rexx-find-environment () - "Return the position of the corresponding \"do\" or \"select\". -If none found, return the beginning of buffer." - (save-excursion - (let ((do-level 1) - (cont t) - state) - (while (and cont (not (zerop do-level))) - (setq cont (re-search-backward "\\b\\(do\\|select\\|end\\)\\b" 1 t)) - (save-excursion (setq state (rexx-inside-comment-or-string))) - (setq do-level (+ do-level - (cond ((or (nth 3 state) (nth 4 state)) 0) - ((looking-at "do") -1) - ((looking-at "select") -1) - ((looking-at "end") +1) - (t 0))))) - - (if cont (point) 1)))) - -(defun rexx-calculate-indent-within-comment () - "Return the indentation amount for line, assuming that -the current line is to be regarded as part of a block comment." - (let (end star-start) - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (setq star-start (= (following-char) ?\*)) - (skip-chars-backward " \t\n") - (setq end (point)) - (beginning-of-line) - (skip-chars-forward " \t") - (and (re-search-forward "/\\*[ \t]*" end t) - star-start - (goto-char (1+ (match-beginning 0)))) - (current-column)))) - -(defun rexx-comment-indent () - (if (looking-at "^/\\*") - 0 ;Existing comment at bol stays there. - (save-excursion - (skip-chars-backward " \t") - (max (1+ (current-column)) ;Else indent at comment column - comment-column)))) ; except leave at least one space. - -(defun rexx-find-matching-do () - "Set mark, look for the \"do\" or \"select\" for the present block." - (interactive) - (set-mark-command nil) - (beginning-of-line) - (goto-char (rexx-find-environment))) - -(defun rexx-check-expansion () - "If abbrev was made within a comment or a string, de-abbrev!" - (let ((state (rexx-inside-comment-or-string))) - (if (or (nth 3 state) (nth 4 state)) - (unexpand-abbrev)))) - -(defun rexx-inside-comment-or-string () - "Check if the point is inside a comment or a string. -It returns the state from parse-partial-sexp for the search that -terminated on the points position" - (let ((origpoint (point)) - state) - (save-excursion - (goto-char 1) - (while (> origpoint (point)) - (setq state (parse-partial-sexp (point) origpoint 0)))) - state)) - -(defun rexx-indent-and-newline () - "New newline-and-indent which expands abbrevs before running -a regular newline-and-indent." - (interactive) - (if abbrev-mode - (expand-abbrev)) - (newline-and-indent)) - -(defun rexx-indent-newline-indent () - "New newline-and-indent which expands abbrevs and indent the line -before running a regular newline-and-indent." - (interactive) - (rexx-indent-command) - (if abbrev-mode - (expand-abbrev)) - (newline-and-indent)) diff -r 43306a74e31c -r d44af0c54775 lisp/modes/rsz-minibuf.el --- a/lisp/modes/rsz-minibuf.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,233 +0,0 @@ -;;; rsz-minibuf.el --- dynamically resize minibuffer to display entire contents - -;; Copyright (C) 1990 Roland McGrath -;; Copyright (C) 1993, 1994 Noah S. Friedman - -;; Author: Noah Friedman -;; Author: Roland McGrath -;; Modified for Lucid Emacs By: Peter Stout -;; Maintainer: friedman@prep.ai.mit.edu -;; Keywords: minibuffer, window, frames, display - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, you can either -;; send email to this program's maintainer or write to: The Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: Not synched. - -;;; Commentary: - -;; This file has received maintenance by the XEmacs development team. - -;; $Id: rsz-minibuf.el,v 1.6 1997/09/17 05:19:26 steve Exp $ - -;; This package allows the entire contents (or as much as possible) of the -;; minibuffer to be visible at once when typing. As the end of a line is -;; reached, the minibuffer will resize itself. When the user is done -;; typing, the minibuffer will return to its original size. - -;; In window systems where it is possible to have a frame in which the -;; minibuffer is the only window, the frame itself can be resized. In FSF -;; GNU Emacs 19.22 and earlier, the frame may not be properly returned to -;; its original size after it ceases to be active because -;; `minibuffer-exit-hook' didn't exist until version 19.23. - -;; NOTE: The code to resize frames has not been tested under Lucid Emacs, -;; because detached minibuffers are broken. - -;; Note that the minibuffer and echo area are not the same! They simply -;; happen to occupy roughly the same place on the frame. Messages put in -;; the echo area will not cause any resizing by this package. - -;; This package is considered a minor mode but it doesn't put anything in -;; minor-mode-alist because this mode is specific to the minibuffer, which -;; has no modeline. - -;; To use this package, put the following in your .emacs: -;; -;; (autoload 'resize-minibuffer-mode "rsz-minibuf" nil t) -;; -;; Invoking the command `resize-minibuffer-mode' will then enable this mode. - -;;; Code: - - - -(defgroup resize-minibuffer nil - "Dynamically resize minibuffer to display entire contents" - :group 'frames) - - -(defcustom resize-minibuffer-mode nil - "*If non-`nil', resize the minibuffer so its entire contents are visible." - :type 'boolean - :require 'rsz-minibuf - :group 'resize-minibuffer) - -(defcustom resize-minibuffer-window-max-height nil - "*Maximum size the minibuffer window is allowed to become. -If less than 1 or not a number, the limit is the height of the frame in -which the active minibuffer window resides." - :type '(choice (const nil) integer) - :group 'resize-minibuffer) - -(defcustom resize-minibuffer-window-exactly t - "*If non-`nil', make minibuffer exactly the size needed to display all its contents. -Otherwise, the minibuffer window can temporarily increase in size but -never get smaller while it is active." - :type 'boolean - :group 'resize-minibuffer) - - -(defcustom resize-minibuffer-frame nil - "*If non-`nil' and the active minibuffer is the sole window in its frame, allow changing the frame height." - :type 'boolean - :group 'resize-minibuffer) - -(defcustom resize-minibuffer-frame-max-height nil - "*Maximum size the minibuffer frame is allowed to become. -If less than 1 or not a number, there is no limit.") - -(defcustom resize-minibuffer-frame-exactly nil - "*If non-`nil', make minibuffer frame exactly the size needed to display all its contents. -Otherwise, the minibuffer frame can temporarily increase in size but -never get smaller while it is active." - :type 'boolean - :group 'resize-minibuffer) - - -;;;###autoload -(defun resize-minibuffer-mode (&optional prefix) - "Enable or disable resize-minibuffer mode. -A negative prefix argument disables this mode. A positive argument or -argument of 0 enables it. - -When this minor mode is enabled, the minibuffer is dynamically resized to -contain the entire region of text put in it as you type. - -The variable `resize-minibuffer-mode' is set to t or nil depending on -whether this mode is active or not. - -The maximum height to which the minibuffer can grow is controlled by the -variable `resize-minibuffer-window-max-height'. - -The variable `resize-minibuffer-window-exactly' determines whether the -minibuffer window should ever be shrunk to make it no larger than needed to -display its contents. - -When using a window system, it is possible for a minibuffer to be the sole -window in a frame. Since that window is already its maximum size, the only -way to make more text visible at once is to increase the size of the frame. -The variable `resize-minibuffer-frame' controls whether this should be -done. The variables `resize-minibuffer-frame-max-height' and -`resize-minibuffer-frame-exactly' are analogous to their window -counterparts." - (interactive "p") - (or prefix (setq prefix 0)) - (cond - ((>= prefix 0) - (setq resize-minibuffer-mode t)) - (t - (setq resize-minibuffer-mode nil)))) - -(defun resize-minibuffer-setup () - (cond - (resize-minibuffer-mode - (cond - ((and (not (eq 'tty (console-type))) - (eq 'only (plist-get (frame-properties) 'minibuffer))) - (and resize-minibuffer-frame - (progn - (make-local-hook 'minibuffer-exit-hook) - (add-hook 'minibuffer-exit-hook 'resize-minibuffer-frame-restore - nil t) - (make-local-hook 'post-command-hook) - (add-hook 'post-command-hook 'resize-minibuffer-frame nil t) - (unless (and (boundp 'icomplete-mode) - icomplete-mode) - (resize-minibuffer-frame))))) - (t - (make-local-hook 'post-command-hook) - (add-hook 'post-command-hook 'resize-minibuffer-window nil t) - (unless (and (boundp 'icomplete-mode) - icomplete-mode) - (resize-minibuffer-window))))))) - -(defun resize-minibuffer-count-window-lines (&optional start end) - "Return number of window lines occupied by text in region. -The number of window lines may be greater than the number of actual lines -in the buffer if any wrap on the display due to their length. - -Optional arguments START and END default to point-min and point-max, -respectively." - (or start (setq start (point-min))) - (or end (setq end (point-max))) - (if (= start end) - 0 - (save-excursion - (save-restriction - (widen) - (narrow-to-region start end) - (goto-char start) - (vertical-motion (buffer-size)))))) - - -;; Resize the minibuffer window to contain the minibuffer's contents. -;; The minibuffer must be the current window. -(defun resize-minibuffer-window () - (let ((height (window-height)) - (lines (1+ (resize-minibuffer-count-window-lines)))) - (and (numberp resize-minibuffer-window-max-height) - (> resize-minibuffer-window-max-height 0) - (setq lines (min - lines - resize-minibuffer-window-max-height))) - (or (if resize-minibuffer-window-exactly - (= lines height) - (<= lines height)) - (enlarge-window (- lines height))))) - - -;; Resize the minibuffer frame to contain the minibuffer's contents. -;; The minibuffer frame must be the current frame. -(defun resize-minibuffer-frame () - (let ((height (frame-height)) - (lines (1+ (resize-minibuffer-count-window-lines)))) - (and (numberp resize-minibuffer-frame-max-height) - (> resize-minibuffer-frame-max-height 0) - (setq lines (min - lines - resize-minibuffer-frame-max-height))) - (cond - ((> lines height) - (set-frame-size (selected-frame) (frame-width) lines)) - ((and resize-minibuffer-frame-exactly - (> height (plist-get minibuffer-frame-plist 'height)) - (< lines height)) - (set-frame-size (selected-frame) (frame-width) lines))))) - -;; Restore the original height of the frame. -(defun resize-minibuffer-frame-restore () - (set-frame-size (selected-frame) (frame-width) - (plist-get minibuffer-frame-plist 'height))) - - -(provide 'rsz-minibuf) - -(add-hook 'minibuffer-setup-hook 'resize-minibuffer-setup) - -;;; rsz-minibuf.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/scheme.el --- a/lisp/modes/scheme.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,516 +0,0 @@ -;;; scheme.el --- Scheme mode, and its idiosyncratic commands. - -;; Copyright (C) 1986, 1987, 1988 Free Software Foundation, Inc. - -;; Author: Bill Rozas -;; Keywords: languages, lisp - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. - -;;; Synched up with: FSF 19.34. - -;;; Commentary: - -;; Adapted from Lisp mode by Bill Rozas, jinx@prep. -;; Initially a query replace of Lisp mode, except for the indentation -;; of special forms. Probably the code should be merged at some point -;; so that there is sharing between both libraries. - -;;; Code: - -(defvar scheme-mode-syntax-table nil "") -(if (not scheme-mode-syntax-table) - (let ((i 0)) - (setq scheme-mode-syntax-table (make-syntax-table)) - (set-syntax-table scheme-mode-syntax-table) - - ;; Default is atom-constituent. - (while (< i 256) - (modify-syntax-entry i "_ ") - (setq i (1+ i))) - - ;; Word components. - (setq i ?0) - (while (<= i ?9) - (modify-syntax-entry i "w ") - (setq i (1+ i))) - (setq i ?A) - (while (<= i ?Z) - (modify-syntax-entry i "w ") - (setq i (1+ i))) - (setq i ?a) - (while (<= i ?z) - (modify-syntax-entry i "w ") - (setq i (1+ i))) - - ;; Whitespace - (modify-syntax-entry ?\t " ") - (modify-syntax-entry ?\n "> ") - (modify-syntax-entry ?\f " ") - (modify-syntax-entry ?\r " ") - (modify-syntax-entry ? " ") - - ;; These characters are delimiters but otherwise undefined. - ;; Brackets and braces balance for editing convenience. - (modify-syntax-entry ?[ "(] ") - (modify-syntax-entry ?] ")[ ") - (modify-syntax-entry ?{ "(} ") - (modify-syntax-entry ?} "){ ") - (modify-syntax-entry ?\| " 23") - - ;; Other atom delimiters - (modify-syntax-entry ?\( "() ") - (modify-syntax-entry ?\) ")( ") - (modify-syntax-entry ?\; "< ") - (modify-syntax-entry ?\" "\" ") - (modify-syntax-entry ?' " p") - (modify-syntax-entry ?` " p") - - ;; Special characters - (modify-syntax-entry ?, "_ p") - (modify-syntax-entry ?@ "_ p") - (modify-syntax-entry ?# "_ p14") - (modify-syntax-entry ?\\ "\\ "))) - -(defvar scheme-mode-abbrev-table nil "") -(define-abbrev-table 'scheme-mode-abbrev-table ()) - -(defun scheme-mode-variables () - (set-syntax-table scheme-mode-syntax-table) - (setq local-abbrev-table scheme-mode-abbrev-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'scheme-indent-line) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - (make-local-variable 'comment-start) - (setq comment-start ";") - (make-local-variable 'comment-start-skip) - ;; Look within the line for a ; following an even number of backslashes - ;; after either a non-backslash or the line beginning. - (setq comment-start-skip "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+[ \t]*") - (make-local-variable 'comment-column) - (setq comment-column 40) - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'scheme-comment-indent) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - (setq mode-line-process '("" scheme-mode-line-process))) - -(defvar scheme-mode-line-process "") - -(defun scheme-mode-commands (map) - (define-key map "\t" 'scheme-indent-line) - (define-key map "\e\C-q" 'scheme-indent-sexp)) - -(defvar scheme-mode-map nil) -(if (not scheme-mode-map) - (progn - (setq scheme-mode-map (make-sparse-keymap)) - (scheme-mode-commands scheme-mode-map))) - -;;;###autoload -(defun scheme-mode () - "Major mode for editing Scheme code. -Editing commands are similar to those of lisp-mode. - -In addition, if an inferior Scheme process is running, some additional -commands will be defined, for evaluating expressions and controlling -the interpreter, and the state of the process will be displayed in the -modeline of all Scheme buffers. The names of commands that interact -with the Scheme process start with \"xscheme-\". For more information -see the documentation for xscheme-interaction-mode. - -Commands: -Delete converts tabs to spaces as it moves back. -Blank lines separate paragraphs. Semicolons start comments. -\\{scheme-mode-map} -Entry to this mode calls the value of scheme-mode-hook -if that value is non-nil." - (interactive) - (kill-all-local-variables) - (scheme-mode-initialize) - (scheme-mode-variables) - (run-hooks 'scheme-mode-hook)) - -(defun scheme-mode-initialize () - (use-local-map scheme-mode-map) - (setq major-mode 'scheme-mode) - (setq mode-name "Scheme")) - -(defvar scheme-mit-dialect t - "If non-nil, scheme mode is specialized for MIT Scheme. -Set this to nil if you normally use another dialect.") - -(defun scheme-comment-indent (&optional pos) - (save-excursion - (if pos (goto-char pos)) - (cond ((looking-at ";;;") (current-column)) - ((looking-at ";;") - (let ((tem (calculate-scheme-indent))) - (if (listp tem) (car tem) tem))) - (t - (skip-chars-backward " \t") - (max (if (bolp) 0 (1+ (current-column))) - comment-column))))) - -(defvar scheme-indent-offset nil "") -(defvar scheme-indent-function 'scheme-indent-function "") - -(defun scheme-indent-line (&optional whole-exp) - "Indent current line as Scheme code. -With argument, indent any additional lines of the same expression -rigidly along with this one." - (interactive "P") - (let ((indent (calculate-scheme-indent)) shift-amt beg end - (pos (- (point-max) (point)))) - (beginning-of-line) - (setq beg (point)) - (skip-chars-forward " \t") - (if (looking-at "[ \t]*;;;") - ;; Don't alter indentation of a ;;; comment line. - nil - (if (listp indent) (setq indent (car indent))) - (setq shift-amt (- indent (current-column))) - (if (zerop shift-amt) - nil - (delete-region beg (point)) - (indent-to indent)) - ;; If initial point was within line's indentation, - ;; position after the indentation. Else stay at same point in text. - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos))) - ;; If desired, shift remaining lines of expression the same amount. - (and whole-exp (not (zerop shift-amt)) - (save-excursion - (goto-char beg) - (forward-sexp 1) - (setq end (point)) - (goto-char beg) - (forward-line 1) - (setq beg (point)) - (> end beg)) - (indent-code-rigidly beg end shift-amt))))) - -(defun calculate-scheme-indent (&optional parse-start) - "Return appropriate indentation for current line as scheme code. -In usual case returns an integer: the column to indent to. -Can instead return a list, whose car is the column to indent to. -This means that following lines at the same level of indentation -should not necessarily be indented the same way. -The second element of the list is the buffer position -of the start of the containing expression." - (save-excursion - (beginning-of-line) - (let ((indent-point (point)) state paren-depth desired-indent (retry t) - last-sexp containing-sexp first-sexp-list-p) - (if parse-start - (goto-char parse-start) - (beginning-of-defun)) - ;; Find outermost containing sexp - (while (< (point) indent-point) - (setq state (parse-partial-sexp (point) indent-point 0))) - ;; Find innermost containing sexp - (while (and retry (setq paren-depth (car state)) (> paren-depth 0)) - (setq retry nil) - (setq last-sexp (nth 2 state)) - (setq containing-sexp (car (cdr state))) - ;; Position following last unclosed open. - (goto-char (1+ containing-sexp)) - ;; Is there a complete sexp since then? - (if (and last-sexp (> last-sexp (point))) - ;; Yes, but is there a containing sexp after that? - (let ((peek (parse-partial-sexp last-sexp indent-point 0))) - (if (setq retry (car (cdr peek))) (setq state peek)))) - (if (not retry) - ;; Innermost containing sexp found - (progn - (goto-char (1+ containing-sexp)) - (if (not last-sexp) - ;; indent-point immediately follows open paren. - ;; Don't call hook. - (setq desired-indent (current-column)) - ;; Move to first sexp after containing open paren - (parse-partial-sexp (point) last-sexp 0 t) - (setq first-sexp-list-p (looking-at "\\s(")) - (cond - ((> (save-excursion (forward-line 1) (point)) - last-sexp) - ;; Last sexp is on same line as containing sexp. - ;; It's almost certainly a function call. - (parse-partial-sexp (point) last-sexp 0 t) - (if (/= (point) last-sexp) - ;; Indent beneath first argument or, if only one sexp - ;; on line, indent beneath that. - (progn (forward-sexp 1) - (parse-partial-sexp (point) last-sexp 0 t))) - (backward-prefix-chars)) - (t - ;; Indent beneath first sexp on same line as last-sexp. - ;; Again, it's almost certainly a function call. - (goto-char last-sexp) - (beginning-of-line) - (parse-partial-sexp (point) last-sexp 0 t) - (backward-prefix-chars))))))) - ;; If looking at a list, don't call hook. - (if first-sexp-list-p - (setq desired-indent (current-column))) - ;; Point is at the point to indent under unless we are inside a string. - ;; Call indentation hook except when overridden by scheme-indent-offset - ;; or if the desired indentation has already been computed. - (cond ((car (nthcdr 3 state)) - ;; Inside a string, don't change indentation. - (goto-char indent-point) - (skip-chars-forward " \t") - (setq desired-indent (current-column))) - ((and (integerp scheme-indent-offset) containing-sexp) - ;; Indent by constant offset - (goto-char containing-sexp) - (setq desired-indent (+ scheme-indent-offset (current-column)))) - ((not (or desired-indent - (and (boundp 'scheme-indent-function) - scheme-indent-function - (not retry) - (setq desired-indent - (funcall scheme-indent-function - indent-point state))))) - ;; Use default indentation if not computed yet - (setq desired-indent (current-column)))) - desired-indent))) - -(defun scheme-indent-function (indent-point state) - (let ((normal-indent (current-column))) - (save-excursion - (goto-char (1+ (car (cdr state)))) - (re-search-forward "\\sw\\|\\s_") - (if (/= (point) (car (cdr state))) - (let ((function (buffer-substring (progn (forward-char -1) (point)) - (progn (forward-sexp 1) (point)))) - method) - ;; Who cares about this, really? - ;(if (not (string-match "\\\\\\||" function))) - (setq function (downcase function)) - (setq method (get (intern-soft function) 'scheme-indent-function)) - (cond ((integerp method) - (scheme-indent-specform method state indent-point)) - (method - (funcall method state indent-point)) - ((and (> (length function) 3) - (string-equal (substring function 0 3) "def")) - (scheme-indent-defform state indent-point)))))))) - -(defvar scheme-body-indent 2 "") - -(defun scheme-indent-specform (count state indent-point) - (let ((containing-form-start (car (cdr state))) (i count) - body-indent containing-form-column) - ;; Move to the start of containing form, calculate indentation - ;; to use for non-distinguished forms (> count), and move past the - ;; function symbol. scheme-indent-function guarantees that there is at - ;; least one word or symbol character following open paren of containing - ;; form. - (goto-char containing-form-start) - (setq containing-form-column (current-column)) - (setq body-indent (+ scheme-body-indent containing-form-column)) - (forward-char 1) - (forward-sexp 1) - ;; Now find the start of the last form. - (parse-partial-sexp (point) indent-point 1 t) - (while (and (< (point) indent-point) - (condition-case nil - (progn - (setq count (1- count)) - (forward-sexp 1) - (parse-partial-sexp (point) indent-point 1 t)) - (error nil)))) - ;; Point is sitting on first character of last (or count) sexp. - (cond ((> count 0) - ;; A distinguished form. Use double scheme-body-indent. - (list (+ containing-form-column (* 2 scheme-body-indent)) - containing-form-start)) - ;; A non-distinguished form. Use body-indent if there are no - ;; distinguished forms and this is the first undistinguished - ;; form, or if this is the first undistinguished form and - ;; the preceding distinguished form has indentation at least - ;; as great as body-indent. - ((and (= count 0) - (or (= i 0) - (<= body-indent normal-indent))) - body-indent) - (t - normal-indent)))) - -(defun scheme-indent-defform (state indent-point) - (goto-char (car (cdr state))) - (forward-line 1) - (if (> (point) (car (cdr (cdr state)))) - (progn - (goto-char (car (cdr state))) - (+ scheme-body-indent (current-column))))) - -;;; Let is different in Scheme - -(defun would-be-symbol (string) - (not (string-equal (substring string 0 1) "("))) - -(defun next-sexp-as-string () - ;; Assumes that protected by a save-excursion - (forward-sexp 1) - (let ((the-end (point))) - (backward-sexp 1) - (buffer-substring (point) the-end))) - -;; This is correct but too slow. -;; The one below works almost always. -;;(defun scheme-let-indent (state indent-point) -;; (if (would-be-symbol (next-sexp-as-string)) -;; (scheme-indent-specform 2 state indent-point) -;; (scheme-indent-specform 1 state indent-point))) - -(defun scheme-let-indent (state indent-point) - (skip-chars-forward " \t") - (if (looking-at "[-a-zA-Z0-9+*/?!@$%^&_:~]") - (scheme-indent-specform 2 state indent-point) - (scheme-indent-specform 1 state indent-point))) - -;; (put 'begin 'scheme-indent-function 0), say, causes begin to be indented -;; like defun if the first form is placed on the next line, otherwise -;; it is indented like any other form (i.e. forms line up under first). - -(put 'begin 'scheme-indent-function 0) -(put 'case 'scheme-indent-function 1) -(put 'delay 'scheme-indent-function 0) -(put 'do 'scheme-indent-function 2) -(put 'lambda 'scheme-indent-function 1) -(put 'let 'scheme-indent-function 'scheme-let-indent) -(put 'let* 'scheme-indent-function 1) -(put 'letrec 'scheme-indent-function 1) -(put 'sequence 'scheme-indent-function 0) - -(put 'call-with-input-file 'scheme-indent-function 1) -(put 'with-input-from-file 'scheme-indent-function 1) -(put 'with-input-from-port 'scheme-indent-function 1) -(put 'call-with-output-file 'scheme-indent-function 1) -(put 'with-output-to-file 'scheme-indent-function 1) -(put 'with-output-to-port 'scheme-indent-function 1) - -;;;; MIT Scheme specific indentation. - -(if scheme-mit-dialect - (progn - (put 'fluid-let 'scheme-indent-function 1) - (put 'in-package 'scheme-indent-function 1) - (put 'let-syntax 'scheme-indent-function 1) - (put 'local-declare 'scheme-indent-function 1) - (put 'macro 'scheme-indent-function 1) - (put 'make-environment 'scheme-indent-function 0) - (put 'named-lambda 'scheme-indent-function 1) - (put 'using-syntax 'scheme-indent-function 1) - - (put 'with-input-from-string 'scheme-indent-function 1) - (put 'with-output-to-string 'scheme-indent-function 0) - (put 'with-values 'scheme-indent-function 1) - - (put 'syntax-table-define 'scheme-indent-function 2) - (put 'list-transform-positive 'scheme-indent-function 1) - (put 'list-transform-negative 'scheme-indent-function 1) - (put 'list-search-positive 'scheme-indent-function 1) - (put 'list-search-negative 'scheme-indent-function 1) - - (put 'access-components 'scheme-indent-function 1) - (put 'assignment-components 'scheme-indent-function 1) - (put 'combination-components 'scheme-indent-function 1) - (put 'comment-components 'scheme-indent-function 1) - (put 'conditional-components 'scheme-indent-function 1) - (put 'disjunction-components 'scheme-indent-function 1) - (put 'declaration-components 'scheme-indent-function 1) - (put 'definition-components 'scheme-indent-function 1) - (put 'delay-components 'scheme-indent-function 1) - (put 'in-package-components 'scheme-indent-function 1) - (put 'lambda-components 'scheme-indent-function 1) - (put 'lambda-components* 'scheme-indent-function 1) - (put 'lambda-components** 'scheme-indent-function 1) - (put 'open-block-components 'scheme-indent-function 1) - (put 'pathname-components 'scheme-indent-function 1) - (put 'procedure-components 'scheme-indent-function 1) - (put 'sequence-components 'scheme-indent-function 1) - (put 'unassigned\?-components 'scheme-indent-function 1) - (put 'unbound\?-components 'scheme-indent-function 1) - (put 'variable-components 'scheme-indent-function 1))) - -(defun scheme-indent-sexp () - "Indent each line of the list starting just after point." - (interactive) - (let ((indent-stack (list nil)) (next-depth 0) bol - outer-loop-done inner-loop-done state this-indent) - (save-excursion (forward-sexp 1)) - (save-excursion - (setq outer-loop-done nil) - (while (not outer-loop-done) - (setq last-depth next-depth - innerloop-done nil) - (while (and (not innerloop-done) - (not (setq outer-loop-done (eobp)))) - (setq state (parse-partial-sexp (point) (progn (end-of-line) (point)) - nil nil state)) - (setq next-depth (car state)) - (if (car (nthcdr 4 state)) - (progn (indent-for-comment) - (end-of-line) - (setcar (nthcdr 4 state) nil))) - (if (car (nthcdr 3 state)) - (progn - (forward-line 1) - (setcar (nthcdr 5 state) nil)) - (setq innerloop-done t))) - (if (setq outer-loop-done (<= next-depth 0)) - nil - (while (> last-depth next-depth) - (setq indent-stack (cdr indent-stack) - last-depth (1- last-depth))) - (while (< last-depth next-depth) - (setq indent-stack (cons nil indent-stack) - last-depth (1+ last-depth))) - (forward-line 1) - (setq bol (point)) - (skip-chars-forward " \t") - (if (or (eobp) (looking-at "[;\n]")) - nil - (if (and (car indent-stack) - (>= (car indent-stack) 0)) - (setq this-indent (car indent-stack)) - (let ((val (calculate-scheme-indent - (if (car indent-stack) (- (car indent-stack)))))) - (if (integerp val) - (setcar indent-stack - (setq this-indent val)) - (if (cdr val) - (setcar indent-stack (- (car (cdr val))))) - (setq this-indent (car val))))) - (if (/= (current-column) this-indent) - (progn (delete-region bol (point)) - (indent-to this-indent))))))))) - -(provide 'scheme) - -;;; scheme.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/scribe.el --- a/lisp/modes/scribe.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,320 +0,0 @@ -;;; scribe.el --- scribe mode, and its idiosyncratic commands. -;; Keywords: wp - -;; Copyright (C) 1985 Free Software Foundation, Inc. - -;; This file is part of XEmacs. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but without any warranty. No author or distributor -;; accepts responsibility to anyone for the consequences of using it -;; or for whether it serves any particular purpose or works at all, -;; unless he says so in writing. - -;; Everyone is granted permission to copy, modify and redistribute -;; GNU Emacs, but only under the conditions described in the -;; document "GNU Emacs copying permission notice". An exact copy -;; of the document is supposed to have been given to you along with -;; GNU Emacs so that you can know how you may redistribute it all. -;; It should be in a file named COPYING. Among other things, the -;; copyright notice and this notice must be preserved on all copies. - -(defgroup scribe nil - "Scribe mode, and its idiosyncratic commands." - :group 'wp) - - -(defvar scribe-mode-syntax-table nil - "Syntax table used while in scribe mode.") - -(defvar scribe-mode-abbrev-table nil - "Abbrev table used while in scribe mode.") - -(defcustom scribe-fancy-paragraphs nil - "*Non-NIL makes Scribe mode use a different style of paragraph separation." - :type 'boolean - :group 'scribe) - -(defcustom scribe-electric-quote nil - "*Non-NIL makes insert of double quote use `` or '' depending on context." - :type 'boolean - :group 'scribe) - -(defcustom scribe-electric-parenthesis nil - "*Non-NIL makes parenthesis char ( (]}> ) automatically insert its close -if typed after an @Command form." - :type 'boolean - :group 'scribe) - -(defconst scribe-open-parentheses "[({<" - "Open parenthesis characters for Scribe.") - -(defconst scribe-close-parentheses "])}>" - "Close parenthesis characters for Scribe. These should match up with -scribe-open-parenthesis.") - -(if (null scribe-mode-syntax-table) - (let ((st (syntax-table))) - (unwind-protect - (progn - (setq scribe-mode-syntax-table (copy-syntax-table - text-mode-syntax-table)) - (set-syntax-table scribe-mode-syntax-table) - (modify-syntax-entry ?\" " ") - (modify-syntax-entry ?\\ " ") - (modify-syntax-entry ?@ "w ") - (modify-syntax-entry ?< "(> ") - (modify-syntax-entry ?> ")< ") - (modify-syntax-entry ?[ "(] ") - (modify-syntax-entry ?] ")[ ") - (modify-syntax-entry ?{ "(} ") - (modify-syntax-entry ?} "){ ") - (modify-syntax-entry ?' "w ")) - (set-syntax-table st)))) - -(defvar scribe-mode-map nil) - -(if scribe-mode-map - nil - (setq scribe-mode-map (make-sparse-keymap)) - (define-key scribe-mode-map "\t" 'scribe-tab) - (define-key scribe-mode-map "\e\t" 'tab-to-tab-stop) - (define-key scribe-mode-map "\es" 'center-line) - (define-key scribe-mode-map "\e}" 'up-list) - (define-key scribe-mode-map "\eS" 'center-paragraph) - (define-key scribe-mode-map "\"" 'scribe-insert-quote) - (define-key scribe-mode-map "(" 'scribe-parenthesis) - (define-key scribe-mode-map "[" 'scribe-parenthesis) - (define-key scribe-mode-map "{" 'scribe-parenthesis) - (define-key scribe-mode-map "<" 'scribe-parenthesis) - (define-key scribe-mode-map "\^cc" 'scribe-chapter) - (define-key scribe-mode-map "\^cS" 'scribe-section) - (define-key scribe-mode-map "\^cs" 'scribe-subsection) - (define-key scribe-mode-map "\^ce" 'scribe-insert-environment) - (define-key scribe-mode-map "\^c\^e" 'scribe-bracket-region-be) - (define-key scribe-mode-map "\^c[" 'scribe-begin) - (define-key scribe-mode-map "\^c]" 'scribe-end) - (define-key scribe-mode-map "\^ci" 'scribe-italicize-word) - (define-key scribe-mode-map "\^cb" 'scribe-bold-word) - (define-key scribe-mode-map "\^cu" 'scribe-underline-word)) - -;;;###autoload -(defun scribe-mode () - "Major mode for editing files of Scribe (a text formatter) source. -Scribe-mode is similar text-mode, with a few extra commands added. -\\{scribe-mode-map} - -Interesting variables: - -scribe-fancy-paragraphs - Non-nil makes Scribe mode use a different style of paragraph separation. - -scribe-electric-quote - Non-nil makes insert of double quote use `` or '' depending on context. - -scribe-electric-parenthesis - Non-nil makes an open-parenthesis char (one of `([<{') - automatically insert its close if typed after an @Command form." - (interactive) - (kill-all-local-variables) - (use-local-map scribe-mode-map) - (setq mode-name "Scribe") - (setq major-mode 'scribe-mode) - (define-abbrev-table 'scribe-mode-abbrev-table ()) - (setq local-abbrev-table scribe-mode-abbrev-table) - (make-local-variable 'comment-start) - (setq comment-start "@Comment[") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip (concat "@Comment[" scribe-open-parentheses "]")) - (make-local-variable 'comment-column) - (setq comment-column 0) - (make-local-variable 'comment-end) - (setq comment-end "]") - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "\\(^[\n\f]\\)\\|\\(^@\\w+[" - scribe-open-parentheses - "].*[" - scribe-close-parentheses - "]$\\)")) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate (if scribe-fancy-paragraphs - paragraph-start "^$")) - (make-local-variable 'compile-command) - (setq compile-command (concat "scribe " (buffer-file-name))) - (set-syntax-table scribe-mode-syntax-table) - (run-hooks 'text-mode-hook 'scribe-mode-hook)) - -(defun scribe-tab () - (interactive) - (insert "@\\")) - -;; This algorithm could probably be improved somewhat. -;; Right now, it loses seriously... - -(defun scribe () - "Run Scribe on the current buffer." - (interactive) - (call-interactively 'compile)) - -(defun scribe-envelop-word (string count) - "Surround current word with Scribe construct @STRING[...]. COUNT -specifies how many words to surround. A negative count means to skip -backward." - (let ((spos (point)) (epos (point)) (ccoun 0)) - (if (not (zerop count)) - (progn (if (= (char-syntax (preceding-char)) ?w) - (forward-sexp (min -1 count))) - (setq spos (point)) - (if (looking-at (concat "@\\w[" scribe-open-parentheses "]")) - (forward-char 2) - (goto-char epos) - (skip-chars-backward "\\W") - (forward-char -1)) - (forward-sexp (max count 1)) - (setq epos (point)))) - (goto-char spos) - (while (and (< ccoun (length scribe-open-parentheses)) - (save-excursion - (or (search-forward (char-to-string - (aref scribe-open-parentheses ccoun)) - epos t) - (search-forward (char-to-string - (aref scribe-close-parentheses ccoun)) - epos t))) - (setq ccoun (1+ ccoun)))) - (if (>= ccoun (length scribe-open-parentheses)) - (progn (goto-char epos) - (insert "@end(" string ")") - (goto-char spos) - (insert "@begin(" string ")")) - (goto-char epos) - (insert (aref scribe-close-parentheses ccoun)) - (goto-char spos) - (insert "@" string (aref scribe-open-parentheses ccoun)) - (goto-char epos) - (forward-char 3) - (skip-chars-forward scribe-close-parentheses)))) - -(defun scribe-underline-word (count) - "Underline COUNT words around point by means of Scribe constructs." - (interactive "p") - (scribe-envelop-word "u" count)) - -(defun scribe-bold-word (count) - "Boldface COUNT words around point by means of Scribe constructs." - (interactive "p") - (scribe-envelop-word "b" count)) - -(defun scribe-italicize-word (count) - "Italicize COUNT words around point by means of Scribe constructs." - (interactive "p") - (scribe-envelop-word "i" count)) - -(defun scribe-begin () - (interactive) - (insert "\n") - (forward-char -1) - (scribe-envelop-word "Begin" 0) - (re-search-forward (concat "[" scribe-open-parentheses "]"))) - -(defun scribe-end () - (interactive) - (insert "\n") - (forward-char -1) - (scribe-envelop-word "End" 0) - (re-search-forward (concat "[" scribe-open-parentheses "]"))) - -(defun scribe-chapter () - (interactive) - (insert "\n") - (forward-char -1) - (scribe-envelop-word "Chapter" 0) - (re-search-forward (concat "[" scribe-open-parentheses "]"))) - -(defun scribe-section () - (interactive) - (insert "\n") - (forward-char -1) - (scribe-envelop-word "Section" 0) - (re-search-forward (concat "[" scribe-open-parentheses "]"))) - -(defun scribe-subsection () - (interactive) - (insert "\n") - (forward-char -1) - (scribe-envelop-word "SubSection" 0) - (re-search-forward (concat "[" scribe-open-parentheses "]"))) - -(defun scribe-bracket-region-be (env min max) - (interactive "sEnvironment: \nr") - (save-excursion - (goto-char max) - (insert "@end(" env ")\n") - (goto-char min) - (insert "@begin(" env ")\n"))) - -(defun scribe-insert-environment (env) - (interactive "sEnvironment: ") - (scribe-bracket-region-be env (point) (point)) - (forward-line 1) - (insert ?\n) - (forward-char -1)) - -(defun scribe-insert-quote (count) - "If scribe-electric-quote is non-NIL, insert ``, '' or \" according -to preceding character. With numeric arg N, always insert N \" characters. -Else just insert \"." - (interactive "P") - (if (or count (not scribe-electric-quote)) - (self-insert-command (prefix-numeric-value count)) - (let (lastfore lastback lastquote) - (insert - (cond - ((= (preceding-char) ?\\) ?\") - ((bobp) "``") - (t - (setq lastfore (save-excursion (and (search-backward - "``" (- (point) 1000) t) - (point))) - lastback (save-excursion (and (search-backward - "''" (- (point) 1000) t) - (point))) - lastquote (save-excursion (and (search-backward - "\"" (- (point) 100) t) - (point)))) - (if (not lastquote) - (cond ((not lastfore) "``") - ((not lastback) "''") - ((> lastfore lastback) "''") - (t "``")) - (cond ((and (not lastback) (not lastfore)) "\"") - ((and lastback (not lastfore) (> lastquote lastback)) "\"") - ((and lastback (not lastfore) (> lastback lastquote)) "``") - ((and lastfore (not lastback) (> lastquote lastfore)) "\"") - ((and lastfore (not lastback) (> lastfore lastquote)) "''") - ((and (> lastquote lastfore) (> lastquote lastback)) "\"") - ((> lastfore lastback) "''") - (t "``"))))))))) - -(defun scribe-parenthesis (count) - "If scribe-electric-parenthesis is non-NIL, insertion of an open-parenthesis -character inserts the following close parenthesis character if the -preceding text is of the form @Command." - (interactive "P") - (self-insert-command (prefix-numeric-value count)) - (let (at-command paren-char point-save) - (if (or count (not scribe-electric-parenthesis)) - nil - (save-excursion - (forward-char -1) - (setq point-save (point)) - (skip-chars-backward (concat "^ \n\t\f" scribe-open-parentheses)) - (setq at-command (and (equal (following-char) ?@) - (/= (point) (1- point-save))))) - (if (and at-command - (setq paren-char - (string-match (regexp-quote - (char-to-string (preceding-char))) - scribe-open-parentheses))) - (save-excursion - (insert (aref scribe-close-parentheses paren-char))))))) diff -r 43306a74e31c -r d44af0c54775 lisp/modes/sendmail.el --- a/lisp/modes/sendmail.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1289 +0,0 @@ -;;; sendmail.el --- mail sending commands for Emacs. - -;; Copyright (C) 1985, 1986, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: mail - -;; This file is part of XEmacs. - -;; XEmacs 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. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: FSF 19.30. - -;;; Commentary: - -;; This mode provides mail-sending facilities from within Emacs. It is -;; documented in the Emacs user's manual. - -;;; Code: - -;;;###autoload -(defvar mail-from-style 'angles "\ -*Specifies how \"From:\" fields look. - -If `nil', they contain just the return address like: - king@grassland.com -If `parens', they look like: - king@grassland.com (Elvis Parsley) -If `angles', they look like: - Elvis Parsley ") - -;;;###autoload -(defvar mail-self-blind nil "\ -Non-nil means insert BCC to self in messages to be sent. -This is done when the message is initialized, -so you can remove or alter the BCC field to override the default.") - -;;;###autoload -(defvar mail-interactive nil "\ -Non-nil means when sending a message wait for and display errors. -nil means let mailer mail back a message to report errors.") - -;;;###autoload -(defvar mail-dir nil "*Default directory for saving messages.") - -;;; XEmacs change: moved rmail-ignored-headers here from rmail.el so that -;;; the value of mail-yank-ignored-headers can default from it. Both of -;;; these end up in loaddefs.el, but "sendmail" comes before "rmail", so... -;;; -;;;###autoload -(defvar rmail-ignored-headers - (purecopy - (concat - "^\\(" - (mapconcat - 'identity - '(;; RFC822 - "Sender:" "References:" "Return-Path:" "Received:" - "[^: \t\n]*Message-ID:" "Errors-To:" - ;; RFC977 (NNTP) - "Path:" "Expires:" "Xref:" "Lines:" "Approved:" "Distribution:" - ;; SYSV mail: - "Content-Length:" - ;; MIME: - "Mime-Version:" "Content-Type:" "Content-Transfer-Encoding:" - ;; X400 - "X400-Received:" "X400-Originator:" "X400-Mts-Identifier:" - "X400-Content-Type:" "Content-Identifier:" - ;; RMAIL and /usr/ucb/mail: - "Status:" "Summary-Line:" - ;; Supercite: - "X-Attribution:" - ;; Other random junk occasionally seen: - "Via:" "Sent-Via:" "Mail-From:" "Origin:" "Comments:" "Originator:" - "NF-ID:" "NF-From:" "Posting-Version:" "Posted:" "Posted-Date:" - "Date-Received:" "Relay-Version:" "Article-I\\.D\\.:" "NNTP-Version:" - "NNTP-Posting-Host:" "X-Mailer:" "X-Newsreader:" "News-Software:" - "X-Received:" "X-References:" "X-Envelope-To:" - "X-VMS-" "Remailed-" "X-Plantation:" "X-Windows:" "X-Pgp-" - ) - "\\|") - "\\)")) - "*Gubbish header fields one would rather not see.") - - -;;;###autoload -(defvar mail-yank-ignored-headers - (purecopy - (concat rmail-ignored-headers "\\|" - "^\\(" - (mapconcat 'identity - '(;; RFC822 - "Resent-To:" "Resent-By:" "Resent-CC:" - "To:" "Subject:" "In-Reply-To:" - ) - "\\|") - "\\)")) - "Delete these headers from old message when it's inserted in a reply.") -;; minimalist FSF version -;(defvar mail-yank-ignored-headers "^via:\\|^mail-from:\\|^origin:\\|^status:\\|^remailed\\|^received:\\|^message-id:\\|^summary-line:\\|^to:\\|^subject:\\|^in-reply-to:\\|^return-path:" "\ -;Delete these headers from old message when it's inserted in a reply.") - -;; Useful to set in site-init.el -;;;###autoload -(defvar send-mail-function 'sendmail-send-it "\ -Function to call to send the current buffer as mail. -The headers should be delimited by a line whose contents -match the variable `mail-header-separator'.") - -;;;###autoload -(defvar mail-header-separator (purecopy "--text follows this line--") "\ -*Line used to separate headers from text in messages being composed.") - -;;;###autoload -(defvar mail-archive-file-name nil "\ -*Name of file to write all outgoing messages in, or nil for none. -This can be an inbox file or an Rmail file.") - -;;;###autoload -(defvar mail-default-reply-to nil - "*Address to insert as default Reply-to field of outgoing messages. -If nil, it will be initialized from the REPLYTO environment variable -when you first send mail.") - -;;;###autoload -(defvar mail-alias-file nil - "*If non-nil, the name of a file to use instead of `/usr/lib/aliases'. -This file defines aliases to be expanded by the mailer; this is a different -feature from that of defining aliases in `.mailrc' to be expanded in Emacs. -This variable has no effect unless your system uses sendmail as its mailer.") - -;(defvar mail-personal-alias-file "~/.mailrc" -; "*If non-nil, the name of the user's personal mail alias file. -;This file typically should be in same format as the `.mailrc' file used by -;the `Mail' or `mailx' program. -;This file need not actually exist.") -(defvaralias 'mail-personal-alias-file 'mail-abbrev-mailrc-file) - -(defvar mail-setup-hook nil - "Normal hook, run each time a new outgoing mail message is initialized. -The function `mail-setup' runs this hook.") - -; These are removed. See `mail-abbrevs.el'. - -;(defvar mail-aliases t -; "Alist of mail address aliases, -;or t meaning should be initialized from your mail aliases file. -;\(The file's name is normally `~/.mailrc', but your MAILRC environment -;variable can override that name.) -;The alias definitions in the file have this form: -; alias ALIAS MEANING") -; -;(defvar mail-alias-modtime nil -; "The modification time of your mail alias file when it was last examined.") - -;;;###autoload -(defvar mail-yank-prefix "> " ; XEmacs change - "*Prefix insert on lines of yanked message being replied to. -nil means use indentation.") - -(defvar mail-indentation-spaces 3 - "*Number of spaces to insert at the beginning of each cited line. -Used by `mail-yank-original' via `mail-indent-citation'.") - -(defvar mail-yank-hooks nil - "Obsolete hook for modifying a citation just inserted in the mail buffer. -Each hook function can find the citation between (point) and (mark t). -And each hook function should leave point and mark around the citation -text as modified. - -This is a normal hook, misnamed for historical reasons. -It is semi-obsolete and mail agents should no longer use it.") - -(defvar mail-citation-hook nil - "*Hook for modifying a citation just inserted in the mail buffer. -Each hook function can find the citation between (point) and (mark t). -And each hook function should leave point and mark around the citation -text as modified. - -If this hook is entirely empty (nil), a default action is taken -instead of no action.") - -(defvar mail-abbrevs-loaded nil) -(defvar mail-mode-map nil) - -; Removed autoloads of `build-mail-aliases' and `expand-mail-aliases'. -; See `mail-abbrevs.el'. - -(autoload 'mail-aliases-setup "mail-abbrevs") - -;;;###autoload -(defvar mail-signature nil - "*Text inserted at end of mail buffer when a message is initialized. -If t, it means to insert the contents of the file `mail-signature-file'.") - -(defvar mail-signature-file "~/.signature" - "*File containing the text inserted at end of mail buffer.") - -(defvar mail-reply-buffer nil) -(defvar mail-send-actions nil - "A list of actions to be performed upon successful sending of a message.") - -(defvar mail-default-headers nil - "*A string containing header lines, to be inserted in outgoing messages. -It is inserted before you edit the message, -so you can edit or delete these lines.") - -(defvar mail-bury-selects-summary t - "*If non-nil, try to show RMAIL summary buffer after returning from mail. -The functions \\[mail-send-on-exit] or \\[mail-dont-send] select -the RMAIL summary buffer before returning, if it exists and this variable -is non-nil.") - -;; Note: could use /usr/ucb/mail instead of sendmail; -;; options -t, and -v if not interactive. -(defvar mail-mailer-swallows-blank-line - (if (and (string-match "sparc-sun-sunos\\(\\'\\|[^5]\\)" system-configuration) - (file-readable-p "/etc/sendmail.cf") - (let ((buffer (get-buffer-create " *temp*"))) - (unwind-protect - (save-excursion - (set-buffer buffer) - (insert-file-contents "/etc/sendmail.cf") - (goto-char (point-min)) - (let ((case-fold-search nil)) - (re-search-forward "^OR\\>" nil t))) - (kill-buffer buffer)))) - ;; According to RFC822, "The field-name must be composed of printable - ;; ASCII characters (i.e. characters that have decimal values between - ;; 33 and 126, except colon)", i.e. any chars except ctl chars, - ;; space, or colon. - '(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:")) - "Set this non-nil if the system's mailer runs the header and body together. -\(This problem exists on Sunos 4 when sendmail is run in remote mode.) -The value should be an expression to test whether the problem will -actually occur.") - -(defvar mail-use-multiple-buffers-p t - "Non-nil means `mail' will create a new buffer if one already exists.") - -(defvar mail-mode-syntax-table nil - "Syntax table used while in mail mode.") - -(if (not mail-mode-syntax-table) - (progn - (setq mail-mode-syntax-table (copy-syntax-table text-mode-syntax-table)) - (modify-syntax-entry ?% ". " mail-mode-syntax-table))) - -(defvar mail-font-lock-keywords - (let* ((cite-prefix "A-Za-z") (cite-suffix (concat cite-prefix "0-9_.@-"))) - (list '("^To:" . font-lock-function-name-face) - '("^B?CC:\\|^Reply-To:" . font-lock-keyword-face) - '("^\\(Subject:\\)[ \t]*\\(.+\\)?" - (1 font-lock-comment-face) (2 font-lock-type-face nil t)) - (list (concat "^\\(" (regexp-quote mail-header-separator) "\\)$") - 1 'font-lock-comment-face) - (cons (concat "^[ \t]*" - "\\([" cite-prefix "]+[" cite-suffix "]*\\)?" - "[>|}].*") - 'font-lock-reference-face) - '("^\\(X-[A-Za-z0-9-]+\\|In-reply-to\\):.*" - . font-lock-string-face))) - "Additional expressions to highlight in Mail mode.") -(put 'mail-mode 'font-lock-defaults '(mail-font-lock-keywords t)) - -(defvar mail-send-hook nil - "Normal hook run before sending mail, in Mail mode.") - -; Removed. See above and `mail-abbrevs.el'. -;(defun sendmail-synch-aliases () -; (let ((modtime (nth 5 (file-attributes mail-personal-alias-file)))) -; (or (equal mail-alias-modtime modtime) -; (setq mail-alias-modtime modtime -; mail-aliases t)))) - -;; Courtesy of Per Abrahamsen in an attempt to make -;; Emacs and XEmacs less stupid about default mail addresses. - -;; We trust the administrator if he has set `mail-host-address'. -;; We trust the user if he has already customized `user-mail-address'. -(defcustom query-user-mail-address (and (not mail-host-address) - (not user-mail-address)) - "If non-nil, prompt the user for his mail address." - :group 'message - :type 'boolean) - -;;;###autoload -(defun user-mail-address () - "Query the user for his mail address, unless it is already known." - (interactive) - (when (and (not noninteractive) query-user-mail-address) - (let ((addr (or user-mail-address - (concat (user-login-name) "@" - (or mail-host-address - (system-name)))))) - (setq user-mail-address - (read-string "Your mail address? " (cons addr 0))) - (setq query-user-mail-address nil) - ;; TODO: Run sanity check from Gnus here. - (when (y-or-n-p "Save address for future sessions? ") - (put 'user-mail-address 'saved-value - (list user-mail-address)) - (put 'query-user-mail-address 'saved-value '(nil)) - (require 'cus-edit) - (custom-save-all)))) - (if user-mail-address - user-mail-address - (setq user-mail-address (concat (user-login-name) "@" - (or mail-host-address - (system-name)))))) - -(defun mail-setup (to subject in-reply-to cc replybuffer actions) - (or mail-default-reply-to - (setq mail-default-reply-to (getenv "REPLYTO"))) -;Removed. See `mail-abbrevs.el'. -; (sendmail-synch-aliases) -; (if (eq mail-aliases t) -; (progn -; (setq mail-aliases nil) -; (if (file-exists-p mail-personal-alias-file) -; (build-mail-aliases)))) - (setq mail-send-actions actions) - (mail-aliases-setup) - (setq mail-reply-buffer replybuffer) - (goto-char (point-min)) - (insert "To: ") - (save-excursion - (if to - ;; Here removed code to extract names from within <...> - ;; on the assumption that mail-strip-quoted-names - ;; has been called and has done so. - (let ((fill-prefix "\t") - (address-start (point))) - (insert to "\n") - (fill-region-as-paragraph address-start (point-max))) - (newline)) - (if cc - (let ((fill-prefix "\t") - (address-start (progn (insert "CC: ") (point)))) - (insert cc "\n") - (fill-region-as-paragraph address-start (point-max)))) - (if in-reply-to - (let ((fill-prefix "\t") - (fill-column 78) - (address-start (point))) - (insert "In-reply-to: " in-reply-to "\n") - (fill-region-as-paragraph address-start (point-max)))) - (insert "Subject: " (or subject "") "\n") - (if mail-default-headers - (insert mail-default-headers)) - (if mail-default-reply-to - (insert "Reply-to: " mail-default-reply-to "\n")) - (if mail-self-blind - (insert "BCC: " (user-login-name) "\n")) - (if mail-archive-file-name - (insert "FCC: " mail-archive-file-name "\n")) - (insert mail-header-separator "\n") - - ;; Insert the signature. But remember the beginning of the message. - (if to (setq to (point))) - (cond ((eq mail-signature t) - (if (file-exists-p mail-signature-file) - (progn - (insert "\n\n-- \n") - (insert-file-contents mail-signature-file)))) - (mail-signature - (insert mail-signature))) - (goto-char (point-max)) - (or (bolp) (newline))) - (if to (goto-char to)) - (or to subject in-reply-to - (set-buffer-modified-p nil)) - (run-hooks 'mail-setup-hook)) - -;;;###autoload -(defun mail-mode () - "Major mode for editing mail to be sent. -Like Text Mode but with these additional commands: -C-c C-s mail-send (send the message) C-c C-c mail-send-and-exit -C-c C-f move to a header field (and create it if there isn't): - C-c C-f C-t move to To: C-c C-f C-s move to Subj: - C-c C-f C-b move to BCC: C-c C-f C-c move to CC: - C-c C-f C-f move to FCC: C-c C-f C-r move to Reply-To: -C-c C-t mail-text (move to beginning of message text). -C-c C-w mail-signature (insert `mail-signature-file' file). -C-c C-y mail-yank-original (insert current message, in Rmail). -C-c C-q mail-fill-yanked-message (fill what was yanked). -C-c C-v mail-sent-via (add a sent-via field for each To or CC)." - (interactive) - (kill-all-local-variables) - (make-local-variable 'mail-reply-buffer) - (setq mail-reply-buffer nil) - (make-local-variable 'mail-send-actions) - (set-syntax-table mail-mode-syntax-table) - (use-local-map mail-mode-map) - (setq local-abbrev-table text-mode-abbrev-table) - (setq major-mode 'mail-mode) - (setq mode-name "Mail") - (setq buffer-offer-save t) - (turn-on-auto-fill) ; XEmacs - maybe filladapt should be default, too. - (make-local-variable 'paragraph-separate) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat (regexp-quote mail-header-separator) - "$\\|[ \t]*[-_][-_][-_]+$\\|" - paragraph-start)) - (setq paragraph-separate (concat (regexp-quote mail-header-separator) - "$\\|[ \t]*[-_][-_][-_]+$\\|" - paragraph-separate)) - ;; Set menu - (setq mode-popup-menu mail-popup-menu) - (if (featurep 'menubar) - (progn - ;; make a local copy of the menubar, so our modes don't - ;; change the global menubar - (set-buffer-menubar current-menubar) - (add-submenu nil mail-menubar-menu))) - - (run-hooks 'text-mode-hook 'mail-mode-hook)) - - -;;; Set up keymap. - -(if mail-mode-map - nil - (setq mail-mode-map (make-sparse-keymap)) - (set-keymap-parents mail-mode-map (list text-mode-map)) - (set-keymap-name mail-mode-map 'mail-mode-map) - (define-key mail-mode-map "\C-c?" 'describe-mode) - (define-key mail-mode-map "\C-c\C-f\C-t" 'mail-to) - (define-key mail-mode-map "\C-c\C-f\C-b" 'mail-bcc) - (define-key mail-mode-map "\C-c\C-f\C-f" 'mail-fcc) - (define-key mail-mode-map "\C-c\C-f\C-c" 'mail-cc) - (define-key mail-mode-map "\C-c\C-f\C-s" 'mail-subject) - (define-key mail-mode-map "\C-c\C-f\C-r" 'mail-reply-to) - (define-key mail-mode-map "\C-c\C-t" 'mail-text) - (define-key mail-mode-map "\C-c\C-y" 'mail-yank-original) - (define-key mail-mode-map "\C-c\C-q" 'mail-fill-yanked-message) - (define-key mail-mode-map "\C-c\C-w" 'mail-signature) - ;;CRAP!!(define-key mail-mode-map "\C-c\C-v" 'mail-sent-via)CRAP! - (define-key mail-mode-map "\C-c\C-c" 'mail-send-and-exit) - (define-key mail-mode-map "\C-c\C-s" 'mail-send)) - -;;; mail-mode popup menu - -(defvar mail-menubar-menu - (purecopy - '("Mail" - "Sending Mail:" - "----" - ["Send and Exit" mail-send-and-exit t] - ["Send Mail" mail-send t] - "----" - "Go to Field:" - "----" - ["To:" mail-to t] - ["Subject:" mail-subject t] - ["CC:" mail-cc t] - ["BCC:" mail-bcc t] - ["Reply-To:" mail-reply-to t] - ;; ["Sent Via:" mail-sent-via t] - ["Text" mail-text t] - "----" - "Miscellaneous Commands:" - "----" - ["Yank Original" mail-yank-original - (not (null mail-reply-buffer))] - ["Fill Yanked Message" mail-fill-yanked-message - (save-excursion - (goto-char (point-min)) - (and (search-forward (concat "\n" mail-header-separator - "\n") nil t) - (not (looking-at "[ \t\n]*\\'"))))] - ["Insert Signature" mail-signature - (and (stringp mail-signature-file) - (file-exists-p mail-signature-file))] - ["Insert File..." insert-file t] - ["Insert Buffer..." insert-buffer t] - "----" - ["Cancel" mail-dont-send t] - )) - "Menubar menu for `mail-mode'.") - -(defvar mail-popup-menu - (purecopy - (cons "Sendmail Commands" - (cdr mail-menubar-menu))) - "Menubar menu for `mail-mode'.") - - -(defun mail-send-and-exit (arg) - "Send message like `mail-send', then, if no errors, exit from mail buffer. -Prefix arg means don't delete this window." - (interactive "P") - (mail-send) - (mail-bury arg)) - -(defun mail-dont-send (arg) - "Don't send the message you have been editing. -Prefix arg means don't delete this window." - (interactive "P") - (mail-bury arg)) - -(defvar rmail-summary-buffer) - -(defun mail-bury (arg) - "Bury this mail buffer." - (let ((newbuf (other-buffer (current-buffer)))) - (bury-buffer (current-buffer)) - (if (and (fboundp 'frame-parameters) - (cdr (assq 'dedicated (frame-parameters))) - (not (null (delq (selected-frame) (visible-frame-list))))) - (delete-frame (selected-frame)) - (let (rmail-flag summary-buffer) - (and (not arg) - (not (one-window-p)) - (save-excursion - (set-buffer (window-buffer (next-window (selected-window) 'not))) - (setq rmail-flag (eq major-mode 'rmail-mode)) - (setq summary-buffer - (and mail-bury-selects-summary - (boundp 'rmail-summary-buffer) - rmail-summary-buffer - (buffer-name rmail-summary-buffer) - (not (get-buffer-window rmail-summary-buffer)) - rmail-summary-buffer)))) - (if rmail-flag - ;; If the Rmail buffer has a summary, show that. - (if summary-buffer (switch-to-buffer summary-buffer) - (delete-window)) - (switch-to-buffer newbuf)))))) - -(defun mail-send () - "Send the message in the current buffer. -If `mail-interactive' is non-nil, wait for success indication or error -messages, and inform user. Otherwise any failure is reported in a message -back to the user from the mailer." - (interactive) - (if (if buffer-file-name - (y-or-n-p "Send buffer contents as mail message? ") - (or (buffer-modified-p) - (y-or-n-p "Message already sent; resend? "))) - (progn - (expand-abbrev) ; for mail-abbrevs - (run-hooks 'mail-send-hook) - (message "Sending...") - (funcall send-mail-function) - ;; Now perform actions on successful sending. - (while mail-send-actions - (condition-case nil - (apply (car (car mail-send-actions)) - (cdr (car mail-send-actions))) - (error)) - (setq mail-send-actions (cdr mail-send-actions))) - (message "Sending...done") - - ;; If buffer has no file, mark it as unmodified and delete autosave. - (cond ((or (not buffer-file-name) - (not (buffer-modified-p))) - (set-buffer-modified-p nil) - (delete-auto-save-file-if-necessary t)) - ((or noninteractive - (y-or-n-p (format "Save file %s? " buffer-file-name))) - (save-buffer)))))) - -(defun sendmail-send-it () - (require 'mail-utils) - (let ((errbuf (if mail-interactive - (generate-new-buffer " sendmail errors") - 0)) - (tembuf (generate-new-buffer " sendmail temp")) - (case-fold-search nil) - resend-to-addresses - delimline - (mailbuf (current-buffer))) - (unwind-protect - (save-excursion - (set-buffer tembuf) - (erase-buffer) - (insert-buffer-substring mailbuf) - (goto-char (point-max)) - ;; require one newline at the end. - (or (= (preceding-char) ?\n) - (insert ?\n)) - ;; Change header-delimiter to be what sendmail expects. - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n")) - (replace-match "\n") - (backward-char 1) - (setq delimline (point-marker)) -;Removed. See `mail-abbrevs.el'. -; (sendmail-synch-aliases) -; (if mail-aliases -; (expand-mail-aliases (point-min) delimline)) -; (goto-char (point-min)) - ;; ignore any blank lines in the header - (while (and (re-search-forward "\n\n\n*" delimline t) - (< (point) delimline)) - (replace-match "\n")) - (let ((case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward "^Resent-to:" delimline t) - (setq resend-to-addresses - (save-restriction - (narrow-to-region (point) - (save-excursion - (end-of-line) - (point))) - (append (mail-parse-comma-list) - resend-to-addresses)))) -;;; Apparently this causes a duplicate Sender. -;;; ;; If the From is different than current user, insert Sender. -;;; (goto-char (point-min)) -;;; (and (re-search-forward "^From:" delimline t) -;;; (progn -;;; (require 'mail-utils) -;;; (not (string-equal -;;; (mail-strip-quoted-names -;;; (save-restriction -;;; (narrow-to-region (point-min) delimline) -;;; (mail-fetch-field "From"))) -;;; (user-login-name)))) -;;; (progn -;;; (forward-line 1) -;;; (insert "Sender: " (user-login-name) "\n"))) - ;; Don't send out a blank subject line - (goto-char (point-min)) - (if (re-search-forward "^Subject:\\([ \t]*\n\\)+\\b" delimline t) - (replace-match "")) - ;; Put the "From:" field in unless for some odd reason - ;; they put one in themselves. - (goto-char (point-min)) - (if (not (re-search-forward "^From:" delimline t)) - (let* ((login (user-mail-address)) - (fullname (user-full-name))) - (cond ((eq mail-from-style 'angles) - (insert "From: " fullname) - (let ((fullname-start (+ (point-min) 6)) - (fullname-end (point-marker))) - (goto-char fullname-start) - ;; Look for a character that cannot appear unquoted - ;; according to RFC 822. - (if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" - fullname-end 1) - (progn - ;; Quote fullname, escaping specials. - (goto-char fullname-start) - (insert "\"") - (while (re-search-forward "[\"\\]" - fullname-end 1) - (replace-match "\\\\\\&" t)) - (insert "\"")))) - (insert " <" login ">\n")) - ((eq mail-from-style 'parens) - (insert "From: " login " (") - (let ((fullname-start (point))) - (insert fullname) - (let ((fullname-end (point-marker))) - (goto-char fullname-start) - ;; RFC 822 says \ and nonmatching parentheses - ;; must be escaped in comments. - ;; Escape every instance of ()\ ... - (while (re-search-forward "[()\\]" fullname-end 1) - (replace-match "\\\\\\&" t)) - ;; ... then undo escaping of matching parentheses, - ;; including matching nested parentheses. - (goto-char fullname-start) - (while (re-search-forward - "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)" - fullname-end 1) - (replace-match "\\1(\\3)" t) - (goto-char fullname-start)))) - (insert ")\n")) - ((null mail-from-style) - (insert "From: " login "\n"))))) - ;; Insert an extra newline if we need it to work around - ;; Sun's bug that swallows newlines. - (goto-char (1+ delimline)) - (if (eval mail-mailer-swallows-blank-line) - (newline)) - ;; Find and handle any FCC fields. - (goto-char (point-min)) - (if (re-search-forward "^FCC:" delimline t) - (mail-do-fcc delimline)) - (if mail-interactive - (save-excursion - (set-buffer errbuf) - (erase-buffer)))) - (let ((default-directory "/")) - (apply 'call-process-region - (append (list (point-min) (point-max) - (if (boundp 'sendmail-program) - sendmail-program - "/usr/lib/sendmail") - nil errbuf nil "-oi") - ;; Always specify who from, - ;; since some systems have broken sendmails. - (list "-f" (user-login-name)) -;;; ;; Don't say "from root" if running under su. -;;; (and (equal (user-real-login-name) "root") -;;; (list "-f" (user-login-name))) - (and mail-alias-file - (list (concat "-oA" mail-alias-file))) - ;; These mean "report errors by mail" - ;; and "deliver in background". - (if (null mail-interactive) '("-oem" "-odb")) - ;; Get the addresses from the message - ;; unless this is a resend. - ;; We must not do that for a resend - ;; because we would find the original addresses. - ;; For a resend, include the specific addresses. - (or resend-to-addresses - '("-t"))))) - (if mail-interactive - (save-excursion - (set-buffer errbuf) - (goto-char (point-min)) - (while (re-search-forward "\n\n* *" nil t) - (replace-match "; ")) - (if (not (zerop (buffer-size))) - (error "Sending...failed to %s" - (buffer-substring (point-min) (point-max))))))) - (kill-buffer tembuf) - (if (bufferp errbuf) - (kill-buffer errbuf))))) - -;;; FCC hackery, by jwz. This version works on BABYL and VM buffers. -;;; To accomplish the latter, VM is loaded when this file is compiled. -;;; Don't worry, it's only loaded at compile-time. - -(defun mail-do-fcc (header-end) - (let (fcc-list - (send-mail-buffer (current-buffer)) - (tembuf (generate-new-buffer " rmail output")) - (case-fold-search t) - beg end) - (or (markerp header-end) (error "header-end must be a marker")) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "^FCC:[ \t]*" header-end t) - (setq fcc-list (cons (buffer-substring (point) - (progn - (end-of-line) - (skip-chars-backward " \t") - (point))) - fcc-list)) - (delete-region (match-beginning 0) - (progn (forward-line 1) (point)))) - (set-buffer tembuf) - (erase-buffer) - ;; insert just the headers to avoid moving the gap more than - ;; necessary (the message body could be arbitrarily huge.) - (insert-buffer-substring send-mail-buffer 1 header-end) - - ;; if there's no From: or Date: field, cons some. - (goto-char (point-min)) - (or (re-search-forward "^From[ \t]*:" header-end t) - (insert "From: " (user-login-name) " (" (user-full-name) ")\n")) - (goto-char (point-min)) - (or (re-search-forward "^Date[ \t]*:" header-end t) - (mail-do-fcc-insert-date-header)) - - ;; insert a magic From_ line. - (goto-char (point-min)) - (insert "\nFrom " (user-login-name) " " (current-time-string) "\n") - (goto-char (point-max)) - (insert-buffer-substring send-mail-buffer header-end) - (goto-char (point-max)) - (insert ?\n) - (goto-char (1- header-end)) - - ;; ``Quote'' "^From " as ">From " - ;; (note that this isn't really quoting, as there is no requirement - ;; that "^[>]+From " be quoted in the same transparent way.) - (let ((case-fold-search nil)) - (while (search-forward "\nFrom " nil t) - (forward-char -5) - (insert ?>))) - - (setq beg (point-min) - end (point-max)) - (while fcc-list - (let ((target-buffer (get-file-buffer (car fcc-list)))) - (if target-buffer - ;; File is present in a buffer => append to that buffer. - (save-excursion - (set-buffer target-buffer) - (cond ((eq major-mode 'rmail-mode) - (mail-do-fcc-rmail-internal tembuf)) - ((eq major-mode 'vm-mode) - (mail-do-fcc-vm-internal tembuf)) - (t - ;; Append to an ordinary buffer as a Unix mail message. - (goto-char (point-max)) - (insert-buffer-substring tembuf beg end)))) - ;; Else append to the file directly. - ;; (It's OK if it is an RMAIL or VM file -- the message will be - ;; parsed when the file is read in.) - (write-region - (1+ (point-min)) (point-max) (car fcc-list) t))) - (setq fcc-list (cdr fcc-list)))) - (kill-buffer tembuf))) - -(defvar mail-do-fcc-cached-timezone nil) - -(defun mail-do-fcc-insert-date-header () - ;; Convert the ctime() format that `current-time-string' returns into - ;; an RFC-822-legal date. - (let ((s (current-time-string))) - (string-match "\\`\\([A-Z][a-z][a-z]\\) +\\([A-Z][a-z][a-z]\\) +\\([0-9][0-9]?\\) *\\([0-9][0-9]?:[0-9][0-9]:[0-9][0-9]\\) *[0-9]?[0-9]?\\([0-9][0-9]\\)" - s) - (insert "Date: " - (substring s (match-beginning 1) (match-end 1)) ", " - (substring s (match-beginning 3) (match-end 3)) " " - (substring s (match-beginning 2) (match-end 2)) " " - (substring s (match-beginning 5) (match-end 5)) " " - (substring s (match-beginning 4) (match-end 4)) " ") - - (if mail-do-fcc-cached-timezone - (insert mail-do-fcc-cached-timezone "\n") - ;; - ;; First, try to use the current-time-zone function, which may not be - ;; defined, and even if it is defined, may error or return nil. - ;; - (or (condition-case () - (let ((zoneinfo (current-time-zone))) - (setq mail-do-fcc-cached-timezone - (if (stringp (nth 1 zoneinfo)) - (nth 1 zoneinfo) - (or (if (nth 1 zoneinfo) (nth 3 zoneinfo)) - (nth 2 zoneinfo)))) - (if mail-do-fcc-cached-timezone - (insert mail-do-fcc-cached-timezone "\n")) - mail-do-fcc-cached-timezone) - (error nil)) - ;; - ;; Otherwise, run date(1) and parse its output. Yuck! - ;; - (save-restriction - (narrow-to-region (point) (point)) - (call-process "date" nil t nil) - (end-of-line) - (insert "\n") - (forward-word -1) ; skip back over year - (delete-region (1- (point)) (1- (point-max))) ; nuke year to end - (forward-word -1) ; skip back over zone - (delete-region (point-min) (point)) ; nuke beginning to zone - (setq mail-do-fcc-cached-timezone - (buffer-substring (point-min) (1- (point-max))))))))) - -;; Can't do this now that VM is unbundled. -;; The lack of vm-misc is handled in mail-do-fcc-vm-internal. -;;(eval-when-compile -;; (require 'vm-misc)) - -(defvar rmail-total-messages) - -(defun mail-do-fcc-rmail-internal (buffer) - (or (eq major-mode 'rmail-mode) (error "this only works in rmail-mode")) - (let ((b (point-min)) - (e (point-max)) - (buffer-read-only nil)) - (unwind-protect - (progn - (widen) - (goto-char (point-max)) - ;; This forces RMAIL's message counters to be recomputed when the - ;; next RMAIL operation is done on the buffer. - ;; See rmail-maybe-set-message-counters. - (setq rmail-total-messages nil) - (insert "\^L\n0, unseen,,\n*** EOOH ***") - (insert-buffer-substring buffer) - (insert "\n\C-_")) - (narrow-to-region b e) - (rmail-maybe-set-message-counters)))) - -(defun mail-do-fcc-vm-internal (buffer) - (or (eq major-mode 'vm-mode) (error "this only works in vm-mode")) - (let ((buffer-read-only nil) - (foreign-folder-p (not (eq vm-folder-type 'From_)))) - - (if foreign-folder-p - ;; `buffer' has already been prepared with a "From " line which - ;; has a sensible user-id and date in it, but if we're FCCing to - ;; a VM folder that isn't in From_ format, we must discard that - ;; and let VM do whatever voodoo it needs to do. (Actually we - ;; could do this all the time, but then all FCCed messages would - ;; have "From VM ..." envelopes, which is less attractive.) - (save-excursion - (set-buffer buffer) - (goto-char (point-min)) - (skip-chars-forward "\n") - (forward-line) - (delete-region (point-min) (point)))) - - ;; Use eval to inhibit compilation of the following code. - ;; The code contains macros, and to compile them a (reuqire - ;; 'vm-misc) is needed. When VM stopped being bundled with - ;; XEmacs, this require call became impossible. - (eval - (quote - ;; Largely copied from #'vm-save-message in vm-save.el - (vm-save-restriction - (widen) - (goto-char (point-max)) - (if foreign-folder-p - (vm-write-string (current-buffer) - (vm-leading-message-separator vm-folder-type))) - (insert-buffer-substring buffer) - (if foreign-folder-p - (vm-write-string (current-buffer) - (vm-trailing-message-separator vm-folder-type))) - - (vm-increment vm-messages-not-on-disk) - (vm-set-buffer-modified-p t) - (vm-clear-modification-flag-undos) - (vm-check-for-killed-summary) - (vm-assimilate-new-messages) - (vm-update-summary-and-mode-line)))))) - -;;(defun mail-sent-via () -;; "Make a Sent-via header line from each To or CC header line." -;; (interactive) -;; (save-excursion -;; (goto-char (point-min)) -;; ;; find the header-separator -;; (search-forward (concat "\n" mail-header-separator "\n")) -;; (forward-line -1) -;; ;; put a marker at the end of the header -;; (let ((end (point-marker)) -;; (case-fold-search t) -;; to-line) -;; (goto-char (point-min)) -;; ;; search for the To: lines and make Sent-via: lines from them -;; ;; search for the next To: line -;; (while (re-search-forward "^\\(to\\|cc\\):" end t) -;; ;; Grab this line plus all its continuations, sans the `to:'. -;; (let ((to-line -;; (buffer-substring (point) -;; (progn -;; (if (re-search-forward "^[^ \t\n]" end t) -;; (backward-char 1) -;; (goto-char end)) -;; (point))))) -;; ;; Insert a copy, with altered header field name. -;; (insert-before-markers "Sent-via:" to-line)))))) - -(defun mail-to () - "Move point to end of To-field." - (interactive) - (expand-abbrev) - (mail-position-on-field "To")) - -(defun mail-subject () - "Move point to end of Subject-field." - (interactive) - (expand-abbrev) - (mail-position-on-field "Subject")) - -(defun mail-cc () - "Move point to end of CC-field. Create a CC field if none." - (interactive) - (expand-abbrev) - (or (mail-position-on-field "cc" t) - (progn (mail-position-on-field "to") - (insert "\nCC: ")))) - -(defun mail-bcc () - "Move point to end of BCC-field. Create a BCC field if none." - (interactive) - (expand-abbrev) - (or (mail-position-on-field "bcc" t) - (progn (mail-position-on-field "to") - (insert "\nBCC: ")))) - -(defun mail-fcc (folder) - "Add a new FCC field, with file name completion." - (interactive "FFolder carbon copy: ") - (expand-abbrev) - (or (mail-position-on-field "fcc" t) ;Put new field after exiting FCC. - (mail-position-on-field "to")) - (insert "\nFCC: " folder)) - -(defun mail-reply-to () - "Move point to end of Reply-To-field. Create a Reply-To field if none." - (interactive) - (expand-abbrev) - (or (mail-position-on-field "reply-to" t) - (progn (mail-position-on-field "to") - (insert "\nReply-To: ")))) - -(defun mail-position-on-field (field &optional soft) - (let (end - (case-fold-search t)) - (goto-char (point-min)) - (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) - (setq end (match-beginning 0)) - (goto-char (point-min)) - (if (re-search-forward (concat "^" (regexp-quote field) ":") end t) - (progn - (re-search-forward "^[^ \t]" nil 'move) - (beginning-of-line) - (skip-chars-backward "\n") - t) - (or soft - (progn (goto-char end) - (insert field ": \n") - (forward-char -1))) - nil))) - -(defun mail-text () - "Move point to beginning of message text." - (interactive) - (expand-abbrev) - (goto-char (point-min)) - (search-forward (concat "\n" mail-header-separator "\n"))) - -(defun mail-signature (&optional atpoint) - "Sign letter with contents of the file `mail-signature-file'. -Prefix arg means put contents at point." - (interactive "P") - (save-excursion - (or atpoint - (goto-char (point-max))) - (skip-chars-backward " \t\n") - (end-of-line) - (or atpoint - (delete-region (point) (point-max))) - (insert "\n\n-- \n") - (insert-file-contents (expand-file-name mail-signature-file)))) - -(defun mail-fill-yanked-message (&optional justifyp) - "Fill the paragraphs of a message yanked into this one. -Numeric argument means justify as well." - (interactive "P") - (save-excursion - (goto-char (point-min)) - (search-forward (concat "\n" mail-header-separator "\n") nil t) - (fill-individual-paragraphs (point) - (point-max) - justifyp - t))) - -(defun mail-indent-citation () - "Modify text just inserted from a message to be cited. -The inserted text should be the region. -When this function returns, the region is again around the modified text. - -Normally, indent each nonblank line `mail-indentation-spaces' spaces. -However, if `mail-yank-prefix' is non-nil, insert that prefix on each line." - (let ((start (point))) - (mail-yank-clear-headers start (mark t)) - (if (null mail-yank-prefix) - (indent-rigidly start (mark t) mail-indentation-spaces) - (save-excursion - (goto-char start) - (while (< (point) (mark t)) - (insert mail-yank-prefix) - (forward-line 1)))))) - -(defun mail-yank-original (arg) - "Insert the message being replied to, if any (in rmail). -Puts point before the text and mark after. -Normally, indents each nonblank line ARG spaces (default 3). -However, if `mail-yank-prefix' is non-nil, insert that prefix on each line. - -Just \\[universal-argument] as argument means don't indent, insert no prefix, -and don't delete any header fields." - (interactive "P") - (if mail-reply-buffer - (let ((start (point)) - (reader-buf mail-reply-buffer) - (reader-window (get-buffer-window mail-reply-buffer - (selected-frame)))) - ;; If the original message is in another window in the same frame, - ;; delete that window to save screen space. - ;; t means don't alter other frames. - (if reader-window - (delete-windows-on reader-buf t)) - (insert-buffer reader-buf) - (if (consp arg) - nil - (goto-char start) - (let ((mail-indentation-spaces (if arg (prefix-numeric-value arg) - mail-indentation-spaces))) - (cond (mail-citation-hook - (run-hooks 'mail-citation-hook)) - (mail-yank-hooks - (run-hooks 'mail-yank-hooks)) - (t - (mail-indent-citation))))) - (exchange-point-and-mark t) - (if (not (eolp)) (insert ?\n))))) - -(defun mail-yank-clear-headers (start end) - (if mail-yank-ignored-headers - (save-excursion - (goto-char start) - (if (search-forward "\n\n" end t) - (save-restriction - (narrow-to-region start (point)) - (goto-char start) - (while (let ((case-fold-search t)) - (re-search-forward mail-yank-ignored-headers nil t)) - (beginning-of-line) - (delete-region (point) - (progn (re-search-forward "\n[^ \t]") - (forward-char -1) - (point))))))))) - -;; Put these last, to reduce chance of lossage from quitting in middle of loading the file. - -;;;###autoload -(defun mail (&optional noerase to subject in-reply-to cc replybuffer actions) - "Edit a message to be sent. Prefix arg means resume editing (don't erase). -When this function returns, the buffer `*mail*' is selected. -The value is t if the message was newly initialized; otherwise, nil. - -Optionally, the signature file `mail-signature-file' can be inserted at the -end; see the variable `mail-signature'. - -\\ -While editing message, type \\[mail-send-and-exit] to send the message and exit. - -Various special commands starting with C-c are available in sendmail mode -to move to message header fields: -\\{mail-mode-map} - -The variable `mail-signature' controls whether the signature file -`mail-signature-file' is inserted immediately. - -If `mail-signature' is nil, use \\[mail-signature] to insert the -signature in `mail-signature-file'. - -If `mail-self-blind' is non-nil, a BCC to yourself is inserted -when the message is initialized. - -If `mail-default-reply-to' is non-nil, it should be an address (a string); -a Reply-to: field with that address is inserted. - -If `mail-archive-file-name' is non-nil, an FCC field with that file name -is inserted. - -The normal hook `mail-setup-hook' is run after the message is -initialized. It can add more default fields to the message. - -When calling from a program, the first argument if non-nil says -not to erase the existing contents of the `*mail*' buffer. - -The second through fifth arguments, - TO, SUBJECT, IN-REPLY-TO and CC, specify if non-nil - the initial contents of those header fields. - These arguments should not have final newlines. -The sixth argument REPLYBUFFER is a buffer whose contents - should be yanked if the user types C-c C-y. -The seventh argument ACTIONS is a list of actions to take - if/when the message is sent. Each action looks like (FUNCTION . ARGS); - when the message is sent, we apply FUNCTION to ARGS. - This is how Rmail arranges to mark messages `answered'." - (interactive "P") - (if mail-use-multiple-buffers-p - - ;; RMS doesn't like this behavior but it seems more logical to me. --ben - (let ((index 1) - buffer) - ;; If requested, look for a mail buffer that is modified and go to it. - (if noerase - (progn - (while (and (setq buffer - (get-buffer (if (= 1 index) "*mail*" - (format "*mail*<%d>" index)))) - (not (buffer-modified-p buffer))) - (setq index (1+ index))) - (if buffer (switch-to-buffer buffer) - ;; If none exists, start a new message. - ;; This will never re-use an existing unmodified mail buffer - ;; (since index is not 1 anymore). Perhaps it should. - (setq noerase nil)))) - ;; Unless we found a modified message and are happy, start a - ;; new message. - (if (not noerase) - (progn - ;; Look for existing unmodified mail buffer. - (while (and (setq buffer - (get-buffer (if (= 1 index) "*mail*" - (format "*mail*<%d>" index)))) - (buffer-modified-p buffer)) - (setq index (1+ index))) - ;; If none, make a new one. - (or buffer - (setq buffer (generate-new-buffer "*mail*"))) - ;; Go there and initialize it. - (switch-to-buffer buffer) - (erase-buffer) - ;; put mail auto-save files in home dir instead of - ;; scattering them around the file system. - (setq default-directory (or mail-dir (expand-file-name "~/"))) - (auto-save-mode auto-save-default) - (mail-mode) - (mail-setup to subject in-reply-to cc replybuffer actions) - (if (and buffer-auto-save-file-name - (file-exists-p buffer-auto-save-file-name)) - (message "Auto save file for draft message exists; consider M-x mail-recover")) - t))) - - ;; Alternate behavior that RMS likes. - (pop-to-buffer "*mail*") - (auto-save-mode auto-save-default) - (mail-mode) - ;; Disconnect the buffer from its visited file - ;; (in case the user has actually visited a file *mail*). -; (set-visited-file-name nil) - (let (initialized) - (and (not noerase) - (or (not (buffer-modified-p)) - (y-or-n-p "Unsent message being composed; erase it? ")) - (progn (erase-buffer) - (mail-setup to subject in-reply-to cc replybuffer actions) - (setq initialized t))) - (if (and buffer-auto-save-file-name - (file-exists-p buffer-auto-save-file-name)) - (message "Auto save file for draft message exists; consider M-x mail-recover")) - initialized))) - -(defun mail-recover () - "Reread contents of current buffer from its last auto-save file." - (interactive) - (let ((file-name (let ((default-directory (expand-file-name "~/"))) - ;; put mail auto-save files in home dir instead of - ;; scattering them around the file system. - (make-auto-save-file-name)))) - (cond ((save-window-excursion - (if (not (eq system-type 'vax-vms)) - (with-output-to-temp-buffer "*Directory*" - (buffer-disable-undo standard-output) - (let ((default-directory "/")) - (call-process - "ls" nil standard-output nil "-l" file-name)))) - (yes-or-no-p (format "Recover auto save file %s? " file-name))) - (let ((buffer-read-only nil)) - (erase-buffer) - (insert-file-contents file-name nil))) - (t (error "mail-recover cancelled"))))) - -;;;###autoload -(defun mail-other-window (&optional noerase to subject in-reply-to cc replybuffer sendactions) - "Like `mail' command, but display mail buffer in another window." - (interactive "P") - (let ((pop-up-windows t) - (special-display-buffer-names nil) - (special-display-regexps nil) - (same-window-buffer-names nil) - (same-window-regexps nil)) - (pop-to-buffer "*mail*")) - (mail noerase to subject in-reply-to cc replybuffer sendactions)) - -;;;###autoload -(defun mail-other-frame (&optional noerase to subject in-reply-to cc - replybuffer sendactions) - "Like `mail' command, but display mail buffer in another frame." - (interactive "P") - (let ((pop-up-frames t) - (special-display-buffer-names nil) - (special-display-regexps nil) - (same-window-buffer-names nil) - (same-window-regexps nil)) - (pop-to-buffer "*mail*")) - (mail noerase to subject in-reply-to cc replybuffer sendactions)) - -;;;###autoload (add-hook 'same-window-buffer-names "*mail*") - -;;; Do not add anything but external entries on this page. - -(provide 'sendmail) - -;;; sendmail.el ends here diff -r 43306a74e31c -r d44af0c54775 lisp/modes/sgml-mode.el --- a/lisp/modes/sgml-mode.el Mon Aug 13 10:07:42 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1272 +0,0 @@ -;;; sgml-mode.el --- SGML- and HTML-editing modes - -;; Copyright (C) 1992, 1995, 1996 Free Software Foundation, Inc. - -;; Author: James Clark -;; Adapted-By: ESR; Daniel.Pfeiffer@Informatik.START.dbp.de -;; Keywords: wp, hypermedia, comm, languages - -;; 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., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Configurable major mode for editing document in the SGML standard general -;; markup language. As an example contains a mode for editing the derived -;; HTML hypertext markup language. - -;;; Code: - -;; As long as Emacs' syntax can't be complemented with predicates to context -;; sensitively confirm the syntax of characters, we have to live with this -;; kludgy kind of tradeoff. -(defvar sgml-specials '(?\") - "List of characters that have a special meaning for sgml-mode. -This list is used when first loading the sgml-mode library. -The supported characters and potential disadvantages are: - - ?\\\" Makes \" in text start a string. - ?' Makes ' in text start a string. - ?- Makes -- in text start a comment. - -When only one of ?\\\" or ?' are included, \"'\" or '\"' as it can be found in -DTDs, start a string. To partially avoid this problem this also makes these -self insert as named entities depending on `sgml-quick-keys'. - -Including ?- has the problem of affecting dashes that have nothing to do -with comments, so we normally turn it off.") - -(defvar sgml-quick-keys nil - "Use <, >, &, SPC and `sgml-specials' keys ``electrically'' when non-nil. -This takes effect when first loading the library.") - - -(defvar sgml-mode-map - (let (;;(map (list 'keymap (make-vector 256 nil))) - (map (make-keymap)) - (menu-map (make-sparse-keymap "SGML"))) - (define-key map "\t" 'indent-relative-maybe) - (define-key map "\C-c\C-i" 'sgml-tags-invisible) - (define-key map "/" 'sgml-slash) - (define-key map "\C-c\C-n" 'sgml-name-char) - (define-key map "\C-c\C-t" 'sgml-tag) - (define-key map "\C-c\C-a" 'sgml-attributes) - (define-key map "\C-c\C-b" 'sgml-skip-tag-backward) - (define-key map [?\C-c left] 'sgml-skip-tag-backward) - (define-key map "\C-c\C-f" 'sgml-skip-tag-forward) - (define-key map [?\C-c right] 'sgml-skip-tag-forward) - (define-key map "\C-c\C-d" 'sgml-delete-tag) - (define-key map "\C-c\^?" 'sgml-delete-tag) - (define-key map "\C-c?" 'sgml-tag-help) - (define-key map "\C-c8" 'sgml-name-8bit-mode) - (define-key map "\C-c\C-v" 'sgml-validate) - (if sgml-quick-keys - (progn - (define-key map "&" 'sgml-name-char) - (define-key map "<" 'sgml-tag) - (define-key map " " 'sgml-auto-attributes) - (define-key map ">" 'sgml-maybe-end-tag) - (if (memq ?\" sgml-specials) - (define-key map "\"" 'sgml-name-self)) - (if (memq ?' sgml-specials) - (define-key map "'" 'sgml-name-self)))) - (let ((c 127) - ;; (map (nth 1 map)) - ) - (while (< (setq c (1+ c)) 256) - ;; (aset map c 'sgml-maybe-name-self))) - (define-key map (int-char c) 'sgml-maybe-name-self))) - (define-key map [menu-bar sgml] (cons "SGML" menu-map)) - (define-key menu-map [sgml-validate] '("Validate" . sgml-validate)) - (define-key menu-map [sgml-name-8bit-mode] - '("Toggle 8 Bit Insertion" . sgml-name-8bit-mode)) - (define-key menu-map [sgml-tags-invisible] - '("Toggle Tag Visibility" . sgml-tags-invisible)) - (define-key menu-map [sgml-tag-help] - '("Describe Tag" . sgml-tag-help)) - (define-key menu-map [sgml-delete-tag] - '("Delete Tag" . sgml-delete-tag)) - (define-key menu-map [sgml-skip-tag-forward] - '("Forward Tag" . sgml-skip-tag-forward)) - (define-key menu-map [sgml-skip-tag-backward] - '("Backward Tag" . sgml-skip-tag-backward)) - (define-key menu-map [sgml-attributes] - '("Insert Attributes" . sgml-attributes)) - (define-key menu-map [sgml-tag] '("Insert Tag" . sgml-tag)) - map) - "Keymap for SGML mode. See also `sgml-specials'.") - - -(defvar sgml-mode-syntax-table - (let ((table (copy-syntax-table text-mode-syntax-table))) - (modify-syntax-entry ?< "(>" table) - (modify-syntax-entry ?> ")<" table) - (if (memq ?- sgml-specials) - (modify-syntax-entry ?- "_ 1234" table)) - (if (memq ?\" sgml-specials) - (modify-syntax-entry ?\" "\"\"" table)) - (if (memq ?' sgml-specials) - (modify-syntax-entry ?\' "\"'" table)) - table) - "Syntax table used in SGML mode. See also `sgml-specials'.") - - -(defvar sgml-name-8bit-mode nil - "*When non-`nil' insert 8 bit characters with their names.") - -(defvar sgml-char-names - [nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil - "ensp" "excl" "quot" "num" "dollar" "percnt" "amp" "apos" - "lpar" "rpar" "ast" "plus" "comma" "hyphen" "period" "sol" - nil nil nil nil nil nil nil nil - nil nil "colon" "semi" "lt" "eq" "gt" "quest" - "commat" nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil - nil nil nil "lsqb" nil "rsqb" "uarr" "lowbar" - "lsquo" nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil - nil nil nil "lcub" "verbar" "rcub" "tilde" nil - nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil - "nbsp" "iexcl" "cent" "pound" "curren" "yen" "brvbar" "sect" - "uml" "copy" "ordf" "laquo" "not" "shy" "reg" "macr" - "ring" "plusmn" "sup2" "sup3" "acute" "micro" "para" "middot" - "cedil" "sup1" "ordm" "raquo" "frac14" "half" "frac34" "iquest" - "Agrave" "Aacute" "Acirc" "Atilde" "Auml" "Aring" "AElig" "Ccedil" - "Egrave" "Eacute" "Ecirc" "Euml" "Igrave" "Iacute" "Icirc" "Iuml" - "ETH" "Ntilde" "Ograve" "Oacute" "Ocirc" "Otilde" "Ouml" nil - "Oslash" "Ugrave" "Uacute" "Ucirc" "Uuml" "Yacute" "THORN" "szlig" - "agrave" "aacute" "acirc" "atilde" "auml" "aring" "aelig" "ccedil" - "egrave" "eacute" "ecirc" "euml" "igrave" "iacute" "icirc" "iuml" - "eth" "ntilde" "ograve" "oacute" "ocirc" "otilde" "ouml" "divide" - "oslash" "ugrave" "uacute" "ucirc" "uuml" "yacute" "thorn" "yuml"] - "Vector of symbolic character names without `&' and `;'.") - - -;; sgmls is a free SGML parser available from -;; ftp.uu.net:pub/text-processing/sgml -;; Its error messages can be parsed by next-error. -;; The -s option suppresses output. - -(defvar sgml-validate-command "sgmls -s" - "*The command to validate an SGML document. -The file name of current buffer file name will be appended to this, -separated by a space.") - -(defvar sgml-saved-validate-command nil - "The command last used to validate in this buffer.") - - -;;; I doubt that null end tags are used much for large elements, -;;; so use a small distance here. -(defconst sgml-slash-distance 1000 - "*If non-nil, is the maximum distance to search for matching /.") - -(defconst sgml-start-tag-regex - "<[A-Za-z]\\([-.A-Za-z0-9= \n\t]\\|\"[^\"]*\"\\|'[^']*'\\)*" - "Regular expression that matches a non-empty start tag. -Any terminating > or / is not matched.") - - -(defvar sgml-font-lock-keywords - '(("<\\([!?][a-z0-9]+\\)" 1 font-lock-keyword-face) - ("<\\(/?[a-z0-9]+\\)" 1 font-lock-function-name-face) - ("[&%][-.A-Za-z0-9]+;?" . font-lock-variable-name-face) - ("" . font-lock-comment-face)) - "*Rules for highlighting SGML code. See also `sgml-tag-face-alist'.") - -;; internal -(defvar sgml-font-lock-keywords-1 ()) - -(defvar sgml-face-tag-alist () - "Alist of face and tag name for facemenu.") - -(defvar sgml-tag-face-alist () - "Tag names and face or list of faces to fontify with when invisible. -When `font-lock-maximum-decoration' is 1 this is always used for fontifying. -When more these are fontified together with `sgml-font-lock-keywords'.") - - -(defvar sgml-display-text () - "Tag names as lowercase symbols, and display string when invisible.") - -;; internal -(defvar sgml-tags-invisible nil) - - -(defvar sgml-tag-alist - '(("![" ("ignore" t) ("include" t)) - ("!attlist") - ("!doctype") - ("!element") - ("!entity")) - "*Alist of tag names for completing read and insertion rules. -This alist is made up as - - ((\"tag\" . TAGRULE) - ...) - -TAGRULE is a list of optionally `t' (no endtag) or `\\n' (separate endtag by -newlines) or a skeleton with `nil', `t' or `\\n' in place of the interactor -followed by an ATTRIBUTERULE (for an always present attribute) or an -attribute alist. - -The attribute alist is made up as - - ((\"attribute\" . ATTRIBUTERULE) - ...) - -ATTRIBUTERULE is a list of optionally `t' (no value when no input) followed by -an optional alist of possible values.") - -(defvar sgml-tag-help - '(("!" . "Empty declaration for comment") - ("![" . "Embed declarations with parser directive") - ("!attlist" . "Tag attributes declaration") - ("!doctype" . "Document type (DTD) declaration") - ("!element" . "Tag declaration") - ("!entity" . "Entity (macro) declaration")) - "*Alist of tag name and short description.") - - -;; put read-only last to enable setting this even when read-only enabled -(or (get 'sgml-tag 'invisible) - (setplist 'sgml-tag - (append '(invisible t - rear-nonsticky t - point-entered sgml-point-entered - read-only t) - (symbol-plist 'sgml-tag)))) - - - -(defun sgml-mode-common (sgml-tag-face-alist sgml-display-text) - "Common code for setting up `sgml-mode' and derived modes. -SGML-TAG-FACE-ALIST is used for calculating `sgml-font-lock-keywords-1'. -SGML-DISPLAY-TEXT sets up alternate text for when tags are invisible (see -varables of same name)." - (kill-all-local-variables) - (setq local-abbrev-table text-mode-abbrev-table) - (set-syntax-table sgml-mode-syntax-table) - (make-local-variable 'indent-line-function) - (make-local-variable 'paragraph-start) - (make-local-variable 'paragraph-separate) - (make-local-variable 'sgml-saved-validate-command) - (make-local-variable 'comment-start) - (make-local-variable 'comment-end) - (make-local-variable 'comment-indent-function) - (make-local-variable 'comment-start-skip) - (make-local-variable 'comment-indent-function) - (make-local-variable 'sgml-tags-invisible) - (make-local-variable 'skeleton-transformation) - (make-local-variable 'skeleton-further-elements) - (make-local-variable 'skeleton-end-hook) - (make-local-variable 'font-lock-defaults) - (make-local-variable 'sgml-font-lock-keywords-1) - (make-local-variable 'facemenu-add-face-function) - (make-local-variable 'facemenu-end-add-face) - ;;(make-local-variable 'facemenu-remove-face-function) - (and sgml-tag-face-alist - (not (assq 1 sgml-tag-face-alist)) - (nconc sgml-tag-face-alist - `((1 (,(concat "<\\(" - (mapconcat 'car sgml-tag-face-alist "\\|") - "\\)\\([ \t].+\\)?>\\(.+\\)") - 3 (cdr (assoc (match-string 1) ',sgml-tag-face-alist))))))) - (setq indent-line-function 'indent-relative-maybe - ;; A start or end tag by itself on a line separates a paragraph. - ;; This is desirable because SGML discards a newline that appears - ;; immediately after a start tag or immediately before an end tag. - paragraph-start "^[ \t\n]\\|\ -\\($\\)" - paragraph-separate "^[ \t\n]*$\\|\ -^$" - comment-start "" - comment-indent-function 'sgml-comment-indent - ;; This will allow existing comments within declarations to be - ;; recognized. - comment-start-skip "--[ \t]*" - skeleton-transformation 'identity - skeleton-further-elements '((completion-ignore-case t)) - skeleton-end-hook (lambda () - (or (eolp) - (not (or (eq v2 '\n) - (eq (car-safe v2) '\n))) - (newline-and-indent))) - sgml-font-lock-keywords-1 (cdr (assq 1 sgml-tag-face-alist)) - font-lock-defaults '((sgml-font-lock-keywords - sgml-font-lock-keywords-1) - nil - t) - facemenu-add-face-function - (lambda (face end) - (if (setq face (cdr (assq face sgml-face-tag-alist))) - (progn - (setq facemenu-end-add-face (concat "")) - (concat "<" face ">")) - (error "Face not configured for %s mode." mode-name)))) - (while sgml-display-text - (put (car (car sgml-display-text)) 'before-string - (cdr (car sgml-display-text))) - (setq sgml-display-text (cdr sgml-display-text))) - (run-hooks 'text-mode-hook 'sgml-mode-hook)) - -;; Conflicts with psgml, don't autoload -;; ;;;###autoload -(defun sgml-mode (&optional function) - "Major mode for editing SGML documents. -Makes > match <. Makes / blink matching /. -Keys <, &, SPC within <>, \" and ' can be electric depending on -`sgml-quick-keys'. - -Do \\[describe-variable] sgml- SPC to see available variables. - -Use \\[sgml-validate] to validate your document with an SGML parser. -\\{sgml-mode-map}" - (interactive) - (sgml-mode-common sgml-tag-face-alist sgml-display-text) - (use-local-map sgml-mode-map) - (setq mode-name "SGML" - major-mode 'sgml-mode)) - - - -(defun sgml-comment-indent () - (if (and (looking-at "--") - (not (and (eq (preceding-char) ?!) - (eq (char-after (- (point) 2)) ?<)))) - (progn - (skip-chars-backward " \t") - (max comment-column (1+ (current-column)))) - 0)) - - - -(defun sgml-slash (arg) - "Insert / and display any previous matching /. -Two /s are treated as matching if the first / ends a net-enabling -start tag, and the second / is the corresponding null end tag." - (interactive "p") - (insert-char ?/ arg) - (if (> arg 0) - (let ((oldpos (point)) - (blinkpos) - (level 0)) - (save-excursion - (save-restriction - (if sgml-slash-distance - (narrow-to-region (max (point-min) - (- (point) sgml-slash-distance)) - oldpos)) - (if (and (re-search-backward sgml-start-tag-regex (point-min) t) - (eq (match-end 0) (1- oldpos))) - () - (goto-char (1- oldpos)) - (while (and (not blinkpos) - (search-backward "/" (point-min) t)) - (let ((tagend (save-excursion - (if (re-search-backward sgml-start-tag-regex - (point-min) t) - (match-end 0) - nil)))) - (if (eq tagend (point)) - (if (eq level 0) - (setq blinkpos (point)) - (setq level (1- level))) - (setq level (1+ level))))))) - (if blinkpos - (progn - (goto-char blinkpos) - (if (pos-visible-in-window-p) - (sit-for 1) - (message "Matches %s" - (buffer-substring (progn - (beginning-of-line) - (point)) - (1+ blinkpos)))))))))) - - -(defun sgml-name-char (&optional char) - "Insert a symbolic character name according to `sgml-char-names'. -8 bit chars may be inserted with the meta key as in M-SPC for no break space, -or M-- for a soft hyphen." - (interactive "*") - (insert ?&) - (or char - (setq char (read-quoted-char))) - (delete-backward-char 1) - (insert char) - (undo-boundary) - (delete-backward-char 1) - (insert ?& - (or (aref sgml-char-names char) - (format "#%d" char)) - ?\;)) - - -(defun sgml-name-self () - "Insert a symbolic character name according to `sgml-char-names'." - (interactive "*") - (sgml-name-char last-command-char)) - - -(defun sgml-maybe-name-self () - "Insert a symbolic character name according to `sgml-char-names'." - (interactive "*") - (if sgml-name-8bit-mode - (sgml-name-char last-command-char) - (self-insert-command 1))) - - -(defun sgml-name-8bit-mode () - "Toggle insertion of 8 bit characters." - (interactive) - (setq sgml-name-8bit-mode (not sgml-name-8bit-mode))) - - - -(define-skeleton sgml-tag - "Insert a tag you are prompted for, optionally with attributes. -Completion and configuration is according to `sgml-tag-alist'. -If you like tags and attributes in uppercase set `skeleton-transformation' -to `upcase'." - (funcall skeleton-transformation - (completing-read "Tag: " sgml-tag-alist)) - ?< (setq v1 (eval str)) | - (("") -1 '(undo-boundary) "<") | - (("") '(setq v2 (sgml-attributes v1 t)) ?> - (if (string= "![" v1) - (prog1 '(("") " [ " _ " ]]") - (backward-char)) - (if (or (eq v2 t) - (string-match "^[/!?]" v1)) - () - (if (symbolp v2) - '(("") v2 _ v2 ") - (if (eq (car v2) t) - (cons '("") (cdr v2)) - (append '(("") (car v2)) - (cdr v2) - '(resume: (car v2) _ ")))))))) - -(autoload 'skeleton-read "skeleton") - -(defun sgml-attributes (alist &optional quiet) - "When at toplevel of a tag, interactively insert attributes." - (interactive (list (save-excursion (sgml-beginning-of-tag t)))) - (or (stringp alist) (error "Wrong context for adding attribute")) - (if alist - (let ((completion-ignore-case t) - car attribute i) - (setq alist (cdr (assoc (downcase alist) sgml-tag-alist))) - (if (or (symbolp (car alist)) - (symbolp (car (car alist)))) - (setq car (car alist) - alist (cdr alist))) - (or quiet - (message "No attributes configured.")) - (if (stringp (car alist)) - (progn - (insert (if (eq (preceding-char) ? ) "" ? ) (car alist)) - (sgml-value alist)) - (setq i (length alist)) - (while (> i 0) - (insert ? ) - (insert (funcall skeleton-transformation - (setq attribute - (skeleton-read '(completing-read - "[Attribute]: " - alist))))) - (if (string= "" attribute) - (setq i 0) - (sgml-value (assoc attribute alist)) - (setq i (1- i)))) - (if (eq (preceding-char) ? ) - (delete-backward-char 1))) - car))) - -(defun sgml-auto-attributes (arg) - "Self insert, except, when at top level of tag, prompt for attributes. -With prefix ARG only self insert." - (interactive "*P") - (let ((point (point)) - tag) - (if (or arg - (not sgml-tag-alist) ; no message when nothing configured - (symbolp (setq tag (save-excursion (sgml-beginning-of-tag t)))) - (eq (aref tag 0) ?/)) - (self-insert-command (prefix-numeric-value arg)) - (sgml-attributes tag) - (setq last-command-char ? ) - (or (> (point) point) - (self-insert-command 1))))) - - -(defun sgml-tag-help (&optional tag) - "Display description of optional TAG or tag at point." - (interactive) - (or tag - (save-excursion - (if (eq (following-char) ?<) - (forward-char)) - (setq tag (sgml-beginning-of-tag)))) - (or (stringp tag) - (error "No tag selected")) - (setq tag (downcase tag)) - (message "%s" - (or (cdr (assoc tag sgml-tag-help)) - (and (eq (aref tag 0) ?/) - (cdr (assoc (substring tag 1) sgml-tag-help))) - "No description available"))) - - -(defun sgml-maybe-end-tag () - "Name self unless in position to end a tag." - (interactive) - (or (condition-case nil - (save-excursion (up-list -1)) - (error - (sgml-name-self) - t)) - (condition-case nil - (progn - (save-excursion (up-list 1)) - (sgml-name-self)) - (error (self-insert-command 1))))) - - -(defun sgml-skip-tag-backward (arg) - "Skip to beginning of tag or matching opening tag if present. -With prefix ARG, repeat that many times." - (interactive "p") - (while (>= arg 1) - (search-backward "<" nil t) - (if (looking-at "]+\\)") - ;; end tag, skip any nested pairs - (let ((case-fold-search t) - (re (concat "= arg 1) - (skip-chars-forward "^<>") - (if (eq (following-char) ?>) - (up-list -1)) - (if (looking-at "<\\([^/ \n\t>]+\\)") - ;; start tag, skip any nested same pairs _and_ closing tag - (let ((case-fold-search t) - (re (concat "= arg 1) - (save-excursion - (let* (close open) - (if (looking-at "[ \t\n]*<") - ;; just before tag - (if (eq (char-after (match-end 0)) ?/) - ;; closing tag - (progn - (setq close (point)) - (goto-char (match-end 0)))) - ;; on tag? - (or (save-excursion (setq close (sgml-beginning-of-tag) - close (and (stringp close) - (eq (aref close 0) ?/) - (point)))) - ;; not on closing tag - (let ((point (point))) - (sgml-skip-tag-backward 1) - (if (or (not (eq (following-char) ?<)) - (save-excursion - (forward-list 1) - (<= (point) point))) - (error "Not on or before tag"))))) - (if close - (progn - (sgml-skip-tag-backward 1) - (setq open (point)) - (goto-char close) - (kill-sexp 1)) - (setq open (point)) - (sgml-skip-tag-forward 1) - (backward-list) - (forward-char) - (if (eq (aref (sgml-beginning-of-tag) 0) ?/) - (kill-sexp 1))) - (goto-char open) - (kill-sexp 1))) - (setq arg (1- arg)))) - - - -(defun sgml-tags-invisible (arg) - "Toggle visibility of existing tags." - (interactive "P") - (let ((modified (buffer-modified-p)) - (inhibit-read-only t) - (point (point-min)) - symbol) - (save-excursion - (goto-char point) - (if (setq sgml-tags-invisible - (if arg - (>= (prefix-numeric-value arg) 0) - (not sgml-tags-invisible))) - (while (re-search-forward "<\\([!/?A-Za-z][-A-Za-z0-9]*\\)" - nil t) - (setq symbol (intern-soft (downcase (match-string 1)))) - (goto-char (match-beginning 0)) - (and (get symbol 'before-string) - (not (overlays-at (point))) - (overlay-put (make-overlay (point) - (match-beginning 1)) - 'category symbol)) - (put-text-property (setq point (point)) (forward-list) - 'intangible (point)) - (put-text-property point (point) - 'category 'sgml-tag)) - (while (< (setq point (next-overlay-change point)) (point-max)) - (delete-overlay (car (overlays-at point)))) - (remove-text-properties (point-min) (point-max) - '(category sgml-tag intangible t)))) - (set-buffer-modified-p modified) - (run-hooks 'sgml-tags-invisible-hook) - (message ""))) - -(defun sgml-point-entered (x y) - ;; Show preceding or following hidden tag, depending of cursor direction. - (let ((inhibit-point-motion-hooks t)) - (save-excursion - (message "Invisible tag: %s" - (buffer-substring - (point) - (if (or (and (> x y) - (not (eq (following-char) ?<))) - (and (< x y) - (eq (preceding-char) ?>))) - (backward-list) - (forward-list))))))) - - -(autoload 'compile-internal "compile") - -(defun sgml-validate (command) - "Validate an SGML document. -Runs COMMAND, a shell command, in a separate process asynchronously -with output going to the buffer *compilation*. -You can then use the command \\[next-error] to find the next error message -and move to the line in the SGML document that caused it." - (interactive - (list (read-string "Validate command: " - (or sgml-saved-validate-command - (concat sgml-validate-command - " " - (let ((name (buffer-file-name))) - (and name - (file-name-nondirectory name)))))))) - (setq sgml-saved-validate-command command) - (if (or (not compilation-ask-about-save) - (y-or-n-p (message "Save buffer %s? " (buffer-name)))) - (save-buffer)) - (compile-internal command "No more errors")) - - -(defun sgml-beginning-of-tag (&optional top-level) - "Skip to beginning of tag and return its name. -Else `t'." - (or (if top-level - (condition-case nil - (up-list -1) - (error t)) - (>= (point) - (if (search-backward "<" nil t) - (save-excursion - (forward-list) - (point)) - 0))) - (if (looking-at "<[!?/]?[[A-Za-z][A-Za-z0-9]*") - (buffer-substring-no-properties - (1+ (point)) - (match-end 0)) - t))) - -(defun sgml-value (alist) - (setq alist (cdr alist)) - (if (stringp (car alist)) - (insert "=\"" (car alist) ?\") - (if (eq (car alist) t) - (if (cdr alist) - (progn - (insert "=\"") - (setq alist (skeleton-read '(completing-read - "[Value]: " (cdr alist)))) - (if (string< "" alist) - (insert (funcall skeleton-transformation alist) ?\") - (delete-backward-char 2)))) - (insert "=\"") - (if alist - (insert (funcall skeleton-transformation - (skeleton-read '(completing-read "Value: " alist))))) - (insert ?\")))) - -(provide 'sgml-mode) - -(defvar html-quick-keys sgml-quick-keys - "Use C-c X combinations for quick insertion of frequent tags when non-nil. -This defaults to `sgml-quick-keys'. -This takes effect when first loading the library.") - -(defvar html-mode-map - (let (; (map (nconc (make-sparse-keymap) sgml-mode-map)) - (map (copy-keymap sgml-mode-map)) - (menu-map (make-sparse-keymap "HTML"))) - (define-key map "\C-c6" 'html-headline-6) - (define-key map "\C-c5" 'html-headline-5) - (define-key map "\C-c4" 'html-headline-4) - (define-key map "\C-c3" 'html-headline-3) - (define-key map "\C-c2" 'html-headline-2) - (define-key map "\C-c1" 'html-headline-1) - (define-key map "\C-c\r" 'html-paragraph) - (define-key map "\C-c\n" 'html-line) - (define-key map "\C-c\C-c-" 'html-horizontal-rule) - (define-key map "\C-c\C-co" 'html-ordered-list) - (define-key map "\C-c\C-cu" 'html-unordered-list) - (define-key map "\C-c\C-cr" 'html-radio-buttons) - (define-key map "\C-c\C-cc" 'html-checkboxes) - (define-key map "\C-c\C-cl" 'html-list-item) - (define-key map "\C-c\C-ch" 'html-href-anchor) - (define-key map "\C-c\C-cn" 'html-name-anchor) - (define-key map "\C-c\C-ci" 'html-image) - (if html-quick-keys - (progn - (define-key map "\C-c-" 'html-horizontal-rule) - (define-key map "\C-co" 'html-ordered-list) - (define-key map "\C-cu" 'html-unordered-list) - (define-key map "\C-cr" 'html-radio-buttons) - (define-key map "\C-cc" 'html-checkboxes) - (define-key map "\C-cl" 'html-list-item) - (define-key map "\C-ch" 'html-href-anchor) - (define-key map "\C-cn" 'html-name-anchor) - (define-key map "\C-ci" 'html-image))) - (define-key map "\C-c\C-s" 'html-autoview-mode) - (define-key map "\C-c\C-v" 'browse-url-of-buffer) - (define-key map [menu-bar html] (cons "HTML" menu-map)) - (define-key menu-map [html-autoview-mode] - '("Toggle Autoviewing" . html-autoview-mode)) - (define-key menu-map [browse-url-of-buffer] - '("View Buffer Contents" . browse-url-of-buffer)) - (define-key menu-map [nil] '("--")) - ;;(define-key menu-map "6" '("Heading 6" . html-headline-6)) - ;;(define-key menu-map "5" '("Heading 5" . html-headline-5)) - ;;(define-key menu-map "4" '("Heading 4" . html-headline-4)) - (define-key menu-map "3" '("Heading 3" . html-headline-3)) - (define-key menu-map "2" '("Heading 2" . html-headline-2)) - (define-key menu-map "1" '("Heading 1" . html-headline-1)) - (define-key menu-map "l" '("Radio Buttons" . html-radio-buttons)) - (define-key menu-map "c" '("Checkboxes" . html-checkboxes)) - (define-key menu-map "l" '("List Item" . html-list-item)) - (define-key menu-map "u" '("Unordered List" . html-unordered-list)) - (define-key menu-map "o" '("Ordered List" . html-ordered-list)) - (define-key menu-map "-" '("Horizontal Rule" . html-horizontal-rule)) - (define-key menu-map "\n" '("Line Break" . html-line)) - (define-key menu-map "\r" '("Paragraph" . html-paragraph)) - (define-key menu-map "i" '("Image" . html-image)) - (define-key menu-map "h" '("Href Anchor" . html-href-anchor)) - (define-key menu-map "n" '("Name Anchor" . html-name-anchor)) - map) - "Keymap for commands for use in HTML mode.") - - -(defvar html-face-tag-alist - '((bold . "b") - (italic . "i") - (underline . "u") - (modeline . "rev")) - "Value of `sgml-face-tag-alist' for HTML mode.") - -(defvar html-tag-face-alist - '(("b" . bold) - ("big" . bold) - ("blink" . highlight) - ("cite" . italic) - ("em" . italic) - ("h1" bold underline) - ("h2" bold-italic underline) - ("h3" italic underline) - ("h4" . underline) - ("h5" . underline) - ("h6" . underline) - ("i" . italic) - ("rev" . modeline) - ("s" . underline) - ("small" . default) - ("strong" . bold) - ("title" bold underline) - ("tt" . default) - ("u" . underline) - ("var" . italic)) - "Value of `sgml-tag-face-alist' for HTML mode.") - - -(defvar html-display-text - '((img . "[/]") - (hr . "----------") - (li . "o ")) - "Value of `sgml-display-text' for HTML mode.") - - -; should code exactly HTML 3 here when that is finished -(defvar html-tag-alist - (let* ((1-9 '(("8") ("9") - ("1") ("2") ("3") ("4") ("5") ("6") ("7"))) - (align '(("align" ("left") ("center") ("right")))) - (valign '(("top") ("middle") ("bottom") ("baseline"))) - (rel '(("next") ("previous") ("parent") ("subdocument") ("made"))) - (href '("href" ("ftp:") ("file:") ("finger:") ("gopher:") ("http:") - ("mailto:") ("news:") ("rlogin:") ("telnet:") ("tn3270:") - ("wais:") ("/cgi-bin/"))) - (name '("name")) - (link `(,href - ("rel" ,@rel) - ("rev" ,@rel) - ("title"))) - (list '((nil \n - ( "List item: " - "

  • " str \n)) - ("type" ("A") ("a") ("I") ("i") ("1")))) - (cell `(t - ,align - ("valign" ,@valign) - ("colspan" ,@1-9) - ("rowspan" ,@1-9) - ("nowrap" t)))) - ;; put ,-expressions first, else byte-compile chokes (as of V19.29) - ;; and like this it's more efficient anyway - `(("a" ,name ,@link) - ("base" t ,@href) - ("dir" ,@list) - ("font" ("size" ("-1") ("+1") ("-2") ("+2") ,@(cdr (cdr 1-9)))) - ("form" (\n _ \n "") - ("action" ,@(cdr href)) ("method" ("get") ("post"))) - ("h1" ,@align) - ("h2" ,@align) - ("h3" ,@align) - ("h4" ,@align) - ("h5" ,@align) - ("h6" ,@align) - ("hr" t ("size" ,@1-9) ("width") ("noshade" t) ,@align) - ("img" t ("align" ,@valign ("texttop") ("absmiddle") ("absbottom")) - ("src") ("alt") ("width" "1") ("height" "1") - ("border" "1") ("vspace" "1") ("hspace" "1") ("ismap" t)) - ("input" t ("size" ,@1-9) ("maxlength" ,@1-9) ("checked" t) ,name - ("type" ("text") ("password") ("checkbox") ("radio") - ("submit") ("reset")) - ("value")) - ("link" t ,@link) - ("menu" ,@list) - ("ol" ,@list) - ("p" t ,@align) - ("select" (nil \n - ("Text: " - "